This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_24 to perl5.003_25] perl-5.003_25
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Tue, 4 Feb 1997 05:47:00 +0000 (17:47 +1200)
committerChip Salzenberg <chip@atlantic.net>
Tue, 4 Feb 1997 05:47:00 +0000 (17:47 +1200)
 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:
Changes
README.amiga
cop.h
doio.c
embed.h
ext/DynaLoader/DynaLoader.pm
ext/DynaLoader/dl_vms.xs
ext/IO/lib/IO/Handle.pm
global.sym
gv.c
interp.sym
lib/AutoSplit.pm
lib/English.pm
lib/ExtUtils/Embed.pm
lib/ExtUtils/MM_VMS.pm
lib/ExtUtils/MakeMaker.pm
lib/FileHandle.pm
mg.c
patchlevel.h
perl.c
perl.h
pod/perldelta.pod
pod/perldiag.pod
pod/perlfunc.pod
pod/perltoc.pod
pod/perlvar.pod
pod/roffitall
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
t/lib/filehand.t
t/lib/safe2.t
t/op/closure.t
t/op/misc.t
toke.c
util.c
vms/Makefile
vms/config.vms
vms/descrip.mms
vms/ext/filespec.t
vms/vms.c
vms/vmsish.h

diff --git a/Changes b/Changes
index acfef8d..6dd2b66 100644 (file)
--- 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
 ----------------
 
index b20c023..110f9cf 100644 (file)
@@ -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 d450e09..501faac 100644 (file)
--- 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 175b6b0..31c9a35 100644 (file)
--- 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 365af2a..88aa929 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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)
 #define Istatgv                        statgv
 #define Istatname              statname
 #define Istatusvalue           statusvalue
+#define Istatusvalue_vms       statusvalue_vms
 #define Istdingv               stdingv
 #define Istrchop               strchop
 #define Istrtab                        strtab
 #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
index a36dc00..3cb06cc 100644 (file)
@@ -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
index fae4e48..370994b 100644 (file)
@@ -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",
index 135351f..e02f6df 100644 (file)
@@ -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
index 941d006..f1d0573 100644 (file)
@@ -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 4cfb584..010a391 100644 (file)
--- 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;
     }
index ea4241a..ec9c038 100644 (file)
@@ -129,6 +129,7 @@ statcache
 statgv
 statname
 statusvalue
+statusvalue_vms
 stdingv
 strchop
 strtab
index c1ff13a..f7b8eee 100644 (file)
@@ -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)){
index ce4520a..736b90d 100644 (file)
@@ -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.
index c663d64..4a37184 100644 (file)
@@ -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;
 }
 
index 1e39e11..f609cc8 100644 (file)
@@ -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
index 2d3dd56..99aaa38 100644 (file)
@@ -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 {
index b907cae..0b5d9ed 100644 (file)
@@ -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 c42667f..8c89e6b 100644 (file)
--- 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);
index 603aaa3..7db0e20 100644 (file)
@@ -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 9b9265c..77bcb4d 100644 (file)
--- 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 cdde319..f91179a 100644 (file)
--- a/perl.h
+++ b/perl.h
 #     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
 #   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>
 #   define SLOPPYDIVIDE
 #endif
 
-#if defined(cray) || defined(convex) || BYTEORDER > 0xffff
-#   define HAS_QUAD
-#endif
-
 #ifdef UV
 #undef UV
 #endif
     --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;
index 04e9a45..56745d1 100644 (file)
@@ -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,
index 018ebb7..32f55be 100644 (file)
@@ -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.
index e532ed2..6825d22 100644 (file)
@@ -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
index 8c97163..02d3dd3 100644 (file)
@@ -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
index 248c378..f0447cd 100644 (file)
@@ -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
index 06b3918..ae2cd06 100755 (executable)
@@ -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   \
index 8eb32e2..2955b16 100644 (file)
--- 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)
index 120c026..16c2505 100644 (file)
--- 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();
 }
 
index 11e11a5..e593b6c 100644 (file)
--- 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 b86894f..f8ad899 100644 (file)
--- 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));
index 14a1770..20b2ee0 100755 (executable)
@@ -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>;
index 586eace..feaab16 100755 (executable)
@@ -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++;
   
index 752f30c..ab1e426 100755 (executable)
@@ -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
index 25eb661..5e628ad 100755 (executable)
@@ -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 10f61f1..c8ff0a0 100644 (file)
--- 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 6097741..c93663c 100644 (file)
--- 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
index e0b293f..d5194b4 100644 (file)
@@ -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
index 95aefec..97d5c96 100644 (file)
@@ -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:
index cfa4b66..36386ef 100644 (file)
@@ -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
index 38cd536..a0a274b 100644 (file)
@@ -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]
index 992e75f..a9060b4 100644 (file)
--- 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() */
index fa23571..10cdc08 100644 (file)
@@ -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 *));