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_26 to perl5.003_27]
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Tue, 18 Feb 1997 01:22:00 +0000 (13:22 +1200)
committerChip Salzenberg <chip@atlantic.net>
Tue, 18 Feb 1997 01:22:00 +0000 (13:22 +1200)
 BUILD PROCESS

Subject: Fix eval "" in Configure
Date: Fri, 14 Feb 1997 13:09:53 -0500
From: John L. Allen <allen@gateway.grumman.com>
Files: Configure

    Subject: Re: Configure problem on IRIX - me dumb

    p5p-msgid: <9702141809.AA17001@gateway.grumman.com>

Subject: Don't link with -lsfio if sfio is not requested
From: Chip Salzenberg <chip@perl.com>
Files: Configure

Subject: perl5.003_26 Configure change "win" for AIX 4
Date: Fri, 14 Feb 1997 13:59:02 -0600 (CST)
From: Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu>
Files: Configure

    p5p-msgid: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoDak.edu>
    private-msgid: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoD

 CORE LANGUAGE CHANGES

Subject: Better looks_like_number() function [sv.c]
Date: Fri, 14 Feb 1997 18:08:52 +0100
From: Gisle Aas <aas@bergen.sn.no>
Files: sv.c
Msg-ID: <199702141708.SAA17546@bergen.sn.no>

    (applied based on p5p patch as commit 8dbaa58ee2aba7cc22d84199a674c58bbf108b46)

Subject: Remove redundant functions UNIVERSAL::{class,is_instance}
Date: 14 Feb 1997 15:52:21 +0000
From: Gisle Aas <aas@bergen.sn.no>
Files: pod/perldelta.pod pod/perlobj.pod t/op/universal.t universal.c
Msg-ID: <hwwsbpeq2.fsf@bergen.sn.no>

    (applied based on p5p patch as commit 77bb9b23081b62119e8fbe9f5655b8802e4537ae)

Subject: Allow C<setpgrp $$>
Date: 16 Feb 1997 23:19:12 -0500
From: Roderick Schertler <roderick@gate.net>
Files: pp_sys.c
Msg-ID: <pzraigyshr.fsf@eeyore.ibcinc.com>

    (applied based on p5p patch as commit 3d2573a84a1aa655d5da58c57b3fc20e04d40f9f)

Subject: Fix syntax error on C<&$1>
From: Chip Salzenberg <chip@perl.com>
Files: toke.c

Subject: Fix grep() with refs in array context
From: Chip Salzenberg <chip@perl.com>
Files: pp.c

 CORE PORTABILITY

Subject: Eliminate $^S; add C<use vmsish qw(status exit time)>
Date: Mon, 17 Feb 1997 02:45:26 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: MANIFEST gv.c lib/English.pm lib/ExtUtils/MM_VMS.pm lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp mg.c op.c perl.c perl.h pod/perldelta.pod pod/perlmod.pod pod/perlvar.pod pp_ctl.c pp_sys.c utils/perldoc.PL vms/Makefile vms/config.vms vms/descrip.mms vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs vms/ext/XSSymSet.pm vms/ext/vmsish.pm vms/vms.c vms/vmsish.h win32/makedef.pl

    private-msgid: <01IFI9CFKL0S004R2V@hmivax.humgen.upenn.edu>

 LIBRARY AND EXTENSIONS

Subject: Remove Fatal.pm
From: Chip Salzenberg <chip@perl.com>
Files: MANIFEST lib/Fatal.pm pod/perldelta.pod pod/perlmod.pod pod/roffitall t/lib/fatal.t

Subject: Refresh MakeMaker to 5.40
From: Andy Dougherty <doughera@lafcol.lafayette.edu>
Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm

 OTHER CORE CHANGES

Subject: Fix core dump when embedding
From: Chip Salzenberg <chip@perl.com>
Files: perl.c

Subject: Re: Fragile signals
Date: Thu, 13 Feb 1997 01:44:39 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: mg.c
Msg-ID: <199702130644.BAA07572@monk.mps.ohio-state.edu>

    (applied based on p5p patch as commit 09df8c7df7dfc9853902f1fdd8a6d95f53be66fc)

Subject: Make format strings correspond exactly to parameters
Date: 13 Feb 1997 17:24:31 -0500
From: Roderick Schertler <roderick@gate.net>
Files: doio.c ext/DB_File/DB_File.xs ext/Opcode/Opcode.xs gv.c op.c perl.c pp_ctl.c pp_sys.c regcomp.c toke.c
Msg-ID: <pz7mkc1h0g.fsf@eeyore.ibcinc.com>

    (applied based on p5p patch as commit bf81aadd817bdea29720b072eef945df2da8463b)

Subject: Don't try to attach 'o' magic to read-only values
From: Chip Salzenberg <chip@perl.com>
Files: sv.c

Subject: Fix carriage-return message
From: Chip Salzenberg <chip@perl.com>
Files: toke.c

Subject: In <=>, test for equality first
From: Chip Salzenberg <chip@perl.com>
Files: pp.c

Subject: Don't mark sv_{true,false} PADTMP
From: Chip Salzenberg <chip@perl.com>
Files: op.c

49 files changed:
Changes
Configure
MANIFEST
av.h
doio.c
ext/DB_File/DB_File.xs
ext/Opcode/Opcode.xs
gv.c
lib/English.pm
lib/ExtUtils/Liblist.pm
lib/ExtUtils/MM_Unix.pm
lib/ExtUtils/MM_VMS.pm
lib/ExtUtils/MakeMaker.pm
lib/ExtUtils/Mksymlists.pm
lib/ExtUtils/xsubpp
mg.c
op.c
patchlevel.h
perl.c
perl.h
pod/perldelta.pod
pod/perlmod.pod
pod/perlobj.pod
pod/perlrun.pod
pod/perltoc.pod
pod/perlvar.pod
pod/roffitall
pp.c
pp_ctl.c
pp_sys.c
regcomp.c
sv.c
t/op/universal.t
toke.c
universal.c
utils/perldoc.PL
vms/Makefile
vms/config.vms
vms/descrip.mms
vms/ext/Stdio/Stdio.pm
vms/ext/Stdio/Stdio.xs
vms/ext/XSSymSet.pm [new file with mode: 0644]
vms/ext/vmsish.pm [new file with mode: 0644]
vms/test.com
vms/vms.c
vms/vmsish.h
win32/makedef.pl
x2p/a2p.c
x2p/a2p.y

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