diff options
| -rw-r--r-- | Changes | 138 | ||||
| -rw-r--r-- | INSTALL | 4 | ||||
| -rw-r--r-- | Porting/Glossary | 10 | ||||
| -rw-r--r-- | cop.h | 4 | ||||
| -rw-r--r-- | lib/ExtUtils/Liblist.pm | 2 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_VMS.pm | 47 | ||||
| -rwxr-xr-x | lib/ExtUtils/xsubpp | 6 | ||||
| -rw-r--r-- | lib/diagnostics.pm | 4 | ||||
| -rw-r--r-- | op.c | 39 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.c | 19 | ||||
| -rw-r--r-- | pod/perldiag.pod | 9 | ||||
| -rw-r--r-- | pod/perlmod.pod | 5 | ||||
| -rw-r--r-- | pod/perltoc.pod | 12 | ||||
| -rw-r--r-- | pp_ctl.c | 16 | ||||
| -rw-r--r-- | scope.h | 10 | ||||
| -rwxr-xr-x | t/op/recurse.t | 8 | ||||
| -rw-r--r-- | toke.c | 13 | ||||
| -rw-r--r-- | vms/Makefile | 9 | ||||
| -rw-r--r-- | vms/config.vms | 12 | ||||
| -rw-r--r-- | vms/descrip.mms | 9 | ||||
| -rw-r--r-- | vms/genconfig.pl | 2 | ||||
| -rw-r--r-- | vms/perlvms.pod | 56 | ||||
| -rw-r--r-- | vms/vms.c | 6 | ||||
| -rw-r--r-- | vms/vmsish.h | 15 |
25 files changed, 363 insertions, 94 deletions
@@ -9,6 +9,144 @@ releases.) ---------------- +Version 5.003_26 +---------------- + +This release is beta candidate #4. "Once more, dear friends...." + + CORE LANGUAGE CHANGES + + Title: "Make \r in script an error (per Larry)" + From: Chip Salzenberg + Files: pod/perldiag.pod toke.c + + Title: "Support '%i' format and 'h' modifier in s?printf" + From: Chip Salzenberg + Files: doop.c pod/perldelta.pod + + CORE PORTABILITY + + Title: "Fix value of system() and $? for DEC UNIX, VMS, others" + From: Chip Salzenberg + Files: mg.c perl.h pp_sys.c + + Title: "VMS patches post _25" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IF48W3P39W0050BD@hmivax.humgen.upenn.edu> + Date: Fri, 07 Feb 1997 01:56:12 -0500 (EST) + Files: Porting/Glossary lib/ExtUtils/Liblist.pm + lib/ExtUtils/MM_VMS.pm lib/ExtUtils/xsubpp perl.c + vms/Makefile vms/config.vms vms/descrip.mms vms/genconfig.pl + vms/perlvms.pod vms/vms.c vms/vmsish.h x2p/a2p.c + + Title: "Hints for BSDOS" + From: Christopher Davis <ckd@loiosh.kei.com> + Msg-ID: <199702042011.PAA09206@loiosh.kei.com> + Date: Tue, 4 Feb 1997 15:11:13 -0500 (EST) + Files: hints/bsdos.sh + + Title: "On C<sysopen(..., O_APPEND)>, call C<fopen(..., "a")>" + From: Chip Salzenberg + Files: doio.c + + OTHER CORE CHANGES + + Title: "Fix (yet another) Tk closure problem" + From: Chip Salzenberg + Files: op.c perl.c pp_ctl.c + + Title: "Fix value of C<foreach>" + From: Chip Salzenberg + Files: cop.h pp_ctl.c + + Title: "Regexp optimizations" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199702041102.GAA24805@monk.mps.ohio-state.edu> + Date: Tue, 4 Feb 1997 06:02:10 -0500 (EST) + Files: regcomp.c regexec.c + + Title: "Re: static buffer in not_a_number() [sv.c] might overflow" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <hbu9uz1si.fsf@bergen.sn.no> + Date: 09 Feb 1997 11:55:41 +0100 + Files: sv.c + + Title: "Refine 'runaway string' heuristic" + From: Chip Salzenberg + Files: toke.c + + Title: "Fix core dump on C<print "a", last> in eval" + From: Chip Salzenberg + Files: pp_ctl.c + + Title: "Catch C<use integer; $x % 0>" + From: Chip Salzenberg + Files: pp.c + + BUILD PROCESS + + Title: "Fix usage message in configure.gnu" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Files: configure.gnu + + LIBRARY AND EXTENSIONS + + Title: "DB_File 1.11 patch" + From: pmarquess@bfsec.bt.co.uk (Paul Marquess) + Msg-ID: <9702061553.AA18147@claudius.bfsec.bt.co.uk> + Date: Thu, 6 Feb 97 15:53:34 GMT + Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs + + Title: "Faster File::Compare" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <199702051342.OAA02753@bergen.sn.no> + Date: Wed, 5 Feb 1997 14:42:49 +0100 + Files: lib/File/Compare.pm + + Title: "Make diagnostics module strip formatting directives" + From: Chip Salzenberg + Files: lib/diagnostics.pm pod/perldiag.pod + + Title: "Fix warning from missing POSIX::setvbuf()" + From: Chip Salzenberg + Files: ext/IO/IO.xs + + TESTS + + Title: "Fix closure.t for AmigaOS (again)" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Msg-ID: <77724742@Armageddon.meb.uni-bonn.de> + Date: Wed, 05 Feb 1997 18:56:45 +0100 + Files: t/op/closure.t + + UTILITIES + + Title: "perldoc -f <perlfunc>" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <199702051127.MAA02090@bergen.sn.no> + Date: Wed, 5 Feb 1997 12:27:36 +0100 + Files: utils/perldoc.PL + + Title: "Fix pod2man's handling of quotes in =items" + From: Jarkko Hietaniemi <jhi@iki.fi> + Msg-ID: <199702042023.WAA13143@alpha.hut.fi> + Date: Tue, 4 Feb 1997 22:23:34 +0200 (EET) + Files: pod/pod2man.PL + + DOCUMENTATION + + Title: "return *FH pod patch" + From: allen@gateway.grumman.com (John L. Allen) + Msg-ID: <9702061507.AA04474@gateway.grumman.com> + Date: Thu, 6 Feb 1997 10:07:28 -0500 + Files: pod/perldata.pod pod/perlsub.pod + + Title: "Describe interation of untie and DESTROY" + From: Paul Marquess and Chip Salzenberg + Files: pod/perltie.pod + + +---------------- Version 5.003_25 ---------------- @@ -117,7 +117,7 @@ e.g. If your prefix contains the string "perl", then the directories are simplified. For example, if you use prefix=/opt/perl, then Configure will suggest /opt/perl/lib instead of -/usr/local/lib/perl5/. +/opt/perl/lib/perl5/. By default, Configure will compile perl to use dynamic loading, if your system supports it. If you want to force perl to be compiled @@ -1102,4 +1102,4 @@ from the original README by Larry Wall. =head1 LAST MODIFIED -22 January 1997 +8 February 1997 diff --git a/Porting/Glossary b/Porting/Glossary index 58f2cac2f6..c71c199ec4 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -1113,6 +1113,11 @@ lns (lns.U): symbolic links (if they are supported). It can be used in the Makefile. It is either 'ln -s' or 'ln' +longsize (intsize.U): + This variable contains the value of the LONGSIZE symbol, + which indicates to the C program how many bytes there are + in a long integer. + lseektype (lseektype.U): This variable defines lseektype to be something like off_t, long, or whatever type is used to declare lseek offset's type in the @@ -1288,6 +1293,11 @@ shmattype (d_shmat.U): This symbol contains the type of pointer returned by shmat(). It can be 'void *' or 'char *'. +shortsize (intsize.U): + This variable contains the value of the SHORTSIZE symbol, + which indicates to the C program how many bytes there are + in a short integer. + shrpenv (libperl.U): If the user builds a shared libperl.so, then we need to tell the 'perl' executable where it will be able to find the installed libperl.so. @@ -125,10 +125,10 @@ struct block_loop { POPLOOP2(); } #define POPLOOP1(cx) \ - cxloop = cx->blk_loop; /* because DESTROY may clobber *cx */ + cxloop = cx->blk_loop; /* because DESTROY may clobber *cx */ \ + newsp = stack_base + cxloop.resetsp; #define POPLOOP2() \ - newsp = stack_base + cxloop.resetsp; \ SvREFCNT_dec(cxloop.iterlval); \ if (cxloop.itervar) { \ SvREFCNT_dec(*cxloop.itervar); \ diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index 59b2efa3ca..cb482e16bf 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -290,7 +290,7 @@ sub _vms_ext { if ($ctype) { eval '$' . $ctype . "{'$cand'}++"; die "Error recording library: $@" if $@; - print STDOUT "\tFound as $name (really $test), type $type\n" if $verbose > 1; + print STDOUT "\tFound as $cand (really $ctest), type $ctype\n" if $verbose > 1; next LIB; } } diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index f609cc8761..b56b1b8cf5 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -6,9 +6,10 @@ # Author: Charles Bailey bailey@genetics.upenn.edu package ExtUtils::MM_VMS; -$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.39 (16-Jan-1997)'; +$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.39 (31-Jan-1997)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; +use Carp qw( &carp ); use Config; require Exporter; use VMS::Filespec; @@ -47,16 +48,23 @@ sub eliminate_macros { return ''; } my($npath) = unixify($path); + my($complex) = 0; my($head,$macro,$tail); # perform m##g in scalar context so it acts as an iterator while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) { if ($self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); - ($macro = unixify($self->{$macro})) =~ s#/$##; + if (ref $self->{$macro}) { + carp "Can't expand macro containing " . ref $self->{$macro}; + $npath = "$head\cB$macro\cB$tail"; + $complex = 1; + } + else { ($macro = unixify($self->{$macro})) =~ s#/$##; } $npath = "$head$macro$tail"; } } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\$($1)#g; } print "eliminate_macros($path) = |$npath|\n" if $Verbose >= 3; $npath; } @@ -590,8 +598,8 @@ sub constants { foreach $def (@defs) { next unless $def; if ($def =~ s/^-D//) { # If it was a Unix-style definition - $def =~ /='(.*)'$/=$1/; # then remove shell-protection '' - $def =~ /^'(.*)'$/$1/; # from entire term or argument + $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' + $def =~ s/^'(.*)'$/$1/; # from entire term or argument } if ($def =~ /=/) { $def =~ s/"/""/g; # Protect existing " from DCL @@ -1590,7 +1598,19 @@ clean :: '; my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files - push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; + # Unlink realclean, $attribs{FILES} is a string here; it may contain + # a list or a macro that expands to a list. + if ($attribs{FILES}) { + my($word,$key,@filist); + if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; } + else { @filist = split /\s+/, $attribs{FILES}; } + foreach $word (@filist) { + if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { + push(@otherfiles, @{$self->{$key}}); + } + else { push(@otherfiles, $attribs{FILES}); } + } + } push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]); push(@otherfiles,$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); my($file,$line); @@ -1649,9 +1669,18 @@ realclean :: clean else { $line .= " $file"; } } push @m, "\t\$(RM_F) $line\n" if $line; - if ($attribs{FILES} && ref $attribs{FILES} eq 'ARRAY') { + if ($attribs{FILES}) { + my($word,$key,@filist,@allfiles); + if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; } + else { @filist = split /\s+/, $attribs{FILES}; } + foreach $word (@filist) { + if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') { + push(@allfiles, @{$self->{$key}}); + } + else { push(@allfiles, $attribs{FILES}); } + } $line = ''; - foreach $file (@{$attribs{'FILES'}}) { + foreach $file (@allfiles) { $file = $self->fixpath($file); if (length($line) + length($file) > 80) { push @m, "\t\$(RM_RF) $line\n"; @@ -1681,7 +1710,7 @@ distcheck : $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; fullcheck()" skipcheck : - $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; skipcheck()" + $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&skipcheck\'; skipcheck()" manifest : $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&mkmanifest\'; mkmanifest()" @@ -1810,7 +1839,7 @@ pure__install : pure_site_install $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" doc__install : doc_site_install - $(NOECHO} $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" # This hack brought to you by DCL's 255-character command line limit pure_perl_install :: diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index d655a26ba6..5f6feb8af7 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -1295,8 +1295,6 @@ sub map_type { sub Exit { -# 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) ; + # VMS error exit: SS$_ABORT. + exit $errors ? ($Is_VMS ? 44 : 1) : 0; } diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 89d7467c4f..bbae58e12b 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -313,7 +313,9 @@ EOFUNC } next; } - $header = $1; + + # strip formatting directives in =item line + ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; if ($header =~ /%[sd]/) { $rhs = $lhs = $header; @@ -177,9 +177,10 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) int saweval; for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { - AV* curlist = CvPADLIST(cv); - SV** svp = av_fetch(curlist, 0, FALSE); + AV *curlist = CvPADLIST(cv); + SV **svp = av_fetch(curlist, 0, FALSE); AV *curname; + if (!svp || *svp == &sv_undef) continue; curname = (AV*)*svp; @@ -198,8 +199,8 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) depth = CvDEPTH(cv); if (!depth) { - if (newoff && !CvUNIQUE(cv)) - return 0; /* don't clone inactive sub's stack frame */ + if (newoff) + return 0; /* don't clone from inactive stack frame */ depth = 1; } oldpad = (AV*)*av_fetch(curlist, depth, FALSE); @@ -1369,22 +1370,18 @@ OP *op; peep(eval_start); } else { - if (!op) { - main_start = 0; + if (!op) return; - } main_root = scope(sawparens(scalarvoid(op))); curcop = &compiling; main_start = LINKLIST(main_root); main_root->op_next = 0; peep(main_start); - main_cv = compcv; compcv = 0; - /* Register with debugger: */ + /* Register with debugger */ if (perldb) { CV *cv = perl_get_cv("DB::postponed", FALSE); - if (cv) { dSP; PUSHMARK(sp); @@ -2858,10 +2855,10 @@ CV* cv; { CV *outside = CvOUTSIDE(cv); AV* padlist = CvPADLIST(cv); - AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE); - AV* pad = (AV*)*av_fetch(padlist, 1, FALSE); - SV** pname = AvARRAY(pad_name); - SV** ppad = AvARRAY(pad); + AV* pad_name; + AV* pad; + SV** pname; + SV** ppad; I32 ix; PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", @@ -2877,10 +2874,20 @@ CV* cv; : CvUNIQUE(outside) ? "UNIQUE" : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + if (!padlist) + return; + + pad_name = (AV*)*av_fetch(padlist, 0, FALSE); + pad = (AV*)*av_fetch(padlist, 1, FALSE); + pname = AvARRAY(pad_name); + ppad = AvARRAY(pad); + for (ix = 1; ix <= AvFILL(pad); ix++) { if (SvPOK(pname[ix])) - PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (\"%s\" %ld-%ld)\n", - ix, ppad[ix], SvPVX(pname[ix]), + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%s\"%s\" %ld-%ld)\n", + ix, ppad[ix], + SvFAKE(pname[ix]) ? "FAKE " : "", + SvPVX(pname[ix]), (long)I_32(SvNVX(pname[ix])), (long)SvIVX(pname[ix])); } diff --git a/patchlevel.h b/patchlevel.h index 7db0e20df5..405184345e 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 25 +#define SUBVERSION 26 /* local_patches -- list of locally applied less-than-subversion patches. @@ -476,9 +476,11 @@ setuid perl scripts securely.\n"); return 0; } + SvREFCNT_dec(main_cv); if (main_root) op_free(main_root); - main_root = 0; + main_cv = 0; + main_start = main_root = 0; time(&basetime); @@ -687,7 +689,7 @@ setuid perl scripts securely.\n"); if (doextract) find_beginning(); - compcv = (CV*)NEWSV(1104,0); + main_cv = compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); CvUNIQUE_on(compcv); @@ -819,6 +821,7 @@ PerlInterpreter *sv_interp; runops(); } else if (main_start) { + CvDEPTH(main_cv) = 1; op = main_start; runops(); } @@ -2348,7 +2351,7 @@ int addsubdirs; if (addsubdirs) { struct stat tmpstatbuf; - /* .../archname/version if -d .../archname/auto */ + /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); sv_catpv(subdir, archpat_auto); if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && @@ -2356,7 +2359,7 @@ int addsubdirs; av_push(GvAVn(incgv), newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); - /* .../archname/version if -d .../archname/version/auto */ + /* .../archname if -d .../archname/auto */ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), strlen(patchlevel) + 1, "", 0); if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && @@ -2464,14 +2467,14 @@ my_failure_exit() { #ifdef VMS if (vaxc$errno & 1) { - if (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */ - SETSTATUS_NATIVE(44); + if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */ + STATUS_NATIVE_SET(44); } else { if (!vaxc$errno && errno) /* someone must have set $^E = 0 */ - SETSTATUS_NATIVE(44); + STATUS_NATIVE_SET(44); else - SETSTATUS_NATIVE(vaxc$errno); + STATUS_NATIVE_SET(vaxc$errno); } #else if (errno & 255) diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 32f55be0a6..e29d1353ff 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1078,6 +1078,13 @@ appear in %ENV. This may be a benign occurrence, as some software packages might directly modify logical name tables and introduce non-standard names, or it may indicate that a logical name table has been corrupted. +=item Illegal character %s (carriage return) + +(F) A carriage return character was found in the input. This is an +error, and not a warning, because carriage return characters can break +here documents (e.g. C<print E<LT>E<LT>EOF;>). Note that Perl always +opens scripts in text mode, so this error should only occur in C<eval>. + =item Illegal division by zero (F) You tried to divide a number by 0. Either something was wrong in your @@ -2185,7 +2192,7 @@ you're not running on Unix. (F) There has to be at least one argument to syscall() to specify the system call to call, silly dilly. -=item Too late for "-T" option (try putting it first) +=item Too late for "B<-T>" option (try putting it first) (X) The #! line in a Perl script contains the "-T" option, but Perl was not invoked with "-T" in its argument list. Due to the way Perl diff --git a/pod/perlmod.pod b/pod/perlmod.pod index c2b1f6c961..da5c62a971 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -332,7 +332,8 @@ F<.pl> files will all eventually be converted into standard modules, and the F<.ph> files made by B<h2ph> will probably end up as extension modules made by B<h2xs>. (Some F<.ph> values may already be available through the POSIX module.) The B<pl2pm> file in the distribution may help in your -conversion, but it's just a mechanical process, so is far from bulletproof. +conversion, but it's just a mechanical process and therefore far from +bulletproof. =head2 Pragmatic Modules @@ -349,7 +350,7 @@ which lasts until the end of that BLOCK. Unlike the pragmas that effect the C<$^H> hints variable, the C<use vars> and C<use subs> declarations are not BLOCK-scoped. They allow you to pre-declare a variables or subroutines within a particular -<I>file</I> rather than just a block. Such declarations are effective +I<file> rather than just a block. Such declarations are effective for the entire file for which they were declared. You cannot rescind them with C<no vars> or C<no subs>. diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 02d3dd3014..1e088c1639 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -64,10 +64,10 @@ $^E, $^H, $^M, $^S =item New and Changed Built-in Functions -delete on slices, flock, keys as an lvalue, my() in Control Structures, -unpack() and pack(), use VERSION, use Module VERSION LIST, -prototype(FUNCTION), $_ as Default, C<m//g> does not trigger a pos() reset -on failure, nested C<sub{}> closures work now, formats work right on +delete on slices, flock, printf and sprintf, keys as an lvalue, my() in +Control Structures, unpack() and pack(), use VERSION, use Module VERSION +LIST, prototype(FUNCTION), $_ as Default, C<m//g> does not trigger a pos() +reset on failure, nested C<sub{}> closures work now, formats work right on changing lexicals =item New Built-in Methods @@ -952,6 +952,8 @@ this, NEXTKEY this, lastkey, DESTROY this TIEHANDLE classname, LIST, PRINT this, LIST, READLINE this, DESTROY this +=item The C<untie> Gotcha + =back =item SEE ALSO @@ -2058,6 +2060,8 @@ $value, $flags) ;>, B<$status = $X-E<gt>sync([$flags]) ;> =item Sharing databases with C applications +=item The untie gotcha + =back =item COMMON QUESTIONS @@ -1287,9 +1287,9 @@ PP(pp_leaveloop) SV **mark; POPBLOCK(cx,newpm); + mark = newsp; POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ - mark = newsp; if (gimme == G_SCALAR) { if (op->op_private & OPpLEAVE_VOID) ; @@ -1422,8 +1422,7 @@ PP(pp_last) case CXt_LOOP: POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ pop2 = CXt_LOOP; - nextop = cx->blk_loop.last_op->op_next; - LEAVE; + nextop = cxloop.last_op->op_next; break; case CXt_SUB: POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ @@ -1458,6 +1457,7 @@ PP(pp_last) switch (pop2) { case CXt_LOOP: POPLOOP2(); /* release loop vars ... */ + LEAVE; break; case CXt_SUB: POPSUB2(); /* release CV and @_ ... */ @@ -2035,10 +2035,8 @@ int gimme; DEBUG_x(dump_eval()); /* Register with debugger: */ - if (perldb && saveop->op_type == OP_REQUIRE) { CV *cv = perl_get_cv("DB::postponed", FALSE); - if (cv) { dSP; PUSHMARK(sp); @@ -2050,6 +2048,8 @@ int gimme; /* compiled okay, so do it */ + CvDEPTH(compcv) = 1; + SP = stack_base + POPMARK; /* pop original mark */ RETURNOP(eval_start); } @@ -2271,6 +2271,11 @@ PP(pp_leaveeval) } curpm = newpm; /* Don't pop $1 et al till now */ +#ifdef DEBUGGING + assert(CvDEPTH(compcv) == 1); +#endif + CvDEPTH(compcv) = 0; + if (optype == OP_REQUIRE && !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) { char *name = cx->blk_eval.old_name; @@ -2282,6 +2287,7 @@ PP(pp_leaveeval) lex_end(); LEAVE; + if (!(save_flags & OPf_SPECIAL)) sv_setpv(GvSV(errgv),""); @@ -49,11 +49,11 @@ * Not using SOFT_CAST on SAVEFREESV and SAVEFREESV * because these are used for several kinds of pointer values */ -#define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i)); -#define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i)); -#define SAVEINT(i) save_int(SOFT_CAST(int*)&(i)); -#define SAVEIV(i) save_iv(SOFT_CAST(IV*)&(i)); -#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l)); +#define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i)) +#define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i)) +#define SAVEINT(i) save_int(SOFT_CAST(int*)&(i)) +#define SAVEIV(i) save_iv(SOFT_CAST(IV*)&(i)) +#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l)) #define SAVESPTR(s) save_sptr((SV**)&(s)) #define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s)) #define SAVEFREESV(s) save_freesv((SV*)(s)) diff --git a/t/op/recurse.t b/t/op/recurse.t index 6b21c66106..6594940a90 100755 --- a/t/op/recurse.t +++ b/t/op/recurse.t @@ -22,13 +22,9 @@ sub fibonacci ($) { # Highly recursive, highly aggressive. # Kids, don't try this at home. -# For example ackermann(4,0) will take quite a long time. # -# In fact, the current Perl, 5.004, will complain loudly: -# "Deep recursion on subroutine." (see perldiag) when -# computing the ackermann(4,0) because the recursion will -# become so deep (>100 levels) that Perl suspects the script -# has been lost in an infinite recursion. +# For example ackermann(4,1) will take quite a long time. +# It will simply eat away your memory. Trust me. sub ackermann ($$) { return $_[1] + 1 if ($_[0] == 0); @@ -1696,7 +1696,9 @@ yylex() return yylex(); } goto retry; - case ' ': case '\t': case '\f': case '\r': case 013: + case '\r': + croak("Illegal character \\%03o (carriage return)"); + case ' ': case '\t': case '\f': case 013: s++; goto retry; case '#': @@ -4445,6 +4447,7 @@ char *start; { register char *s; register PMOP *pm; + I32 first_start; I32 es = 0; yylval.ival = OP_NULL; @@ -4461,6 +4464,7 @@ char *start; if (s[-1] == multi_open) s--; + first_start = multi_start; s = scan_str(s); if (!s) { if (lex_stuff) @@ -4471,6 +4475,7 @@ char *start; lex_repl = Nullsv; croak("Substitution replacement not terminated"); } + multi_start = first_start; /* so whole substitution is taken together */ pm = (PMOP*)newPMOP(OP_SUBST, 0); while (*s && strchr("iogmsex", *s)) { @@ -5162,10 +5167,10 @@ char *s; (void)sprintf(tname,"next char %c",yychar); (void)sprintf(buf, "%s at %s line %d, %s\n", s,SvPVX(GvSV(curcop->cop_filegv)),curcop->cop_line,tname); - if (curcop->cop_line == multi_end && multi_start < multi_end) { + 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); + " (Might be a runaway multi-line %c%c string starting on line %ld)\n", + multi_open,multi_close,(long)multi_start); multi_end = 0; } if (in_eval & 2) diff --git a/vms/Makefile b/vms/Makefile index d5194b41eb..d5e6553c59 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_00325# +PERL_VERSION = 5_00326# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -418,6 +418,13 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S @ If f$$Search("a2p$(O)").nes."" Then Rename/NoLog a2p$(O),hash$(O),str$(O),util$(O),walk$(O) [.x2p] Link $(LINKFLAGS) /Exe=$@ $(MMS$SOURCE_LIST) $(CRTLOPTS) +# Accomodate buggy cpp in some version of DECC, which chokes on illegal +# filespec "y.tab.c" +[.x2p]a2p$(O) : [.x2p]a2p.c $(MINIPERL_EXE) + $(MINIPERL) -pe "s/^#line\s+(\d+)\s+\Q""y.tab.c""/#line $1 ""y_tab.c""/;" [.x2p]a2p.c >$*_vms.c + $(CC) $(CFLAGS) /Object=$@ $*_vms.c + Delete/Log/NoConfirm $*_vms.c; + [.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.pod]pod2html.PL diff --git a/vms/config.vms b/vms/config.vms index 97d5c960b8..41f0fa56f8 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_00325" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00326" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ /* ARCHNAME: @@ -1263,7 +1263,17 @@ * This symbol contains the size of an int, so that the C preprocessor * can make decisions based on it. */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. + */ #define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ /* Off_t: * This symbol holds the type used to declare offsets in the kernel. diff --git a/vms/descrip.mms b/vms/descrip.mms index 36386ef846..c15db049e6 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_00325# +PERL_VERSION = 5_00326# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -539,6 +539,13 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S @ If F$Search("a2p$(O)").nes."" Then Rename/NoLog a2p$(O),hash$(O),str$(O),util$(O),walk$(O) [.x2p] Link $(LINKFLAGS) /Exe=$(MMS$TARGET) $(MMS$SOURCE_LIST) $(CRTLOPTS) +# Accomodate buggy cpp in some version of DECC, which chokes on illegal +# filespec "y.tab.c" +[.x2p]a2p$(O) : [.x2p]a2p.c $(MINIPERL_EXE) + $(MINIPERL) -pe "s/^#line\s+(\d+)\s+\Q""y.tab.c""/#line $1 ""y_tab.c""/;" $(MMS$SOURCE) >$(MMS$TARGET_NAME)_vms.c + $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$TARGET_NAME)_vms.c + Delete/Log/NoConfirm $(MMS$TARGET_NAME)_vms.c; + [.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 3680147e47..22bf016b03 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -104,7 +104,7 @@ installsitelib='$installsitelib' installsitearch='$installsitearch' path_sep='|' startperl='\$ perl 'f\$env("procedure")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' ! -$ exit++ + ++$status != 0 and $exit = $status = undef; +\$ exit++ + ++\$status != 0 and \$exit = \$status = undef;' EndOfIntro foreach (@ARGV) { diff --git a/vms/perlvms.pod b/vms/perlvms.pod index e065b08baa..830ff613d5 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -300,7 +300,7 @@ As of the time this document was last revised, the following Perl functions were implemented in the VMS port of Perl (functions marked with * are discussed in more detail below): - file tests*, abs, alarm, atan, binmode*, bless, + file tests*, abs, alarm, atan, backticks*, binmode*, bless, caller, chdir, chmod, chown, chomp, chop, chr, close, closedir, cos, crypt*, defined, delete, die, do, dump*, each, endpwent, eof, eval, exec*, @@ -310,7 +310,7 @@ Perl functions were implemented in the VMS port of Perl last, lc, lcfirst, length, local, localtime, log, m//, map, mkdir, my, next, no, oct, open, opendir, ord, pack, pipe, pop, pos, print, printf, push, q//, qq//, qw//, - qx//, quotemeta, rand, read, readdir, redo, ref, rename, + qx//*, quotemeta, rand, read, readdir, redo, ref, rename, require, reset, return, reverse, rewinddir, rindex, rmdir, s///, scalar, seek, seekdir, select(internal), select (system call)*, setpwent, shift, sin, sleep, @@ -375,6 +375,13 @@ only, and then manually check the appropriate bits, as defined by your C compiler's F<stat.h>, in the mode value it returns, if you need an approximation of the file's protections. +=item backticks + +Backticks create a subprocess, and pass the enclosed string +to it for execution as a DCL command. Since the subprocess is +created directly via C<lib$spawn()>, any valid DCL command string +may be specified. + =item binmode FILEHANDLE The C<binmode> operator will attempt to insure that no translation @@ -509,6 +516,10 @@ supervisor-mode images like DCL.) Also, negative signal values don't do anything special under VMS; they're just converted to the corresponding positive value. +=item qx// + +See the entry on C<backticks> above. + =item select (system call) If Perl was not built with socket support, the system call @@ -537,7 +548,12 @@ valid DCL command string may be specified. If LIST consists of the empty string, C<system> spawns an interactive DCL subprocess, in the same fashion as typiing B<SPAWN> at the DCL prompt. Perl waits for the subprocess to complete before continuing -execution in the current process. +execution in the current process. As described in L<perlfunc>, +the return value of C<system> is a fake "status" which follows +POSIX semantics; see the description of C<$?> in this document +for more detail. The actual VMS exit status of the subprocess +is available in C<$^S> (as long as you haven't used another Perl +function that resets C<$?> and C<$^S> in the meantime). =item time @@ -679,16 +695,6 @@ In all operations on %ENV, the key string is treated as if it were entirely uppercase, regardless of the case actually specified in the Perl expression. -=item $? - -Since VMS status values are 32 bits wide, the value of C<$?> -is simply the final status value of the last subprocess to -complete. This differs from the behavior of C<$?> under Unix, -and under VMS' POSIX environment, in that the low-order 8 bits -of C<$?> do not specify whether the process terminated normally -or due to a signal, and you do not need to shift C<$?> 8 bits -to the right in order to find the process' exit status. - =item $! The string value of C<$!> is that returned by the CRTL's @@ -710,6 +716,30 @@ is the value of vaxc$errno, and its string value is the corresponding VMS message string, as retrieved by sys$getmsg(). Setting C<$^E> sets vaxc$errno to the value specified. +=item $? + +The "status value" returned in C<$?> is synthesized from the +actual exit status of the subprocess in a way that approximates +POSIX wait(5) semantics, in order to allow Perl programs to +portably test for successful completion of subprocesses. The +low order 8 bits of C<$?> are always 0 under VMS, since the +termination status of a process may or may not have been +generated by an exception. The next 8 bits are derived from +severity portion of the subprocess' exit status: if the +severity was success or informational, these bits are all 0; +otherwise, they contain the severity value shifted left one bit. +As a result, C<$?> will always be zero if the subprocess' exit +status indicated successful completion, and non-zero if a +warning or error occurred. The actual VMS exit status may +be found in C<$^S> (q.v.). + +=item $^S + +Under VMS, this is the 32-bit VMS status value returned by the +last subprocess to complete. Unlink C<$?>, no manipulation +is done to make this look like a POSIX wait(5) value, so it +may be treated as a normal VMS status value. + =item $| Setting C<$|> for an I/O stream causes data to be flushed @@ -801,9 +801,9 @@ I32 my_pclose(FILE *fp) } /* end of my_pclose() */ /* sort-of waitpid; use only with popen() */ -/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/ -unsigned long int -waitpid(unsigned long int pid, int *statusp, int flags) +/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ +Pid_t +my_waitpid(Pid_t pid, int *statusp, int flags) { struct pipe_details *info; diff --git a/vms/vmsish.h b/vms/vmsish.h index 10cdc08eda..ad3f1e10a5 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -13,7 +13,7 @@ #include <libdef.h> /* status codes for various places */ #include <rmsdef.h> /* at which errno and vaxc$errno are */ #include <ssdef.h> /* explicitly set in the perl source code */ -#include <stsdef.h> +#include <stsdef.h> /* bitmasks for exit status testing */ /* Suppress compiler warnings from DECC for VMS-specific extensions: * GLOBALEXT, NOSHAREEXT, READONLYEXT: global[dr]ef declarations @@ -56,6 +56,15 @@ # include <unistd.h> /* DECC has this; VAXC and gcc don't */ #endif +/* DECC introduces this routine in the RTL as of VMS 7.0; for now, + * we'll use ours, since it gives us the full VMS exit status. */ +#ifdef __PID_T +# define Pid_t pid_t +#else +# define Pid_t unsigned int +#endif +#define waitpid my_waitpid + /* Our own contribution to PerlShr's global symbols . . . */ #ifdef EMBED # define my_trnlnm Perl_my_trnlnm @@ -63,7 +72,7 @@ # define prime_env_iter Perl_prime_env_iter # define my_setenv Perl_my_setenv # define my_crypt Perl_my_crypt -# define waitpid Perl_waitpid +# define my_waitpid Perl_my_waitpid # define my_gconvert Perl_my_gconvert # define do_rmdir Perl_do_rmdir # define kill_file Perl_kill_file @@ -454,7 +463,7 @@ typedef char __VMS_PROTOTYPES__; int my_trnlnm _((char *, char *, unsigned long int)); char * my_getenv _((char *)); char * my_crypt _((const char *, const char *)); -unsigned long int waitpid _((unsigned long int, int *, int)); +Pid_t my_waitpid _((Pid_t, int *, int)); char * my_gconvert _((double, int, int, char *)); int do_rmdir _((char *)); int kill_file _((char *)); |