diff options
| author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-02-18 13:22:00 +1200 |
|---|---|---|
| committer | Chip Salzenberg <chip@atlantic.net> | 1997-02-18 13:22:00 +1200 |
| commit | ff0cee690d2ef6ba882e59dd4baaa0c944adb7a2 (patch) | |
| tree | 91b3d734c5c24df3e5127c9974064d91ec428678 | |
| parent | f65adc383296c14b415f0ade0cf7fc4a27049a24 (diff) | |
| download | perl-ff0cee690d2ef6ba882e59dd4baaa0c944adb7a2.tar.gz | |
[inseparable changes from patch from perl5.003_26 to perl5.003_27]
BUILD PROCESS
Subject: Fix eval "" in Configure
Date: Fri, 14 Feb 1997 13:09:53 -0500
From: John L. Allen <allen@gateway.grumman.com>
Files: Configure
Subject: Re: Configure problem on IRIX - me dumb
p5p-msgid: <9702141809.AA17001@gateway.grumman.com>
Subject: Don't link with -lsfio if sfio is not requested
From: Chip Salzenberg <chip@perl.com>
Files: Configure
Subject: perl5.003_26 Configure change "win" for AIX 4
Date: Fri, 14 Feb 1997 13:59:02 -0600 (CST)
From: Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu>
Files: Configure
p5p-msgid: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoDak.edu>
private-msgid: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoD
CORE LANGUAGE CHANGES
Subject: Better looks_like_number() function [sv.c]
Date: Fri, 14 Feb 1997 18:08:52 +0100
From: Gisle Aas <aas@bergen.sn.no>
Files: sv.c
Msg-ID: <199702141708.SAA17546@bergen.sn.no>
(applied based on p5p patch as commit 8dbaa58ee2aba7cc22d84199a674c58bbf108b46)
Subject: Remove redundant functions UNIVERSAL::{class,is_instance}
Date: 14 Feb 1997 15:52:21 +0000
From: Gisle Aas <aas@bergen.sn.no>
Files: pod/perldelta.pod pod/perlobj.pod t/op/universal.t universal.c
Msg-ID: <hwwsbpeq2.fsf@bergen.sn.no>
(applied based on p5p patch as commit 77bb9b23081b62119e8fbe9f5655b8802e4537ae)
Subject: Allow C<setpgrp $$>
Date: 16 Feb 1997 23:19:12 -0500
From: Roderick Schertler <roderick@gate.net>
Files: pp_sys.c
Msg-ID: <pzraigyshr.fsf@eeyore.ibcinc.com>
(applied based on p5p patch as commit 3d2573a84a1aa655d5da58c57b3fc20e04d40f9f)
Subject: Fix syntax error on C<&$1>
From: Chip Salzenberg <chip@perl.com>
Files: toke.c
Subject: Fix grep() with refs in array context
From: Chip Salzenberg <chip@perl.com>
Files: pp.c
CORE PORTABILITY
Subject: Eliminate $^S; add C<use vmsish qw(status exit time)>
Date: Mon, 17 Feb 1997 02:45:26 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: MANIFEST gv.c lib/English.pm lib/ExtUtils/MM_VMS.pm lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp mg.c op.c perl.c perl.h pod/perldelta.pod pod/perlmod.pod pod/perlvar.pod pp_ctl.c pp_sys.c utils/perldoc.PL vms/Makefile vms/config.vms vms/descrip.mms vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs vms/ext/XSSymSet.pm vms/ext/vmsish.pm vms/vms.c vms/vmsish.h win32/makedef.pl
private-msgid: <01IFI9CFKL0S004R2V@hmivax.humgen.upenn.edu>
LIBRARY AND EXTENSIONS
Subject: Remove Fatal.pm
From: Chip Salzenberg <chip@perl.com>
Files: MANIFEST lib/Fatal.pm pod/perldelta.pod pod/perlmod.pod pod/roffitall t/lib/fatal.t
Subject: Refresh MakeMaker to 5.40
From: Andy Dougherty <doughera@lafcol.lafayette.edu>
Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
OTHER CORE CHANGES
Subject: Fix core dump when embedding
From: Chip Salzenberg <chip@perl.com>
Files: perl.c
Subject: Re: Fragile signals
Date: Thu, 13 Feb 1997 01:44:39 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: mg.c
Msg-ID: <199702130644.BAA07572@monk.mps.ohio-state.edu>
(applied based on p5p patch as commit 09df8c7df7dfc9853902f1fdd8a6d95f53be66fc)
Subject: Make format strings correspond exactly to parameters
Date: 13 Feb 1997 17:24:31 -0500
From: Roderick Schertler <roderick@gate.net>
Files: doio.c ext/DB_File/DB_File.xs ext/Opcode/Opcode.xs gv.c op.c perl.c pp_ctl.c pp_sys.c regcomp.c toke.c
Msg-ID: <pz7mkc1h0g.fsf@eeyore.ibcinc.com>
(applied based on p5p patch as commit bf81aadd817bdea29720b072eef945df2da8463b)
Subject: Don't try to attach 'o' magic to read-only values
From: Chip Salzenberg <chip@perl.com>
Files: sv.c
Subject: Fix carriage-return message
From: Chip Salzenberg <chip@perl.com>
Files: toke.c
Subject: In <=>, test for equality first
From: Chip Salzenberg <chip@perl.com>
Files: pp.c
Subject: Don't mark sv_{true,false} PADTMP
From: Chip Salzenberg <chip@perl.com>
Files: op.c
49 files changed, 1480 insertions, 560 deletions
@@ -9,6 +9,184 @@ releases.) ---------------- +Version 5.003_27 +---------------- + +This release is beta candidate #5: Our last, best hope for a beta. + + CORE LANGUAGE CHANGES + + Title: "Better looks_like_number() function [sv.c]" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <199702141708.SAA17546@bergen.sn.no> + Date: Fri, 14 Feb 1997 18:08:52 +0100 + Files: sv.c + + Title: "Remove redundant functions UNIVERSAL::{class,is_instance}" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <hwwsbpeq2.fsf@bergen.sn.no> + Date: 14 Feb 1997 15:52:21 +0000 + Files: pod/perldelta.pod pod/perlobj.pod t/op/universal.t universal.c + + Title: "Allow C<setpgrp $$>" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pzraigyshr.fsf@eeyore.ibcinc.com> + Date: 16 Feb 1997 23:19:12 -0500 + Files: pp_sys.c + + Title: "Fix syntax error on C<&$1>" + From: Chip Salzenberg + Files: toke.c + + Title: "Fix sub call through magic var (e.g. C<&$1>)" + From: Chip Salzenberg + Files: pp_hot.c + + Title: "Fix grep() with refs in array context" + From: Chip Salzenberg + Files: pp.c + + CORE PORTABILITY + + Title: "Eliminate $^S; add C<use vmsish qw(status exit time)>" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IFI9CFKL0S004R2V@hmivax.humgen.upenn.edu> + Date: Mon, 17 Feb 1997 02:45:26 -0500 (EST) + Files: MANIFEST gv.c lib/English.pm lib/ExtUtils/MM_VMS.pm + lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp mg.c op.c + perl.c perl.h pod/perldelta.pod pod/perlmod.pod + pod/perlvar.pod pp_ctl.c pp_sys.c utils/perldoc.PL + vms/Makefile vms/config.vms vms/descrip.mms + vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs + vms/ext/XSSymSet.pm vms/ext/vmsish.pm vms/vms.c vms/vmsish.h + win32/makedef.pl + + Title: "Eliminate FP exceptions under SCO 5" + From: Chip Salzenberg + Files: hints/sco.sh unixish.h + + Title: "Digital UNIX hints" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199702151906.VAA22999@alpha.hut.fi> + Date: Sat, 15 Feb 1997 21:06:33 +0200 (EET) + Files: hints/dec_osf.sh + + Title: "Irix6.4 (with 7.1 compilers)" + From: John Stoffel <jfs@fluent.com> + Msg-ID: <199702130238.VAA24468@jfs.Fluent.COM> + Date: Wed, 12 Feb 1997 21:38:51 -0500 (EST) + Files: hints/irix_6_2.sh hints/irix_6_4.sh + + Title: "Update Plan 9, Win32, VMS configs with $shortsize and $longsize" + From: Chip Salzenberg + Files: plan9/config.plan9 plan9/genconfig.pl + vms/genconfig.pl win32/config.w32 + + OTHER CORE CHANGES + + Title: "Fix core dump when embedding" + From: Chip Salzenberg + Files: perl.c + + Title: "Re: Fragile signals" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199702130644.BAA07572@monk.mps.ohio-state.edu> + Date: Thu, 13 Feb 1997 01:44:39 -0500 (EST) + Files: mg.c + + Title: "Make format strings correspond exactly to parameters" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <pz7mkc1h0g.fsf@eeyore.ibcinc.com> + Date: 13 Feb 1997 17:24:31 -0500 + Files: doio.c ext/DB_File/DB_File.xs ext/Opcode/Opcode.xs gv.c op.c + perl.c pp_ctl.c pp_sys.c regcomp.c toke.c + + Title: "Don't try to attach 'o' magic to read-only values" + From: Chip Salzenberg + Files: sv.c + + Title: "Fix carriage-return message" + From: Chip Salzenberg + Files: toke.c + + Title: "In <=>, test for equality first" + From: Chip Salzenberg + Files: pp.c + + Title: "Don't mark sv_{true,false} PADTMP" + From: Chip Salzenberg + Files: op.c + + BUILD PROCESS + + Title: "Fix eval "" in Configure" + From: allen@gateway.grumman.com (John L. Allen) + Msg-ID: <9702141809.AA17001@gateway.grumman.com> + Date: Fri, 14 Feb 1997 13:09:53 -0500 + Files: Configure + + Title: "Don't link with -lsfio if sfio is not requested" + From: Chip Salzenberg + Files: Configure + + Title: "perl5.003_26 Configure change "win" for AIX 4" + From: Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu> + Msg-ID: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoD + Date: Fri, 14 Feb 1997 13:59:02 -0600 (CST) + Files: Configure + + Title: "Update os2/diff.configure" + From: Chip Salzenberg + Files: os2/diff.configure + + LIBRARY AND EXTENSIONS + + Title: "Remove Fatal.pm" + From: Chip Salzenberg + Files: MANIFEST lib/Fatal.pm pod/perldelta.pod pod/perlmod.pod + pod/roffitall t/lib/fatal.t + + Title: "Refresh MakeMaker to 5.40" + From: Andy Dougherty, Andreas Koenig, Tim Bunce + Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm + lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm + + Title: "Refresh CPAN.pm to 1.21" + From: Andreas Koenig <a.koenig@mind.de> + Files: lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm + + Title: "Refresh Test::Harness to 1.15" + From: Andreas Koenig <a.koenig@mind.de> + Files: lib/Test/Harness.pm + + TESTS + + Title: "Remove non-portable locale tests" + From: Chip Salzenberg + Files: t/pragma/locale.t + + UTILITIES + + Title: "pod2man: missing '-' in name section shouldn't be fatal" + From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> + Msg-ID: <yfmzpxcimsa.fsf@ls6.informatik.uni-dortmund.de> + Date: 10 Feb 1997 18:38:45 +0100 + Files: pod/pod2man.PL + + DOCUMENTATION + + Title: "Update To-Do list" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <9702101900.AA25293@toad.ig.co.uk> + Date: Mon, 10 Feb 1997 19:00:59 +0000 + Files: Todo + + Title: "Fix formatting in perldiag" + From: Chip Salzenberg + Files: pod/perldiag.pod + + +---------------- Version 5.003_26 ---------------- @@ -91,25 +91,39 @@ if test ! -t 0; then exit 1 fi -: On HP-UX, large Configure scripts may exercise a bug in /bin/sh -if test -f /hp-ux -a -f /bin/ksh; then - if (PATH=.; alias -x) >/dev/null 2>&1; then - : already under /bin/ksh - else +: Test and see if we are running under ksh, either blatantly or in disguise. +if (PATH=.; alias -x) >/dev/null 2>&1; then + : running under ksh. Is this a good thing? + if test -d /usr/lpp -a -f /usr/bin/bsh -a -f /usr/bin/uname ; then + if test X`/usr/bin/uname -v` = X4 ; then + : on AIX 4, /bin/sh is really ksh, and it causes us problems. + : Avoid it cat <<'EOM' -(Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.) +(Feeding myself to /usr/bin/bsh to avoid AIX 4's /bin/sh.) EOM unset ENV - exec /bin/ksh $0 "$@" + exec /usr/bin/bsh $0 "$@" fi -else + else + if test ! -f /hp-ux ; then : Warn them if they use ksh on other systems - (PATH=.; alias -x) >/dev/null 2>&1 && \ cat <<EOM (I see you are using the Korn shell. Some ksh's blow up on $me, especially on older exotic systems. If yours does, try the Bourne shell instead.) EOM + fi + fi +else + : Not running under ksh. Maybe we should be? + : On HP-UX, large Configure scripts may exercise a bug in /bin/sh + if test -f /hp-ux -a -f /bin/ksh; then + cat <<'EOM' +(Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.) +EOM + unset ENV + exec /bin/ksh $0 "$@" + fi fi : Configure runs within the UU subdirectory @@ -1220,7 +1234,7 @@ while expr "X\$ans" : "X!" >/dev/null; do read answ set x \$xxxm shift - aok=''; eval "ans=\"\$answ\"" && aok=y + aok=''; eval ans="\\"\$answ\\"" && aok=y case "\$answ" in "\$ans") case "\$ans" in @@ -7350,6 +7364,11 @@ $define) y|Y) ;; *) echo "Ok, avoiding sfio this time. I'll use stdio instead." val="$undef" + : Remove sfio from list of libraries to use + set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'` + shift + libs="$*" + echo "libs = $libs" >&4 ;; esac ;; @@ -303,7 +303,6 @@ lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension lib/ExtUtils/typemap Extension interface types lib/ExtUtils/xsubpp External subroutine preprocessor -lib/Fatal.pm Make do-or-die equivalents of functions lib/File/Basename.pm Emulate the basename program lib/File/CheckTree.pm Perl module supporting wholesale file mode validation lib/File/Compare.pm Emulation of cmp command @@ -600,7 +599,6 @@ t/lib/db-recno.t See if DB_File works t/lib/dirhand.t See if DirHandle works t/lib/english.t See if English works t/lib/env.t See if Env works -t/lib/fatal.t See if Fatal works t/lib/filecache.t See if FileCache works t/lib/filecopy.t See if File::Copy works t/lib/filefind.t See if File::Find works @@ -737,7 +735,9 @@ vms/ext/Stdio/Makefile.PL MakeMaker driver for VMS::Stdio vms/ext/Stdio/Stdio.pm VMS options to stdio routines vms/ext/Stdio/Stdio.xs VMS options to stdio routines vms/ext/Stdio/test.pl regression tests for VMS::Stdio +vms/ext/XSSymSet.pm manage linker symbols when building extensions vms/ext/filespec.t See if VMS::Filespec funtions work +vms/ext/vmsish.pm Control VMS-specific behavior of Perl core vms/fndvers.com parse Perl version from patchlevel.h vms/gen_shrfls.pl generate options files and glue for shareable image vms/genconfig.pl retcon config.sh from config.h @@ -8,7 +8,7 @@ */ struct xpvav { - char* xav_array; /* pointer to malloced string */ + char* xav_array; /* pointer to first array element */ SSize_t xav_fill; SSize_t xav_max; IV xof_off; /* ptr is incremented by offset */ @@ -16,7 +16,7 @@ struct xpvav { MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ - SV** xav_alloc; + SV** xav_alloc; /* pointer to malloced string */ SV* xav_arylen; U8 xav_flags; }; @@ -1370,8 +1370,8 @@ SV **sp; { a = SvPV(astr, len); if (len != infosize) - croak("Bad arg length for %s, is %d, should be %d", - op_desc[optype], len, infosize); + croak("Bad arg length for %s, is %d, should be %ld", + op_desc[optype], len, (long)infosize); } } else diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 092958eb19..796c5c669c 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -161,7 +161,7 @@ const DBT * key2 ; SPAGAIN ; if (count != 1) - croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ; + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; retval = POPi ; @@ -208,7 +208,7 @@ const DBT * key2 ; SPAGAIN ; if (count != 1) - croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ; + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; retval = POPi ; @@ -245,7 +245,7 @@ size_t size ; SPAGAIN ; if (count != 1) - croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ; + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; retval = POPi ; @@ -339,7 +339,7 @@ I32 value ; /* check for attempt to write before start of array */ if (length + value + 1 <= 0) - croak("Modification of non-creatable array value attempted, subscript %d", value) ; + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; value = length + value + 1 ; } diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 1fd2c6b891..5a95238979 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -156,7 +156,7 @@ set_opset_bits(bitmap, bitspec, on, opname) if (myopcode >= maxo || myopcode < 0) croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode); if (opcode_debug >= 2) - warn("set_opset_bits bit %2d (off=%d, bit=%d) %s on\n", + warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n", myopcode, offset, bit, opname, (on)?"on":"off"); if (on) bitmap[offset] |= 1 << bit; @@ -175,8 +175,8 @@ set_opset_bits(bitmap, bitspec, on, opname) while(len-- > 0) bitmap[len] &= ~specbits[len]; } else - croak("panic: invalid bitspec for \"%s\" (type %d)", - opname, SvTYPE(bitspec)); + croak("panic: invalid bitspec for \"%s\" (type %u)", + opname, (unsigned)SvTYPE(bitspec)); } @@ -235,7 +235,7 @@ BOOT: assert(maxo < OP_MASK_BUF_SIZE); opset_len = (maxo + 7) / 8; if (opcode_debug >= 1) - warn("opset_len %d\n", opset_len); + warn("opset_len %ld\n", (long)opset_len); op_names_init(); @@ -413,8 +413,8 @@ opdesc(...) } } else - croak("panic: invalid bitspec for \"%s\" (type %d)", - opname, SvTYPE(bitspec)); + croak("panic: invalid bitspec for \"%s\" (type %u)", + opname, (unsigned)SvTYPE(bitspec)); } @@ -341,7 +341,7 @@ I32 create; #ifdef VMS warn("Weird package name \"%s\" truncated", name); #else - warn("Weird package name \"%.*s...\" truncated", namelen, name); + warn("Weird package name \"%.*s...\" truncated", (int)namelen, name); #endif } Copy(name,tmpbuf,namelen,char); @@ -636,6 +636,14 @@ I32 sv_type; sv_setpv(GvSV(gv),chopset); goto magicalize; + case '?': + if (len > 1) + break; +#ifdef COMPLEX_STATUS + sv_upgrade(GvSV(gv), SVt_PVLV); +#endif + goto magicalize; + case '#': case '*': if (dowarn && len == 1 && sv_type == SVt_PV) @@ -643,7 +651,6 @@ I32 sv_type; /* FALL THROUGH */ case '[': case '!': - case '?': case '^': case '~': case '=': @@ -666,7 +673,6 @@ I32 sv_type; case '\017': case '\t': case '\020': - case '\023': case '\024': case '\027': if (len > 1) diff --git a/lib/English.pm b/lib/English.pm index 736b90d4a8..0cf62bd3b6 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -65,7 +65,6 @@ sub import { *FORMAT_LINE_BREAK_CHARACTERS *FORMAT_FORMFEED *CHILD_ERROR - *SYSTEM_CHILD_STATUS *OS_ERROR *ERRNO *EXTENDED_OS_ERROR @@ -138,7 +137,6 @@ sub import { # Error status. *CHILD_ERROR = *? ; - *SYSTEM_CHILD_STATUS = *^S ; *OS_ERROR = *! ; *ERRNO = *! ; *EXTENDED_OS_ERROR = *^E ; diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index cb482e16bf..a885653820 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -2,7 +2,7 @@ package ExtUtils::Liblist; use vars qw($VERSION); # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.21 $, 10; +$VERSION = substr q$Revision: 1.22 $, 10; use Config; use Cwd 'cwd'; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index c44d6c9e2b..465a075132 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -8,8 +8,8 @@ use strict; use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Verbose %pm %static $Xsubpp_Version); -$VERSION = substr q$Revision: 1.109_01 $, 10; -# $Id: MM_Unix.pm,v 1.109 1996/12/17 00:42:32 k Exp k $ +$VERSION = substr q$Revision: 1.113 $, 10; +# $Id: MM_Unix.pm,v 1.113 1997/02/11 21:54:09 k Exp $ Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); @@ -1000,7 +1000,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists push(@m,' $(RANLIB) '."$ldfrom\n"); } $ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf'); - push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ $(LDDLFLAGS) '.$ldfrom. + + # Brain dead solaris linker does not use LD_RUN_PATH? + # This fixes dynamic extensions which need shared libs + my $ldrun = ''; + $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} + if ($^O eq 'solaris'); + + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' $(CHMOD) 755 $@ @@ -1696,9 +1703,9 @@ usually solves this kind of problem. foreach $component ($self->{PERL_SRC}, $self->path(), $Config::Config{binexp}) { push @defpath, $component if defined $component; } - $self->{PERL} = + $self->{PERL} ||= $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ], - \@defpath, $Verbose ) unless ($self->{PERL}); + \@defpath, $Verbose ); # don't check if perl is executable, maybe they have decided to # supply switches with perl @@ -2136,6 +2143,16 @@ MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; $lperl = "$dir/$lperl"; + + if (! -f $libperl and ! -f $lperl) { + # We did not find a static libperl. Maybe there is a shared one? + if ($^O eq 'solaris' or $^O eq 'sunos') { + $lperl = $libperl = "$dir/$Config::Config{libperl}"; + # SUNOS ld does not take the full path to a shared library + $libperl = '' if $^O eq 'sunos'; + } + } + print STDOUT "Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed otherwise ignore this warning\n" @@ -2156,10 +2173,17 @@ MAP_LIBPERL = $libperl foreach $catfile (@$extra){ push @m, "\tcat $catfile >> \$\@\n"; } + # SUNOS ld does not take the full path to a shared library + my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl'; - push @m, " + # Brain dead solaris linker does not use LD_RUN_PATH? + # This fixes dynamic extensions which need shared libs + my $ldfrom = ($^O eq 'solaris')? + join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):''; + +push @m, " \$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all - \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) + \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom $llibperl \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) $self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call' $self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' $self->{NOECHO}echo 'To remove the intermediate files say' diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index b56b1b8cf5..12350aaab5 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -459,22 +459,32 @@ sub path { Follows VMS naming conventions for executable files. If the name passed in doesn't exactly match an executable file, -appends F<.Exe> to check for executable image, and F<.Com> to check -for DCL procedure. If this fails, checks F<Sys$System:> for an -executable file having the name specified. Finally, appends F<.Exe> -and checks again. +appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> +to check for DCL procedure. If this fails, checks directories in DCL$PATH +and finally F<Sys$System:> for an executable file having the name specified, +with or without the F<.Exe>-equivalent suffix. =cut sub maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d _; - return "$file.exe" if -x "$file.exe"; - return "$file.com" if -x "$file.com"; + my(@dirs) = (''); + my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); + my($dir,$ext); if ($file !~ m![/:>\]]!) { - my($shrfile) = 'Sys$System:' . $file; - return $file if -x $shrfile && ! -d _; - return "$file.exe" if -x "$shrfile.exe"; + for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { + $dir = $ENV{"DCL\$PATH;$i"}; + $dir .= ':' unless $dir =~ m%[\]:]$%; + push(@dirs,$dir); + } + push(@dirs,'Sys$System:'); + foreach $dir (@dirs) { + my $sysfile = "$dir$file"; + foreach $ext (@exts) { + return $file if -x "$sysfile$ext" && ! -d _; + } + } } return 0; } @@ -517,8 +527,8 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl =item perl_script (override) -If name passed in doesn't specify a readable file, appends F<.pl> and -tries again, since it's customary to have file types on all files +If name passed in doesn't specify a readable file, appends F<.com> or +F<.pl> and tries again, since it's customary to have file types on all files under VMS. =cut @@ -526,7 +536,8 @@ under VMS. sub perl_script { my($self,$file) = @_; return $file if -r $file && ! -d _; - return "$file.pl" if -r "$file.pl" && ! -d _; + return "$file.com" if -r "$file.com"; + return "$file.pl" if -r "$file.pl"; return ''; } @@ -748,7 +759,7 @@ INST_STATIC = INST_DYNAMIC = INST_BOOT = EXPORT_LIST = $(BASEEXT).opt -PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : 'Sys$Share:PerlShr.Exe'),' +PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : "Sys\$Share:PerlShr.$Config{'dlext'}"),' '; } @@ -1002,7 +1013,10 @@ sub xsubpp_version my $command = "$self->{PERL} \"-I$self->{PERL_LIB}\" $xsubpp -v"; print "Running: $command\n" if $Verbose; $version = `$command` ; - warn "Running '$command' exits with status " . $? unless ($? & 1); + if ($?) { + use vmsish 'status'; + warn "Running '$command' exits with status $?"; + } chop $version ; return $1 if $version =~ /^xsubpp version (.*)/ ; @@ -1325,7 +1339,7 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep push @m, ' $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) - $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.Exe + $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config{'dlext'},' Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option '; @@ -2220,7 +2234,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) } } - $target = "Perl.Exe" unless $target; + $target = "Perl$Config{'exe_ext'}" unless $target; ($shrtarget,$targdir) = fileparse($target); $shrtarget =~ s/^([^.]*)/$1Shr/; $shrtarget = $targdir . $shrtarget; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 99aaa38c56..ad846ffbb7 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -2,10 +2,10 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib package ExtUtils::MakeMaker; -$Version = $VERSION = "5.39"; +$Version = $VERSION = "5.40"; $Version_OK = "5.17"; # Makefiles older than $Version_OK will die # (Will be checked from MakeMaker version 4.13 onwards) -($Revision = substr(q$Revision: 1.208 $, 10)) =~ s/\s+$//; +($Revision = substr(q$Revision: 1.211 $, 10)) =~ s/\s+$//; @@ -1557,7 +1557,7 @@ B<after> the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; - ( $VERSION ) = '$Revision: 1.208 $ ' =~ /\$Revision:\s+([^\s]+)/; + ( $VERSION ) = '$Revision: 1.211 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; but these will fail: diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 4c96437e15..eeed4bf794 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -7,7 +7,7 @@ use Exporter; use vars qw( @ISA @EXPORT $VERSION ); @ISA = 'Exporter'; @EXPORT = '&Mksymlists'; -$VERSION = substr q$Revision: 1.12 $, 10; +$VERSION = substr q$Revision: 1.13 $, 10; sub Mksymlists { my(%spec) = @_; @@ -98,8 +98,10 @@ sub _write_vms { my($data) = @_; require Config; # a reminder for once we do $^O + require ExtUtils::XSSymSet; my($isvax) = $Config::Config{'arch'} =~ /VAX/i; + my($set) = new ExtUtils::XSSymSet; my($sym); rename "$data->{FILE}.opt", "$data->{FILE}.opt_old"; @@ -115,13 +117,15 @@ sub _write_vms { # the GSMATCH criteria for a dynamic extension foreach $sym (@{$data->{FUNCLIST}}) { - if ($isvax) { print OPT "UNIVERSAL=$sym\n" } - else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; } + my $safe = $set->addsym($sym); + if ($isvax) { print OPT "UNIVERSAL=$safe\n" } + else { print OPT "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; } } foreach $sym (@{$data->{DL_VARS}}) { + my $safe = $set->addsym($sym); print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; - if ($isvax) { print OPT "UNIVERSAL=$sym\n" } - else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; } + if ($isvax) { print OPT "UNIVERSAL=$safe\n" } + else { print OPT "SYMBOL_VECTOR=($safe=DATA)\n"; } } close OPT; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 5f6feb8af7..09b8e7dcd3 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -80,7 +80,7 @@ use Cwd; use vars '$cplusplus'; # Global Constants -$XSUBPP_version = "1.94001"; +$XSUBPP_version = "1.9401"; $Is_VMS = $^O eq 'VMS'; sub Q ; @@ -127,6 +127,13 @@ $pwd = cwd(); my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); +my($SymSet); +if ($Is_VMS) { + # Establish set of global symbols with max length 28, since xsubpp + # will later add the 'XS_' prefix. + require ExtUtils::XSSymSet; + $SymSet = new ExtUtils::XSSymSet 28; +} sub TrimWhitespace { @@ -798,6 +805,7 @@ while (fetch_para()) { ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; ($clean_func_name = $func_name) =~ s/^$Prefix//; $Full_func_name = "${Packid}_$clean_func_name"; + if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } # Check for duplicate function definition for $tmp (@XSStack) { @@ -1295,6 +1303,9 @@ sub map_type { sub Exit { - # VMS error exit: SS$_ABORT. - exit $errors ? ($Is_VMS ? 44 : 1) : 0; +# If this is VMS, the exit status has meaning to the shell, so we +# use a predictable value (SS$_Normal or SS$_Abort) rather than an +# arbitrary number. +# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; + exit ($errors ? 1 : 0); } @@ -386,12 +386,6 @@ MAGIC *mg; case '\020': /* ^P */ sv_setiv(sv, (IV)perldb); break; - case '\023': /* ^S */ - if (STATUS_NATIVE == -1) - sv_setiv(sv, (IV)-1); - else - sv_setuv(sv, (UV)STATUS_NATIVE); - break; case '\024': /* ^T */ #ifdef BIG_TIME sv_setnv(sv, basetime); @@ -462,7 +456,11 @@ MAGIC *mg; #endif break; case '?': - sv_setiv(sv, (IV)STATUS_POSIX); + sv_setiv(sv, (IV)STATUS_CURRENT); +#ifdef COMPLEX_STATUS + LvTARGOFF(sv) = statusvalue; + LvTARGLEN(sv) = statusvalue_vms; +#endif break; case '^': s = IoTOP_NAME(GvIOp(defoutgv)); @@ -708,13 +706,11 @@ MAGIC* mg; warn("No such signal: SIG%s", s); return 0; } - if(psig_ptr[i]) - SvREFCNT_dec(psig_ptr[i]); + SvREFCNT_dec(psig_name[i]); + SvREFCNT_dec(psig_ptr[i]); psig_ptr[i] = SvREFCNT_inc(sv); - if(psig_name[i]) - SvREFCNT_dec(psig_name[i]); - psig_name[i] = newSVpv(s,strlen(s)); SvTEMP_off(sv); /* Make sure it doesn't go away on us */ + psig_name[i] = newSVpv(s, strlen(s)); SvREADONLY_on(psig_name[i]); } if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { @@ -1269,9 +1265,6 @@ MAGIC* mg; } perldb = i; break; - case '\023': /* ^S */ - STATUS_NATIVE_SET(SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)); - break; case '\024': /* ^T */ #ifdef BIG_TIME basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); @@ -1351,7 +1344,19 @@ MAGIC* mg; compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '?': - STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); +#ifdef COMPLEX_STATUS + if (localizing == 2) { + statusvalue = LvTARGOFF(sv); + statusvalue_vms = LvTARGLEN(sv); + } + else +#endif +#ifdef VMSISH_STATUS + if (VMSISH_STATUS) + STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))); + else +#endif + STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '!': SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), @@ -1540,10 +1545,23 @@ int sig; SV *sv; CV *cv; AV *oldstack; - - if(!psig_ptr[sig]) - die("Signal SIG%s received, but no signal handler set.\n", - sig_name[sig]); + bool long_savestack = (savestack_ix + 14) < savestack_max; + bool long_cxstack = (cxstack_ix + 1) < cxstack_max; + + /* Protect PUSHXXX in progress. */ + if (long_cxstack) + cxstack_ix++; + + if (!psig_ptr[sig]) + die("Signal SIG%s received, but no signal handler set.\n", + sig_name[sig]); + + /* + * Protect save in progress. Max number of items pushed there is + * 3*n or 4. We cannot fix infinity, so we fix 4 (in fact 5). + */ + if (long_savestack) + savestack_ix += 5; cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { @@ -1561,8 +1579,8 @@ int sig; if(psig_name[sig]) sv = SvREFCNT_inc(psig_name[sig]); else { - sv = sv_newmortal(); - sv_setpv(sv,sig_name[sig]); + sv = sv_newmortal(); + sv_setpv(sv,sig_name[sig]); } PUSHMARK(sp); PUSHs(sv); @@ -1571,6 +1589,10 @@ int sig; perl_call_sv((SV*)cv, G_DISCARD); SWITCHSTACK(signalstack, oldstack); - + if (long_savestack) + savestack_ix -= 5; /* Unprotect save in progress. */ + if (long_cxstack) + cxstack_ix--; /* Unprotect PUSHXXX in progress. */ + return; } @@ -406,7 +406,7 @@ pad_free(PADOFFSET po) if (!po) croak("panic: pad_free po"); DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po)); - if (curpad[po] && curpad[po] != &sv_undef) + if (curpad[po] && !SvIMMORTAL(curpad[po])) SvPADTMP_off(curpad[po]); if ((I32)po < padix) padix = po - 1; @@ -442,7 +442,7 @@ pad_reset() DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(comppad); po > padix_floor; po--) { - if (curpad[po] && curpad[po] != &sv_undef) + if (curpad[po] && !SvIMMORTAL(curpad[po])) SvPADTMP_off(curpad[po]); } padix = padix_floor; @@ -2377,6 +2377,9 @@ OP *op; } cop->op_flags = flags; cop->op_private = 0 | (flags >> 8); +#ifdef NATIVE_HINTS + cop->op_private |= NATIVE_HINTS; +#endif cop->op_next = (OP*)cop; if (label) { @@ -3800,8 +3803,8 @@ OP *op; OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); if (dowarn) - warn("Array @%s missing the @ in argument %d of %s()", - name, numargs, op_desc[type]); + warn("Array @%s missing the @ in argument %ld of %s()", + name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; @@ -3818,8 +3821,8 @@ OP *op; OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); if (dowarn) - warn("Hash %%%s missing the %% in argument %d of %s()", - name, numargs, op_desc[type]); + warn("Hash %%%s missing the %% in argument %ld of %s()", + name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; diff --git a/patchlevel.h b/patchlevel.h index 405184345e..5c392cac4b 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 26 +#define SUBVERSION 27 /* local_patches -- list of locally applied less-than-subversion patches. @@ -198,12 +198,18 @@ register PerlInterpreter *sv_interp; LEAVE; FREETMPS; - /* We must account for everything. First the syntax tree. */ + /* We must account for everything. */ + + /* Destroy the main CV and syntax tree */ if (main_root) { curpad = AvARRAY(comppad); op_free(main_root); - main_root = 0; + main_root = Nullop; } + main_start = Nullop; + SvREFCNT_dec(main_cv); + main_cv = Nullcv; + if (sv_objcount) { /* * Try to destruct global references. We do this first so that the @@ -349,13 +355,17 @@ register PerlInterpreter *sv_interp; FREETMPS; if (destruct_level >= 2) { if (scopestack_ix != 0) - warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix); + warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + (long)scopestack_ix); if (savestack_ix != 0) - warn("Unbalanced saves: %d more saves than restores\n", savestack_ix); + warn("Unbalanced saves: %ld more saves than restores\n", + (long)savestack_ix); if (tmps_floor != -1) - warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1); + warn("Unbalanced tmps: %ld more allocs than frees\n", + (long)tmps_floor + 1); if (cxstack_ix != -1) - warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1); + warn("Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } /* Now absolutely destruct everything, somehow or other, loops or no. */ @@ -399,7 +409,7 @@ register PerlInterpreter *sv_interp; SvREFCNT_dec(strtab); if (sv_count != 0) - warn("Scalars leaked: %d\n", sv_count); + warn("Scalars leaked: %ld\n", (long)sv_count); sv_free_arenas(); @@ -476,11 +486,14 @@ setuid perl scripts securely.\n"); return 0; } - SvREFCNT_dec(main_cv); - if (main_root) + if (main_root) { + curpad = AvARRAY(comppad); op_free(main_root); - main_cv = 0; - main_start = main_root = 0; + main_root = Nullop; + } + main_start = Nullop; + SvREFCNT_dec(main_cv); + main_cv = Nullcv; time(&basetime); @@ -1785,12 +1798,12 @@ char *scriptname; (void)PerlIO_close(rsfp); if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ PerlIO_printf(rsfp, -"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ -(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", - uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, - statbuf.st_dev, statbuf.st_ino, +"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ +(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", + (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, + (long)statbuf.st_dev, (long)statbuf.st_ino, SvPVX(GvSV(curcop->cop_filegv)), - statbuf.st_uid, statbuf.st_gid); + (long)statbuf.st_uid, (long)statbuf.st_gid); (void)my_pclose(rsfp); } croak("Permission denied\n"); @@ -2471,7 +2484,7 @@ my_failure_exit() STATUS_NATIVE_SET(44); } else { - if (!vaxc$errno && errno) /* someone must have set $^E = 0 */ + if (!vaxc$errno && errno) /* unlikely */ STATUS_NATIVE_SET(44); else STATUS_NATIVE_SET(vaxc$errno); @@ -2508,5 +2521,6 @@ my_exit_jump() POPBLOCK(cx,curpm); LEAVE; } + Siglongjmp(top_env, 2); } @@ -443,18 +443,10 @@ # endif #endif -#define STATUS_POSIX statusvalue -#define STATUS_POSIX_SET(n) \ - STMT_START { \ - statusvalue = (n); \ - if (statusvalue != -1) \ - statusvalue &= 0xFFFF; \ - } STMT_END - #ifdef VMS # define STATUS_NATIVE statusvalue_vms # define STATUS_NATIVE_EXPORT \ - ((I32)statusvalue_vms == -1 ? 4 : statusvalue_vms) + ((I32)statusvalue_vms == -1 ? 44 : statusvalue_vms) # define STATUS_NATIVE_SET(n) \ STMT_START { \ statusvalue_vms = (n); \ @@ -467,12 +459,35 @@ else \ statusvalue = (statusvalue_vms & STS$M_SEVERITY) << 8; \ } STMT_END +# define STATUS_POSIX statusvalue +# ifdef VMSISH_STATUS +# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_POSIX) +# else +# define STATUS_CURRENT STATUS_POSIX +# endif +# define STATUS_POSIX_SET(n) \ + STMT_START { \ + statusvalue = (n); \ + if (statusvalue != -1) { \ + statusvalue &= 0xFFFF; \ + statusvalue_vms = statusvalue ? 44 : 1; \ + } \ + else statusvalue_vms = -1; \ + } STMT_END # define STATUS_ALL_SUCCESS (statusvalue = 0, statusvalue_vms = 1) -# define STATUS_ALL_FAILURE (statusvalue = 1, statusvalue_vms = 4) +# define STATUS_ALL_FAILURE (statusvalue = 1, statusvalue_vms = 44) #else # define STATUS_NATIVE STATUS_POSIX # define STATUS_NATIVE_EXPORT STATUS_POSIX # define STATUS_NATIVE_SET STATUS_POSIX_SET +# define STATUS_POSIX statusvalue +# define STATUS_POSIX_SET(n) \ + STMT_START { \ + statusvalue = (n); \ + if (statusvalue != -1) \ + statusvalue &= 0xFFFF; \ + } STMT_END +# define STATUS_CURRENT STATUS_POSIX # define STATUS_ALL_SUCCESS (statusvalue = 0) # define STATUS_ALL_FAILURE (statusvalue = 1) #endif @@ -658,12 +673,8 @@ # ifdef convex # define Quad_t long long # else -# if defined(VMS) && defined(__ALPHA) -# define Quad_t __int64 -# else -# if BYTEORDER > 0xFFFF -# define Quad_t long -# endif +# if BYTEORDER > 0xFFFF +# define Quad_t long # endif # endif #endif @@ -1719,7 +1730,7 @@ IEXT I32 Imaxsysfd IINIT(MAXSYSFD); /* top fd to pass to subprocesses */ IEXT int Imultiline; /* $*--do strings hold >1 line? */ IEXT I32 Istatusvalue; /* $? */ #ifdef VMS -IEXT U32 Istatusvalue_vms; /* $^S */ +IEXT U32 Istatusvalue_vms; #endif IEXT struct stat Istatcache; /* _ */ diff --git a/pod/perldelta.pod b/pod/perldelta.pod index bfaeedcc11..ab5cde38ff 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -79,15 +79,6 @@ See the F<INSTALL> file for information on how to enable this option. As a disincentive to casual use of this advanced feature, there is no C<use English> long name for this variable. -=item $^S - -The status returned by the last pipe close, back-tick (C<``>) command, or -system() operator, in the native system format. On UNIX and UNIX-like -systems, C<$^S> is a synonym for C<$?>. Elsewhere, C<$^S> can be used to -determine aspects of child status that are system-specific. Check C<$^O> -before using this variable. (Mnemonic: System-Specific Subprocess Status. -Also known as $SYSTEM_CHILD_STATUS if you C<use English>.) - =back =head2 New and Changed Built-in Functions @@ -277,34 +268,6 @@ C<VERSION> form of C<use>. # implies: A->VERSION(1.2); -=item class() - -C<class> returns the class name of its object. - -=item is_instance() - -C<is_instance> returns true if its object is an instance of some -class, false if its object is the class (package) itself. Example - - A->is_instance(); # False - - $var = 'A'; - $var->is_instance(); # False - - $ref = bless [], 'A'; - $ref->is_instance(); # True - -This can be useful for methods that wish to easily distinguish -whether they were invoked as class or as instance methods. - - sub some_meth { - my $classname = shift; - if ($classname->is_instance()) { - die "unexpectedly called as instance not class method"; - } - ..... - } - =back B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and @@ -379,7 +342,7 @@ a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). =head1 Pragmata -Three new pragmatic modules exist: +Four new pragmatic modules exist: =over @@ -416,6 +379,15 @@ See L<perllocale> for more information. Disable unsafe opcodes, or any named opcodes, when compiling Perl code. +=item use vmsish + +Enable VMS-specific language features. Currently, there are three +VMS-specific feature available: 'status', which makes C<$?> and +C<system> return genuine VMS status values instead of emulating POSIX; +'exit', which makes C<exit> take a genuine VMS status value instead of +assuming that C<exit 1> is an error; and 'time', which makes all times +relative to the local time zone, in the VMS tradition. + =back =head1 Modules @@ -476,7 +448,6 @@ alphabetically: ExtUtils/Embed.pm Utilities for embedding Perl in C programs ExtUtils/testlib.pm Fixes up @INC to use just-built extension - Fatal.pm Make do-or-die equivalents of functions FindBin.pm Find path of currently executing program Class/Template.pm Structure/member template builder diff --git a/pod/perlmod.pod b/pod/perlmod.pod index da5c62a971..b7383d23d3 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -403,6 +403,10 @@ restrict unsafe constructs pre-declare sub names +=item vmsish + +adopt certain VMS-specific behaviors + =item vars pre-declare global variable names @@ -533,10 +537,6 @@ write linker options files for dynamic extension add blib/* directories to @INC -=item Fatal - -replace functions with equivalents which succeed or die - =item Fcntl load the C Fcntl.h defines diff --git a/pod/perlobj.pod b/pod/perlobj.pod index 9b1ede111f..c8b85b4b7d 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -313,23 +313,6 @@ C<VERSION> form of C<use>. # implies: A->VERSION(1.2); -=item class() - -C<class> returns the class name of its object. - -=item is_instance() - -C<is_instance> returns true if its object is an instance of some -class, false if its object is the class (package) itself. Example - - A->is_instance(); # False - - $var = 'A'; - $var->is_instance(); # False - - $ref = bless [], 'A'; - $ref->is_instance(); # True - =back B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and diff --git a/pod/perlrun.pod b/pod/perlrun.pod index da355c17be..df606bf0ea 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -432,8 +432,7 @@ in L<perlvar> and L<perlfunc/warn>. See also L<perldiag> and L<perltrap>. tells Perl that the script is embedded in a message. Leading garbage will be discarded until the first line that starts with #! and contains the string "perl". Any meaningful switches on that line will -be applied (but only one group of switches, as with normal #! -processing). If a directory name is specified, Perl will switch to +be applied. If a directory name is specified, Perl will switch to that directory before running the script. The B<-x> switch controls only the disposal of leading garbage. The script must be terminated with C<__END__> if there is trailing garbage to be ignored (the diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 1e088c1639..224ad5e863 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -60,7 +60,7 @@ HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERL_DESTRUCT_LEVEL, PERLLIB =item New and Changed Built-in Variables -$^E, $^H, $^M, $^S +$^E, $^H, $^M =item New and Changed Built-in Functions @@ -72,7 +72,7 @@ changing lexicals =item New Built-in Methods -isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance() +isa(CLASS), can(METHOD), VERSION( [NEED] ) =item TIEHANDLE Now Supported @@ -83,7 +83,7 @@ Efficiency Enhancements =item Pragmata -use blib, use blib 'dir', use locale, use ops +use blib, use blib 'dir', use locale, use ops, use vmsish =item Modules @@ -431,14 +431,13 @@ format_lines_left HANDLE EXPR, $FORMAT_LINES_LEFT, $-, format_name HANDLE EXPR, $FORMAT_NAME, $~, format_top_name HANDLE EXPR, $FORMAT_TOP_NAME, $^, format_line_break_characters HANDLE EXPR, $FORMAT_LINE_BREAK_CHARACTERS, $:, format_formfeed HANDLE EXPR, $FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A, -$CHILD_ERROR, $?, $SYSTEM_CHILD_STATUS, $^S, $OS_ERROR, $ERRNO, $!, -$EXTENDED_OS_ERROR, $^E, $EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, -$REAL_USER_ID, $UID, $<, $EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, -$GID, $(, $EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, -$PERL_VERSION, $], $DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, -$INPLACE_EDIT, $^I, $OSNAME, $^O, $PERLDB, $^P, $BASETIME, $^T, $WARNING, -$^W, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, %INC, $ENV{expr}, -$SIG{expr} +$CHILD_ERROR, $?, $OS_ERROR, $ERRNO, $!, $EXTENDED_OS_ERROR, $^E, +$EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID, $UID, $<, +$EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, $GID, $(, +$EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, $PERL_VERSION, $], +$DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, $INPLACE_EDIT, $^I, $OSNAME, +$^O, $PERLDB, $^P, $BASETIME, $^T, $WARNING, $^W, $EXECUTABLE_NAME, $^X, +$ARGV, @ARGV, @INC, %INC, $ENV{expr}, $SIG{expr} =back @@ -497,7 +496,7 @@ $SIG{expr} =item Pragmatic Modules blib, diagnostics, integer, less, lib, locale, ops, overload, sigtrap, -strict, subs, vars +strict, subs, vmsish, vars =item Standard Modules @@ -506,19 +505,19 @@ CPAN::Nox, Carp, Class::Template, Config, Cwd, DB_File, Devel::SelfStubber, DirHandle, DynaLoader, English, Env, Exporter, ExtUtils::Embed, ExtUtils::Install, ExtUtils::Liblist, ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS, ExtUtils::MakeMaker, ExtUtils::Manifest, -ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::testlib, Fatal, -Fcntl, File::Basename, File::CheckTree, File::Compare, File::Copy, -File::Find, File::Path, File::stat, FileCache, FileHandle, FindBin, -GDBM_File, Getopt::Long, Getopt::Std, I18N::Collate, IO, IO::File, -IO::Handle, IO::Pipe, IO::Seekable, IO::Select, IO::Socket, IPC::Open2, -IPC::Open3, Math::BigFloat, Math::BigInt, Math::Complex, NDBM_File, -Net::Ping, Net::hostent, Net::netent, Net::protoent, Net::servent, Opcode, -Pod::Text, POSIX, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, -Shell, Socket, Symbol, Sys::Hostname, Sys::Syslog, Term::Cap, -Term::Complete, Term::ReadLine, Test::Harness, Text::Abbrev, -Text::ParseWords, Text::Soundex, Text::Tabs, Text::Wrap, Tie::Hash, -Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, -Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent +ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::testlib, Fcntl, +File::Basename, File::CheckTree, File::Compare, File::Copy, File::Find, +File::Path, File::stat, FileCache, FileHandle, FindBin, GDBM_File, +Getopt::Long, Getopt::Std, I18N::Collate, IO, IO::File, IO::Handle, +IO::Pipe, IO::Seekable, IO::Select, IO::Socket, IPC::Open2, IPC::Open3, +Math::BigFloat, Math::BigInt, Math::Complex, NDBM_File, Net::Ping, +Net::hostent, Net::netent, Net::protoent, Net::servent, Opcode, Pod::Text, +POSIX, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell, +Socket, Symbol, Sys::Hostname, Sys::Syslog, Term::Cap, Term::Complete, +Term::ReadLine, Test::Harness, Text::Abbrev, Text::ParseWords, +Text::Soundex, Text::Tabs, Text::Wrap, Tie::Hash, Tie::RefHash, +Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime, +Time::tm, UNIVERSAL, User::grent, User::pwent =item Extension Modules @@ -911,7 +910,7 @@ more elaborate constructs =item Default UNIVERSAL methods -isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance() +isa(CLASS), can(METHOD), VERSION( [NEED] ) =item Destructors @@ -1679,6 +1678,14 @@ operations =item DESCRIPTION +=head2 ops - Perl pragma to restrict unsafe operations when compiling + +=item SYNOPSIS + +=item DESCRIPTION + +=item SEE ALSO + =head2 overload - Package for overloading perl operations =item SYNOPSIS @@ -2366,6 +2373,14 @@ C<Added to MANIFEST:> I<file> =item AUTHOR +=head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c + +=item SYNOPSIS + +=item DESCRIPTION + +=item SEE ALSO + =head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader =item SYNOPSIS @@ -2391,14 +2406,6 @@ NAME, DL_FUNCS, DL_VARS, FILE, FUNCLIST, DLBASE =item DESCRIPTION -=head2 Fatal - replace functions with equivalents which succeed or die - -=item SYNOPSIS - -=item DESCRIPTION - -=item AUTHOR - =head2 Fcntl - load the C Fcntl.h defines =item SYNOPSIS @@ -2581,6 +2588,139 @@ locale =item DESCRIPTION +=head2 IO::File - supply object methods for filehandles + +=item SYNOPSIS + +=item DESCRIPTION + +=item CONSTRUCTOR + +new ([ ARGS ] ) + +=item METHODS + +open( FILENAME [,MODE [,PERMS]] ) + +=item SEE ALSO + +=item HISTORY + +=head2 IO::Handle - supply object methods for I/O handles + +=item SYNOPSIS + +=item DESCRIPTION + +=item CONSTRUCTOR + +new (), new_from_fd ( FD, MODE ) + +=item METHODS + +$fh->getline, $fh->getlines, $fh->fdopen ( FD, MODE ), $fh->write ( BUF, +LEN [, OFFSET }\] ), $fh->opened, $fh->untaint + +=item NOTE + +=item SEE ALSO + +=item BUGS + +=item HISTORY + +=head2 IO::Pipe, IO::pipe - supply object methods for pipes + +=item SYNOPSIS + +=item DESCRIPTION + +=item CONSTRCUTOR + +new ( [READER, WRITER] ) + +=item METHODS + +reader ([ARGS]), writer ([ARGS]), handles () + +=item SEE ALSO + +=item AUTHOR + +=item COPYRIGHT + +=head2 IO::Seekable - supply seek based methods for I/O objects + +=item SYNOPSIS + +=item DESCRIPTION + +=item SEE ALSO + +=item HISTORY + +=head2 IO::Select - OO interface to the select system call + +=item SYNOPSIS + +=item DESCRIPTION + +=item CONSTRUCTOR + +new ( [ HANDLES ] ) + +=item METHODS + +add ( HANDLES ), remove ( HANDLES ), exists ( HANDLE ), handles, can_read ( +[ TIMEOUT ] ), can_write ( [ TIMEOUT ] ), has_error ( [ TIMEOUT ] ), count +(), bits(), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] ) + +=item EXAMPLE + +=item AUTHOR + +=item COPYRIGHT + +=head2 IO::Socket - Object interface to socket communications + +=item SYNOPSIS + +=item DESCRIPTION + +=item CONSTRUCTOR + +new ( [ARGS] ) + +=item METHODS + +accept([PKG]), timeout([VAL]), sockopt(OPT [, VAL]), sockdomain, socktype, +protocol + +=item SUB-CLASSES + +=over + +=item IO::Socket::INET + +=item METHODS + +sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost +() + +=item IO::Socket::UNIX + +=item METHODS + +hostpath(), peerpath() + +=back + +=item SEE ALSO + +=item AUTHOR + +=item COPYRIGHT + =head2 IO::lib::IO::File, IO::File - supply object methods for filehandles =item SYNOPSIS @@ -3081,6 +3221,35 @@ Constants, Macros =item DESCRIPTION +=head2 Safe - Compile and execute code in restricted compartments + +=item SYNOPSIS + +=item DESCRIPTION + +a new namespace, an operator mask + +=item WARNING + +=over + +=item RECENT CHANGES + +=item Methods in class Safe + +permit (OP, ...), permit_only (OP, ...), deny (OP, ...), deny_only (OP, +...), trap (OP, ...), untrap (OP, ...), share (NAME, ...), share_from +(PACKAGE, ARRAYREF), varglob (VARNAME), reval (STRING), rdo (FILENAME), +root (NAMESPACE), mask (MASK) + +=item Some Safety Issues + +Memory, CPU, Snooping, Signals, State Changes + +=item AUTHOR + +=back + =head2 Search::Dict, look - search for key in dictionary file =item SYNOPSIS diff --git a/pod/perlvar.pod b/pod/perlvar.pod index f0447cd58f..23c110d34e 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -397,25 +397,20 @@ L<perlfunc/formline()>. =item $? The status returned by the last pipe close, back-tick (C<``>) command, -or system() operator. Note that this is the status word returned by the -wait() system call (or else is made up to look like it -- see L<$^S>). -Thus, the exit value of the subprocess is actually (C<$? E<gt>E<gt> 8>), -and C<$? & 255> gives which signal, if any, the process died from, and -whether there was a core dump. (Mnemonic: similar to B<sh> and B<ksh>.) +or system() operator. Note that this is the status word returned by +the wait() system call (or else is made up to look like it). Thus, +the exit value of the subprocess is actually (C<$? E<gt>E<gt> 8>), and +C<$? & 255> gives which signal, if any, the process died from, and +whether there was a core dump. (Mnemonic: similar to B<sh> and +B<ksh>.) Inside an C<END> subroutine C<$?> contains the value that is going to be given to C<exit()>. You can modify C<$?> in an C<END> subroutine to change the exit status of the script. -=item $SYSTEM_CHILD_STATUS - -=item $^S - -The status returned by the last pipe close, back-tick (C<``>) command, or -system() operator, in the native system format. On UNIX and UNIX-like -systems, C<$^S> is a synonym for C<$?>. Elsewhere, C<$^S> can be used to -determine aspects of child status that are system-specific. Check C<$^O> -before using this variable. (Mnemonic: System-Specific Subprocess Status.) +Under VMS, the pragma C<use vmsish 'status'> make C<$?> reflect the +actual VMS exit status, instead of the default emulation of POSIX +status. =item $OS_ERROR diff --git a/pod/roffitall b/pod/roffitall index ae2cd060f9..2d00bdc666 100755 --- a/pod/roffitall +++ b/pod/roffitall @@ -96,7 +96,6 @@ toroff=` $libdir/ExtUtils::Manifest.3 \ $libdir/ExtUtils::Mkbootstrap.3 \ $libdir/ExtUtils::Mksymlists.3 \ - $libdir/Fatal.3 \ $libdir/Fcntl.3 \ $libdir/File::Basename.3 \ $libdir/File::CheckTree.3 \ @@ -857,10 +857,10 @@ PP(pp_ncmp) dPOPTOPnnrl; I32 value; - if (left < right) - value = -1; - else if (left == right) + if (left == right) value = 0; + else if (left < right) + value = -1; else if (left > right) value = 1; else { @@ -2130,7 +2130,7 @@ PP(pp_lslice) if (ix >= max || !(*lelem = firstrelem[ix])) *lelem = &sv_undef; } - if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem))) + if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem))) is_something_there = TRUE; } if (is_something_there) @@ -1853,8 +1853,13 @@ PP(pp_exit) if (MAXARG < 1) anum = 0; - else + else { anum = SvIVx(POPs); +#ifdef VMSISH_EXIT + if (anum == 1 && VMSISH_EXIT) + anum = 0; +#endif + } my_exit(anum); PUSHs(&sv_undef); RETURN; @@ -2200,7 +2205,7 @@ PP(pp_entereval) /* switch to eval mode */ SAVESPTR(compiling.cop_filegv); - sprintf(tmpbuf, "_<(eval %d)", ++evalseq); + sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq); compiling.cop_filegv = gv_fetchfile(tmpbuf+2); compiling.cop_line = 1; /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up @@ -523,8 +523,8 @@ PP(pp_untie) mg = mg_find(sv, 'q') ; if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) - warn("untie attempted while %d inner references still exist", - SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; + warn("untie attempted while %lu inner references still exist", + (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; } } @@ -2946,7 +2946,7 @@ PP(pp_system) STATUS_NATIVE_SET(result == -1 ? -1 : status); do_execfree(); /* free any memory child malloced on vfork */ SP = ORIGMARK; - PUSHi(STATUS_POSIX); + PUSHi(STATUS_CURRENT); RETURN; } if (op->op_flags & OPf_STACKED) { @@ -2972,7 +2972,7 @@ PP(pp_system) STATUS_NATIVE_SET(value); do_execfree(); SP = ORIGMARK; - PUSHi(STATUS_POSIX); + PUSHi(STATUS_CURRENT); #endif /* !FORK or VMS */ RETURN; } @@ -3048,7 +3048,7 @@ PP(pp_getpgrp) #ifdef BSD_GETPGRP value = (I32)BSD_GETPGRP(pid); #else - if (pid != 0) + if (pid != 0 && pid != getpid()) { DIE("POSIX getpgrp can't take an argument"); value = (I32)getpgrp(); #endif @@ -3078,7 +3078,7 @@ PP(pp_setpgrp) #ifdef BSD_SETPGRP SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else - if ((pgrp != 0) || (pid != 0)) { + if ((pgrp != 0 && pgrp != getpid())) || (pid != 0 && pid != getpid())) { DIE("POSIX setpgrp can't take an argument"); } SETi( setpgrp() >= 0 ); @@ -456,7 +456,7 @@ I32 *flagp; break; case '$': case '@': - croak("Sequence (?%c...) not implemented", paren); + croak("Sequence (?%c...) not implemented", (int)paren); break; case '#': while (*regparse && *regparse != ')') @@ -1504,7 +1504,7 @@ SV *sv; register char *s; register char *send; register char *sbegin; - I32 numtype = 1; + I32 numtype; STRLEN len; if (SvPOK(sv)) { @@ -1520,31 +1520,53 @@ SV *sv; s = sbegin; while (isSPACE(*s)) s++; - if (s >= send) - return 0; if (*s == '+' || *s == '-') s++; - while (isDIGIT(*s)) - s++; - if (s == send) - return numtype; - if (*s == '.') { - numtype = 1; - s++; + + /* next must be digit or '.' */ + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + if (*s == '.') { + s++; + while (isDIGIT(*s)) /* optional digits after "." */ + s++; + } } - else if (s == SvPVX(sv)) - return 0; - while (isDIGIT(*s)) - s++; - if (s == send) - return numtype; + else if (*s == '.') { + s++; + /* no digits before '.' means we need digits after it */ + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; + } + else + return 0; + + /* + * we return 1 if the number can be converted to _integer_ with atol() + * and 2 if you need (int)atof(). + */ + numtype = 1; + + /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { numtype = 2; s++; if (*s == '+' || *s == '-') s++; - while (isDIGIT(*s)) - s++; + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; } while (isSPACE(*s)) s++; @@ -2929,6 +2951,11 @@ sv_collxfrm(sv, nxp) Safefree(mg->mg_ptr); s = SvPV(sv, len); if ((xf = mem_collxfrm(s, len, &xlen))) { + if (SvREADONLY(sv)) { + SAVEFREEPV(xf); + *nxp = xlen; + return xf; + } if (! mg) { sv_magic(sv, 0, 'o', 0, 0); mg = mg_find(sv, 'o'); @@ -2938,8 +2965,10 @@ sv_collxfrm(sv, nxp) mg->mg_len = xlen; } else { - mg->mg_ptr = NULL; - mg->mg_len = -1; + if (mg) { + mg->mg_ptr = NULL; + mg->mg_len = -1; + } } } if (mg && mg->mg_ptr) { diff --git a/t/op/universal.t b/t/op/universal.t index 3e075cff43..03f0fbdd9d 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -3,36 +3,53 @@ # check UNIVERSAL # -print "1..4\n"; - -# explicit bless +print "1..11\n"; $a = {}; bless $a, "Bob"; -if ($a->class eq "Bob") {print "ok 1\n";} else {print "not ok 1\n";} +print "not " unless $a->isa("Bob"); +print "ok 1\n"; -# bless through a package +package Human; +sub eat {} -package Fred; +package Female; +@ISA=qw(Human); -$b = {}; -bless $b; -if ($b->class eq "Fred") {print "ok 2\n";} else {print "not ok 2\n";} +package Alice; +@ISA=qw(Bob Female); +sub drink {} +sub new { bless {} } package main; +$a = new Alice; -# same as test 1 and 2, but with other object syntax +print "not " unless $a->isa("Alice"); +print "ok 2\n"; -# explicit bless +print "not " unless $a->isa("Bob"); +print "ok 3\n"; -$a = {}; -bless $a, "Bob"; -if (class $a eq "Bob") {print "ok 3\n";} else {print "not ok 3\n";} +print "not " unless $a->isa("Female"); +print "ok 4\n"; + +print "not " unless $a->isa("Human"); +print "ok 5\n"; + +print "not " if $a->isa("Male"); +print "ok 6\n"; + +print "not " unless $a->can("drink"); +print "ok 7\n"; + +print "not " unless $a->can("eat"); +print "ok 8\n"; -# bless through a package +print "not " if $a->can("sleep"); +print "ok 9\n"; -package Fred; +print "not " unless UNIVERSAL::isa([], "ARRAY"); +print "ok 10\n"; -$b = {}; -bless $b; -if (class $b eq "Fred") {print "ok 4\n";} else {print "not ok 4\n";} +print "not " unless UNIVERSAL::isa({}, "HASH"); +print "ok 11\n"; @@ -1101,7 +1101,7 @@ filter_add(funcp, datasv) die("Can't upgrade filter_add data to SVt_PVIO"); IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ if (filter_debug) - warn("filter_add func %lx (%s)", funcp, SvPV(datasv,na)); + warn("filter_add func %p (%s)", funcp, SvPV(datasv,na)); av_unshift(rsfp_filters, 1); av_store(rsfp_filters, 0, datasv) ; return(datasv); @@ -1114,7 +1114,7 @@ filter_del(funcp) filter_t funcp; { if (filter_debug) - warn("filter_del func %lx", funcp); + warn("filter_del func %p", funcp); if (!rsfp_filters || AvFILL(rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ @@ -1180,7 +1180,7 @@ filter_read(idx, buf_sv, maxlen) /* Get function pointer hidden within datasv */ funcp = (filter_t)IoDIRP(datasv); if (filter_debug) - warn("filter_read %d: via function %lx (%s)\n", + warn("filter_read %d: via function %p (%s)\n", idx, funcp, SvPV(datasv,na)); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ @@ -1697,7 +1697,7 @@ yylex() } goto retry; case '\r': - croak("Illegal character \\%03o (carriage return)"); + croak("Illegal character \\%03o (carriage return)", '\r'); case ' ': case '\t': case '\f': case 013: s++; goto retry; @@ -1733,7 +1733,7 @@ yylex() if (strnEQ(s,"=>",2)) { if (dowarn) warn("Ambiguous use of -%c => resolved to \"-%c\" =>", - tmp, tmp); + (int)tmp, (int)tmp); s = force_word(bufptr,WORD,FALSE,FALSE,FALSE); OPERATOR('-'); /* unary minus */ } @@ -1768,7 +1768,7 @@ yylex() case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME); case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME); default: - croak("Unrecognized file test: -%c", tmp); + croak("Unrecognized file test: -%c", (int)tmp); break; } } @@ -2062,7 +2062,7 @@ yylex() if (tmp == '~') PMop(OP_MATCH); if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) - warn("Reversed %c= operator",tmp); + warn("Reversed %c= operator",(int)tmp); s--; if (expect == XSTATE && isALPHA(tmp) && (s == linestart+1 || s[-2] == '\n') ) @@ -4332,7 +4332,7 @@ I32 ck_uni; return s; } if (*s == '$' && s[1] && - (isALPHA(s[1]) || strchr("$_{", s[1]) || strnEQ(s+1,"::",2)) ) + (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) ) return s; if (*s == '{') { bracket = s; @@ -5170,7 +5170,7 @@ char *s; if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) { sprintf(buf+strlen(buf), " (Might be a runaway multi-line %c%c string starting on line %ld)\n", - multi_open,multi_close,(long)multi_start); + (int)multi_open,(int)multi_close,(long)multi_start); multi_end = 0; } if (in_eval & 2) diff --git a/universal.c b/universal.c index 74d182d953..03b907de0c 100644 --- a/universal.c +++ b/universal.c @@ -170,26 +170,6 @@ XS(XS_UNIVERSAL_can) } static -XS(XS_UNIVERSAL_is_instance) -{ - dXSARGS; - ST(0) = SvROK(ST(0)) ? &sv_yes : &sv_no; - XSRETURN(1); -} - -static -XS(XS_UNIVERSAL_class) -{ - dXSARGS; - if(SvROK(ST(0)) && SvOBJECT(SvRV(ST(0)))) { - SV *sv = sv_newmortal(); - sv_setpv(sv, HvNAME(SvSTASH(SvRV(ST(0))))); - ST(0) = sv; - } - XSRETURN(1); -} - -static XS(XS_UNIVERSAL_VERSION) { dXSARGS; @@ -239,7 +219,5 @@ boot_core_UNIVERSAL() newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); - newXS("UNIVERSAL::class", XS_UNIVERSAL_class, file); - newXS("UNIVERSAL::is_instance", XS_UNIVERSAL_is_instance, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); } diff --git a/utils/perldoc.PL b/utils/perldoc.PL index b6f8bf90f1..b311c7652d 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -59,10 +59,9 @@ use Getopt::Std; $Is_VMS = $^O eq 'VMS'; sub usage{ - warn "@_\n" if @_; - # Make sure exit status is success under VMS, so shell doesn't - # display error messages left over from startup. - ($! = 0, $^E = 1) if $^O eq 'VMS'; + warn "@_\n" if @_; + # Erase evidence of previous errors (if any), so exit status is simple. + $! = 0; die <<EOF; perldoc [options] PageName|ModuleName|ProgramName... perldoc [options] -f BuiltinFunction diff --git a/vms/Makefile b/vms/Makefile index d5e6553c59..c137113b7f 100644 --- a/vms/Makefile +++ b/vms/Makefile @@ -32,7 +32,7 @@ ARCH = VMS_VAX OBJVAL = $@ # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00326# +PERL_VERSION = 5_00327# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -159,6 +159,9 @@ CRTLOPTS =,$(CRTL)/Options $(XSUBPP) $< >$(MMS$SOURCE_NAME).c $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c +# Modules which must be installed before we can build extensions +LIBPREREQ = $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib]vmsish.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]XSSymSet.pm + utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com utils2 = [.lib]splain.com [.utils]pl2pm.com @@ -168,7 +171,7 @@ base : miniperl perl @ $(NOOP) extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) -libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm +libmods : $(LIBPREREQ) @ $(NOOP) utils : $(utils1) $(utils2) @ $(NOOP) @@ -178,12 +181,12 @@ x2p : [.x2p]a2p$(E) [.x2p]s2p.com [.x2p]find2perl.com @ $(NOOP) pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod -pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod +pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod -pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod -pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod -pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod +pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlrun.pod +pod6 = [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod +pod7 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltoot.pod pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod @@ -245,7 +248,7 @@ $(ARCHDIR)config.pm : [.lib]config.pm @ Delete/NoLog/NoConfirm genconfig.opt; $(MINIPERL) ConfigPM. -[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE) +[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE) $(XSUBPP) [.ext.dynaloader]dl_vms.xs >$@ [.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c @@ -284,7 +287,7 @@ Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.Opcode]Makefile : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.Opcode]Makefile : [.ext.Opcode]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) @@ -303,7 +306,7 @@ Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) @@ -322,7 +325,7 @@ POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.POSIX]Makefile : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.POSIX]Makefile : [.ext.POSIX]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E) @@ -371,13 +374,20 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.IO]Makefile : [.ext.IO]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.IO]Makefile : [.ext.IO]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +[.lib]vmsish.pm : [.vms.ext]vmsish.pm + Copy/Log/NoConfirm [.vms.ext]vmsish.pm $@ + [.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm @ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@ +[.lib.ExtUtils]XSSymSet.pm : [.vms.ext]XSSymSet.pm + @ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] + Copy/Log/NoConfirm [.vms.ext]XSSymSet.pm $@ + [.lib.pod]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.utils]perldoc.PL @@ -445,7 +455,7 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S $(MINIPERL) [.pod]pod2text.PL Rename/Log [.pod]pod2text.com $@ -preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM) +preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM) @ Write sys$$Output "Autosplitting Perl library . . ." @ Create/Directory [.lib.auto] @ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm @@ -1483,6 +1493,8 @@ tidy : cleanlis - If f$$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm - If f$$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm - If f$$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm + - If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* + - If f$$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;* - If f$$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.* - If f$$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod - If f$$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.* @@ -1548,6 +1560,7 @@ realclean : clean - If f$$Search("[.x2p]*.com").nes."" Then Delete/NoConfirm/Log [.x2p]*.com;* - If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;* - If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* + - If f$$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;* - If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - If f$$Search("[.lib.pod]perldoc.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.com;* - If f$$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;* diff --git a/vms/config.vms b/vms/config.vms index 41f0fa56f8..76596afb3d 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -76,7 +76,7 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00326" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00327" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ /* ARCHNAME: @@ -114,17 +114,24 @@ */ #undef HAS_BCMP /**/ +#include <string.h> /* Check whether new DECC has #defined bcopy and bzero */ /* HAS_BCOPY: * This symbol is defined if the bcopy() routine is available to * copy blocks of memory. */ #undef HAS_BCOPY /**/ +#ifdef bcopy +# define HAS_BCOPY /*config-skip*/ +#endif /* HAS_BZERO: * This symbol is defined if the bzero() routine is available to * set a memory block to 0. */ #undef HAS_BZERO /**/ +#ifdef bzero +# define HAS_BZERO /*config-skip*/ +#endif /* CASTNEGFLOAT: * This symbol is defined if the C compiler can cast negative diff --git a/vms/descrip.mms b/vms/descrip.mms index c15db049e6..d3ac365eb2 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00326# +PERL_VERSION = 5_00327# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -265,6 +265,9 @@ CRTLOPTS =,$(CRTL)/Options $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c .endif +# Modules which must be installed before we can build extensions +LIBPREREQ = $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib]vmsish.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]XSSymSet.pm + utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com utils2 = [.lib]splain.com [.utils]pl2pm.com @@ -274,7 +277,7 @@ base : miniperl perl @ $(NOOP) extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) -libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm +libmods : $(LIBPREREQ) @ $(NOOP) utils : $(utils1) $(utils2) @ $(NOOP) @@ -284,12 +287,12 @@ x2p : [.x2p]a2p$(E) [.x2p]s2p.com [.x2p]find2perl.com @ $(NOOP) pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod -pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod +pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod -pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod -pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod -pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod +pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlrun.pod +pod6 = [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod +pod7 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltoot.pod pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod @@ -366,7 +369,7 @@ $(ARCHDIR)config.pm : [.lib]config.pm @ Delete/NoLog/NoConfirm genconfig.opt; $(MINIPERL) ConfigPM. -[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE) +[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE) $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) [.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c @@ -405,7 +408,7 @@ Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) @@ -424,7 +427,7 @@ Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) @@ -443,7 +446,7 @@ POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E) @@ -492,13 +495,20 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make -[.ext.IO]Descrip.MMS : [.ext.IO]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E) +[.ext.IO]Descrip.MMS : [.ext.IO]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E) $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" +[.lib]vmsish.pm : [.vms.ext]vmsish.pm + Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) + [.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm @ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) +[.lib.ExtUtils]XSSymSet.pm : [.vms.ext]XSSymSet.pm + @ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] + Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) + [.lib.pod]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) @@ -566,7 +576,7 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S $(MINIPERL) $(MMS$SOURCE) Rename/Log [.pod]pod2text.com $(MMS$TARGET) -preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM) +preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM) @ Write Sys$Output "Autosplitting Perl library . . ." @ Create/Directory [.lib.auto] @ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm @@ -720,7 +730,7 @@ $(SOCKOBJ) : $(SOCKC) $(SOCKH) [.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE) -[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE) +[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE) $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) .endif # !LINK_ONLY @@ -1639,6 +1649,8 @@ tidy : cleanlis - If F$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm - If F$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm - If F$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm + - If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* + - If F$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;* - If F$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.* - If F$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod - If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.* @@ -1714,6 +1726,7 @@ realclean : clean - If F$Search("[.x2p]*.com").nes."" Then Delete/NoConfirm/Log [.x2p]*.com;* - If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;* - If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* + - If F$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;* - If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - If F$Search("[.lib.pod]perldoc.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.com;* - If F$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;* diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index ad16af366f..516e678e2c 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -1,8 +1,8 @@ # VMS::Stdio - VMS extensions to Perl's stdio calls # # Author: Charles Bailey bailey@genetics.upenn.edu -# Version: 2.01 -# Revised: 10-Dec-1996 +# Version: 2.02 +# Revised: 15-Feb-1997 package VMS::Stdio; @@ -12,7 +12,7 @@ use Carp '&croak'; use DynaLoader (); use Exporter (); -$VERSION = '2.01'; +$VERSION = '2.02'; @ISA = qw( Exporter DynaLoader IO::File ); @EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY ); diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 200268c7f1..b10fec0d48 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -1,8 +1,8 @@ /* VMS::Stdio - VMS extensions to stdio routines * - * Version: 2.0 + * Version: 2.02 * Author: Charles Bailey bailey@genetics.upenn.edu - * Revised: 28-Feb-1996 + * Revised: 15-Feb-1997 * */ @@ -127,7 +127,8 @@ flush(sv) CODE: FILE *fp = Nullfp; if (SvOK(sv)) fp = IoIFP(sv_2io(sv)); - ST(0) = fflush(fp) ? &sv_undef : &sv_yes; + if (fflush(fp)) { ST(0) = &sv_undef; } + else { clearerr(fp); ST(0) = &sv_yes; } char * getname(fp) @@ -157,7 +158,8 @@ sync(fp) FILE * fp PROTOTYPE: $ CODE: - ST(0) = fsync(fileno(fp)) ? &sv_undef : &sv_yes; + if (fsync(fileno(fp))) { ST(0) = &sv_undef; } + else { clearerr(fp); ST(0) = &sv_yes; } char * tmpnam() diff --git a/vms/ext/XSSymSet.pm b/vms/ext/XSSymSet.pm new file mode 100644 index 0000000000..868a303c01 --- /dev/null +++ b/vms/ext/XSSymSet.pm @@ -0,0 +1,239 @@ +package ExtUtils::XSSymSet; + +use Carp qw( &carp ); +use strict; +use vars qw( $VERSION ); +$VERSION = '1.0'; + + +sub new { + my($pkg,$maxlen,$silent) = @_; + $maxlen ||= 31; + $silent ||= 0; + my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent }; + bless $obj, $pkg; +} + + +sub trimsym { + my($self,$name,$maxlen,$silent) = @_; + + unless (defined $maxlen) { + if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; } + $maxlen ||= 31; + } + unless (defined $silent) { + if (ref $self) { $silent ||= $self->{'__S!lent'}; } + $silent ||= 0; + } + return $name if (length $name <= $maxlen); + + my $trimmed = $name; + # First, just try to remove duplicated delimiters + $trimmed =~ s/__/_/g; + if (length $trimmed > $maxlen) { + # Next, all duplicated chars + $trimmed =~ s/(.)\1+/$1/g; + if (length $trimmed > $maxlen) { + my $squeezed = $trimmed; + my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/; + if (length $func <= 12) { # Try to preserve short function names + my $frac = int(length $prefix / (length $trimmed - $maxlen) + 0.5); + my $pat = '([^_])'; + if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; } + $prefix =~ s/$pat/$1/g; + $squeezed = "$xs$prefix" . "_$func"; + if (length $squeezed > $maxlen) { + $pat =~ s/A-Z//; + $prefix =~ s/$pat/$1/g; + $squeezed = "$xs$prefix" . "_$func"; + } + } + else { + my $frac = int(length $trimmed / (length $trimmed - $maxlen) + 0.5); + my $pat = '([^_])'; + if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; } + $squeezed = "$prefix$func"; + $squeezed =~ s/$pat/$1/g; + if (length "$xs$squeezed" > $maxlen) { + $pat =~ s/A-Z//; + $squeezed =~ s/$pat/$1/g; + } + $squeezed = "$xs$squeezed"; + } + if (length $squeezed <= $maxlen) { $trimmed = $squeezed; } + else { + my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5); + my $pat = '(.).{$frac}'; + $trimmed =~ s/$pat/$1/g; + } + } + } + carp "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent; + return $trimmed; +} + + +sub addsym { + my($self,$sym,$maxlen,$silent) = @_; + my $trimmed = $self->get_trimmed($sym); + + return $trimmed if defined $trimmed; + + $maxlen ||= $self->{'__M@xLen'} || 31; + $silent ||= $self->{'__S!lent'} || 0; + $trimmed = $self->trimsym($sym,$maxlen,1); + if (exists $self->{$trimmed}) { + my($i) = "00"; + $trimmed = $self->trimsym($sym,$maxlen-3,$silent); + while (exists $self->{"${trimmed}_$i"}) { $i++; } + carp "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t" + unless $silent; + $trimmed .= "_$i"; + } + elsif (not $silent and $trimmed ne $sym) { + carp "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t"; + } + $self->{$trimmed} = $sym; + $self->{'__N+Map'}->{$sym} = $trimmed; + $trimmed; +} + + +sub delsym { + my($self,$sym) = @_; + my $trimmed = $self->{'__N+Map'}->{$sym}; + if (defined $trimmed) { + delete $self->{'__N+Map'}->{$sym}; + delete $self->{$trimmed}; + } + $trimmed; +} + + +sub get_trimmed { + my($self,$sym) = @_; + $self->{'__N+Map'}->{$sym}; +} + + +sub get_orig { + my($self,$trimmed) = @_; + $self->{$trimmed}; +} + + +sub all_orig { (keys %{$_[0]->{'__N+Map'}}); } +sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); } + +__END__ + +=head1 NAME + +VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker + +=head1 SYNOPSIS + + use VMS::XSSymSet; + + $set = new VMS::XSSymSet; + while ($sym = make_symbol()) { $set->addsym($sym); } + foreach $safesym ($set->all_trimmed) { + print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n"; + do_stuff($safesym); + } + + $safesym = VMS::XSSymSet->trimsym($onesym); + +=head1 DESCRIPTION + +Since the VMS linker distinguishes symbols based only on the first 31 +characters of their names, it is occasionally necessary to shorten +symbol names in order to avoid collisions. (This is especially true of +names generated by xsubpp, since prefixes generated by nested package +names can become quite long.) C<VMS::XSSymSet> provides functions to +shorten names in a consistent fashion, and to track a set of names to +insure that each is unique. While designed with F<xsubpp> in mind, it +may be used with any set of strings. + +This package supplies the following functions, all of which should be +called as methods. + +=over 4 + +=item new([$maxlen[,$silent]]) + +Creates an empty C<VMS::XSSymset> set of symbols. This function may be +called as a static method or via an existing object. If C<$maxlen> or +C<$silent> are specified, they are used as the defaults for maximum +name length and warning behavior in future calls to addsym() or +trimsym() via this object. + +=item addsym($name[,$maxlen[,$silent]]) + +Creates a symbol name from C<$name>, using the methods described +under trimsym(), which is unique in this set of symbols, and returns +the new name. C<$name> and its resultant are added to the set, and +any future calls to addsym() specifying the same C<$name> will return +the same result, regardless of the value of C<$maxlen> specified. +Unless C<$silent> is true, warnings are output if C<$name> had to be +trimmed or changed in order to avoid collision with an existing symbol +name. C<$maxlen> and C<$silent> default to the values specified when +this set of symbols was created. This method must be called via an +existing object. + +=item trimsym($name[,$maxlen[,$silent]]) + +Creates a symbol name C<$maxlen> or fewer characters long from +C<$name> and returns it. If C<$name> is too long, it first tries to +shorten it by removing duplicate characters, then by periodically +removing non-underscore characters, and finally, if necessary, by +periodically removing characters of any type. C<$maxlen> defaults +to 31. Unless C<$silent> is true, a warning is output if C<$name> +is altered in any way. This function may be called either as a +static method or via an existing object, but in the latter case no +check is made to insure that the resulting name is unique in the +set of symbols. + +=item delsym($name) + +Removes C<$name> from the set of symbols, where C<$name> is the +original symbol name passed previously to addsym(). If C<$name> +existed in the set of symbols, returns its "trimmed" equivalent, +otherwise returns C<undef>. This method must be called via an +existing object. + +=item get_orig($trimmed) + +Returns the original name which was trimmed to C<$trimmed> by a +previous call to addsym(), or C<undef> if C<$trimmed> does not +correspond to a member of this set of symbols. This method must be +called via an existing object. + +=item get_trimmed($name) + +Returns the trimmed name which was generated from C<$name> by a +previous call to addsym(), or C<undef> if C<$name> is not a member +of this set of symbols. This method must be called via an +existing object. + +=item all_orig() + +Returns a list containing all of the original symbol names +from this set. + +=item all_trimmed() + +Returns a list containing all of the trimmed symbol names +from this set. + +=back + +=head1 AUTHOR + +Charles Bailey E<lt>I<bailey@genetics.upenn.edu>E<gt> + +=head1 REVISION + +Last revised 14-Feb-1997, for Perl 5.004. + diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm new file mode 100644 index 0000000000..851d576e79 --- /dev/null +++ b/vms/ext/vmsish.pm @@ -0,0 +1,76 @@ +package vmsish; + +=head1 NAME + +vmsish - Perl pragma to control VMS-specific language features + +=head1 SYNOPSIS + + use vmsish; + + use vmsish 'status'; # or '$?' + use vmsish 'exit'; + use vmsish 'time'; + + use vmsish; + no vmsish 'time'; + +=head1 DESCRIPTION + +If no import list is supplied, all possible VMS-specific features are +assumed. Currently, there are three VMS-specific features available: +'status' (a.k.a '$?'), 'exit', and 'time'. + +=over 6 + +=item C<vmsish status> + +This makes C<$?> and C<system> return the native VMS exit status +instead of emulating the POSIX exit status. + +=item C<vmsish exit> + +This makes C<exit 1> produce a successful exit (with status SS$_NORMAL), +instead of emulating UNIX exit(), which considers C<exit 1> to indicate +an error. As with the CRTL's exit() function, C<exit 0> is also mapped +to an exit status of SS$_NORMAL, and any other argument to exit() is +used directly as Perl's exit status. + +=item C<vmsish time> + +This makes all times relative to the local time zone, instead of the +default of Universal Time (a.k.a Greenwich Mean Time, or GMT). + +=back + +See L<perlmod/Pragmatic Modules>. + +=cut + +if ($^O ne 'VMS') { + require Carp; + Carp::croak("This isn't VMS"); +} + +sub bits { + my $bits = 0; + my $sememe; + foreach $sememe (@_) { + $bits |= 0x01000000, next if $sememe eq 'status' || $sememe eq '$?'; + $bits |= 0x02000000, next if $sememe eq 'exit'; + $bits |= 0x04000000, next if $sememe eq 'time'; + } + $bits; +} + +sub import { + shift; + $^H |= bits(@_ ? @_ : qw(status exit time)); +} + +sub unimport { + shift; + $^H &= ~ bits(@_ ? @_ : qw(status exit time)); +} + +1; diff --git a/vms/test.com b/vms/test.com index 72354d2823..50a98caf00 100644 --- a/vms/test.com +++ b/vms/test.com @@ -27,7 +27,7 @@ $ Copy/Log/NoConfirm [-]Perl'exe' []Perl. $ $! Make the environment look a little friendlier to tests which assume Unix $ cat = "Type" -$ Macro/NoDebug/Object=Echo.Obj Sys$Input +$ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input .title echo .psect data,wrt,noexe dsc: @@ -67,7 +67,7 @@ $ Macro/NoDebug/Object=Echo.Obj Sys$Input movl #1,r0 ret .end echo -$ Link/NoTrace/Exe=Echo.Exe Echo.Obj; +$ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj; $ Delete/Log/NoConfirm Echo.Obj;* $ echo = "$" + F$Parse("Echo.Exe") $ @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 29-Jan-1997 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.3.24 + * Last revised: 15-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.3.27 */ #include <acedef.h> @@ -453,163 +453,6 @@ kill_file(char *name) } /* end of kill_file() */ /*}}}*/ -/* my_utime - update modification time of a file - * calling sequence is identical to POSIX utime(), but under - * VMS only the modification time is changed; ODS-2 does not - * maintain access times. Restrictions differ from the POSIX - * definition in that the time can be changed as long as the - * caller has permission to execute the necessary IO$_MODIFY $QIO; - * no separate checks are made to insure that the caller is the - * owner of the file or has special privs enabled. - * Code here is based on Joe Meadows' FILE utility. - */ - -/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00) - * to VMS epoch (01-JAN-1858 00:00:00.00) - * in 100 ns intervals. - */ -static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; - -/*{{{int my_utime(char *path, struct utimbuf *utimes)*/ -int my_utime(char *file, struct utimbuf *utimes) -{ - register int i; - long int bintime[2], len = 2, lowbit, unixtime, - secscale = 10000000; /* seconds --> 100 ns intervals */ - unsigned long int chan, iosb[2], retsts; - char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS]; - struct FAB myfab = cc$rms_fab; - struct NAM mynam = cc$rms_nam; -#if defined (__DECC) && defined (__VAX) - /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr, - * at least through VMS V6.1, which causes a type-conversion warning. - */ -# pragma message save -# pragma message disable cvtdiftypes -#endif - struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}}; - struct fibdef myfib; -#if defined (__DECC) && defined (__VAX) - /* This should be right after the declaration of myatr, but due - * to a bug in VAX DEC C, this takes effect a statement early. - */ -# pragma message restore -#endif - struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, - devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, - fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; - - if (file == NULL || *file == '\0') { - set_errno(ENOENT); - set_vaxc_errno(LIB$_INVARG); - return -1; - } - if (do_tovmsspec(file,vmsspec,0) == NULL) return -1; - - if (utimes != NULL) { - /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) - * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00). - * Since time_t is unsigned long int, and lib$emul takes a signed long int - * as input, we force the sign bit to be clear by shifting unixtime right - * one bit, then multiplying by an extra factor of 2 in lib$emul(). - */ - lowbit = (utimes->modtime & 1) ? secscale : 0; - unixtime = (long int) utimes->modtime; - unixtime >> 1; secscale << 1; - retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); - if (!(retsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(retsts); - return -1; - } - retsts = lib$addx(bintime,utime_baseadjust,bintime,&len); - if (!(retsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(retsts); - return -1; - } - } - else { - /* Just get the current time in VMS format directly */ - retsts = sys$gettim(bintime); - if (!(retsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(retsts); - return -1; - } - } - - myfab.fab$l_fna = vmsspec; - myfab.fab$b_fns = (unsigned char) strlen(vmsspec); - myfab.fab$l_nam = &mynam; - mynam.nam$l_esa = esa; - mynam.nam$b_ess = (unsigned char) sizeof esa; - mynam.nam$l_rsa = rsa; - mynam.nam$b_rss = (unsigned char) sizeof rsa; - - /* Look for the file to be affected, letting RMS parse the file - * specification for us as well. I have set errno using only - * values documented in the utime() man page for VMS POSIX. - */ - retsts = sys$parse(&myfab,0,0); - if (!(retsts & 1)) { - set_vaxc_errno(retsts); - if (retsts == RMS$_PRV) set_errno(EACCES); - else if (retsts == RMS$_DIR) set_errno(ENOTDIR); - else set_errno(EVMSERR); - return -1; - } - retsts = sys$search(&myfab,0,0); - if (!(retsts & 1)) { - set_vaxc_errno(retsts); - if (retsts == RMS$_PRV) set_errno(EACCES); - else if (retsts == RMS$_FNF) set_errno(ENOENT); - else set_errno(EVMSERR); - return -1; - } - - devdsc.dsc$w_length = mynam.nam$b_dev; - devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev; - - retsts = sys$assign(&devdsc,&chan,0,0); - if (!(retsts & 1)) { - set_vaxc_errno(retsts); - if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR); - else if (retsts == SS$_NOPRIV) set_errno(EACCES); - else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR); - else set_errno(EVMSERR); - return -1; - } - - fnmdsc.dsc$a_pointer = mynam.nam$l_name; - fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver; - - memset((void *) &myfib, 0, sizeof myfib); -#ifdef __DECC - for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; - for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; - /* This prevents the revision time of the file being reset to the current - * time as a result of our IO$_MODIFY $QIO. */ - myfib.fib$l_acctl = FIB$M_NORECORD; -#else - for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i]; - for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i]; - myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD; -#endif - retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); - _ckvmssts(sys$dassgn(chan)); - if (retsts & 1) retsts = iosb[0]; - if (!(retsts & 1)) { - set_vaxc_errno(retsts); - if (retsts == SS$_NOPRIV) set_errno(EACCES); - else set_errno(EVMSERR); - return -1; - } - - return 0; -} /* end of my_utime() */ -/*}}}*/ - static void create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) { @@ -3231,56 +3074,285 @@ void my_endpwent() /*}}}*/ -/* my_gmtime - * If the CRTL has a real gmtime(), use it, else look for the logical - * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on - * VMS >= 6.0. Can be manually defined under earlier versions of VMS - * to translate to the number of seconds which must be added to UTC - * to get to the local time of the system. - * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu> +/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(), + * my_utime(), and flex_stat(), all of which operate on UTC unless + * VMSISH_TIMES is true. + */ +/* method used to handle UTC conversions: + * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction */ +static int gmtime_emulation_type; +/* number of secs to add to UTC POSIX-style time to get local time */ +static long int utc_offset_secs; -/*{{{struct tm *my_gmtime(const time_t *time)*/ -/* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here - * so we can call the CRTL's routine to see if it works. +/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc. + * in vmsish.h. #undef them here so we can call the CRTL routines + * directly. */ #undef gmtime -struct tm * -my_gmtime(const time_t *time) +#undef localtime +#undef time + +/* my_time(), my_localtime(), my_gmtime() + * By default traffic in UTC time values, suing CRTL gmtime() or + * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone. + * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu> + * Modified by Charles Bailey <bailey@genetics.upenn.edu> + */ + +/*{{{time_t my_time(time_t *timep)*/ +time_t my_time(time_t *timep) { - static int gmtime_emulation_type; - static long int utc_offset_secs; - char *p; time_t when; if (gmtime_emulation_type == 0) { + struct tm *tm_p; + time_t base = 15 * 86400; /* 15jan71; to avoid month ends */ + gmtime_emulation_type++; - when = 300000000; - if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */ + if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */ + char *off; + gmtime_emulation_type++; - if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) + if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) { gmtime_emulation_type++; - else - utc_offset_secs = atol(p); + warn("no UTC offset information; assuming local time is UTC"); + } + else { utc_offset_secs = atol(off); } + } + else { /* We've got a working gmtime() */ + struct tm gmt, local; + + gmt = *tm_p; + tm_p = localtime(&base); + local = *tm_p; + utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400; + utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600; + utc_offset_secs += (local.tm_min - gmt.tm_min) * 60; + utc_offset_secs += (local.tm_sec - gmt.tm_sec); } } - switch (gmtime_emulation_type) { - case 1: - return gmtime(time); - case 2: - when = *time - utc_offset_secs; - return localtime(&when); - default: - warn("gmtime not supported on this system"); - return NULL; - } + when = time(NULL); + if ( +# ifdef VMSISH_TIME + !VMSISH_TIME && +# endif + when != -1) when -= utc_offset_secs; + if (timep != NULL) *timep = when; + return when; + +} /* end of my_time() */ +/*}}}*/ + + +/*{{{struct tm *my_gmtime(const time_t *timep)*/ +struct tm * +my_gmtime(const time_t *timep) +{ + char *p; + time_t when; + + if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */ + + when = *timep; +# ifdef VMSISH_TIME + if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */ +# endif + /* CRTL localtime() wants local time as input, so does no tz correction */ + return localtime(&when); + } /* end of my_gmtime() */ -/* Reset definition for later calls */ -#define gmtime(t) my_gmtime(t) /*}}}*/ +/*{{{struct tm *my_localtime(const time_t *timep)*/ +struct tm * +my_localtime(const time_t *timep) +{ + time_t when; + + if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */ + + when = *timep; +# ifdef VMSISH_TIME + if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */ +# endif + /* CRTL localtime() wants local time as input, so does no tz correction */ + return localtime(&when); + +} /* end of my_localtime() */ +/*}}}*/ + +/* Reset definitions for later calls */ +#define gmtime(t) my_gmtime(t) +#define localtime(t) my_localtime(t) +#define time(t) my_time(t) + + +/* my_utime - update modification time of a file + * calling sequence is identical to POSIX utime(), but under + * VMS only the modification time is changed; ODS-2 does not + * maintain access times. Restrictions differ from the POSIX + * definition in that the time can be changed as long as the + * caller has permission to execute the necessary IO$_MODIFY $QIO; + * no separate checks are made to insure that the caller is the + * owner of the file or has special privs enabled. + * Code here is based on Joe Meadows' FILE utility. + */ + +/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00) + * to VMS epoch (01-JAN-1858 00:00:00.00) + * in 100 ns intervals. + */ +static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; + +/*{{{int my_utime(char *path, struct utimbuf *utimes)*/ +int my_utime(char *file, struct utimbuf *utimes) +{ + register int i; + long int bintime[2], len = 2, lowbit, unixtime, + secscale = 10000000; /* seconds --> 100 ns intervals */ + unsigned long int chan, iosb[2], retsts; + char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS]; + struct FAB myfab = cc$rms_fab; + struct NAM mynam = cc$rms_nam; +#if defined (__DECC) && defined (__VAX) + /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr, + * at least through VMS V6.1, which causes a type-conversion warning. + */ +# pragma message save +# pragma message disable cvtdiftypes +#endif + struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}}; + struct fibdef myfib; +#if defined (__DECC) && defined (__VAX) + /* This should be right after the declaration of myatr, but due + * to a bug in VAX DEC C, this takes effect a statement early. + */ +# pragma message restore +#endif + struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, + devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, + fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; + + if (file == NULL || *file == '\0') { + set_errno(ENOENT); + set_vaxc_errno(LIB$_INVARG); + return -1; + } + if (do_tovmsspec(file,vmsspec,0) == NULL) return -1; + + if (utimes != NULL) { + /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) + * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00). + * Since time_t is unsigned long int, and lib$emul takes a signed long int + * as input, we force the sign bit to be clear by shifting unixtime right + * one bit, then multiplying by an extra factor of 2 in lib$emul(). + */ + lowbit = (utimes->modtime & 1) ? secscale : 0; + unixtime = (long int) utimes->modtime; +# ifdef VMSISH_TIME + if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */ + if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */ + unixtime += utc_offset_secs; + } +# endif + unixtime >> 1; secscale << 1; + retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); + if (!(retsts & 1)) { + set_errno(EVMSERR); + set_vaxc_errno(retsts); + return -1; + } + retsts = lib$addx(bintime,utime_baseadjust,bintime,&len); + if (!(retsts & 1)) { + set_errno(EVMSERR); + set_vaxc_errno(retsts); + return -1; + } + } + else { + /* Just get the current time in VMS format directly */ + retsts = sys$gettim(bintime); + if (!(retsts & 1)) { + set_errno(EVMSERR); + set_vaxc_errno(retsts); + return -1; + } + } + + myfab.fab$l_fna = vmsspec; + myfab.fab$b_fns = (unsigned char) strlen(vmsspec); + myfab.fab$l_nam = &mynam; + mynam.nam$l_esa = esa; + mynam.nam$b_ess = (unsigned char) sizeof esa; + mynam.nam$l_rsa = rsa; + mynam.nam$b_rss = (unsigned char) sizeof rsa; + + /* Look for the file to be affected, letting RMS parse the file + * specification for us as well. I have set errno using only + * values documented in the utime() man page for VMS POSIX. + */ + retsts = sys$parse(&myfab,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else if (retsts == RMS$_DIR) set_errno(ENOTDIR); + else set_errno(EVMSERR); + return -1; + } + retsts = sys$search(&myfab,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else if (retsts == RMS$_FNF) set_errno(ENOENT); + else set_errno(EVMSERR); + return -1; + } + + devdsc.dsc$w_length = mynam.nam$b_dev; + devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev; + + retsts = sys$assign(&devdsc,&chan,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR); + else if (retsts == SS$_NOPRIV) set_errno(EACCES); + else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR); + else set_errno(EVMSERR); + return -1; + } + + fnmdsc.dsc$a_pointer = mynam.nam$l_name; + fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver; + + memset((void *) &myfib, 0, sizeof myfib); +#ifdef __DECC + for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; + for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; + /* This prevents the revision time of the file being reset to the current + * time as a result of our IO$_MODIFY $QIO. */ + myfib.fib$l_acctl = FIB$M_NORECORD; +#else + for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i]; + for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i]; + myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD; +#endif + retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); + _ckvmssts(sys$dassgn(chan)); + if (retsts & 1) retsts = iosb[0]; + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == SS$_NOPRIV) set_errno(EACCES); + else set_errno(EVMSERR); + return -1; + } + + return 0; +} /* end of my_utime() */ +/*}}}*/ + /* * flex_stat, flex_fstat * basic stat, but gets it right when asked to stat @@ -3525,6 +3597,16 @@ flex_fstat(int fd, struct mystat *statbufp) if (!fstat(fd,(stat_t *) statbufp)) { if (statbufp == &statcache) *namecache == '\0'; statbufp->st_dev = encode_dev(statbufp->st_devnam); +# ifdef VMSISH_TIME + if (!VMSISH_TIME) { /* Return UTC instead of local time */ +# else + if (1) { +# endif + if (!gmtime_emulation_type) (void)time(NULL); + statbufp->st_mtime -= utc_offset_secs; + statbufp->st_atime -= utc_offset_secs; + statbufp->st_ctime -= utc_offset_secs; + } return 0; } return -1; @@ -3569,7 +3651,19 @@ flex_stat(char *fspec, struct mystat *statbufp) if (!retval && statbufp == &statcache) strcpy(namecache,fileified); } if (retval) retval = stat(fspec,(stat_t *) statbufp); - if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam); + if (!retval) { + statbufp->st_dev = encode_dev(statbufp->st_devnam); +# ifdef VMSISH_TIME + if (!VMSISH_TIME) { /* Return UTC instead of local time */ +# else + if (1) { +# endif + if (!gmtime_emulation_type) (void)time(NULL); + statbufp->st_mtime -= utc_offset_secs; + statbufp->st_atime -= utc_offset_secs; + statbufp->st_ctime -= utc_offset_secs; + } + } return retval; } /* end of flex_stat() */ diff --git a/vms/vmsish.h b/vms/vmsish.h index ad3f1e10a5..cab319dc04 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -100,6 +100,8 @@ # define vmsreaddirversions Perl_vmsreaddirversions # define getredirection Perl_getredirection # define my_gmtime Perl_my_gmtime +# define my_localtime Perl_my_localtime +# define my_time Perl_my_time # define cando_by_name Perl_cando_by_name # define flex_fstat Perl_flex_fstat # define flex_stat Perl_flex_stat @@ -175,6 +177,21 @@ # define set_vaxc_errno(v) (vaxc$errno = (v)) #endif +/* Support for 'vmsish' behaviors enabled with C<use vmsish> pragma */ + +#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */ + +#define HINT_S_VMSISH 24 +#define HINT_M_VMSISH_STATUS 0x01000000 /* system, $? return VMS status */ +#define HINT_M_VMSISH_EXIT 0x02000000 /* exit(1) ==> SS$_NORMAL */ +#define HINT_M_VMSISH_TIME 0x04000000 /* times are local, not UTC */ +#define NATIVE_HINTS (hints >> HINT_S_VMSISH) /* used in op.c */ + +#define TEST_VMSISH(h) (curcop->op_private & ((h) >> HINT_S_VMSISH)) +#define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS) +#define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT) +#define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME) + /* Handy way to vet calls to VMS system services and RTL routines. */ #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \ if (!((__ckvms_sts=(call))&1)) { \ @@ -294,9 +311,12 @@ struct utimbuf { /* Prior to VMS 7.0, the CRTL gmtime() routine was a stub which always * returned NULL. Substitute our own routine, which uses the logical * SYS$TIMEZONE_DIFFERENTIAL, whcih the native UTC support routines - * in VMS 6.0 or later use.* + * in VMS 6.0 or later use. We also add shims for time() and localtime() + * so we can run on UTC by default. */ #define gmtime(t) my_gmtime(t) +#define localtime(t) my_localtime(t) +#define time(t) my_time(t) /* VMS doesn't use a real sys_nerr, but we need this when scanning for error * messages in text strings . . . @@ -489,7 +509,9 @@ long telldir _((DIR *)); void seekdir _((DIR *, long)); void closedir _((DIR *)); void vmsreaddirversions _((DIR *, int)); -struct tm *my_gmtime _((const time_t *)); +struct tm * my_gmtime _((const time_t *)); +struct tm * my_localtime _((const time_t *)); +time_t my_time _((time_t *)); I32 cando_by_name _((I32, I32, char *)); int flex_fstat _((int, struct stat *)); int flex_stat _((char *, struct stat *)); diff --git a/win32/makedef.pl b/win32/makedef.pl index 1a555f53f3..f118aaf215 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -1,4 +1,3 @@ - #!../miniperl # Written: 10 April 1996 Gary Ng (71564.1743@compuserve.com) @@ -129,6 +128,7 @@ perl_init_ext perl_requirepv siggv stack +statusvalue_vms tainting Perl_safexcalloc Perl_safexmalloc @@ -2000,8 +2000,11 @@ short yyss[YYSTACKSIZE]; YYSTYPE yyvs[YYSTACKSIZE]; #define yystacksize YYSTACKSIZE #line 396 "a2p.y" + +int yyparse _((void)); + #include "a2py.c" -#line 2005 "y.tab.c" +#line 2008 "y.tab.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -2667,7 +2670,7 @@ case 137: #line 392 "a2p.y" { yyval = oper3(OBLOCK,oper2(OJUNK,yyvsp[-3],yyvsp[-2]),Nullop,yyvsp[0]); } break; -#line 2671 "y.tab.c" +#line 2674 "y.tab.c" } yyssp -= yym; yystate = *yyssp; @@ -393,4 +393,7 @@ compound ; %% + +int yyparse _((void)); + #include "a2py.c" |