diff options
| author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-02-04 17:47:00 +1200 |
|---|---|---|
| committer | Chip Salzenberg <chip@atlantic.net> | 1997-02-04 17:47:00 +1200 |
| commit | f86702ccfcc3646d7aa30b09ce4f4413be9f99d1 (patch) | |
| tree | f8a3d6634bf3149e753dd0ea414c0c0079003708 | |
| parent | 8a7dc658e6602067382c308b2131d135e4063624 (diff) | |
| download | perl-5.003_25.tar.gz | |
[inseparable changes from patch from perl5.003_24 to perl5.003_25]perl-5.003_25
CORE LANGUAGE CHANGES
Subject: Make $] read-only
From: Chip Salzenberg <chip@perl.com>
Files: gv.c
Subject: New variable C<$^S> is a native version of C<$?>
From: Chip Salzenberg <chip@perl.com>
Files: doio.c global.sym gv.c interp.sym lib/English.pm mg.c perl.c perl.h pod/perldelta.pod pod/perlfunc.pod pod/perlvar.pod pp_ctl.c pp_sys.c proto.h util.c
Subject: Make $^T work with undump, and don't taint it
From: Chip Salzenberg <chip@perl.com>
Files: perl.c
CORE PORTABILITY
Subject: VMS patches for _24
Date: Fri, 31 Jan 1997 02:34:37 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_vms.xs lib/AutoSplit.pm lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MakeMaker.pm perl.h pp_hot.c t/lib/filehand.t t/op/closure.t vms/Makefile vms/config.vms vms/descrip.mms vms/ext/filespec.t vms/vms.c vms/vmsish.h
private-msgid: <01IEUIFP5038004GQP@hmivax.humgen.upenn.edu>
DOCUMENTATION
Subject: Document how extension pms go in $archlib
From: Chip Salzenberg <chip@perl.com>
Files: pod/perldelta.pod
Subject: perlfunc.pod tweaks
Date: Thu, 30 Jan 1997 16:20:55 -0500
From: Roderick Schertler <roderick@gate.net>
Files: pod/perlfunc.pod
private-msgid: <20526.854659255@eeyore.ibcinc.com>
Subject: Error lines must not have trailing periods
From: Chip Salzenberg <chip@perl.com>
Files: pod/perldiag.pod
LIBRARY AND EXTENSIONS
Subject: Make IO::Handle::gets() an alias of getline
Date: Thu, 30 Jan 1997 12:03:15 +0100
From: Gisle Aas <aas@bergen.sn.no>
Files: ext/IO/lib/IO/Handle.pm lib/IO/Handle.pm
private-msgid: <199701301103.MAA11291@bergen.sn.no>
OTHER CORE CHANGES
Subject: Require '-T' in argv[], not just on #! line
From: Chip Salzenberg <chip@perl.com>
Files: perl.c pod/perldiag.pod
Subject: Fix C<return @_> and associated stack bugs
From: Chip Salzenberg <chip@perl.com>
Files: cop.h pp_ctl.c pp_hot.c t/op/misc.t
Subject: Fix never-closing handle after C<select>
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c
Subject: Fix /\G/g with patterns that match empty string
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: pp_hot.c
Subject: Don't create AV, HV, IO when assigning glob
From: Chip Salzenberg <chip@perl.com>
Files: mg.c
TESTS
Subject: More Amiga test patches
Date: Wed, 29 Jan 1997 16:07:33 +0100
From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
Files: README.amiga t/lib/safe2.t t/op/closure.t
private-msgid: <77724725@Armageddon.meb.uni-bonn.de>
43 files changed, 901 insertions, 570 deletions
@@ -9,6 +9,173 @@ releases.) ---------------- +Version 5.003_25 +---------------- + +This release is beta candidate #3. Here's hoping... + + CORE LANGUAGE CHANGES + + Title: "Make $] read-only" + From: Chip Salzenberg + Files: gv.c + + Title: "New variable C<$^S> is a native version of C<$?>" + From: Chip Salzenberg + Files: doio.c global.sym gv.c interp.sym lib/English.pm mg.c perl.c + perl.h pod/perldelta.pod pod/perlfunc.pod pod/perlvar.pod + pp_ctl.c pp_sys.c proto.h util.c + + Title: "Make $^T work with undump, and don't taint it" + From: Chip Salzenberg + Files: perl.c + + CORE PORTABILITY + + Title: "VMS patches for _24" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IEUIFP5038004GQP@hmivax.humgen.upenn.edu> + Date: Fri, 31 Jan 1997 02:34:37 -0500 (EST) + Files: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_vms.xs + lib/AutoSplit.pm lib/ExtUtils/MM_VMS.pm + lib/ExtUtils/MakeMaker.pm perl.h pp_hot.c t/lib/filehand.t + t/op/closure.t vms/Makefile vms/config.vms vms/descrip.mms + vms/ext/filespec.t vms/vms.c vms/vmsish.h + + Title: "hints/dec_osf.sh: polishing the comments" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199701301958.VAA08992@alpha.hut.fi> + Date: Thu, 30 Jan 1997 21:58:10 +0200 (EET) + Files: hints/dec_osf.sh + + Title: "amigaos.sh" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Msg-ID: <77724724@Armageddon.meb.uni-bonn.de> + Date: Wed, 29 Jan 1997 11:39:49 +0100 + Files: hints/amigaos.sh + + OTHER CORE CHANGES + + Title: "Require '-T' in argv[], not just on #! line" + From: Chip Salzenberg + Files: perl.c pod/perldiag.pod + + Title: "Fix C<return @_> and associated stack bugs" + From: Chip Salzenberg + Files: cop.h pp_ctl.c pp_hot.c t/op/misc.t + + Title: "Fix never-closing handle after C<select>" + From: Chip Salzenberg + Files: pp_sys.c + + Title: "Fix /\G/g with patterns that match empty string" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Files: pp_hot.c + + Title: "Fix scalar leak in av_unshift" + From: Chip Salzenberg + Files: av.c + + Title: "Ignore refs to lexicals when making refs to lexicals" + From: Chip Salzenberg + Files: op.c + + Title: "Don't create AV, HV, IO when assigning glob" + From: Chip Salzenberg + Files: mg.c + + BUILD PROCESS + + Title: "Configure updates for intsize and ssizetype" + From: Andy Dougherty + Files: Configure MANIFEST config_H config_h.SH handy.h + + Title: "Ask about /usr/bin/perl iff STDIN and STDERR are terminals" + From: Chip Salzenberg + Files: installperl + + LIBRARY AND EXTENSIONS + + Title: "Refresh CPAN to 1.19" + From: Andreas Koenig <a.koenig@mind.de> + Files: lib/Bundle/CPAN.pm lib/CPAN.pm lib/CPAN/FirstTime.pm + + Title: "Debugger update" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199702030406.XAA23029@monk.mps.ohio-state.edu> + Date: Sun, 2 Feb 1997 23:06:34 -0500 (EST) + Files: lib/perl5db.pl + + Title: "In Symbol::gensym, don't make glob fake by copying it" + From: John Hughes <john@AtlanTech.COM> + Files: lib/Symbol.pm + + Title: "Make POSIX::is*() eight-bit-clean" + From: Chip Salzenberg + Files: ext/POSIX/POSIX.xs + + Title: "Make IO::Handle::gets() an alias of getline" + From: Gisle Aas <aas@bergen.sn.no> + Msg-ID: <199701301103.MAA11291@bergen.sn.no> + Date: Thu, 30 Jan 1997 12:03:15 +0100 + Files: ext/IO/lib/IO/Handle.pm lib/IO/Handle.pm + + TESTS + + Title: "More Amiga test patches" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Msg-ID: <77724725@Armageddon.meb.uni-bonn.de> + Date: Wed, 29 Jan 1997 16:07:33 +0100 + Files: README.amiga t/lib/safe2.t t/op/closure.t + + UTILITIES + + Title: "c2ph.PL fix" + From: lvirden@cas.org (Larry W. Virden) + Msg-ID: <199701301349.IAA16724@cas.org> + Date: Thu, 30 Jan 1997 08:49:19 -0500 + Files: utils/c2ph.PL + + Title: "Make pod2man a little laxer for perltoc.pod" + From: Chip Salzenberg + Files: pod/pod2man.PL + + DOCUMENTATION + + Title: "Update to perl INSTALL file" + From: lvirden@cas.org (Larry W. Virden) + Msg-ID: <199701301338.IAA15878@cas.org> + Date: Thu, 30 Jan 1997 08:38:23 -0500 + Files: INSTALL + + Title: "Update to perl.pod suggested" + From: lvirden@cas.org (Larry W. Virden) + Msg-ID: <199701301345.IAA16514@cas.org> + Date: Thu, 30 Jan 1997 08:45:59 -0500 + Files: pod/perl.pod + + Title: "Document how extension pms go in $archlib" + From: Chip Salzenberg + Files: pod/perldelta.pod + + Title: "perlfunc.pod tweaks" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <20526.854659255@eeyore.ibcinc.com> + Date: Thu, 30 Jan 1997 16:20:55 -0500 + Files: pod/perlfunc.pod + + Title: "new (Feb 1) perlembed.pod" + From: Jon Orwant <orwant@media.mit.edu> + Msg-ID: <9702012334.AA15747@fahrenheit-451.media.mit.edu> + Date: Sat, 1 Feb 1997 18:34:59 -0500 + Files: pod/perlembed.pod + + Title: "Error lines must not have trialing periods" + From: Chip Salzenberg + Files: pod/perldiag.pod + + +---------------- Version 5.003_24 ---------------- diff --git a/README.amiga b/README.amiga index b20c0239ae..110f9cf696 100644 --- a/README.amiga +++ b/README.amiga @@ -214,6 +214,10 @@ emulate some Unixisms with the standard Amiga filesystem. These tests will be skipped because they use the fork() function, which is not supported under AmigaOS. +=item F<op/magic.t> + +The ixemul.library doesn't set the expected values for $0 and $^X. + =back =head2 Installing the built perl @@ -46,23 +46,26 @@ struct block_sub { cx->blk_sub.dfoutgv = defoutgv; \ (void)SvREFCNT_inc(cx->blk_sub.dfoutgv) -/* We muck with cxstack_ix since _dec may call a DESTROY, overwriting cx. */ - #define POPSUB(cx) \ - if (cx->blk_sub.hasargs) { \ + { struct block_sub cxsub; \ + POPSUB1(cx); \ + POPSUB2(); } + +#define POPSUB1(cx) \ + cxsub = cx->blk_sub; /* because DESTROY may clobber *cx */ + +#define POPSUB2() \ + if (cxsub.hasargs) { \ /* put back old @_ */ \ SvREFCNT_dec(GvAV(defgv)); \ - GvAV(defgv) = cx->blk_sub.savearray; \ + GvAV(defgv) = cxsub.savearray; \ /* destroy arg array */ \ - av_clear(cx->blk_sub.argarray); \ - AvREAL_off(cx->blk_sub.argarray); \ + av_clear(cxsub.argarray); \ + AvREAL_off(cxsub.argarray); \ } \ - if (cx->blk_sub.cv) { \ - if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \ - cxstack_ix++; \ - SvREFCNT_dec((SV*)cx->blk_sub.cv); \ - cxstack_ix--; \ - } \ + if (cxsub.cv) { \ + if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \ + SvREFCNT_dec(cxsub.cv); \ } #define POPFORMAT(cx) \ @@ -117,14 +120,22 @@ struct block_loop { cx->blk_loop.iterix = -1; #define POPLOOP(cx) \ - newsp = stack_base + cx->blk_loop.resetsp; \ - SvREFCNT_dec(cx->blk_loop.iterlval); \ - if (cx->blk_loop.itervar) { \ - SvREFCNT_dec(*cx->blk_loop.itervar); \ - *cx->blk_loop.itervar = cx->blk_loop.itersave; \ + { struct block_loop cxloop; \ + POPLOOP1(cx); \ + POPLOOP2(); } + +#define POPLOOP1(cx) \ + cxloop = cx->blk_loop; /* because DESTROY may clobber *cx */ + +#define POPLOOP2() \ + newsp = stack_base + cxloop.resetsp; \ + SvREFCNT_dec(cxloop.iterlval); \ + if (cxloop.itervar) { \ + SvREFCNT_dec(*cxloop.itervar); \ + *cxloop.itervar = cxloop.itersave; \ } \ - if (cx->blk_loop.iterary && cx->blk_loop.iterary != curstack) \ - SvREFCNT_dec(cx->blk_loop.iterary); + if (cxloop.iterary && cxloop.iterary != curstack) \ + SvREFCNT_dec(cxloop.iterary); /* context common to subroutines, evals and loops */ struct block { @@ -578,7 +578,7 @@ IO* io; if (IoTYPE(io) == '|') { status = my_pclose(IoIFP(io)); retval = (status == 0); - statusvalue = FIXSTATUS(status); + STATUS_NATIVE_SET(status); } else if (IoTYPE(io) == '-') retval = TRUE; @@ -375,6 +375,7 @@ #define my_bzero Perl_my_bzero #define my_chsize Perl_my_chsize #define my_exit Perl_my_exit +#define my_failure_exit Perl_my_failure_exit #define my_htonl Perl_my_htonl #define my_lstat Perl_my_lstat #define my_memcmp Perl_my_memcmp @@ -1299,6 +1300,7 @@ #define statgv (curinterp->Istatgv) #define statname (curinterp->Istatname) #define statusvalue (curinterp->Istatusvalue) +#define statusvalue_vms (curinterp->Istatusvalue_vms) #define stdingv (curinterp->Istdingv) #define strchop (curinterp->Istrchop) #define strtab (curinterp->Istrtab) @@ -1450,6 +1452,7 @@ #define Istatgv statgv #define Istatname statname #define Istatusvalue statusvalue +#define Istatusvalue_vms statusvalue_vms #define Istdingv stdingv #define Istrchop strchop #define Istrtab strtab @@ -1609,6 +1612,7 @@ #define statgv Perl_statgv #define statname Perl_statname #define statusvalue Perl_statusvalue +#define statusvalue_vms Perl_statusvalue_vms #define stdingv Perl_stdingv #define strchop Perl_strchop #define strtab Perl_strtab diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm index a36dc003d7..3cb06cc4db 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm @@ -31,6 +31,7 @@ $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; # Flags to alter dl_load_file behaviour. Assigned bits: # 0x01 make symbols available for linking later dl_load_file's. # (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) +# (ignored under VMS; effect is built-in to image linking) # # This is called as a class method $module->dl_load_flags. The # definition here will be inherited and result on "default" loading @@ -511,6 +512,7 @@ Assigned bits: 0x01 make symbols available for linking later dl_load_file's. (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) + (ignored under VMS; this is a normal part of image linking) (On systems that provide a handle for the loaded object such as SunOS and HPUX, $libref will be that handle. On other systems $libref will diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index fae4e482ec..370994b516 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -224,8 +224,8 @@ dl_expandspec(filespec) } void -dl_load_file(filename, flags) - char * filename +dl_load_file(filespec, flags) + char * filespec int flags PREINIT: char vmsspec[NAM$C_MAXRSS]; @@ -244,9 +244,7 @@ dl_load_file(filename, flags) void (*entry)(); CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags)); specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index 135351fac0..e02f6dfe5d 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -75,7 +75,6 @@ corresponding built-in functions: close fileno getc - gets eof read truncate @@ -187,7 +186,7 @@ use SelectSaver; require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1501"; +$VERSION = "1.1502"; $XS_VERSION = "1.15"; @EXPORT_OK = qw( @@ -336,12 +335,6 @@ sub getc { getc($_[0]); } -sub gets { - @_ == 1 or croak 'usage: $fh->gets()'; - my ($handle) = @_; - scalar <$handle>; -} - sub eof { @_ == 1 or croak 'usage: $fh->eof()'; eof($_[0]); @@ -365,6 +358,8 @@ sub getline { return scalar <$this>; } +*gets = \&getline; # deprecated + sub getlines { @_ == 1 or croak 'usage: $fh->getline()'; wantarray or diff --git a/global.sym b/global.sym index 941d006649..f1d0573b22 100644 --- a/global.sym +++ b/global.sym @@ -547,6 +547,7 @@ my_bcopy my_bzero my_chsize my_exit +my_failure_exit my_htonl my_lstat my_memcmp @@ -666,6 +666,7 @@ I32 sv_type; case '\017': case '\t': case '\020': + case '\023': case '\024': case '\027': if (len > 1) @@ -701,10 +702,11 @@ I32 sv_type; break; case ']': if (len == 1) { - SV *sv; - sv = GvSV(gv); + SV *sv = GvSV(gv); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, patchlevel); + (void)sv_2nv(sv); + SvREADONLY_on(sv); } break; } diff --git a/interp.sym b/interp.sym index ea4241ac25..ec9c038986 100644 --- a/interp.sym +++ b/interp.sym @@ -129,6 +129,7 @@ statcache statgv statname statusvalue +statusvalue_vms stdingv strchop strtab diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index c1ff13a70c..f7b8eee76d 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -149,7 +149,10 @@ sub autosplit_file{ # where to write output files $autodir = "lib/auto" unless $autodir; - ($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$## if $Is_VMS; + if ($Is_VMS) { + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{}; + $filename = VMS::Filespec::unixify($filename); # may have dirs + } unless (-d $autodir){ local($", @p)="/"; foreach(split(/\//,$autodir)){ diff --git a/lib/English.pm b/lib/English.pm index ce4520a891..736b90d4a8 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -65,6 +65,7 @@ sub import { *FORMAT_LINE_BREAK_CHARACTERS *FORMAT_FORMFEED *CHILD_ERROR + *SYSTEM_CHILD_STATUS *OS_ERROR *ERRNO *EXTENDED_OS_ERROR @@ -137,9 +138,10 @@ sub import { # Error status. *CHILD_ERROR = *? ; + *SYSTEM_CHILD_STATUS = *^S ; *OS_ERROR = *! ; - *EXTENDED_OS_ERROR = *^E ; *ERRNO = *! ; + *EXTENDED_OS_ERROR = *^E ; *EVAL_ERROR = *@ ; # Process info. diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm index c663d64dd7..4a371840b9 100644 --- a/lib/ExtUtils/Embed.pm +++ b/lib/ExtUtils/Embed.pm @@ -1,4 +1,4 @@ -# $Id: Embed.pm,v 1.21 1996/11/29 17:26:23 dougm Exp $ +# $Id: Embed.pm,v 1.22 1997/01/30 00:37:09 dougm Exp $ require 5.002; package ExtUtils::Embed; @@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT $VERSION ); use strict; -$VERSION = sprintf("%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/); #for the namespace change $Devel::embed::VERSION = "99.99"; @@ -206,7 +206,7 @@ sub ldopts { my $ld_or_bs = $bsloadlibs || $ldloadlibs; print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose; - my $linkage = "$Config{ldflags} @archives $ld_or_bs"; + my $linkage = "$Config{ccdlflags} $Config{ldflags} @archives $ld_or_bs"; print STDERR "ldopts: '$linkage'\n" if $Verbose; return $linkage if scalar @_; @@ -227,7 +227,6 @@ sub perl_inc { sub ccopts { ccflags; - ccdlflags; perl_inc; } diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 1e39e118fc..f609cc8761 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -589,8 +589,14 @@ sub constants { my(@defs) = split(/\s+/,$self->{DEFINE}); foreach $def (@defs) { next unless $def; - $def =~ s/^-D//; - $def = "\"$def\"" if $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 + } + if ($def =~ /=/) { + $def =~ s/"/""/g; # Protect existing " from DCL + $def = qq["$def"]; # and quote to prevent parsing of = + } } $self->{DEFINE} = join ',',@defs; } @@ -708,6 +714,7 @@ MAN3PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN3PODS}}),' } push @m," +.SUFFIXES : .SUFFIXES : \$(OBJ_EXT) .c .cpp .cxx .xs # Here is the Config.pm that we are using/depend on @@ -1576,7 +1583,7 @@ clean :: '; foreach $dir (@{$self->{DIR}}) { # clean subdirectories first my($vmsdir) = $self->fixpath($dir,1); - push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t", + push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)").nes."" Then \\',"\n\t", '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n"); } push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso .MM_Tmp diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 2d3dd56e6a..99aaa38c56 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -432,7 +432,7 @@ sub ExtUtils::MakeMaker::new { # into a filespec. $self->{$key} = $self->catdir("..",$self->{$key}) unless $self->file_name_is_absolute($self->{$key}) - || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{key} =~ /^[\w\-\$]$/)); + || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/)); } $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT}; } else { diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm index b907cae40c..0b5d9edcb4 100644 --- a/lib/FileHandle.pm +++ b/lib/FileHandle.pm @@ -130,7 +130,7 @@ FileHandle - supply object methods for filehandles } $pos = $fh->getpos; - $fh->setpos $pos; + $fh->setpos($pos); $fh->setvbuf($buffer_var, _IOLBF, 1024); @@ -386,6 +386,12 @@ 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); @@ -456,7 +462,10 @@ MAGIC *mg; #endif break; case '?': - sv_setiv(sv, (IV)statusvalue); + if (STATUS_POSIX == -1) + sv_setiv(sv, (IV)-1); + else + sv_setuv(sv, (UV)STATUS_POSIX); break; case '^': s = IoTOP_NAME(GvIOp(defoutgv)); @@ -1036,12 +1045,6 @@ MAGIC* mg; if (GvGP(sv)) gp_free((GV*)sv); GvGP(sv) = gp_ref(GvGP(gv)); - if (!GvAV(gv)) - gv_AVadd(gv); - if (!GvHV(gv)) - gv_HVadd(gv); - if (!GvIOp(gv)) - GvIOp(gv) = newIO(); return 0; } @@ -1233,7 +1236,8 @@ MAGIC* mg; #ifdef VMS set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); #else - SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4); /* will anyone ever use this? */ + /* will anyone ever use this? */ + SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); #endif break; case '\006': /* ^F */ @@ -1268,6 +1272,9 @@ 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)); @@ -1347,10 +1354,11 @@ MAGIC* mg; compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; case '?': - statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + STATUS_POSIX_SET(SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)); break; case '!': - SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SvIV(sv) == EVMSERR ? 4 : vaxc$errno); /* will anyone ever use this? */ + SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), + (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno); break; case '<': uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); diff --git a/patchlevel.h b/patchlevel.h index 603aaa3ac4..7db0e20df5 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 24 +#define SUBVERSION 25 /* local_patches -- list of locally applied less-than-subversion patches. @@ -68,6 +68,7 @@ static void init_perllib _((void)); static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); static void init_stacks _((void)); +static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *)); static void usage _((char *)); @@ -139,6 +140,8 @@ register PerlInterpreter *sv_interp; init_ids(); + STATUS_ALL_SUCCESS; + SET_NUMERIC_STANDARD(); #if defined(SUBVERSION) && SUBVERSION > 0 sprintf(patchlevel, "%7.5f", (double) 5 @@ -477,18 +480,18 @@ setuid perl scripts securely.\n"); op_free(main_root); main_root = 0; + time(&basetime); + switch (Sigsetjmp(top_env,1)) { case 1: -#ifdef VMS - statusvalue = 255; -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; + /* FALL THROUGH */ case 2: + /* my_exit() was called */ curstash = defstash; if (endav) calllist(endav); - return(statusvalue); /* my_exit() was called */ + return STATUS_NATIVE_EXPORT; case 3: PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; @@ -524,7 +527,6 @@ setuid perl scripts securely.\n"); case 'n': case 'p': case 's': - case 'T': case 'u': case 'U': case 'v': @@ -533,6 +535,11 @@ setuid perl scripts securely.\n"); goto reswitch; break; + case 'T': + tainting = TRUE; + s++; + goto reswitch; + case 'e': if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); @@ -766,6 +773,7 @@ PerlInterpreter *sv_interp; cxstack_ix = -1; /* start context stack again */ break; case 2: + /* my_exit() was called */ curstash = defstash; if (endav) calllist(endav); @@ -774,7 +782,7 @@ PerlInterpreter *sv_interp; if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - return(statusvalue); /* my_exit() was called */ + return STATUS_NATIVE_EXPORT; case 3: if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); @@ -819,24 +827,6 @@ PerlInterpreter *sv_interp; return 0; } -void -my_exit(status) -U32 status; -{ - register CONTEXT *cx; - I32 gimme; - SV **newsp; - - statusvalue = FIXSTATUS(status); - if (cxstack_ix >= 0) { - if (cxstack_ix > 0) - dounwind(0); - POPBLOCK(cx,curpm); - LEAVE; - } - Siglongjmp(top_env, 2); -} - SV* perl_get_sv(name, create) char* name; @@ -1006,11 +996,7 @@ I32 flags; /* See G_* flags in cop.h */ case 0: break; case 1: -#ifdef VMS - statusvalue = 255; /* XXX I don't think we use 1 anymore. */ -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; /* FALL THROUGH */ case 2: /* my_exit() was called */ @@ -1019,7 +1005,7 @@ I32 flags; /* See G_* flags in cop.h */ Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ case 3: if (restartop) { @@ -1115,11 +1101,7 @@ restart: case 0: break; case 1: -#ifdef VMS - statusvalue = 255; /* XXX I don't think we use 1 anymore. */ -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; /* FALL THROUGH */ case 2: /* my_exit() was called */ @@ -1128,7 +1110,7 @@ restart: Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ case 3: if (restartop) { @@ -1386,7 +1368,8 @@ char *s; s++; return s; case 'T': - tainting = TRUE; + if (!tainting) + croak("Too late for \"-T\" option (try putting it first)"); s++; return s; case 'u': @@ -2201,8 +2184,6 @@ register char **env; sv_setpv(GvSV(tmpgv),origfilename); magicname("0", "0", 1); } - if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV)) - time(&basetime); if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) sv_setpv(GvSV(tmpgv),origargv[0]); if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { @@ -2425,11 +2406,7 @@ AV* list; } break; case 1: -#ifdef VMS - statusvalue = 255; /* XXX I don't think we use 1 anymore. */ -#else - statusvalue = 1; -#endif + STATUS_ALL_FAILURE; /* FALL THROUGH */ case 2: /* my_exit() was called */ @@ -2446,9 +2423,8 @@ AV* list; else croak("END failed--cleanup aborted"); } - my_exit(statusvalue); + my_exit_jump(); /* NOTREACHED */ - return; case 3: if (!restartop) { PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); @@ -2465,3 +2441,69 @@ AV* list; Copy(oldtop, top_env, 1, Sigjmp_buf); } +void +my_exit(status) +U32 status; +{ + switch (status) { + case 0: + STATUS_ALL_SUCCESS; + break; + case 1: + STATUS_ALL_FAILURE; + break; + default: + STATUS_NATIVE_SET(status); + break; + } + my_exit_jump(); +} + +void +my_failure_exit() +{ +#ifdef VMS + if (vaxc$errno & 1) { + if (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */ + SETSTATUS_NATIVE(44); + } + else { + if (!vaxc$errno && errno) /* someone must have set $^E = 0 */ + SETSTATUS_NATIVE(44); + else + SETSTATUS_NATIVE(vaxc$errno); + } +#else + if (errno & 255) + STATUS_POSIX_SET(errno); + else if (STATUS_POSIX == 0) + STATUS_POSIX_SET(255); +#endif + my_exit_jump(); +} + +static void +my_exit_jump() +{ + register CONTEXT *cx; + I32 gimme; + SV **newsp; + + if (e_tmpname) { + if (e_fp) { + PerlIO_close(e_fp); + e_fp = Nullfp; + } + (void)UNLINK(e_tmpname); + Safefree(e_tmpname); + e_tmpname = Nullch; + } + + if (cxstack_ix >= 0) { + if (cxstack_ix > 0) + dounwind(0); + POPBLOCK(cx,curpm); + LEAVE; + } + Siglongjmp(top_env, 2); +} @@ -408,14 +408,15 @@ # include <net/errno.h> # endif #endif -#ifndef VMS -# define FIXSTATUS(sts) (U_L((sts) & 0xffff)) -# define SHIFTSTATUS(sts) ((sts) >> 8) -# define SETERRNO(errcode,vmserrcode) errno = (errcode) + +#ifdef VMS +# define SETERRNO(errcode,vmserrcode) \ + STMT_START { \ + set_errno(errcode); \ + set_vaxc_errno(vmserrcode); \ + } STMT_END #else -# define FIXSTATUS(sts) (U_L(sts)) -# define SHIFTSTATUS(sts) (sts) -# define SETERRNO(errcode,vmserrcode) STMT_START {set_errno(errcode); set_vaxc_errno(vmserrcode);} STMT_END +# define SETERRNO(errcode,vmserrcode) errno = (errcode) #endif #ifndef errno @@ -442,6 +443,35 @@ # endif #endif +#define STATUS_POSIX statusvalue +#define STATUS_POSIX_SET(n) (statusvalue = (n)) + +#ifdef VMS +# define STATUS_NATIVE statusvalue_vms +# define STATUS_NATIVE_EXPORT \ + ((I32)statusvalue_vms == -1 ? 4 : statusvalue_vms) +# define STATUS_NATIVE_SET(n) \ + STMT_START { \ + statusvalue_vms = (n); \ + if ((I32)statusvalue_vms == -1) \ + statusvalue = -1; \ + else if (statusvalue_vms & STS$M_SUCCESS) \ + statusvalue = 0; \ + else if ((statusvalue_vms & STS$M_SEVERITY) == 0) \ + statusvalue = 1 << 8; \ + else \ + statusvalue = (statusvalue_vms & STS$M_SEVERITY) << 8; \ + } STMT_END +# define STATUS_ALL_SUCCESS (statusvalue = 0, statusvalue_vms = 1) +# define STATUS_ALL_FAILURE (statusvalue = 1, statusvalue_vms = 4) +#else +# define STATUS_NATIVE STATUS_POSIX +# define STATUS_NATIVE_EXPORT STATUS_POSIX +# define STATUS_NATIVE_SET STATUS_POSIX_SET +# define STATUS_ALL_SUCCESS STATUS_POSIX_SET(0) +# define STATUS_ALL_FAILURE STATUS_POSIX_SET(1) +#endif + #ifdef I_SYS_IOCTL # ifndef _IOCTL_ # include <sys/ioctl.h> @@ -600,10 +630,6 @@ # define SLOPPYDIVIDE #endif -#if defined(cray) || defined(convex) || BYTEORDER > 0xffff -# define HAS_QUAD -#endif - #ifdef UV #undef UV #endif @@ -621,16 +647,24 @@ --Andy Dougherty August 1996 */ -#ifdef HAS_QUAD -# ifdef cray -# define Quad_t int +#ifdef cray +# define Quad_t int +#else +# ifdef convex +# define Quad_t long long # else -# if defined(convex) -# define Quad_t long long +# if defined(VMS) && defined(__ALPHA) +# define Quad_t __int64 # else -# define Quad_t long +# if BYTEORDER > 0xFFFF +# define Quad_t long +# endif # endif # endif +#endif + +#ifdef Quad_t +# define HAS_QUAD typedef Quad_t IV; typedef unsigned Quad_t UV; # define IV_MAX PERL_QUAD_MAX @@ -1677,8 +1711,11 @@ IEXT char * Iors; /* $\ */ IEXT STRLEN Iorslen; IEXT char * Iofmt; /* $# */ IEXT I32 Imaxsysfd IINIT(MAXSYSFD); /* top fd to pass to subprocesses */ -IEXT int Imultiline; /* $*--do strings hold >1 line? */ -IEXT U32 Istatusvalue; /* $? */ +IEXT int Imultiline; /* $*--do strings hold >1 line? */ +IEXT U32 Istatusvalue; /* $? */ +#ifdef VMS +IEXT U32 Istatusvalue_vms; /* $^S */ +#endif IEXT struct stat Istatcache; /* _ */ IEXT GV * Istatgv; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 04e9a45ab8..56745d1d98 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -54,8 +54,8 @@ the F<INSTALL> file for how to use it. =item $^E -Extended error message under some platforms ($EXTENDED_OS_ERROR -if you C<use English>). +Extended error message on some platforms. (Also known as +$EXTENDED_OS_ERROR if you C<use English>). =item $^H @@ -79,6 +79,15 @@ 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 @@ -405,6 +414,16 @@ Disable unsafe opcodes, or any named opcodes, when compiling Perl code. =head1 Modules +=head2 Installation Directories + +The I<installperl> script now places the Perl source files for +extensions in the architecture-specific library directory, which is +where the shared libraries for extensions have always been. This +change is intended to allow administrators to keep the Perl 5.004 +library directory unchanged from a previous version, without running +the risk of binary incompatibility between extensions' Perl source and +shared libraries. + =head2 Fcntl New constants in the existing Fcntl modules are now supported, diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 018ebb757a..32f55be0a6 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -96,11 +96,11 @@ sees what it knows to be a term when it was expecting to see an operator, it gives you this warning. Usually it indicates that an operator or delimiter was omitted, such as a semicolon. -=item %s had compilation errors. +=item %s had compilation errors (F) The final summary message when a C<perl -c> fails. -=item %s has too many errors. +=item %s has too many errors (F) The parser has given up trying to parse the program after 10 errors. Further error messages would likely be uninformative. @@ -119,19 +119,19 @@ before it could possibly have been used. (F) The final summary message when a C<perl -c> succeeds. -=item %s: Command not found. +=item %s: Command not found (A) You've accidentally run your script through B<csh> instead of Perl. Check the E<lt>#!E<gt> line, or manually feed your script into Perl yourself. -=item %s: Expression syntax. +=item %s: Expression syntax (A) You've accidentally run your script through B<csh> instead of Perl. Check the E<lt>#!E<gt> line, or manually feed your script into Perl yourself. -=item %s: Undefined variable. +=item %s: Undefined variable (A) You've accidentally run your script through B<csh> instead of Perl. Check the E<lt>#!E<gt> line, or manually feed your script @@ -195,7 +195,7 @@ a missing quote, operator, parenthesis pair or declaration. (F) The setuid emulator requires that the arguments Perl was invoked with match the arguments specified on the #! line. -=item Argument "%s" isn't numeric +=item Argument "%s" isn't numeric%s (W) The indicated string was fed as an argument to an operator that expected a numeric value instead. If you're fortunate the message @@ -920,7 +920,7 @@ single form when it must operate on them directly. Either you've passed an invalid file specification to Perl, or you've found a case the conversion routines don't handle. Drat. -=item Execution of %s aborted due to compilation errors. +=item Execution of %s aborted due to compilation errors (F) The final summary message when a Perl compilation fails. @@ -2011,7 +2011,7 @@ because the world might have written on it already. (W) You tried to do a shutdown on a closed socket. Seems a bit superfluous. -=item SIG%s handler "%s" not defined. +=item SIG%s handler "%s" not defined (W) The signal handler named in %SIG doesn't, in fact, exist. Perhaps you put it into the wrong package? @@ -2089,7 +2089,7 @@ construct. Remember that bracketing delimiters count nesting level. That is, the absolute value of the offset was larger than the length of the string. See L<perlfunc/substr>. -=item suidperl is no longer needed since... +=item suidperl is no longer needed since %s (F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but a version of the setuid emulator somehow got run anyway. @@ -2161,7 +2161,7 @@ out from under another module inadvertently. See L<perlvar/$[>. The function indicated isn't implemented on this architecture, according to the probings of Configure. -=item The crypt() function is unimplemented due to excessive paranoia. +=item The crypt() function is unimplemented due to excessive paranoia (F) Configure couldn't find the crypt() function on your machine, probably because your vendor didn't supply it, probably because they @@ -2185,6 +2185,19 @@ 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) + +(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 +handles tainting, by the time Perl discovers a "-T" in a script, it's +too late to properly taint everything from the environment. So Perl +gives up. + +This error can usually be fixed by editing the "#!" line so that the +"-T" option is in the Perl program's first argument. (Many operating +systems that implement the "#!" feature only pick up one argument from +it, so Perl has to get the rest on its own.) + =item Too many ('s =item Too many )'s @@ -2500,7 +2513,7 @@ reference variables in outer subroutines are called or referenced, they are automatically re-bound to the current values of such variables. -=item Variable syntax. +=item Variable syntax (A) You've accidentally run your script through B<csh> instead of Perl. Check the E<lt>#!E<gt> line, or manually feed your script @@ -2511,7 +2524,7 @@ into Perl yourself. (W) You passed warn() an empty string (the equivalent of C<warn "">) or you called it with no args and C<$_> was empty. -=item Warning: unable to close filehandle %s properly. +=item Warning: unable to close filehandle %s properly (S) The implicit close() done by an open() got an error indication on the close(). This usually indicates your file system ran out of disk space. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index e532ed2aa3..6825d22e7d 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -191,12 +191,10 @@ operator which can be used in expressions. dbmclose, dbmopen - =back =head2 Alphabetical Listing of Perl Functions - =over 8 =item -X FILEHANDLE @@ -1061,7 +1059,10 @@ are called before exit.) Example: $ans = <STDIN>; exit 0 if $ans =~ /^[Xx]/; -See also die(). If EXPR is omitted, exits with 0 status. +See also die(). If EXPR is omitted, exits with 0 status. The only +univerally portable values for EXPR are 0 for success and 1 for error; +all other values are subject to unpredictable interpretation depending +on the environment in which the Perl program is running. You shouldn't use exit() to abort a subroutine if there's any chance that someone might want to trap whatever error happened. Use die() instead, @@ -1249,7 +1250,7 @@ single-characters, however. For that, try something more like: } print "\n"; -Determination of whether to whether $BSD_STYLE should be set +Determination of whether $BSD_STYLE should be set is left as an exercise to the reader. The POSIX::getattr() function can do this more portably on systems @@ -1262,7 +1263,7 @@ details on CPAN can be found on L<perlmod/CPAN>. Returns the current login from F</etc/utmp>, if any. If null, use getpwuid(). - $login = getlogin || (getpwuid($<))[0] || "Kilroy"; + $login = getlogin || getpwuid($<) || "Kilroy"; Do not consider getlogin() for authentication: it is not as secure as getpwuid(). @@ -3066,7 +3067,7 @@ for a seed can fall prey to the mathematical property that a^b == (a+1)^(b+1) one-third of the time. So don't do that. - + =item stat FILEHANDLE =item stat EXPR @@ -3313,7 +3314,7 @@ signals and coredumps. print "signal $rc\n" } $ok = ($rc != 0); - + =item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET =item syswrite FILEHANDLE,SCALAR,LENGTH diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 8c97163e05..02d3dd3014 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 +$^E, $^H, $^M, $^S =item New and Changed Built-in Functions @@ -89,6 +89,8 @@ use blib, use blib 'dir', use locale, use ops =over +=item Installation Directories + =item Fcntl =item Module Information Summary @@ -391,19 +393,20 @@ SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, sort SUBNAME LIST, sort BLOCK LIST, sort LIST, splice ARRAY,OFFSET,LENGTH,LIST, splice ARRAY,OFFSET,LENGTH, splice ARRAY,OFFSET, split /PATTERN/,EXPR,LIMIT, split /PATTERN/,EXPR, split /PATTERN/, split, sprintf FORMAT, LIST, sqrt EXPR, sqrt, srand EXPR, -stat EXPR, stat, study SCALAR, study, sub BLOCK, sub NAME, sub NAME BLOCK, -substr EXPR,OFFSET,LEN, substr EXPR,OFFSET, symlink OLDFILE,NEWFILE, -syscall LIST, sysopen FILEHANDLE,FILENAME,MODE, sysopen +stat FILEHANDLE, stat EXPR, stat, study SCALAR, study, sub BLOCK, sub NAME, +sub NAME BLOCK, substr EXPR,OFFSET,LEN, substr EXPR,OFFSET, symlink +OLDFILE,NEWFILE, syscall LIST, sysopen FILEHANDLE,FILENAME,MODE, sysopen FILEHANDLE,FILENAME,MODE,PERMS, sysread FILEHANDLE,SCALAR,LENGTH,OFFSET, sysread FILEHANDLE,SCALAR,LENGTH, system LIST, syswrite -FILEHANDLE,SCALAR,LENGTH, tell FILEHANDLE, tell, telldir DIRHANDLE, tie -VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate -FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, -ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack -TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module LIST, use -Module, use Module VERSION LIST, use VERSION, utime LIST, values -ASSOC_ARRAY, vec EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn -LIST, write FILEHANDLE, write EXPR, write, y/// +FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite FILEHANDLE,SCALAR,LENGTH, tell +FILEHANDLE, tell, telldir DIRHANDLE, tie VARIABLE,CLASSNAME,LIST, tied +VARIABLE, time, times, tr///, truncate FILEHANDLE,LENGTH, truncate +EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, ucfirst, umask EXPR, umask, undef +EXPR, undef, unlink LIST, unlink, unpack TEMPLATE,EXPR, untie VARIABLE, +unshift ARRAY,LIST, use Module LIST, use Module, use Module VERSION LIST, +use VERSION, utime LIST, values ASSOC_ARRAY, vec EXPR,OFFSET,BITS, wait, +waitpid PID,FLAGS, wantarray, warn LIST, write FILEHANDLE, write EXPR, +write, y/// =back @@ -428,13 +431,14 @@ 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, $?, $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, $?, $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} =back @@ -1231,6 +1235,8 @@ program =item AUTHOR +=item COPYRIGHT + =head2 perlapio - perl's IO abstraction interface. =item SYNOPSIS @@ -1671,14 +1677,6 @@ 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 @@ -1872,6 +1870,16 @@ timeit(COUNT, CODE), timethis, timethese, timediff, timestr =item MODIFICATION HISTORY +=head2 Bundle::CPAN - A bundle to play with all the other modules on CPAN + +=item SYNOPSIS + +=item CONTENTS + +=item DESCRIPTION + +=item AUTHOR + =head2 CPAN - query, download and build perl modules from CPAN sites =item SYNOPSIS @@ -2354,14 +2362,6 @@ 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 @@ -2577,139 +2577,6 @@ 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 @@ -3210,35 +3077,6 @@ 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 248c378614..f0447cd58f 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -397,16 +397,26 @@ 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, so the exit value of the subprocess is actually -(C<$? E<gt>E<gt> 8>). Thus on many systems, 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 -- 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>.) 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.) + =item $OS_ERROR =item $ERRNO @@ -426,9 +436,8 @@ operator. (Mnemonic: What just went bang?) =item $^E -More specific information about the last system error than that -provided by C<$!>, if available. (If not, it's just C<$!> again, except under -OS/2.) +More specific information about the last system error than that provided by +C<$!>, if available. (If not, it's just C<$!> again, except under OS/2.) At the moment, this differs from C<$!> under only VMS and OS/2, where it provides the VMS status value from the last system error, and OS/2 error code of the last call to OS/2 API which was not directed via CRT. The diff --git a/pod/roffitall b/pod/roffitall index 06b39188f2..ae2cd060f9 100755 --- a/pod/roffitall +++ b/pod/roffitall @@ -69,7 +69,7 @@ toroff=` $libdir/integer.3 \ $libdir/less.3 \ $libdir/lib.3 \ - $libdir/localle.3 \ + $libdir/locale.3 \ $libdir/overload.3 \ $libdir/sigtrap.3 \ $libdir/strict.3 \ @@ -976,21 +976,8 @@ char *message; } PerlIO_printf(PerlIO_stderr(), "%s",message); PerlIO_flush(PerlIO_stderr()); - if (e_tmpname) { - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; - } - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; - } - statusvalue = SHIFTSTATUS(statusvalue); -#ifdef VMS - my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT); -#else - my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); -#endif + my_failure_exit(); + /* NOTREACHED */ return 0; } @@ -1293,14 +1280,16 @@ PP(pp_leaveloop) { dSP; register CONTEXT *cx; + struct block_loop cxloop; I32 gimme; SV **newsp; PMOP *newpm; SV **mark; POPBLOCK(cx,newpm); + POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ + mark = newsp; - POPLOOP(cx); if (gimme == G_SCALAR) { if (op->op_private & OPpLEAVE_VOID) ; @@ -1315,12 +1304,16 @@ PP(pp_leaveloop) while (mark < SP) *++newsp = sv_mortalcopy(*++mark); } - curpm = newpm; /* Don't pop $1 et al till now */ - sp = newsp; + SP = newsp; + PUTBACK; + + POPLOOP2(); /* Stack values are safe: release loop vars ... */ + curpm = newpm; /* ... and pop $1 et al */ + LEAVE; LEAVE; - RETURN; + return NORMAL; } PP(pp_return) @@ -1328,6 +1321,8 @@ PP(pp_return) dSP; dMARK; I32 cxix; register CONTEXT *cx; + struct block_sub cxsub; + bool popsub2 = FALSE; I32 gimme; SV **newsp; PMOP *newpm; @@ -1352,7 +1347,8 @@ PP(pp_return) POPBLOCK(cx,newpm); switch (cx->cx_type) { case CXt_SUB: - POPSUB(cx); + POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ + popsub2 = TRUE; break; case CXt_EVAL: POPEVAL(cx); @@ -1371,17 +1367,24 @@ PP(pp_return) if (gimme == G_SCALAR) { if (MARK < SP) - *++newsp = sv_mortalcopy(*SP); + *++newsp = (popsub2 && SvTEMP(*SP)) + ? *SP : sv_mortalcopy(*SP); else *++newsp = &sv_undef; } else { - while (MARK < SP) - *++newsp = sv_mortalcopy(*++MARK); + while (++MARK <= SP) + *++newsp = (popsub2 && SvTEMP(*MARK)) + ? *MARK : sv_mortalcopy(*MARK); } - curpm = newpm; /* Don't pop $1 et al till now */ stack_sp = newsp; + /* Stack values are safe: */ + if (popsub2) { + POPSUB2(); /* release CV and @_ ... */ + } + curpm = newpm; /* ... and pop $1 et al */ + LEAVE; return pop_return(); } @@ -1391,6 +1394,9 @@ PP(pp_last) dSP; I32 cxix; register CONTEXT *cx; + struct block_loop cxloop; + struct block_sub cxsub; + I32 pop2 = 0; I32 gimme; I32 optype; OP *nextop; @@ -1414,16 +1420,18 @@ PP(pp_last) POPBLOCK(cx,newpm); switch (cx->cx_type) { case CXt_LOOP: - POPLOOP(cx); + POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ + pop2 = CXt_LOOP; nextop = cx->blk_loop.last_op->op_next; LEAVE; break; - case CXt_EVAL: - POPEVAL(cx); + case CXt_SUB: + POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ + pop2 = CXt_SUB; nextop = pop_return(); break; - case CXt_SUB: - POPSUB(cx); + case CXt_EVAL: + POPEVAL(cx); nextop = pop_return(); break; default: @@ -1432,20 +1440,33 @@ PP(pp_last) } if (gimme == G_SCALAR) { - if (mark < SP) - *++newsp = sv_mortalcopy(*SP); + if (MARK < SP) + *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) + ? *SP : sv_mortalcopy(*SP); else *++newsp = &sv_undef; } else { - while (mark < SP) - *++newsp = sv_mortalcopy(*++mark); + while (++MARK <= SP) + *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) + ? *MARK : sv_mortalcopy(*MARK); } - curpm = newpm; /* Don't pop $1 et al till now */ - sp = newsp; + SP = newsp; + PUTBACK; + + /* Stack values are safe: */ + switch (pop2) { + case CXt_LOOP: + POPLOOP2(); /* release loop vars ... */ + break; + case CXt_SUB: + POPSUB2(); /* release CV and @_ ... */ + break; + } + curpm = newpm; /* ... and pop $1 et al */ LEAVE; - RETURNOP(nextop); + return nextop; } PP(pp_next) @@ -769,6 +769,7 @@ PP(pp_match) STRLEN len; I32 minmatch = 0; I32 oldsave = savestack_ix; + I32 update_minmatch = 1; if (op->op_flags & OPf_STACKED) TARG = POPs; @@ -799,6 +800,7 @@ PP(pp_match) if (mg && mg->mg_len >= 0) { rx->endp[0] = rx->startp[0] = s + mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH); + update_minmatch = 0; } } } @@ -815,7 +817,8 @@ play_it_again: t = s = rx->endp[0]; if (s >= strend) goto nope; - minmatch = (s == rx->startp[0]); + if (update_minmatch++) + minmatch = (s == rx->startp[0]); } if (pm->op_pmshort) { if (pm->op_pmflags & PMf_SCANFIRST) { @@ -1052,7 +1055,7 @@ do_readline() *(end++) = '\n'; *end = '\0'; for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob)); + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); begin = rstr; } else { @@ -1654,37 +1657,33 @@ PP(pp_leavesub) PMOP *newpm; I32 gimme; register CONTEXT *cx; + struct block_sub cxsub; POPBLOCK(cx,newpm); - /* Delay POPSUB until stack values are safe */ - + POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ + if (gimme == G_SCALAR) { MARK = newsp + 1; if (MARK <= SP) - if (SvFLAGS(TOPs) & SVs_TEMP) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); + *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); else { - MEXTEND(mark,0); + MEXTEND(MARK, 0); *MARK = &sv_undef; } SP = MARK; } else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & SVs_TEMP)) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ + for (MARK = newsp + 1; MARK <= SP; MARK++) { + if (!SvTEMP(*MARK)) + *MARK = sv_mortalcopy(*MARK); + } } - - /* Now that stack values are safe, release CV and @_ */ - POPSUB(cx); - - curpm = newpm; /* Don't pop $1 et al till now */ + PUTBACK; + + POPSUB2(); /* Stack values are safe: release CV and @_ ... */ + curpm = newpm; /* ... and pop $1 et al */ LEAVE; - PUTBACK; return pop_return(); } @@ -177,10 +177,10 @@ PP(pp_backtick) } } } - statusvalue = FIXSTATUS(my_pclose(fp)); + STATUS_NATIVE_SET(my_pclose(fp)); } else { - statusvalue = -1; + STATUS_NATIVE_SET(-1); if (GIMME == G_SCALAR) RETPUSHUNDEF; } @@ -798,11 +798,13 @@ PP(pp_select) XPUSHs(&sv_undef); else { GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); - if (gvp && *gvp == egv) + if (gvp && *gvp == egv) { gv_efullname3(TARG, defoutgv, Nullch); - else - sv_setsv(TARG, sv_2mortal(newRV((SV*)egv))); - XPUSHTARG; + XPUSHTARG; + } + else { + XPUSHs(sv_2mortal(newRV((SV*)egv))); + } } if (newdefout) { @@ -2880,7 +2882,7 @@ PP(pp_wait) int argflags; childpid = wait4pid(-1, &argflags, 0); - statusvalue = (childpid > 0) ? FIXSTATUS(argflags) : -1; + STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); XPUSHi(childpid); RETURN; #else @@ -2899,7 +2901,7 @@ PP(pp_waitpid) optype = POPi; childpid = TOPi; childpid = wait4pid(childpid, &argflags, optype); - statusvalue = (childpid > 0) ? FIXSTATUS(argflags) : -1; + STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); SETi(childpid); RETURN; #else @@ -2941,12 +2943,8 @@ PP(pp_system) } while (result == -1 && errno == EINTR); (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); - statusvalue = FIXSTATUS(status); - if (result < 0) - value = -1; - else { - value = (I32)((unsigned int)status & 0xffff); - } + STATUS_NATIVE_SET(status); + value = (result == -1) ? -1 : status; do_execfree(); /* free any memory child malloced on vfork */ SP = ORIGMARK; PUSHi(value); @@ -2972,7 +2970,7 @@ PP(pp_system) else { value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na)); } - statusvalue = FIXSTATUS(value); + STATUS_NATIVE_SET(value); do_execfree(); SP = ORIGMARK; PUSHi(value); @@ -3450,7 +3448,7 @@ PP(pp_ghostent) #ifdef HOST_NOT_FOUND if (!hent) - statusvalue = FIXSTATUS(h_errno); + STATUS_NATIVE_SET(h_errno); #endif if (GIMME != G_ARRAY) { @@ -243,6 +243,7 @@ char* my_bcopy _((char* from, char* to, I32 len)); char* my_bzero _((char* loc, I32 len)); #endif void my_exit _((U32 status)) __attribute__((noreturn)); +void my_failure_exit _((void)) __attribute__((noreturn)); I32 my_lstat _((void)); #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 my_memcmp _((char* s1, char* s2, I32 len)); diff --git a/t/lib/filehand.t b/t/lib/filehand.t index 14a17704b9..20b2ee0bb0 100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -22,7 +22,9 @@ print "1..11\n"; print $mystdout "ok ",fileno($mystdout),"\n"; -$fh = new FileHandle "TEST", O_RDONLY and print "ok 2\n"; +$fh = (new FileHandle "./TEST", O_RDONLY + or new FileHandle "TEST", O_RDONLY) + and print "ok 2\n"; $buffer = <$fh>; diff --git a/t/lib/safe2.t b/t/lib/safe2.t index 586eace6a8..feaab16956 100755 --- a/t/lib/safe2.t +++ b/t/lib/safe2.t @@ -120,7 +120,8 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || - $! =~ /A file or directory in the path name does not exist/ ? + $! =~ /A file or directory in the path name does not exist/ || + $! =~ /Device not configured/ ? "ok $t\n" : "not ok $t # $!\n"); $t++; print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; diff --git a/t/op/closure.t b/t/op/closure.t index 752f30c9c6..ab1e426d81 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -5,6 +5,13 @@ # Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. # +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + print "1..167\n"; my $test = 1; @@ -123,16 +130,11 @@ test { &{$foo[4]}() == 0 }; +exit 0 unless $Config{'d_fork'}; + # Additional tests by Tom Phoenix <rootbeer@teleport.com>. { - BEGIN { - if (-d 't') { - unshift @INC, "lib" - } else { - unshift @INC, '../lib' - } - } use strict; use vars qw!$test!; @@ -377,38 +379,64 @@ END $test++; } - # Fork off a new perl to run the tests. - # (This is so we can catch spurious warnings.) - $| = 1; print ""; $| = 0; # flush output before forking - pipe READ, WRITE or die "Can't make pipe: $!"; - pipe READ2, WRITE2 or die "Can't make second pipe: $!"; - die "Can't fork: $!" unless defined($pid = open PERL, "|-"); - unless ($pid) { - # Child process here. We're going to send errors back - # through the extra pipe. - close READ; - close READ2; - open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; - open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; - exec './perl', '-w', '-' + if ($Config{d_fork} and $^O ne 'VMS') { + # Fork off a new perl to run the tests. + # (This is so we can catch spurious warnings.) + $| = 1; print ""; $| = 0; # flush output before forking + pipe READ, WRITE or die "Can't make pipe: $!"; + pipe READ2, WRITE2 or die "Can't make second pipe: $!"; + die "Can't fork: $!" unless defined($pid = open PERL, "|-"); + unless ($pid) { + # Child process here. We're going to send errors back + # through the extra pipe. + close READ; + close READ2; + open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; + open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; + exec './perl', '-w', '-' or die "Can't exec ./perl: $!"; + } else { + # Parent process here. + close WRITE; + close WRITE2; + print PERL $code; + close PERL; + { local $/; + $output = join '', <READ>; + $errors = join '', <READ2>; } + close READ; + close READ2; + } + } else { + # No fork(). Do it the hard way. + my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; + my $outfile = "tout$$"; $outfile++ while -e $outfile; + my $errfile = "terr$$"; $errfile++ while -e $errfile; + open CMD, ">$cmdfile"; print CMD $code; close CMD; + my $cmd = ($^O eq 'VMS') ? "MCR $^X" : "./perl"; + $cmd .= " -w $cmdfile >$outfile 2>$errfile"; + system $cmd; + $? = 0 if $^O eq 'VMS' and $? & 1; # Keep Unix-minded code below happy + if ($?) { + printf "not ok: exited with error code %04X\n", $?; + $debugging or do { 1 while unlink $cmdfile, $outfile, $errfile }; + exit; + } + { local $/; + open IN, $outfile; $output = <IN>; close IN; + open IN, $errfile; $errors = <IN>; close IN; } + 1 while unlink $cmdfile, $outfile, $errfile; } - # Parent process here. - close WRITE; - close WRITE2; - print PERL $code; - close PERL; - $output = join '', <READ>; - $errors = join '', <READ2>; - print $output, $errors; + print $output; + print STDERR $errors; if ($debugging && ($errors || $? || ($output =~ /not ok/))) { my $lnum = 0; for $line (split '\n', $code) { printf "%3d: %s\n", ++$lnum, $line; } } - printf "not ok: exited with error code %04lX\n",$? if $?; - print "-" x 30, $/ if $debugging; + printf "not ok: exited with error code %04X\n", $? if $?; + print "-" x 30, "\n" if $debugging; } # End of foreach $within } # End of foreach $where_declared diff --git a/t/op/misc.t b/t/op/misc.t index 25eb6619ed..5e628ad67a 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -293,3 +293,12 @@ print "eat flaming death\n" unless ($s == 7); sub foo { local $_ = shift; split; @_ } @x = foo(' x y z '); print "you die joe!\n" unless "@x" eq 'x y z'; +######## +sub foo { local(@_) = ('p', 'q', 'r'); } +sub bar { unshift @_, 'D'; @_ } +sub baz { push @_, 'E'; return @_ } +for (1..3) { print foo('a', 'b', 'c'), bar('d'), baz('e'), "\n" } +EXPECT +pqrDdeE +pqrDdeE +pqrDdeE @@ -445,10 +445,15 @@ char *s; #define LOP(f,x) return lop(f,x,s) static I32 -lop(f,x,s) +lop +#ifdef CAN_PROTOTYPE + (I32 f, expectation x, char *s) +#else + (f,x,s) I32 f; expectation x; char *s; +#endif /* CAN_PROTOTYPE */ { yylval.ival = f; CLINE; @@ -1268,21 +1268,7 @@ croak(pat, va_alist) } PerlIO_puts(PerlIO_stderr(),message); (void)PerlIO_flush(PerlIO_stderr()); - if (e_tmpname) { - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; - } - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; - } - statusvalue = SHIFTSTATUS(statusvalue); -#ifdef VMS - my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44))); -#else - my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); -#endif + my_failure_exit(); } void diff --git a/vms/Makefile b/vms/Makefile index e0b293fd5e..d5194b41eb 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_00324# +PERL_VERSION = 5_00325# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -378,7 +378,7 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S @ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@ -[.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.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 Copy/Log [.utils]perldoc.com $@ @@ -412,7 +412,10 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S [.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm $(MINIPERL) [.x2p]s2p.PL +# Rename catches problem with some DECC versions in which object file is +# placed in current default dir, not same one as source file. [.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O) + @ 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) [.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @@ -617,7 +620,7 @@ perly$(O) : perly.c, perly.h, $(h) [.t.lib]vmsfspec.t : [.vms.ext]filespec.t Copy/Log/NoConfirm [.vms.ext]filespec.t $@ -test : all +test : all [.t.lib]vmsfspec.t - @[.VMS]Test.Com "$(E)" # CORE subset for MakeMaker, so we can build Perl without sources @@ -1476,8 +1479,9 @@ tidy : cleanlis - 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)*.* - - If f$$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile. - - If f$$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug. + - If f$$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.com + - If f$$Search("[.utils]*.com;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.com + - If f$$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com - If f$$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*. clean : tidy @@ -1532,14 +1536,15 @@ realclean : clean - If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;* - If f$$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;* - If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;* - - If f$$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;* + - If f$$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log [.Lib]*.com;* + - If f$$Search("[.utils]*.com").nes."" Then Delete/NoConfirm/Log [.utils]*.com;* + - 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("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile. - - If f$$Search("[.x2p]*.").nes."" Then Delete/NoConfirm/Log [.x2p]*.;*/Exclude=Makefile. - If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - - If f$$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;* + - 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;* + - If f$$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;* - If f$$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);* cleansrc : clean diff --git a/vms/config.vms b/vms/config.vms index 95aefec05a..97d5c960b8 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_00324" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00325" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ /* ARCHNAME: diff --git a/vms/descrip.mms b/vms/descrip.mms index cfa4b660f4..36386ef846 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_00324# +PERL_VERSION = 5_00325# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -499,7 +499,7 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S @ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) -[.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm +[.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) Copy/Log [.utils]perldoc.com $(MMS$TARGET) @@ -533,7 +533,10 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S [.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) +# Rename catches problem with some DECC versions in which object file is +# placed in current default dir, not same one as source file. [.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O) + @ 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) [.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @@ -765,7 +768,7 @@ perly$(O) : perly.c, perly.h, $(h) [.t.lib]vmsfspec.t : [.vms.ext]filespec.t Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) -test : all +test : all [.t.lib]vmsfspec.t - @[.VMS]Test.Com "$(E)" # CORE subset for MakeMaker, so we can build Perl without sources @@ -1632,8 +1635,9 @@ tidy : cleanlis - 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)*.* - - If F$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile. - - If F$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug. + - If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.com + - If F$Search("[.utils]*.com;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.com + - If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com - If F$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*. clean : tidy @@ -1698,14 +1702,15 @@ realclean : clean - If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;* - If F$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;* - If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;* - - If F$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;* + - If F$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log [.Lib]*.com;* + - If F$Search("[.utils]*.com").nes."" Then Delete/NoConfirm/Log [.utils]*.com;* + - 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("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile. - - If F$Search("[.x2p]*.").nes."" Then Delete/NoConfirm/Log [.x2p]*.;*/Exclude=Makefile. - If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - - If F$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;* + - 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;* + - If F$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;* - If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);* cleansrc : clean diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 38cd5368c9..a0a274bfee 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -36,18 +36,30 @@ some:[where.over]the.rainbow unixify /some/where/over/the.rainbow [.some.where.over]the.rainbow unixify some/where/over/the.rainbow [-.some.where.over]the.rainbow unixify ../some/where/over/the.rainbow [.some.--.where.over]the.rainbow unixify some/../../where/over/the.rainbow +[.some...where.over]the.rainbow unixify some/.../where/over/the.rainbow +[...some.where.over]the.rainbow unixify .../some/where/over/the.rainbow +[.some.where.over...]the.rainbow unixify some/where/over/.../the.rainbow +[.some.where.over...] unixify some/where/over/.../ +[.some.where.over.-] unixify some/where/over/../ [] unixify ./ [-] unixify ../ [--] unixify ../../ +[...] unixify .../ # and back again /some/where/over/the.rainbow vmsify some:[where.over]the.rainbow some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow ../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow +.../some/where/over/the.rainbow vmsify [...some.where.over]the.rainbow +some/.../where/over/the.rainbow vmsify [.some...where.over]the.rainbow +/some/.../where/over/the.rainbow vmsify some:[...where.over]the.rainbow +some/where/... vmsify [.some.where...] +/where/... vmsify where:[...] . vmsify [] .. vmsify [-] ../.. vmsify [--] +.../ vmsify [...] # Fileifying directory specs down:[the.garden.path] fileify down:[the.garden]path.dir;1 @@ -73,12 +85,16 @@ down:[the]garden.path pathify /down/the/garden.path pathify down:[the.garden]path.dir;2 pathify #N.B. ;2 path pathify path/ +/down/the/garden/. pathify /down/the/garden/./ +/down/the/garden/.. pathify /down/the/garden/../ +/down/the/garden/... pathify /down/the/garden/.../ path.notdir pathify # Both VMS/Unix and file/path conversions down:[the.garden]path.dir;1 unixpath /down/the/garden/path/ /down/the/garden/path vmspath down:[the.garden.path] down:[the.garden.path] unixpath /down/the/garden/path/ +down:[the.garden.path...] unixpath /down/the/garden/path/.../ /down/the/garden/path.dir vmspath down:[the.garden.path] [.down.the.garden]path.dir unixpath down/the/garden/path/ down/the/garden/path vmspath [.down.the.garden.path] @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 14-Oct-1996 by Charles Bailey bailey@genetics.upenn.edu - * Version: 5.3.7 + * Last revised: 29-Jan-1997 by Charles Bailey bailey@genetics.upenn.edu + * Version: 5.3.24 */ #include <acedef.h> @@ -28,7 +28,8 @@ #include <shrdef.h> #include <ssdef.h> #include <starlet.h> -#include <stsdef.h> +#include <strdef.h> +#include <str$routines.h> #include <syidef.h> #include <uaidef.h> #include <uicdef.h> @@ -1339,7 +1340,11 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) if ( !(cp1 = strrchr(dir,'/')) && !(cp1 = strrchr(dir,']')) && !(cp1 = strrchr(dir,'>')) ) cp1 = dir; - if ((cp2 = strchr(cp1,'.')) != NULL) { + if ((cp2 = strchr(cp1,'.')) != NULL && + (*(cp2-1) != '/' || /* Trailing '.', '..', */ + !(*(cp2+1) == '\0' || /* or '...' are dirs. */ + (*(cp2+1) == '.' && *(cp2+2) == '\0') || + (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) { int ver; char *cp3; if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ @@ -1482,7 +1487,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) { static char __tounixspec_retbuf[NAM$C_MAXRSS+1]; char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; - int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0; + int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0; if (spec == NULL) return NULL; if (strlen(spec) > NAM$C_MAXRSS) return NULL; @@ -1492,9 +1497,13 @@ static char *do_tounixspec(char *spec, char *buf, int ts) cp1 = strchr(spec,'['); if (!cp1) cp1 = strchr(spec,'<'); if (cp1) { - for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */ + for (cp1++; *cp1; cp1++) { + if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */ + if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.') + { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */ + } } - New(7015,rslt,retlen+2+2*dashes,char); + New(7015,rslt,retlen+2+2*expand,char); } else rslt = __tounixspec_retbuf; if (strchr(spec,'/') != NULL) { @@ -1517,11 +1526,10 @@ static char *do_tounixspec(char *spec, char *buf, int ts) else { /* the VMS spec begins with directories */ cp2++; if (*cp2 == ']' || *cp2 == '>') { - strcpy(rslt,"./"); + *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0'; return rslt; } - else if ( *cp2 != '.' && *cp2 != '-') { - *(cp1++) = '/'; /* add the implied device into the Unix spec */ + else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */ if (getcwd(tmp,sizeof tmp,1) == NULL) { if (ts) Safefree(rslt); return NULL; @@ -1532,26 +1540,36 @@ static char *do_tounixspec(char *spec, char *buf, int ts) *(cp3++) = '\0'; if (strchr(cp3,']') != NULL) break; } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3)); - cp3 = tmp; - while (*cp3) *(cp1++) = *(cp3++); - *(cp1++) = '/'; - if (ts && + if (ts && !buf && ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) { - int offset = cp1 - rslt; - retlen = devlen + dirlen; - Renew(rslt,retlen+1+2*dashes,char); - cp1 = rslt + offset; + Renew(rslt,retlen+1+2*expand,char); + cp1 = rslt; + } + cp3 = tmp; + *(cp1++) = '/'; + while (*cp3) { + *(cp1++) = *(cp3++); + if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */ } + *(cp1++) = '/'; + } + else if ( *cp2 == '.') { + if (*(cp2+1) == '.' && *(cp2+2) == '.') { + *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; + cp2 += 3; + } + else cp2++; } - else if (*cp2 == '.') cp2++; } for (; cp2 <= dirend; cp2++) { if (*cp2 == ':') { *(cp1++) = '/'; if (*(cp2+1) == '[') cp2++; } - else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/'; + else if (*cp2 == ']' || *cp2 == '>') { + if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */ + } else if (*cp2 == '.') { *(cp1++) = '/'; if (*(cp2+1) == ']' || *(cp2+1) == '>') { @@ -1560,6 +1578,10 @@ static char *do_tounixspec(char *spec, char *buf, int ts) if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' || *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7; } + else if ( *(cp2+1) == '.' && *(cp2+2) == '.') { + *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/'; + cp2 += 2; + } } else if (*cp2 == '-') { if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') { @@ -1609,9 +1631,10 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { else strcpy(rslt,path); return rslt; } - if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */ + if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */ if (!*(dirend+2)) dirend +=2; if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; + if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; } cp1 = rslt; cp2 = path; @@ -1660,6 +1683,12 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { *(cp1++) = '-'; /* "../" --> "-" */ cp2 += 3; } + else if (*(cp2+1) == '.' && *(cp2+2) == '.' && + (*(cp2+3) == '/' || *(cp2+3) == '\0')) { + *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ + if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */ + cp2 += 4; + } if (cp2 > dirend) cp2 = dirend; } else *(cp1++) = '.'; @@ -1687,6 +1716,16 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { cp2 += 2; if (cp2 == dirend) break; } + else if ( *(cp2+1) == '.' && *(cp2+2) == '.' && + (*(cp2+3) == '/' || *(cp2+3) == '\0') ) { + if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */ + *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ + if (!*(cp2+3)) { + *(cp1++) = '.'; /* Simulate trailing '/' */ + cp2 += 2; /* for loop will incr this to == dirend */ + } + else cp2 += 3; /* Trailing '/' was there, so skip it, too */ + } else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ } else { @@ -2132,7 +2171,7 @@ unsigned long int zero = 0, sts; for (c = string; *c; ++c) if (isupper(*c)) *c = tolower(*c); - if (isunix) trim_unixpath(string,item); + if (isunix) trim_unixpath(string,item,1); add_item(head, tail, string, count); ++expcount; } @@ -2289,23 +2328,26 @@ unsigned long int flags = 17, one = 1, retsts; * of whether input filespec was VMS-style or Unix-style. * * fspec is filespec to be trimmed, and wildspec is wildcard spec used to - * determine prefix (both may be in VMS or Unix syntax). + * determine prefix (both may be in VMS or Unix syntax). opts is a bit + * vector of options; at present, only bit 0 is used, and if set tells + * trim unixpath to try the current default directory as a prefix when + * presented with a possibly ambiguous ... wildcard. * * Returns !=0 on success, with trimmed filespec replacing contents of * fspec, and 0 on failure, with contents of fpsec unchanged. */ -/*{{{int trim_unixpath(char *fspec, char *wildspec)*/ +/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/ int -trim_unixpath(char *fspec, char *wildspec) +trim_unixpath(char *fspec, char *wildspec, int opts) { char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1], - *template, *base, *cp1, *cp2; - register int tmplen, reslen = 0; + *template, *base, *end, *cp1, *cp2; + register int tmplen, reslen = 0, dirs = 0; if (!wildspec || !fspec) return 0; if (strpbrk(wildspec,"]>:") != NULL) { if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0; - else template = unixified; + else template = unixwild; } else template = wildspec; if (strpbrk(fspec,"]>:") != NULL) { @@ -2327,63 +2369,112 @@ trim_unixpath(char *fspec, char *wildspec) return 1; } - /* Find prefix to template consisting of path elements without wildcards */ - if ((cp1 = strpbrk(template,"*%?")) == NULL) - for (cp1 = template; *cp1; cp1++) ; - else while (cp1 > template && *cp1 != '/') cp1--; - for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */ - - /* Wildcard was in first element, so we don't have a reliable string to - * match against. Guess where to trim resultant filespec by counting - * directory levels in the Unix template. (We could do this instead of - * string matching in all cases, since Unix doesn't have a ... wildcard - * that can expand into multiple levels of subdirectory, but we try for - * the string match so our caller can interpret foo/.../bar.* as - * [.foo...]bar.* if it wants, and only get burned if there was a - * wildcard in the first word (in which case, caveat caller). */ - if (cp1 == template) { - int subdirs = 0; - for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++; - /* need to back one more '/' than in template, to pick up leading dirname */ - subdirs++; - while (cp2 > base) { - if (*cp2 == '/') subdirs--; - if (!subdirs) break; /* quit without decrement when we hit last '/' */ - cp2--; - } - /* ran out of directories on resultant; allow for already trimmed - * resultant, which hits start of string looking for leading '/' */ - if (subdirs && (cp2 != base || subdirs != 1)) return 0; - /* Move past leading '/', if there is one */ - base = cp2 + (*cp2 == '/' ? 1 : 0); - tmplen = strlen(base); - if (reslen && tmplen > reslen) return 0; /* not enough space */ - memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */ + for (end = base; *end; end++) ; /* Find end of resultant filespec */ + if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */ + for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++; + for (cp1 = end ;cp1 >= base; cp1--) + if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */ + { cp1++; break; } + if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1); return 1; } - /* We have a prefix string of complete directory names, so we - * try to find it on the resultant filespec */ - else { - tmplen = cp1 - template; - if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */ - if (reslen) { /* we converted to Unix syntax; copy result over */ - tmplen = cp2 - base; - if (tmplen > reslen) return 0; /* not enough space */ - memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */ + else { + char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1]; + char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1; + int ells = 1, totells, segdirs, match; + struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl}, + resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + + while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;} + totells = ells; + for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++; + if (ellipsis == template && opts & 1) { + /* Template begins with an ellipsis. Since we can't tell how many + * directory names at the front of the resultant to keep for an + * arbitrary starting point, we arbitrarily choose the current + * default directory as a starting point. If it's there as a prefix, + * clip it off. If not, fall through and act as if the leading + * ellipsis weren't there (i.e. return shortest possible path that + * could match template). + */ + if (getcwd(tpl, sizeof tpl,0) == NULL) return 0; + for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) + if (_tolower(*cp1) != _tolower(*cp2)) break; + segdirs = dirs - totells; /* Min # of dirs we must have left */ + for (front = cp2+1; *front; front++) if (*front == '/') segdirs--; + if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) { + memcpy(fspec,cp2+1,end - cp2); + return 1; } - return 1; } - for ( ; cp2 - base > tmplen; base++) { - if (*base != '/') continue; - if (!memcmp(base + 1,template,tmplen)) break; + /* First off, back up over constant elements at end of path */ + if (dirs) { + for (front = end ; front >= base; front--) + if (*front == '/' && !dirs--) { front++; break; } + } + for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend; + cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */ + if (cp1 != '\0') return 0; /* Path too long. */ + lcend = cp2; + *cp2 = '\0'; /* Pick up with memcpy later */ + lcfront = lcres + (front - base); + /* Now skip over each ellipsis and try to match the path in front of it. */ + while (ells--) { + for (cp1 = ellipsis - 2; cp1 >= template; cp1--) + if (*(cp1) == '.' && *(cp1+1) == '.' && + *(cp1+2) == '.' && *(cp1+3) == '/' ) break; + if (cp1 < template) break; /* template started with an ellipsis */ + if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */ + ellipsis = cp1; continue; + } + wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1; + nextell = cp1; + for (segdirs = 0, cp2 = tpl; + cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl; + cp1++, cp2++) { + if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */ + else *cp2 = _tolower(*cp1); /* else lowercase for match */ + if (*cp2 == '/') segdirs++; + } + if (cp1 != ellipsis - 1) return 0; /* Path too long */ + /* Back up at least as many dirs as in template before matching */ + for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--) + if (*cp1 == '/' && !segdirs--) { cp1++; break; } + for (match = 0; cp1 > lcres;) { + resdsc.dsc$a_pointer = cp1; + if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) { + match++; + if (match == 1) lcfront = cp1; + } + for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; } + } + if (!match) return 0; /* Can't find prefix ??? */ + if (match > 1 && opts & 1) { + /* This ... wildcard could cover more than one set of dirs (i.e. + * a set of similar dir names is repeated). If the template + * contains more than 1 ..., upstream elements could resolve the + * ambiguity, but it's not worth a full backtracking setup here. + * As a quick heuristic, clip off the current default directory + * if it's present to find the trimmed spec, else use the + * shortest string that this ... could cover. + */ + char def[NAM$C_MAXRSS+1], *st; + + if (getcwd(def, sizeof def,0) == NULL) return 0; + for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) + if (_tolower(*cp1) != _tolower(*cp2)) break; + segdirs = dirs - totells; /* Min # of dirs we must have left */ + for (st = cp2+1; *st; st++) if (*st == '/') segdirs--; + if (*cp1 == '\0' && *cp2 == '/') { + memcpy(fspec,cp2+1,end - cp2); + return 1; + } + /* Nope -- stick with lcfront from above and keep going. */ + } } - - if (cp2 - base == tmplen) return 0; /* Not there - not good */ - base++; /* Move past leading '/' */ - if (reslen && cp2 - base > reslen) return 0; /* not enough space */ - /* Copy down remaining portion of filespec, including trailing NUL */ - memmove(fspec,base,cp2 - base + 1); + memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1); return 1; + ellipsis = nextell; } } /* end of trim_unixpath() */ diff --git a/vms/vmsish.h b/vms/vmsish.h index fa23571d47..10cdc08eda 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -13,6 +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> /* Suppress compiler warnings from DECC for VMS-specific extensions: * GLOBALEXT, NOSHAREEXT, READONLYEXT: global[dr]ef declarations @@ -483,7 +484,7 @@ struct tm *my_gmtime _((const time_t *)); I32 cando_by_name _((I32, I32, char *)); int flex_fstat _((int, struct stat *)); int flex_stat _((char *, struct stat *)); -int trim_unixpath _((char *, char*)); +int trim_unixpath _((char *, char*, int)); int my_vfork _(()); bool vms_do_aexec _((SV *, SV **, SV **)); bool vms_do_exec _((char *)); |