summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>1997-02-04 17:47:00 +1200
committerChip Salzenberg <chip@atlantic.net>1997-02-04 17:47:00 +1200
commitf86702ccfcc3646d7aa30b09ce4f4413be9f99d1 (patch)
treef8a3d6634bf3149e753dd0ea414c0c0079003708
parent8a7dc658e6602067382c308b2131d135e4063624 (diff)
downloadperl-f86702ccfcc3646d7aa30b09ce4f4413be9f99d1.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>
-rw-r--r--Changes167
-rw-r--r--README.amiga4
-rw-r--r--cop.h49
-rw-r--r--doio.c2
-rw-r--r--embed.h4
-rw-r--r--ext/DynaLoader/DynaLoader.pm2
-rw-r--r--ext/DynaLoader/dl_vms.xs8
-rw-r--r--ext/IO/lib/IO/Handle.pm11
-rw-r--r--global.sym1
-rw-r--r--gv.c6
-rw-r--r--interp.sym1
-rw-r--r--lib/AutoSplit.pm5
-rw-r--r--lib/English.pm4
-rw-r--r--lib/ExtUtils/Embed.pm7
-rw-r--r--lib/ExtUtils/MM_VMS.pm13
-rw-r--r--lib/ExtUtils/MakeMaker.pm2
-rw-r--r--lib/FileHandle.pm2
-rw-r--r--mg.c28
-rw-r--r--patchlevel.h2
-rw-r--r--perl.c138
-rw-r--r--perl.h75
-rw-r--r--pod/perldelta.pod23
-rw-r--r--pod/perldiag.pod37
-rw-r--r--pod/perlfunc.pod15
-rw-r--r--pod/perltoc.pod232
-rw-r--r--pod/perlvar.pod25
-rwxr-xr-xpod/roffitall2
-rw-r--r--pp_ctl.c93
-rw-r--r--pp_hot.c37
-rw-r--r--pp_sys.c30
-rw-r--r--proto.h1
-rwxr-xr-xt/lib/filehand.t4
-rwxr-xr-xt/lib/safe2.t3
-rwxr-xr-xt/op/closure.t90
-rwxr-xr-xt/op/misc.t9
-rw-r--r--toke.c7
-rw-r--r--util.c16
-rw-r--r--vms/Makefile23
-rw-r--r--vms/config.vms2
-rw-r--r--vms/descrip.mms23
-rw-r--r--vms/ext/filespec.t16
-rw-r--r--vms/vms.c249
-rw-r--r--vms/vmsish.h3
43 files changed, 901 insertions, 570 deletions
diff --git a/Changes b/Changes
index acfef8dd0b..6dd2b66c2d 100644
--- a/Changes
+++ b/Changes
@@ -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
diff --git a/cop.h b/cop.h
index d450e09b01..501faac80e 100644
--- a/cop.h
+++ b/cop.h
@@ -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 {
diff --git a/doio.c b/doio.c
index 175b6b065a..31c9a35ff2 100644
--- a/doio.c
+++ b/doio.c
@@ -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;
diff --git a/embed.h b/embed.h
index 365af2a115..88aa929d5d 100644
--- a/embed.h
+++ b/embed.h
@@ -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
diff --git a/gv.c b/gv.c
index 4cfb5849e4..010a3911e8 100644
--- a/gv.c
+++ b/gv.c
@@ -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);
diff --git a/mg.c b/mg.c
index c42667f70a..8c89e6b54d 100644
--- a/mg.c
+++ b/mg.c
@@ -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.
diff --git a/perl.c b/perl.c
index 9b9265cab1..77bcb4d02c 100644
--- a/perl.c
+++ b/perl.c
@@ -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);
+}
diff --git a/perl.h b/perl.h
index cdde3192bd..f91179a669 100644
--- a/perl.h
+++ b/perl.h
@@ -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 \
diff --git a/pp_ctl.c b/pp_ctl.c
index 8eb32e208a..2955b165be 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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)
diff --git a/pp_hot.c b/pp_hot.c
index 120c026b4b..16c250593e 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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();
}
diff --git a/pp_sys.c b/pp_sys.c
index 11e11a5d48..e593b6c8f9 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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) {
diff --git a/proto.h b/proto.h
index b86894ff27..f8ad899c16 100644
--- a/proto.h
+++ b/proto.h
@@ -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
diff --git a/toke.c b/toke.c
index 10f61f1bc6..c8ff0a0d76 100644
--- a/toke.c
+++ b/toke.c
@@ -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;
diff --git a/util.c b/util.c
index 6097741657..c93663cbe8 100644
--- a/util.c
+++ b/util.c
@@ -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]
diff --git a/vms/vms.c b/vms/vms.c
index 992e75f0a7..a9060b49de 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -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 *));