[inseparable changes from match from perl-5.003_90 to perl-5.003_91]
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Tue, 25 Feb 1997 01:12:02 +0000 (13:12 +1200)
committerChip Salzenberg <chip@atlantic.net>
Tue, 25 Feb 1997 01:12:02 +0000 (13:12 +1200)
 BUILD PROCESS

Subject: Sanity check linking with $libs
Date: Tue, 25 Feb 1997 14:13:45 -0500 (EST)
From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>
Files: Configure
Msg-ID: <Pine.SOL.3.95q.970225221634.2486A-100000@fractal.lafayette.edu>

    (applied based on p5p patch as commit 5c37e92e59bb92e49d5a21017cd6dc066a28ddea)

Subject: Flush stdout when printing $randbits guess
From: Chip Salzenberg <chip@perl.com>
Files: Configure

Subject: Configure changes for Irix nm
From: Helmut Jarausch <helmutjarausch@unknown>
Files: Configure

 CORE LANGUAGE CHANGES

Subject: Fix perl_call_*() when !G_EVAL
Date: Tue, 25 Feb 1997 02:25:56 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: MANIFEST gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c t/op/runlevel.t
Msg-ID: <199702250725.CAA09192@aatma.engin.umich.edu>, <199702251925.OAA15498@aatma.engin.umich.edu>, <199702252200.RAA16853@aatma.engin.umich.edu>

    (applied based on p5p patch as commits 40f788c454d994616342c409de5b5d181ad9b8af, and 907a881cde89c56bc61d3f314c0efb8754ca472a20efc0829f6564c44574762adb07e8865bc14026)

Subject: Fix taint tests for writeable dirs in $ENV{PATH}
From: Chip Salzenberg <chip@perl.com>
Files: mg.c mg.h pod/perlsec.pod taint.c

Subject: Forbid tainted parameters for truncate()
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c

Subject: Don't taint magic hash keys unnecessarily
Date: Fri, 28 Feb 1997 02:11:26 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: hv.c

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

 CORE PORTABILITY

Subject: VMS patches post _90
Date: Fri, 28 Feb 1997 15:26:33 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: doio.c mg.c perl.h pp_hot.c t/op/rand.t t/op/taint.t taint.c vms/descrip.mms vms/vms.c

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

Subject: Fix taint check in system() and exec() under VMS and OS/2
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c

Subject: If _XOPEN_VERSION >= 4, socket length parameters are size_t
From: Michael H. Moran <mhm@austin.ibm.com>
Files: perl.h pp_sys.c

Subject: Make dooneliner() compile again
From: Chip Salzenberg <chip@perl.com>
Files: pp_sys.c

 DOCUMENTATION

Subject: Move ENVIRONMENT from perl.pod to perlrun.pod
From: Chip Salzenberg <chip@perl.com>
Files: pod/perl.pod pod/perlrun.pod

Subject: Describe PERL_DEBUG_MSTATS in perlrun.pod
From: Nat <gnat@frii.com>
Files: pod/perlrun.pod

Subject: Fix references to perlbug
From: Chip Salzenberg <chip@perl.com>
Files: pod/perl.pod pod/perldelta.pod pod/perllocale.pod pod/perltoc.pod

 OTHER CORE CHANGES

Subject: Short-circuit duplicate study() calls
From: Chip Salzenberg <chip@perl.com>
Files: pp.c

Subject: Call sv_set[iu]v() with [IU]V parameter, not [IU]32
From: Chip Salzenberg <chip@perl.com>
Files: perl.c pp.c pp_sys.c toke.c util.c

Subject: Clean up and document API for hashes
Date: Tue, 25 Feb 1997 13:24:02 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: hv.c hv.h pod/perldelta.pod pod/perlguts.pod
Msg-ID: <199702251824.NAA14859@aatma.engin.umich.edu>

    (applied based on p5p patch as commit a61fe43df197fcc70e6f310c06ee17d52b606c45)

Subject: pp_undef was not always freeing memory
Date: Thu, 27 Feb 1997 01:53:51 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: pp.c
Msg-ID: <199702270653.BAA13949@monk.mps.ohio-state.edu>

    (applied based on p5p patch as commit 1da885048b65b5be1bd3077c6fc45f92c567e1b5)

Subject: Don't examine rx->exec_tainted if pregexec() fails
From: Chip Salzenberg <chip@perl.com>
Files: pp_hot.c

 TESTS

Subject: New test op/taint.t
Date: Tue, 25 Feb 1997 11:36:53 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: MANIFEST t/op/taint.t

    private-msgid: <Pine.GSO.3.95q.970225101328.18288M-100000@kelly.teleport.com

Subject: Patch to t/op/rand.t
Date: Tue, 25 Feb 1997 18:19:34 -0800 (PST)
From: Tom Phoenix <rootbeer@teleport.com>
Files: t/op/rand.t

    private-msgid: <Pine.GSO.3.95q.970225181321.13796Q-100000@kelly.teleport.com

 UTILITIES

Subject: Add --lax option to pod2man; use it in perldoc
From: Nat <gnat@frii.com>
Files: pod/pod2man.PL utils/perldoc.PL

Subject: Eliminate dead code in pod2man
From: Chip Salzenberg <chip@perl.com>
Files: pod/pod2man.PL

39 files changed:
Changes
Configure
MANIFEST
configure
configure.gnu
doio.c
embed.h
gv.c
hv.c
hv.h
interp.sym
mg.c
mg.h
patchlevel.h
perl.c
perl.h
plan9/buildinfo
pod/perl.pod
pod/perldelta.pod
pod/perlguts.pod
pod/perllocale.pod
pod/perlrun.pod
pod/perlsec.pod
pod/perltoc.pod
pod/pod2man.PL
pp.c
pp_ctl.c
pp_hot.c
pp_sys.c
t/op/rand.t
t/op/runlevel.t [new file with mode: 0644]
t/op/taint.t [new file with mode: 0644]
taint.c
toke.c
util.c
utils/perldoc.PL
vms/config.vms
vms/descrip.mms
vms/vms.c

diff --git a/Changes b/Changes
index 8c4aedf..a9da262 100644 (file)
--- a/Changes
+++ b/Changes
@@ -8,6 +8,198 @@ or in the .../src/5/0/unsupported directory for sub-version
 releases.)
 
 
+----------------
+Version 5.003_91
+----------------
+
+This is (should be?  must be!) the public beta of 5.004.
+
+ CORE LANGUAGE CHANGES
+
+  Title:  "Fix perl_call_*() when !G_EVAL"
+   From:  Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID:  <199702250725.CAA09192@aatma.engin.umich.edu>,
+          <199702251925.OAA15498@aatma.engin.umich.edu>,
+          <199702252200.RAA16853@aatma.engin.umich.edu>
+   Date:  Tue, 25 Feb 1997 02:25:56 -0500
+  Files:  MANIFEST gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c
+          t/op/runlevel.t
+
+  Title:  "Fix taint tests for writeable dirs in $ENV{PATH}"
+   From:  Chip Salzenberg
+  Files:  mg.c mg.h pod/perlsec.pod taint.c
+
+  Title:  "Forbid tainted parameters for truncate()"
+   From:  Chip Salzenberg
+  Files:  pp_sys.c
+
+  Title:  "Don't taint magic hash keys unnecessarily"
+   From:  Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID:  <01IFXL9TY74Y00661G@hmivax.humgen.upenn.edu>
+   Date:  Fri, 28 Feb 1997 02:11:26 -0500 (EST)
+  Files:  hv.c
+
+ CORE PORTABILITY
+
+  Title:  "VMS patches post _90"
+   From:  Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID:  <01IFYDE5ZT7O005A53@hmivax.humgen.upenn.edu>
+   Date:  Fri, 28 Feb 1997 15:26:33 -0500 (EST)
+  Files:  doio.c mg.c perl.h pp_hot.c t/op/rand.t t/op/taint.t taint.c
+          vms/descrip.mms vms/vms.c
+
+  Title:  "Fix taint check in system() and exec() under VMS and OS/2"
+   From:  Chip Salzenberg
+  Files:  pp_sys.c
+
+  Title:  "If _XOPEN_VERSION >= 4, socket length parameters are size_t"
+   From:  Michael H. Moran <mhm@austin.ibm.com>
+  Files:  perl.h pp_sys.c
+
+  Title:  "Make dooneliner() compile again"
+   From:  Chip Salzenberg
+  Files:  pp_sys.c
+
+ OTHER CORE CHANGES
+
+  Title:  "Short-circuit duplicate study() calls"
+   From:  Chip Salzenberg
+  Files:  pp.c
+
+  Title:  "Call sv_set[iu]v() with [IU]V parameter, not [IU]32"
+   From:  Chip Salzenberg
+  Files:  perl.c pp.c pp_sys.c toke.c util.c
+
+  Title:  "Clean up and document API for hashes"
+   From:  Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID:  <199702251824.NAA14859@aatma.engin.umich.edu>
+   Date:  Tue, 25 Feb 1997 13:24:02 -0500
+  Files:  hv.c hv.h pod/perldelta.pod pod/perlguts.pod
+
+  Title:  "pp_undef was not always freeing memory"
+   From:  Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID:  <199702270653.BAA13949@monk.mps.ohio-state.edu>
+   Date:  Thu, 27 Feb 1997 01:53:51 -0500 (EST)
+  Files:  pp.c
+
+  Title:  "Fix SEGV when debugging with foreach() lvalue patch"
+   From:  Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID:  <199702271924.OAA14557@monk.mps.ohio-state.edu>
+   Date:  Thu, 27 Feb 1997 14:24:36 -0500 (EST)
+  Files:  sv.c
+
+  Title:  "Don't examine rx->exec_tainted if pregexec() fails"
+   From:  Chip Salzenberg
+  Files:  pp_hot.c
+
+  Title:  "Silence bogus typo warning on $DB::postponed"
+   From:  Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID:  <199702271802.NAA12505@aatma.engin.umich.edu>
+   Date:  Thu, 27 Feb 1997 13:02:30 -0500
+  Files:  op.c
+
+ BUILD PROCESS
+
+  Title:  "Sanity check linking with $libs"
+   From:  Andy Dougherty <doughera@fractal.phys.lafayette.edu>
+ Msg-ID:  <Pine.SOL.3.95q.970225221634.2486A-100000@fractal.lafayette.edu>
+   Date:  Tue, 25 Feb 1997 14:13:45 -0500 (EST)
+  Files:  Configure
+
+  Title:  "Flush stdout when printing $randbits guess"
+   From:  Chip Salzenberg
+  Files:  Configure
+
+  Title:  "Configure changes for Irix nm"
+   From:  Helmut Jarausch and Fabien Tassin
+  Files:  Configure
+
+  Title:  "Update OS/2 Configure diff"
+   From:  Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID:  <199702251906.OAA10608@monk.mps.ohio-state.edu>
+   Date:  Tue, 25 Feb 1997 14:06:23 -0500 (EST)
+  Files:  os2/diff.configure
+
+ LIBRARY AND EXTENSIONS
+
+  Title:  "Don't require() in a signal handler"
+   From:  Chip Salzenberg
+  Files:  lib/perl5db.pl
+
+  Title:  "Make IPC::Open3 work without fork()"
+   From:  Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID:  <199702251937.OAA10718@monk.mps.ohio-state.edu>
+   Date:  Tue, 25 Feb 1997 14:37:07 -0500 (EST)
+  Files:  lib/IPC/Open3.pm
+
+  Title:  "Follow up on elimination of $` $& $' in libraries"
+   From:  "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID:  <E0w0Sqc-00046E-00@ursa.cus.cam.ac.uk>
+   Date:  Fri, 28 Feb 1997 13:59:42 +0000
+  Files:  lib/Getopt/Long.pm lib/diagnostics.pm
+
+  Title:  "Don't warn on use of CCFLAGS"
+   From:  Andreas Koenig <k@anna.in-berlin.de>
+ Msg-ID:  <199702251038.LAA13123@anna.in-berlin.de>
+   Date:  Tue, 25 Feb 1997 11:38:43 +0100
+  Files:  lib/ExtUtils/MakeMaker.pm
+
+  Title:  "Allow explicit '-lperl' in link arguments"
+   From:  Doug MacEachern <dougm@opengroup.org>
+ Msg-ID:  <199702271625.LAA25402@postman.osf.org>
+   Date:  Thu, 27 Feb 1997 11:25:04 -0500
+  Files:  lib/ExtUtils/Embed.pm
+
+ TESTS
+
+  Title:  "New test op/taint.t"
+   From:  Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID:  <Pine.GSO.3.95q.970225101328.18288M-100000@kelly.teleport.com
+   Date:  Tue, 25 Feb 1997 11:36:53 -0800 (PST)
+  Files:  MANIFEST t/op/taint.t
+
+  Title:  "Patch to t/op/rand.t"
+   From:  Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID:  <Pine.GSO.3.95q.970225181321.13796Q-100000@kelly.teleport.com
+   Date:  Tue, 25 Feb 1997 18:19:34 -0800 (PST)
+  Files:  t/op/rand.t
+
+ UTILITIES
+
+  Title:  "Add --lax option to pod2man; use it in perldoc"
+   From:  Nat <gnat@frii.com>, Chip Salzenberg
+  Files:  pod/pod2man.PL utils/perldoc.PL
+
+  Title:  "Eliminate dead code in pod2man"
+   From:  Chip Salzenberg
+  Files:  pod/pod2man.PL
+
+ DOCUMENTATION
+
+  Title:  "Warn about intrusive sfio behavior"
+   From:  Andy Dougherty <doughera@fractal.phys.lafayette.edu>
+ Msg-ID:  <Pine.SOL.3.95q.970228112136.24038G-100000@fractal.lafayette.
+   Date:  Fri, 28 Feb 1997 11:35:49 -0500 (EST)
+  Files:  INSTALL
+
+  Title:  "Updates to perlfunc.pod"
+   From:  Tom Phoenix (with help from M.J.T. Guy and Tom C.)
+  Files:  pod/perlfunc.pod
+
+  Title:  "Move ENVIRONMENT from perl.pod to perlrun.pod"
+   From:  Chip Salzenberg
+  Files:  pod/perl.pod pod/perlrun.pod
+
+  Title:  "Describe PERL_DEBUG_MSTATS in perlrun.pod"
+   From:  Nat <gnat@frii.com>
+  Files:  pod/perlrun.pod
+
+  Title:  "Fix references to perlbug"
+   From:  Chip Salzenberg
+  Files:  pod/perl.pod pod/perldelta.pod pod/perllocale.pod
+          pod/perltoc.pod
+
+
 ----------------
 Version 5.003_90
 ----------------
index a6e202c..6767793 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -3771,8 +3771,8 @@ rmlist="$rmlist pdp11"
 
 : coherency check
 echo " "
-echo "Checking your choice of C compiler and flags for coherency..." >&4
-set X $cc $optimize $ccflags $ldflags try.c -o try
+echo "Checking your choice of C compiler, libs, and flags for coherency..." >&4
+set X $cc $optimize $ccflags $ldflags -o try try.c $libs
 shift
 $cat >try.msg <<EOM
 I've tried to compile and run a simple program with:
@@ -3788,7 +3788,7 @@ $cat > try.c <<'EOF'
 main() { exit(0); }
 EOF
 dflt=y
-if sh -c "$cc $optimize $ccflags try.c -o try $ldflags" >>try.msg 2>&1; then
+if sh -c "$cc $optimize $ccflags -o try try.c $ldflags $libs" >>try.msg 2>&1; then
        if sh -c './try' >>try.msg 2>&1; then
                dflt=n
        else
@@ -3894,11 +3894,13 @@ esac
 : nm options which may be necessary
 case "$nm_opt" in
 '') if $test -f /mach_boot; then
-               nm_opt=''
+               nm_opt=''       # Mach
        elif $test -d /usr/ccs/lib; then
-               nm_opt='-p'
+               nm_opt='-p'     # Solaris (and SunOS?)
        elif $test -f /dgux; then
-               nm_opt='-p'
+               nm_opt='-p'     # DG-UX
+       elif $test -x /lib64/rld; then
+               nm_opt='-p'     # 64-bit Irix
        else
                nm_opt=''
        fi;;
@@ -4118,6 +4120,10 @@ elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\
        eval $xscan;\
        $contains '^fprintf$' libc.list >/dev/null 2>&1; then
                eval $xrun
+elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\
+       eval $xscan;\
+       $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+               eval $xrun
 elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\
        eval $xscan;\
        $contains '^fprintf$' libc.list >/dev/null 2>&1; then
@@ -8573,6 +8579,7 @@ main()
        for (i = 0; max; i++)
                max /= 2;
        printf("%d\n",i);
+       fflush(stdout);
 }
 EOCP
        if $cc $ccflags $ldflags -o try try.c $libs >/dev/null 2>&1 ; then
index 29657cb..8b0b497 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -684,6 +684,7 @@ t/op/recurse.t              See if deep recursion works
 t/op/ref.t             See if refs and objects work
 t/op/regexp.t          See if regular expressions work
 t/op/repeat.t          See if x operator works
+t/op/runlevel.t                See if die() works from perl_call_*()
 t/op/sleep.t           See if sleep works
 t/op/sort.t            See if sort works
 t/op/split.t           See if split works
@@ -693,6 +694,7 @@ t/op/study.t                See if study works
 t/op/subst.t           See if substitution works
 t/op/substr.t          See if substr works
 t/op/sysio.t           See if sysread and syswrite work
+t/op/taint.t           See if tainting works
 t/op/tie.t             See if tie/untie functions work
 t/op/time.t            See if time functions work
 t/op/undef.t           See if undef works
index 30af30d..e101147 100755 (executable)
--- a/configure
+++ b/configure
@@ -27,7 +27,7 @@ case "$0" in
     if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then
        echo "Your configure and Configure scripts seem to be identical."
        echo "This can happen on filesystems that aren't fully case sensitive."
-       echo "You'll have to explicitely extract Configure and run that."
+       echo "You'll have to explicitly extract Configure and run that."
        exit 1
     fi
     ;;
index 98876cc..fa46532 100755 (executable)
@@ -27,7 +27,7 @@ case "$0" in
     if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then
        echo "Your configure and Configure scripts seem to be identical."
        echo "This can happen on filesystems that aren't fully case sensitive."
-       echo "You'll have to explicitely extract Configure and run that."
+       echo "You'll have to explicitly extract Configure and run that."
        exit 1
     fi
     ;;
diff --git a/doio.c b/doio.c
index 0db0e1a..f2973d1 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -584,8 +584,8 @@ IO* io;
     if (IoIFP(io)) {
        if (IoTYPE(io) == '|') {
            status = my_pclose(IoIFP(io));
-           retval = (status == 0);
            STATUS_NATIVE_SET(status);
+           retval = (STATUS_POSIX == 0);
        }
        else if (IoTYPE(io) == '-')
            retval = TRUE;
diff --git a/embed.h b/embed.h
index 88aa929..faa9225 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define minus_n                        (curinterp->Iminus_n)
 #define minus_p                        (curinterp->Iminus_p)
 #define multiline              (curinterp->Imultiline)
+#define mustcatch              (curinterp->Imustcatch)
 #define mystack_base           (curinterp->Imystack_base)
 #define mystack_mark           (curinterp->Imystack_mark)
 #define mystack_max            (curinterp->Imystack_max)
 #define Iminus_n               minus_n
 #define Iminus_p               minus_p
 #define Imultiline             multiline
+#define Imustcatch             mustcatch
 #define Imystack_base          mystack_base
 #define Imystack_mark          mystack_mark
 #define Imystack_max           mystack_max
 #define minus_n                        Perl_minus_n
 #define minus_p                        Perl_minus_p
 #define multiline              Perl_multiline
+#define mustcatch              Perl_mustcatch
 #define mystack_base           Perl_mystack_base
 #define mystack_mark           Perl_mystack_mark
 #define mystack_max            Perl_mystack_max
diff --git a/gv.c b/gv.c
index 62afd91..67b2600 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1284,12 +1284,14 @@ int flags;
     dSP;
     BINOP myop;
     SV* res;
+    bool oldmustcatch = mustcatch;
 
     Zero(&myop, 1, BINOP);
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
     myop.op_flags = OPf_KNOW|OPf_STACKED;
 
+    mustcatch = TRUE;
     ENTER;
     SAVESPTR(op);
     op = (OP *) &myop;
@@ -1315,6 +1317,7 @@ int flags;
 
     res=POPs;
     PUTBACK;
+    mustcatch = oldmustcatch;
 
     if (postpr) {
       int ans;
diff --git a/hv.c b/hv.c
index 1ae7ad9..bcf5b96 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -135,9 +135,9 @@ I32 lval;
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
       char *gotenv;
 
-      gotenv = ENV_getenv(key);
-      if (gotenv != NULL) {
+      if ((gotenv = ENV_getenv(key)) != Nullch) {
         sv = newSVpv(gotenv,strlen(gotenv));
+        SvTAINTED_on(sv);
         return hv_store(hv,key,klen,sv,hash);
       }
     }
@@ -177,7 +177,6 @@ register U32 hash;
            char *k;
            New(54, k, HEK_BASESIZE + sizeof(SV*), char);
            HeKEY_hek(&mh) = (HEK*)k;
-           HeKLEN(&mh) = HEf_SVKEY;    /* key will always hold an SV* */
        }
        HeSVKEY_set(&mh, keysv);
        HeVAL(&mh) = sv;
@@ -215,9 +214,9 @@ register U32 hash;
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
       char *gotenv;
 
-      gotenv = ENV_getenv(key);
-      if (gotenv != NULL) {
+      if ((gotenv = ENV_getenv(key)) != Nullch) {
         sv = newSVpv(gotenv,strlen(gotenv));
+        SvTAINTED_on(sv);
         return hv_store_ent(hv,keysv,sv,hash);
       }
     }
@@ -316,8 +315,12 @@ register U32 hash;
 
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
+       bool save_taint = tainted;
+       if (tainting)
+           tainted = SvTAINTED(keysv);
        keysv = sv_2mortal(newSVsv(keysv));
        mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+       TAINT_IF(save_taint);
        if (!xhv->xhv_array
            && (SvMAGIC(hv)->mg_moremagic
                || (SvMAGIC(hv)->mg_type != 'E'
diff --git a/hv.h b/hv.h
index 7c04cc2..a51a0ba 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -95,9 +95,11 @@ struct xpvhv {
 #define HeKLEN(he)             HEK_LEN(HeKEY_hek(he))
 #define HeVAL(he)              (he)->hent_val
 #define HeHASH(he)             HEK_HASH(HeKEY_hek(he))
-#define HePV(he)               ((HeKLEN(he) == HEf_SVKEY) ?            \
-                                SvPV(HeKEY_sv(he),na) :                \
-                                HeKEY(he))
+#define HePV(he,lp)            ((HeKLEN(he) == HEf_SVKEY) ?            \
+                                SvPV(HeKEY_sv(he),lp) :                \
+                                (((lp = HeKLEN(he)) >= 0) ?            \
+                                 HeKEY(he) : Nullch))
+
 #define HeSVKEY(he)            ((HeKEY(he) &&                          \
                                  HeKLEN(he) == HEf_SVKEY) ?            \
                                 HeKEY_sv(he) : Nullsv)
@@ -108,7 +110,7 @@ struct xpvhv {
                                  sv_2mortal(newSVpv(HeKEY(he),         \
                                                     HeKLEN(he)))) :    \
                                 &sv_undef)
-#define HeSVKEY_set(he,sv)     (HeKEY_sv(he) = sv)
+#define HeSVKEY_set(he,sv)     ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv))
 
 #define Nullhek Null(HEK*)
 #define HEK_BASESIZE           STRUCT_OFFSET(HEK, hek_key[0])
index ec9c038..a82c2c4 100644 (file)
@@ -85,6 +85,7 @@ minus_l
 minus_n
 minus_p
 multiline
+mustcatch
 mystack_base
 mystack_mark
 mystack_max
diff --git a/mg.c b/mg.c
index 318b7fe..04fccaf 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -585,37 +585,76 @@ MAGIC* mg;
     char *ptr;
     STRLEN len;
     I32 i;
+
     s = SvPV(sv,len);
     ptr = MgPV(mg);
     my_setenv(ptr, s);
+
 #ifdef DYNAMIC_ENV_FETCH
      /* We just undefd an environment var.  Is a replacement */
      /* waiting in the wings? */
     if (!len) {
        HE *envhe;
        SV *keysv;
-       if (mg->mg_len == HEf_SVKEY) keysv = (SV *)mg->mg_ptr;
-       else keysv = newSVpv(mg->mg_ptr,mg->mg_len);
-       if (envhe = hv_fetch_ent(GvHVn(envgv),keysv,FALSE,0))
-           s = SvPV(HeVAL(envhe),len);
-       if (mg->mg_len != HEf_SVKEY) SvREFCNT_dec(keysv);
+       if (mg->mg_len == HEf_SVKEY)
+           keysv = (SV *)mg->mg_ptr;
+       else
+           keysv = newSVpv(mg->mg_ptr, mg->mg_len);
+       if ((envhe = hv_fetch_ent(GvHVn(envgv), keysv, FALSE, 0)))
+           s = SvPV(HeVAL(envhe), len);
+       if (mg->mg_len != HEf_SVKEY)
+           SvREFCNT_dec(keysv);
     }
 #endif
+
+#if !defined(OS2) && !defined(AMIGAOS)
                            /* And you'll never guess what the dog had */
                            /*   in its mouth... */
     if (tainting) {
+       MgTAINTEDDIR_off(mg);
+#ifdef VMS
+       if (s && strnEQ(ptr, "DCL$PATH", 8)) {
+           char pathbuf[256], eltbuf[256], *cp, *elt = s;
+           struct stat sbuf;
+           int i = 0, j = 0;
+
+           do {          /* DCL$PATH may be a search list */
+               while (1) {   /* as may dev portion of any element */
+                   if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
+                       if ( *(cp+1) == '.' || *(cp+1) == '-' ||
+                            cando_by_name(S_IWUSR,0,elt) ) {
+                           MgTAINTEDDIR_on(mg);
+                           return 0;
+                       }
+                   }
+                   if ((cp = strchr(elt, ':')) != Nullch)
+                       *cp = '\0';
+                   if (my_trnlnm(elt, eltbuf, j++))
+                       elt = eltbuf;
+                   else
+                       break;
+               }
+               j = 0;
+           } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
+       }
+#endif /* VMS */
        if (s && strEQ(ptr,"PATH")) {
            char *strend = s + len;
 
            while (s < strend) {
-               s = cpytill(tokenbuf,s,strend,':',&i);
+               struct stat st;
+               s = cpytill(tokenbuf, s, strend, ':', &i);
                s++;
                if (*tokenbuf != '/'
-                 || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
+                     || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
                    MgTAINTEDDIR_on(mg);
+                   return 0;
+               }
            }
        }
     }
+#endif /* neither OS2 nor AMIGAOS */
+
     return 0;
 }
 
diff --git a/mg.h b/mg.h
index 8fbda82..416eceb 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -32,8 +32,9 @@ struct magic {
 
 #define MGf_MINMATCH   1
 
-#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
-#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+#define MgTAINTEDDIR(mg)       (mg->mg_flags & MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_on(mg)    (mg->mg_flags |= MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_off(mg)   (mg->mg_flags &= ~MGf_TAINTEDDIR)
 
 #define MgPV(mg)                ((mg)->mg_len == HEf_SVKEY) ?   \
                                 SvPV((SV*)((mg)->mg_ptr),na) :   \
index 47ca5dd..0d6595b 100644 (file)
@@ -1,5 +1,5 @@
 #define PATCHLEVEL 3
-#define SUBVERSION 90
+#define SUBVERSION 91
 
 /*
        local_patches -- list of locally applied less-than-subversion patches.
diff --git a/perl.c b/perl.c
index a93ff71..e3dd3f7 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -496,6 +496,7 @@ setuid perl scripts securely.\n");
     main_cv = Nullcv;
 
     time(&basetime);
+    mustcatch = FALSE;
 
     switch (Sigsetjmp(top_env,1)) {
     case 1:
@@ -508,6 +509,7 @@ setuid perl scripts securely.\n");
            calllist(endav);
        return STATUS_NATIVE_EXPORT;
     case 3:
+       mustcatch = FALSE;
        PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
        return 1;
     }
@@ -799,6 +801,7 @@ PerlInterpreter *sv_interp;
 #endif
        return STATUS_NATIVE_EXPORT;
     case 3:
+       mustcatch = FALSE;
        if (!restartop) {
            PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
            FREETMPS;
@@ -953,7 +956,8 @@ I32 flags;          /* See G_* flags in cop.h */
     Sigjmp_buf oldtop;
     I32 oldscope;
     static CV *DBcv;
-    
+    bool oldmustcatch = mustcatch;
+
     if (flags & G_DISCARD) {
        ENTER;
        SAVETMPS;
@@ -1028,6 +1032,7 @@ I32 flags;                /* See G_* flags in cop.h */
            my_exit_jump();
            /* NOTREACHED */
        case 3:
+           mustcatch = FALSE;
            if (restartop) {
                op = restartop;
                restartop = 0;
@@ -1043,6 +1048,8 @@ I32 flags;                /* See G_* flags in cop.h */
            goto cleanup;
        }
     }
+    else
+       mustcatch = TRUE;
 
     if (op == (OP*)&myop)
        op = pp_entersub();
@@ -1069,6 +1076,9 @@ I32 flags;                /* See G_* flags in cop.h */
        }
        Copy(oldtop, top_env, 1, Sigjmp_buf);
     }
+    else
+       mustcatch = oldmustcatch;
+
     if (flags & G_DISCARD) {
        stack_sp = stack_base + oldmark;
        retval = 0;
@@ -1133,6 +1143,7 @@ restart:
        my_exit_jump();
        /* NOTREACHED */
     case 3:
+       mustcatch = FALSE;
        if (restartop) {
            op = restartop;
            restartop = 0;
@@ -2252,7 +2263,7 @@ register char **env;
     }
     TAINT_NOT;
     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
-       sv_setiv(GvSV(tmpgv),(I32)getpid());
+       sv_setiv(GvSV(tmpgv), (IV)getpid());
 }
 
 static void
diff --git a/perl.h b/perl.h
index d62c035..1ca2c2b 100644 (file)
--- a/perl.h
+++ b/perl.h
 
 #define MEM_SIZE Size_t
 
+#if _XOPEN_VERSION >= 4
+#   define Sock_size_t Size_t
+#else
+#   define Sock_size_t int
+#endif
+
 #if defined(STANDARD_C) && defined(I_STDDEF)
 #   include <stddef.h>
 #   define STRUCT_OFFSET(s,m)  offsetof(s,m)
@@ -1211,7 +1217,9 @@ char *crypt ();       /* Maybe more hosts will need the unprototyped version */
 #else
 char *crypt _((const char*, const char*));
 #endif
+#ifndef getenv
 char *getenv _((const char*));
+#endif
 Off_t lseek _((int,Off_t,int));
 char *getlogin _((void));
 #endif
@@ -1827,6 +1835,7 @@ IEXT I32  Icxstack_ix IINIT(-1);
 IEXT I32       Icxstack_max IINIT(128);
 IEXT Sigjmp_buf        Itop_env;
 IEXT I32       Irunlevel;
+IEXT bool      Imustcatch;     /* doeval() must be caught locally */
 
 /* stack stuff */
 IEXT AV *      Icurstack;              /* THE STACK */
index 4d4407e..96639c3 100644 (file)
@@ -1 +1 @@
-p9pvers = 5.003_90
+p9pvers = 5.003_91
index e306037..99f996f 100644 (file)
@@ -42,7 +42,6 @@ of sections:
     perlbot    Perl OO tricks and examples
     perlipc    Perl interprocess communication
 
-    perlbug    Perl bug reports howto
     perldebug  Perl debugging
     perldiag   Perl diagnostic messages
     perlsec    Perl security
@@ -224,64 +223,7 @@ Ok, that's I<definitely> enough hype.
 
 =head1 ENVIRONMENT
 
-=over 12
-
-=item HOME
-
-Used if chdir has no argument.
-
-=item LOGDIR
-
-Used if chdir has no argument and HOME is not set.
-
-=item PATH
-
-Used in executing subprocesses, and in finding the script if B<-S> is
-used.
-
-=item PERL5LIB
-
-A colon-separated list of directories in which to look for Perl library
-files before looking in the standard library and the current
-directory.  If PERL5LIB is not defined, PERLLIB is used.  When running
-taint checks (because the script was running setuid or setgid, or the
-B<-T> switch was used), neither variable is used.  The script should
-instead say
-
-    use lib "/my/directory";
-
-=item PERL5DB
-
-The command used to get the debugger code.  If unset, uses
-
-       BEGIN { require 'perl5db.pl' }
-
-=item PERL_DESTRUCT_LEVEL
-
-Relevant only if your perl executable was built with B<-DDEBUGGING>,
-this controls the behavior of global destruction of objects and other
-references.
-
-=item PERLLIB
-
-A colon-separated list of directories in which to look for Perl library
-files before looking in the standard library and the current
-directory.  If PERL5LIB is defined, PERLLIB is not used.
-
-=back
-
-Perl also has environment variables that control how Perl handles data
-specific to particular natural languages.  See L<perllocale>.
-
-Apart from these, Perl uses no other environment variables, except
-to make them available to the script being executed, and to child
-processes.  However, scripts running setuid would do well to execute
-the following lines before doing anything else, just to keep people
-honest:
-
-    $ENV{'PATH'} = '/bin:/usr/bin';    # or whatever you need
-    $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
-    $ENV{'IFS'} = ''          if defined $ENV{'IFS'};
+See L<perlrun>.
 
 =head1 AUTHOR
 
index 23f216f..bfdf903 100644 (file)
@@ -671,6 +671,17 @@ C<perl_call_sv> is Perl's producing an "Undefined subroutine called"
 error on the I<second> call to a given method (since there is no cache
 on the first call).
 
+=item Extended API for manipulating hashes
+
+Internal handling of hash keys has changed.  The old hashtable API is
+still fully supported, and will likely remain so.  The additions to the
+API allow passing keys as C<SV*>s, so that C<tied> hashes can be given
+real scalars as keys rather than plain strings (non-tied hashes still
+can only use strings as keys).  New extensions must use the new hash
+access functions and macros if they wish to use C<SV*> keys.  These
+additions also make it feasible to manipulate C<HE*>s (hash entries),
+which can be more efficient.  See L<perlguts> for details.
+
 =back
 
 =head1 Documentation Changes
@@ -680,10 +691,6 @@ new pods are included in section 1:
 
 =over
 
-=item L<perlbug>
-
-A "howto" on reporting perl bugs.
-
 =item L<perldelta>
 
 This document.
@@ -1023,7 +1030,7 @@ Home Page.
 If you believe you have an unreported bug, please run the B<perlbug>
 program included with your release.  Make sure you trim your bug
 down to a tiny but sufficient test case.  Your bug report, along
-with the output of C<perl -V>, will be sent off to perlbug@perl.com
+with the output of C<perl -V>, will be sent off to F<perlbug@perl.com>
 to be analysed by the Perl porting team.
 
 =head1 SEE ALSO
index 77acc98..95bd4ec 100644 (file)
@@ -322,6 +322,48 @@ The hash algorithm is defined in the C<PERL_HASH(hash, key, klen)> macro:
     while (i--)
        hash = hash * 33 + *s++;
 
+=head2 Hash API Extensions
+
+Beginning with version 5.004, the following functions are also supported:
+
+    HE*     hv_fetch_ent  (HV* tb, SV* key, I32 lval, U32 hash);
+    HE*     hv_store_ent  (HV* tb, SV* key, SV* val, U32 hash);
+    
+    bool    hv_exists_ent (HV* tb, SV* key, U32 hash);
+    SV*     hv_delete_ent (HV* tb, SV* key, I32 flags, U32 hash);
+    
+    SV*     hv_iterkeysv  (HE* entry);
+
+Note that these functions take C<SV*> keys, which simplifies writing
+of extension code that deals with hash structures.  These functions
+also allow passing of C<SV*> keys to C<tie> functions without forcing
+you to stringify the keys (unlike the previous set of functions).
+
+They also return and accept whole hash entries (C<HE*>), making their
+use more efficient (since the hash number for a particular string
+doesn't have to be recomputed every time).  See L<API LISTING> later in
+this document for detailed descriptions.
+
+The following macros must always be used to access the contents of hash
+entries.  Note that the arguments to these macros must be simple
+variables, since they may get evaluated more than once.  See
+L<API LISTING> later in this document for detailed descriptions of these
+macros.
+
+    HePV(HE* he, STRLEN len)
+    HeVAL(HE* he)
+    HeHASH(HE* he)
+    HeSVKEY(HE* he)
+    HeSVKEY_force(HE* he)
+    HeSVKEY_set(HE* he, SV* sv)
+
+These two lower level macros are defined, but must only be used when
+dealing with keys that are not C<SV*>s:
+
+    HeKEY(HE* he)
+    HeKLEN(HE* he)
+
+
 =head2 References
 
 References are a special type of scalar that point to other data types
@@ -1392,6 +1434,12 @@ statement (or thereabouts) with C<sv_2mortal>.  See C<hv_iternext>.
 
        void    he_delayfree _((HV* hv, HE* hent));
 
+=item HEf_SVKEY
+
+This flag, used in the length slot of hash entries and magic
+structures, specifies the structure contains a C<SV*> pointer where a
+C<char*> pointer is to be expected. (For information only--not to be used).
+
 =item he_free
 
 Releases a hash entry, such as while iterating though the hash.  See
@@ -1399,6 +1447,71 @@ C<hv_iternext>.
 
        void    he_free _((HV* hv, HE* hent));
 
+=item HeHASH
+
+Returns the computed hash (type C<U32>) stored in the hash entry.
+
+       HeHASH(HE* he)
+
+=item HeKEY
+
+Returns the actual pointer stored in the key slot of the hash entry.
+The pointer may be either C<char*> or C<SV*>, depending on the value of
+C<HeKLEN()>.  Can be assigned to.  The C<HePV()> or C<HeSVKEY()> macros
+are usually preferable for finding the value of a key.
+
+       HeKEY(HE* he)
+
+=item HeKLEN
+
+If this is negative, and amounts to C<HEf_SVKEY>, it indicates the entry
+holds an C<SV*> key.  Otherwise, holds the actual length of the key.
+Can be assigned to. The C<HePV()> macro is usually preferable for finding
+key lengths.
+
+       HeKLEN(HE* he)
+
+=item HePV
+
+Returns the key slot of the hash entry as a C<char*> value, doing any
+necessary dereferencing of possibly C<SV*> keys.  The length of
+the string is placed in C<len> (this is a macro, so do I<not> use
+C<&len>).  If you do not care about what the length of the key is,
+you may use the global variable C<na>.  Remember though, that hash
+keys in perl are free to contain embedded nulls, so using C<strlen()>
+or similar is not a good way to find the length of hash keys.
+This is very similar to the C<SvPV()> macro described elsewhere in
+this document.
+
+       HePV(HE* he, STRLEN len)
+
+=item HeSVKEY
+
+Returns the key as an C<SV*>, or C<Nullsv> if the hash entry
+does not contain an C<SV*> key.
+
+       HeSVKEY(HE* he)
+
+=item HeSVKEY_force
+
+Returns the key as an C<SV*>.  Will create and return a temporary
+mortal C<SV*> if the hash entry contains only a C<char*> key.
+
+       HeSVKEY_force(HE* he)
+
+=item HeSVKEY_set
+
+Sets the key to a given C<SV*>, taking care to set the appropriate flags
+to indicate the presence of an C<SV*> key, and returns the same C<SV*>.
+
+       HeSVKEY_set(HE* he, SV* sv)
+
+=item HeVAL
+
+Returns the value slot (type C<SV*>) stored in the hash entry.
+
+       HeVAL(HE* he)
+
 =item hv_clear
 
 Clears a hash, making it empty.
@@ -1414,6 +1527,15 @@ returned.
 
        SV*     hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
 
+=item hv_delete_ent
+
+Deletes a key/value pair in the hash.  The value SV is removed from the hash
+and returned to the caller.  The C<flags> value will normally be zero; if set
+to G_DISCARD then null will be returned.  C<hash> can be a valid pre-computed
+hash value, or 0 to ask for it to be computed.
+
+       SV*     hv_delete_ent _((HV* tb, SV* key, I32 flags, U32 hash));
+
 =item hv_exists
 
 Returns a boolean indicating whether the specified hash key exists.  The
@@ -1421,6 +1543,13 @@ C<klen> is the length of the key.
 
        bool    hv_exists _((HV* tb, char* key, U32 klen));
 
+=item hv_exists_ent
+
+Returns a boolean indicating whether the specified hash key exists. C<hash>
+can be a valid pre-computed hash value, or 0 to ask for it to be computed.
+
+       bool    hv_exists_ent _((HV* tb, SV* key, U32 hash));
+
 =item hv_fetch
 
 Returns the SV which corresponds to the specified key in the hash.  The
@@ -1430,6 +1559,18 @@ dereferencing it to a C<SV*>.
 
        SV**    hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
 
+=item hv_fetch_ent
+
+Returns the hash entry which corresponds to the specified key in the hash.
+C<hash> must be a valid pre-computed hash number for the given C<key>, or
+0 if you want the function to compute it.  IF C<lval> is set then the
+fetch will be part of a store.  Make sure the return value is non-null
+before accessing it.  The return value when C<tb> is a tied hash
+is a pointer to a static location, so be sure to make a copy of the
+structure if you need to store it somewhere.
+
+       HE*     hv_fetch_ent  _((HV* tb, SV* key, I32 lval, U32 hash));
+
 =item hv_iterinit
 
 Prepares a starting point to traverse a hash table.
@@ -1443,6 +1584,14 @@ C<hv_iterinit>.
 
        char*   hv_iterkey _((HE* entry, I32* retlen));
 
+=item hv_iterkeysv
+       
+Returns the key as an C<SV*> from the current position of the hash
+iterator.  The return value will always be a mortal copy of the
+key.  Also see C<hv_iterinit>.
+
+       SV*     hv_iterkeysv  _((HE* entry));
+
 =item hv_iternext
 
 Returns entries from a hash iterator.  See C<hv_iterinit>.
@@ -1485,6 +1634,17 @@ original C<SV*>.
 
        SV**    hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash));
 
+=item hv_store_ent
+
+Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
+parameter is the pre-computed hash value; if it is zero then Perl will
+compute it.  The return value is the new hash entry so created.  It will be
+null if the operation failed or if the entry was stored in a tied hash.
+Otherwise the contents of the return value can be accessed using the
+C<He???> macros described here.
+
+       HE*     hv_store_ent  _((HV* tb, SV* key, SV* val, U32 hash));
+
 =item hv_undef
 
 Undefines the hash.
@@ -2748,4 +2908,4 @@ API Listing by Dean Roehrich <roehrich@cray.com>.
 
 =head1 DATE
 
-Version 31: 1997/1/27
+Version 31.1: 1997/2/25
index 41a0bc5..1513867 100644 (file)
@@ -778,7 +778,7 @@ In certain system environments the operating system's locale support
 is broken and cannot be fixed or used by Perl.  Such deficiencies can
 and will result in mysterious hangs and/or Perl core dumps when the
 C<use locale> is in effect.  When confronted with such a system,
-please report in excruciating detail to C<perlbug@perl.com>, and
+please report in excruciating detail to F<perlbug@perl.com>, and
 complain to your vendor: maybe some bug fixes exist for these problems
 in your operating system.  Sometimes such bug fixes are called an
 operating system upgrade.
index df606bf..f90e642 100644 (file)
@@ -439,5 +439,73 @@ terminated with C<__END__> if there is trailing garbage to be ignored (the
 script can process any or all of the trailing garbage via the DATA
 filehandle if desired).
 
+=back
+
+=head1 ENVIRONMENT
+
+=over 12
+
+=item HOME
+
+Used if chdir has no argument.
+
+=item LOGDIR
+
+Used if chdir has no argument and HOME is not set.
+
+=item PATH
+
+Used in executing subprocesses, and in finding the script if B<-S> is
+used.
+
+=item PERL5LIB
+
+A colon-separated list of directories in which to look for Perl library
+files before looking in the standard library and the current
+directory.  If PERL5LIB is not defined, PERLLIB is used.  When running
+taint checks (because the script was running setuid or setgid, or the
+B<-T> switch was used), neither variable is used.  The script should
+instead say
+
+    use lib "/my/directory";
+
+=item PERLLIB
+
+A colon-separated list of directories in which to look for Perl library
+files before looking in the standard library and the current directory.
+If PERL5LIB is defined, PERLLIB is not used.
+
+=item PERL5DB
+
+The command used to load the debugger code.  The default is:
+
+       BEGIN { require 'perl5db.pl' }
+
+=item PERL_DEBUG_MSTATS
+
+Relevant only if your perl executable was built with B<-DDEBUGGING_MSTATS>,
+if set, this causes memory statistics to be dumped after execution.  If set
+to an integer greater than one, also causes memory statistics to be dumped
+after compilation.
+
+=item PERL_DESTRUCT_LEVEL
+
+Relevant only if your perl executable was built with B<-DDEBUGGING>,
+this controls the behavior of global destruction of objects and other
+references.
 
 =back
+
+Perl also has environment variables that control how Perl handles data
+specific to particular natural languages.  See L<perllocale>.
+
+Apart from these, Perl uses no other environment variables, except
+to make them available to the script being executed, and to child
+processes.  However, scripts running setuid would do well to execute
+the following lines before doing anything else, just to keep people
+honest:
+
+    $ENV{'PATH'} = '/bin:/usr/bin';    # or whatever you need
+    $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
+    $ENV{'IFS'} = ''          if defined $ENV{'IFS'};
+
index 3e44e5b..6089431 100644 (file)
@@ -20,10 +20,11 @@ mode explicitly by using the B<-T> command line flag. This flag is
 I<strongly> suggested for server programs and any program run on behalf of
 someone else, such as a CGI script.
 
-While in this mode, Perl takes special precautions called I<taint checks> to
-prevent both obvious and subtle traps.  Some of these checks are reasonably
-simple, such as not blindly using the PATH inherited from one's parent
-process.  Other checks, however, are best supported by the language itself,
+While in this mode, Perl takes special precautions called I<taint
+checks> to prevent both obvious and subtle traps.  Some of these checks
+are reasonably simple, such as verifying that path directories aren't
+writable by others; careful programmers have always used checks like
+these.  Other checks, however, are best supported by the language itself,
 and it is these checks especially that contribute to making a setuid Perl
 program more secure than the corresponding C program.
 
@@ -155,13 +156,15 @@ UNIX-like environments that support #! and setuid or setgid scripts.)
 =head2 Cleaning Up Your Path
 
 For "Insecure C<$ENV{PATH}>" messages, you need to set C<$ENV{'PATH'}> to a
-known value.  You may be surprised to get this message even if the pathname
-to your executable is fully qualified.  This is I<not> generated because you
-didn't supply a full path to the program; instead, it's generated because
-you never set your PATH environment variable.  Because Perl can't guarantee
-that the executable in question isn't itself going to turn around and
-execute some other program that is dependent on your PATH, it makes sure you
-set the PATH.
+known value, and each directory in the path must be non-writable by others
+than its owner and group.  You may be surprised to get this message even
+if the pathname to your executable is fully qualified.  This is I<not>
+generated because you didn't supply a full path to the program; instead,
+it's generated because you never set your PATH environment variable, or
+you didn't set it to something that was safe.  Because Perl can't
+guarantee that the executable in question isn't itself going to turn
+around and execute some other program that is dependent on your PATH, it
+makes sure you set the PATH.  
 
 It's also possible to get into trouble with other operations that don't
 care whether they use tainted values.  Make judicious use of the file
index 01a03f3..551f444 100644 (file)
@@ -26,8 +26,6 @@ expression enhancements, Innumerable Unbundled Modules, Compilability
 
 =item ENVIRONMENT
 
-HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERL_DESTRUCT_LEVEL, PERLLIB
-
 =item AUTHOR
 
 =item FILES
@@ -126,12 +124,12 @@ C<void> XSUBs now default to returning nothing
 
 =item C Language API Changes
 
-C<gv_fetchmethod> and C<perl_call_sv>
+C<gv_fetchmethod> and C<perl_call_sv>, Extended API for manipulating hashes
 
 =item Documentation Changes
 
-L<perlbug>, L<perldelta>, L<perllocale>, L<perltoot>, L<perlapio>,
-L<perldebug>, L<perlsec>
+L<perldelta>, L<perllocale>, L<perltoot>, L<perlapio>, L<perldebug>,
+L<perlsec>
 
 =item New Diagnostics
 
@@ -323,6 +321,11 @@ B<-T>, B<-u>, B<-U>, B<-v>, B<-V>, B<-V:>I<name>, B<-w>, B<-x> I<directory>
 
 =back
 
+=item ENVIRONMENT
+
+HOME, LOGDIR, PATH, PERL5LIB, PERLLIB, PERL5DB, PERL_DEBUG_MSTATS,
+PERL_DESTRUCT_LEVEL
+
 =head2 perlfunc - Perl builtin functions
 
 =item DESCRIPTION
@@ -1434,6 +1437,8 @@ B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)>
 
 =item Working with HV's
 
+=item Hash API Extensions
+
 =item References
 
 =item Blessed References and Class Objects
@@ -1501,35 +1506,41 @@ av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak, CvSTASH,
 DBsingle, DBsub, DBtrace, dMARK, dORIGMARK, dowarn, dSP, dXSARGS, dXSI32,
 dXSI32, ENTER, EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME,
 G_NOARGS, G_SCALAR, gv_fetchmeth, gv_fetchmethod, gv_stashpv, gv_stashsv,
-GvSV, he_delayfree, he_free, hv_clear, hv_delete, hv_exists, hv_fetch,
-hv_iterinit, hv_iterkey, hv_iternext, hv_iternextsv, hv_iterval, hv_magic,
-HvNAME, hv_store, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE,
-isUPPER, items, ix, LEAVE, MARK, mg_clear, mg_copy, mg_find, mg_free,
-mg_get, mg_len, mg_magical, mg_set, Move, na, New, Newc, Newz, newAV,
-newHV, newRV_inc, newRV_noinc, newSV, newSViv, newSVnv, newSVpv, newSVrv,
-newSVsv, newXS, newXSproto, Nullav, Nullch, Nullcv, Nullhv, Nullsv,
-ORIGMARK, perl_alloc, perl_call_argv, perl_call_method, perl_call_pv,
-perl_call_sv, perl_construct, perl_destruct, perl_eval_sv, perl_free,
-perl_get_av, perl_get_cv, perl_get_hv, perl_get_sv, perl_parse,
-perl_require_pv, perl_run, POPi, POPl, POPp, POPn, POPs, PUSHMARK, PUSHi,
-PUSHn, PUSHp, PUSHs, PUTBACK, Renew, Renewc, RETVAL, safefree, safemalloc,
-saferealloc, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE,
-strGT, strLE, strLT, strNE, strnEQ, strnNE, sv_2mortal, sv_bless, sv_catpv,
-sv_catpvn, sv_catsv, sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec, sv_dec,
-SvEND, sv_eq, SvGROW, sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on,
-SvIOK_only, SvIOK_only, SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN,
-sv_len, sv_len, sv_magic, sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK,
-SvNIOK_off, SvNIOKp, SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only,
-SvNOKp, SvNV, SvNVX, SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only,
-SvPOKp, SvPV, SvPVX, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK,
-SvROK_off, SvROK_on, SvRV, sv_setiv, sv_setnv, sv_setpv, sv_setpvn,
-sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, SvSTASH,
-SVt_IV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE,
-SvTYPE, svtype, SvUPGRADE, sv_upgrade, sv_undef, sv_unref, sv_usepvn,
-sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XS,
-XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV,
-XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNV, XST_mNO,
-XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero
+GvSV, he_delayfree, HEf_SVKEY, he_free, HeHASH, HeKEY, HeKLEN, HePV,
+HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, hv_clear, hv_delete,
+hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent,
+hv_iterinit, hv_iterkey, hv_iterkeysv   
+Returns the key as an C<SV*> from the current position of the hash
+iterator.  The return value will always be a mortal copy of the
+key.  Also see C<hv_iterinit>, hv_iternext, hv_iternextsv, hv_iterval,
+hv_magic, HvNAME, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA,
+isDIGIT, isLOWER, isSPACE, isUPPER, items, ix, LEAVE, MARK, mg_clear,
+mg_copy, mg_find, mg_free, mg_get, mg_len, mg_magical, mg_set, Move, na,
+New, Newc, Newz, newAV, newHV, newRV_inc, newRV_noinc, newSV, newSViv,
+newSVnv, newSVpv, newSVrv, newSVsv, newXS, newXSproto, Nullav, Nullch,
+Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc, perl_call_argv,
+perl_call_method, perl_call_pv, perl_call_sv, perl_construct,
+perl_destruct, perl_eval_sv, perl_free, perl_get_av, perl_get_cv,
+perl_get_hv, perl_get_sv, perl_parse, perl_require_pv, perl_run, POPi,
+POPl, POPp, POPn, POPs, PUSHMARK, PUSHi, PUSHn, PUSHp, PUSHs, PUTBACK,
+Renew, Renewc, RETVAL, safefree, safemalloc, saferealloc, savepv, savepvn,
+SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, strGT, strLE, strLT, strNE,
+strnEQ, strnNE, sv_2mortal, sv_bless, sv_catpv, sv_catpvn, sv_catsv,
+sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec, sv_dec, SvEND, sv_eq, SvGROW,
+sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on, SvIOK_only, SvIOK_only,
+SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN, sv_len, sv_len, sv_magic,
+sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK, SvNIOK_off, SvNIOKp,
+SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only, SvNOKp, SvNV, SvNVX,
+SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only, SvPOKp, SvPV, SvPVX,
+SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, SvROK_on, SvRV,
+sv_setiv, sv_setnv, sv_setpv, sv_setpvn, sv_setref_iv, sv_setref_nv,
+sv_setref_pv, sv_setref_pvn, sv_setsv, SvSTASH, SVt_IV, SVt_PV, SVt_PVAV,
+SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE, SvTYPE, svtype, SvUPGRADE,
+sv_upgrade, sv_undef, sv_unref, sv_usepvn, sv_yes, THIS, toLOWER, toUPPER,
+warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XS, XSRETURN, XSRETURN_EMPTY,
+XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF,
+XSRETURN_YES, XST_mIV, XST_mNV, XST_mNO, XST_mPV, XST_mUNDEF, XST_mYES,
+XS_VERSION, XS_VERSION_BOOTCHECK, Zero
 
 =item EDITOR
 
index 934d525..d1ba228 100644 (file)
@@ -46,6 +46,7 @@ B<pod2man>
 [ B<--date=>I<string> ]
 [ B<--fixed=>I<font> ]
 [ B<--official> ]
+[ B<--lax> ]
 I<inputfile>
 
 =head1 DESCRIPTION
@@ -105,6 +106,10 @@ best if you put your Perl man pages in a separate tree, like
 F</usr/local/perl/man/>.  By default, section 1 will be used
 unless the file ends in F<.pm> in which case section 3 will be selected.
 
+=item lax
+
+Don't complain when required sections aren't present.
+
 =back
 
 =head1 Anatomy of a Proper Man Page
@@ -329,6 +334,7 @@ $DEF_SECTION = 1;
 $DEF_CENTER = "User Contributed Perl Documentation";
 $STD_CENTER = "Perl Programmers Reference Guide";
 $DEF_FIXED = 'CW';
+$DEF_LAX = 0;
 
 sub usage {
     warn "$0: @_\n" if @_;
@@ -341,6 +347,7 @@ Options are:
        --date=string         (default "$DEF_DATE")
        --fixed=font          (default "$DEF_FIXED")
        --official            (default NOT)
+       --lax                 (default NOT)
 EOF
 }
 
@@ -351,6 +358,7 @@ $uok = GetOptions( qw(
        date=s
        fixed=s
        official
+       lax
        help));
 
 $DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
@@ -362,6 +370,7 @@ usage("Need one and only one podpage argument") unless @ARGV == 1;
 $section = $opt_section || ($ARGV[0] =~ /\.pm$/ ? 3 : $DEF_SECTION);
 $RP = $opt_release || $DEF_RELEASE;
 $center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER);
+$lax = $opt_lax || $DEF_LAX;
 
 $CFont = $opt_fixed || $DEF_FIXED;
 
@@ -410,9 +419,9 @@ if ($name ne 'something') {
                last FCHECK;
            }
            next if /^=cut\b/;  # DB_File and Net::Ping have =cut before NAME
-           die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n";
+           die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax;
        }
-       die "$0: Invalid man page - no documentation in $ARGV[0]\n";
+       die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
     }
     close F;
 }
@@ -861,7 +870,7 @@ print <<"END";
 .rn }` ''
 END
 
-if (%wanna_see) {
+if (%wanna_see && !$lax) {
     @missing = keys %wanna_see;
     warn "$0: $Filename is missing required section"
        .  (@missing > 1 && "s")
@@ -945,13 +954,7 @@ sub escapes {
 # make troff just be normal, but make small nroff get quoted
 # decided to just put the quotes in the text; sigh;
 sub ccvt {
-     local($_,$prev) = @_;
-     if ( /^\W+$/ && !/^\$./ ) {
-       ($prev && "\n") . noremap(qq{.CQ $_ \n\\&});
-       # what about $" ?
-     } else {
-       noremap(qq{${CFont_embed}$_\\fR});
-     }
+    local($_,$prev) = @_;
     noremap(qq{.CQ "$_" \n\\&});
 }
 
diff --git a/pp.c b/pp.c
index 62a01ec..c4f90ed 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -377,13 +377,12 @@ PP(pp_study)
     register I32 ch;
     register I32 *sfirst;
     register I32 *snext;
-    I32 retval;
     STRLEN len;
 
-    s = (unsigned char*)(SvPV(sv, len));
-    pos = len;
-    if (sv == lastscream)
-       SvSCREAM_off(sv);
+    if (sv == lastscream) {
+       if (SvSCREAM(sv))
+           RETPUSHYES;
+    }
     else {
        if (lastscream) {
            SvSCREAM_off(lastscream);
@@ -391,10 +390,11 @@ PP(pp_study)
        }
        lastscream = SvREFCNT_inc(sv);
     }
-    if (pos <= 0) {
-       retval = 0;
-       goto ret;
-    }
+
+    s = (unsigned char*)(SvPV(sv, len));
+    pos = len;
+    if (pos <= 0)
+       RETPUSHNO;
     if (pos > maxscream) {
        if (maxscream < 0) {
            maxscream = pos + 80;
@@ -428,10 +428,7 @@ PP(pp_study)
 
     SvSCREAM_on(sv);
     sv_magic(sv, Nullsv, 'g', Nullch, 0);      /* piggyback on m//g magic */
-    retval = 1;
-  ret:
-    XPUSHs(sv_2mortal(newSViv((I32)retval)));
-    RETURN;
+    RETPUSHYES;
 }
 
 PP(pp_trans)
@@ -555,7 +552,7 @@ PP(pp_undef)
            sv_setsv(sv, &sv_undef);
        break;
     default:
-       if (SvPOK(sv) && SvLEN(sv)) {
+       if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
            (void)SvOOK_off(sv);
            Safefree(SvPVX(sv));
            SvPV_set(sv, Nullch);
@@ -1631,7 +1628,7 @@ PP(pp_vec)
        }
     }
 
-    sv_setiv(TARG, (I32)retnum);
+    sv_setiv(TARG, (IV)retnum);
     PUSHs(TARG);
     RETURN;
 }
@@ -2741,7 +2738,7 @@ PP(pp_unpack)
                    if (aint >= 128)    /* fake up signed chars */
                        aint -= 256;
                    sv = NEWSV(36, 0);
-                   sv_setiv(sv, (I32)aint);
+                   sv_setiv(sv, (IV)aint);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2762,7 +2759,7 @@ PP(pp_unpack)
                while (len-- > 0) {
                    auint = *s++ & 255;
                    sv = NEWSV(37, 0);
-                   sv_setiv(sv, (I32)auint);
+                   sv_setiv(sv, (IV)auint);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2785,7 +2782,7 @@ PP(pp_unpack)
                    Copy(s, &ashort, 1, I16);
                    s += sizeof(I16);
                    sv = NEWSV(38, 0);
-                   sv_setiv(sv, (I32)ashort);
+                   sv_setiv(sv, (IV)ashort);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2826,7 +2823,7 @@ PP(pp_unpack)
                    if (datumtype == 'v')
                        aushort = vtohs(aushort);
 #endif
-                   sv_setiv(sv, (I32)aushort);
+                   sv_setiv(sv, (IV)aushort);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2852,7 +2849,7 @@ PP(pp_unpack)
                    Copy(s, &aint, 1, int);
                    s += sizeof(int);
                    sv = NEWSV(40, 0);
-                   sv_setiv(sv, (I32)aint);
+                   sv_setiv(sv, (IV)aint);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2878,10 +2875,7 @@ PP(pp_unpack)
                    Copy(s, &auint, 1, unsigned int);
                    s += sizeof(unsigned int);
                    sv = NEWSV(41, 0);
-                   if (auint <= I32_MAX)
-                       sv_setiv(sv, (I32)auint);
-                   else
-                       sv_setnv(sv, (double)auint);
+                   sv_setuv(sv, (UV)auint);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2907,7 +2901,7 @@ PP(pp_unpack)
                    Copy(s, &along, 1, I32);
                    s += sizeof(I32);
                    sv = NEWSV(42, 0);
-                   sv_setiv(sv, (I32)along);
+                   sv_setiv(sv, (IV)along);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -2942,7 +2936,6 @@ PP(pp_unpack)
                while (len-- > 0) {
                    Copy(s, &aulong, 1, U32);
                    s += sizeof(U32);
-                   sv = NEWSV(43, 0);
 #ifdef HAS_NTOHL
                    if (datumtype == 'N')
                        aulong = ntohl(aulong);
@@ -2951,7 +2944,8 @@ PP(pp_unpack)
                    if (datumtype == 'V')
                        aulong = vtohl(aulong);
 #endif
-                   sv_setnv(sv, (double)aulong);
+                   sv = NEWSV(43, 0);
+                   sv_setuv(sv, (UV)aulong);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -3058,7 +3052,7 @@ PP(pp_unpack)
                    s += sizeof(unsigned Quad_t);
                }
                sv = NEWSV(43, 0);
-               sv_setiv(sv, (IV)auquad);
+               sv_setuv(sv, (UV)auquad);
                PUSHs(sv_2mortal(sv));
            }
            break;
index c70375b..de3c13b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -23,6 +23,9 @@
 #define WORD_ALIGN sizeof(U16)
 #endif
 
+#define DOCATCH(o) (mustcatch ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
 static OP *doeval _((int gimme));
 static OP *dofindlabel _((OP *op, char *label, OP **opstack));
 static void doparseform _((SV *sv));
@@ -625,6 +628,7 @@ PP(pp_sort)
            AV *oldstack;
            CONTEXT *cx;
            SV** newsp;
+           bool oldmustcatch = mustcatch;
 
            SAVETMPS;
            SAVESPTR(op);
@@ -635,6 +639,7 @@ PP(pp_sort)
                AvREAL_off(sortstack);
                av_extend(sortstack, 32);
            }
+           mustcatch = TRUE;
            SWITCHSTACK(curstack, sortstack);
            if (sortstash != stash) {
                firstgv = gv_fetchpv("a", TRUE, SVt_PV);
@@ -651,6 +656,7 @@ PP(pp_sort)
 
            POPBLOCK(cx,curpm);
            SWITCHSTACK(sortstack, oldstack);
+           mustcatch = oldmustcatch;
        }
        LEAVE;
     }
@@ -1934,6 +1940,49 @@ SV *sv;
     }
 }
 
+static OP *
+docatch(o)
+OP *o;
+{
+    int ret;
+    int oldrunlevel = runlevel;
+    OP *oldop = op;
+    Sigjmp_buf oldtop;
+
+    op = o;
+    Copy(top_env, oldtop, 1, Sigjmp_buf);
+#ifdef DEBUGGING
+    assert(mustcatch == TRUE);
+#endif
+    mustcatch = FALSE;
+    switch ((ret = Sigsetjmp(top_env,1))) {
+    default:                           /* topmost level handles it */
+       Copy(oldtop, top_env, 1, Sigjmp_buf);
+       runlevel = oldrunlevel;
+       mustcatch = TRUE;
+       op = oldop;
+       Siglongjmp(top_env, ret);
+       /* NOTREACHED */
+    case 3:
+       if (!restartop) {
+           PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+           break;
+       }
+       mustcatch = FALSE;
+       op = restartop;
+       restartop = 0;
+       /* FALL THROUGH */
+    case 0:
+        runops();
+       break;
+    }
+    Copy(oldtop, top_env, 1, Sigjmp_buf);
+    runlevel = oldrunlevel;
+    mustcatch = TRUE;
+    op = oldop;
+    return Nullop;
+}
+
 static OP *
 doeval(gimme)
 int gimme;
@@ -2177,7 +2226,7 @@ PP(pp_require)
     compiling.cop_line = 0;
 
     PUTBACK;
-    return doeval(G_SCALAR);
+    return DOCATCH(doeval(G_SCALAR));
 }
 
 PP(pp_dofile)
@@ -2232,7 +2281,7 @@ PP(pp_entereval)
     if (perldb && was != sub_generation) { /* Some subs defined here. */
        strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
     }
-    return ret;
+    return DOCATCH(ret);
 }
 
 PP(pp_leaveeval)
@@ -2316,7 +2365,8 @@ PP(pp_entertry)
 
     in_eval = 1;
     sv_setpv(GvSV(errgv),"");
-    RETURN;
+    PUTBACK;
+    return DOCATCH(op->op_next);
 }
 
 PP(pp_leavetry)
index 59aec4f..c9750e6 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -951,7 +951,6 @@ nope:
        ++BmUSEFUL(pm->op_pmshort);
 
 ret_no:
-    TAINT_IF(rx->exec_tainted);                /* /\W/ */
     LEAVE_SCOPE(oldsave);
     if (gimme == G_ARRAY)
        RETURN;
@@ -1082,6 +1081,7 @@ do_readline()
                           PerlIO_rewind(tmpfp);
                           IoTYPE(io) = '<';
                           IoIFP(io) = fp = tmpfp;
+                          IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
                        }
                    }
                }
@@ -1460,7 +1460,6 @@ PP(pp_subst)
     if (c && clen <= rx->minlen) {
        if (! pregexec(rx, s, strend, orig, 0,
                       SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
-           TAINT_IF(rx->exec_tainted);
            PUSHs(&sv_no);
            LEAVE_SCOPE(oldsave);
            RETURN;
@@ -1606,7 +1605,6 @@ PP(pp_subst)
        RETURN;
     }
 
-    TAINT_IF(rx->exec_tainted);
     PUSHs(&sv_no);
     LEAVE_SCOPE(oldsave);
     RETURN;
index 75fdc40..e597701 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -459,6 +459,7 @@ PP(pp_tie)
     SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
     I32 markoff = mark - stack_base - 1;
     char *methname;
+    bool oldmustcatch = mustcatch;
 
     varsv = mark[0];
     if (SvTYPE(varsv) == SVt_PVHV)
@@ -479,6 +480,7 @@ PP(pp_tie)
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
     myop.op_flags = OPf_KNOW|OPf_STACKED;
+    mustcatch = TRUE;
 
     ENTER;
     SAVESPTR(op);
@@ -493,6 +495,7 @@ PP(pp_tie)
         runops();
     SPAGAIN;
 
+    mustcatch = oldmustcatch;
     sv = TOPs;
     if (sv_isobject(sv)) {
        if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
@@ -569,6 +572,7 @@ PP(pp_dbmopen)
     GV *gv;
     BINOP myop;
     SV *sv;
+    bool oldmustcatch = mustcatch;
 
     hv = (HV*)POPs;
 
@@ -587,6 +591,7 @@ PP(pp_dbmopen)
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
     myop.op_flags = OPf_KNOW|OPf_STACKED;
+    mustcatch = TRUE;
 
     ENTER;
     SAVESPTR(op);
@@ -629,6 +634,7 @@ PP(pp_dbmopen)
        SPAGAIN;
     }
 
+    mustcatch = oldmustcatch;
     if (sv_isobject(TOPs))
        sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
     LEAVE;
@@ -1117,7 +1123,7 @@ PP(pp_sysread)
     IO *io;
     char *buffer;
     int length;
-    int bufsize;
+    Sock_size_t bufsize;
     SV *bufsv;
     STRLEN blen;
 
@@ -1333,8 +1339,9 @@ PP(pp_truncate)
     SETERRNO(0,0);
 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
     if (op->op_flags & OPf_SPECIAL) {
-       tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
+       tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
     do_ftruncate:
+       TAINT_PROPER("truncate");
        if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
 #ifdef HAS_TRUNCATE
          ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
@@ -1345,6 +1352,8 @@ PP(pp_truncate)
     }
     else {
        SV *sv = POPs;
+       char *name;
+
        if (SvTYPE(sv) == SVt_PVGV) {
            tmpgv = (GV*)sv;            /* *main::FRED for example */
            goto do_ftruncate;
@@ -1353,14 +1362,16 @@ PP(pp_truncate)
            tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
            goto do_ftruncate;
        }
+
+       name = SvPV(sv, na);
+       TAINT_PROPER("truncate");
 #ifdef HAS_TRUNCATE
-       if (truncate (SvPV (sv, na), len) < 0)
+       if (truncate(name, len) < 0)
            result = 0;
 #else
        {
            int tmpfd;
-
-           if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0)
+           if ((tmpfd = open(name, O_RDWR)) < 0)
                result = 0;
            else {
                if (my_chsize(tmpfd, len) < 0)
@@ -1679,7 +1690,7 @@ PP(pp_accept)
     register IO *nstio;
     register IO *gstio;
     struct sockaddr saddr;     /* use a struct to avoid alignment problems */
-    int len = sizeof saddr;
+    Sock_size_t len = sizeof saddr;
     int fd;
 
     ggv = (GV*)POPs;
@@ -1771,7 +1782,7 @@ PP(pp_ssockopt)
     unsigned int lvl;
     GV *gv;
     register IO *io;
-    int aint;
+    Sock_size_t len;
 
     if (optype == OP_GSOCKOPT)
        sv = sv_2mortal(NEWSV(22, 257));
@@ -1792,24 +1803,26 @@ PP(pp_ssockopt)
        (void)SvPOK_only(sv);
        SvCUR_set(sv,256);
        *SvEND(sv) ='\0';
-       aint = SvCUR(sv);
-       if (getsockopt(fd, lvl, optname, SvPVX(sv), &aint) < 0)
+       len = SvCUR(sv);
+       if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
            goto nuts2;
-       SvCUR_set(sv,aint);
+       SvCUR_set(sv, len);
        *SvEND(sv) ='\0';
        PUSHs(sv);
        break;
     case OP_SSOCKOPT: {
-           STRLEN len = 0;
-           char *buf = 0;
-           if (SvPOKp(sv))
-               buf = SvPV(sv, len);
+           char *buf;
+           int aint;
+           if (SvPOKp(sv)) {
+               buf = SvPV(sv, na);
+               len = na;
+           }
            else if (SvOK(sv)) {
                aint = (int)SvIV(sv);
                buf = (char*)&aint;
                len = sizeof(int);
            }
-           if (setsockopt(fd, lvl, optname, buf, (int)len) < 0)
+           if (setsockopt(fd, lvl, optname, buf, len) < 0)
                goto nuts2;
            PUSHs(&sv_yes);
        }
@@ -1847,34 +1860,34 @@ PP(pp_getpeername)
     int fd;
     GV *gv = (GV*)POPs;
     register IO *io = GvIOn(gv);
-    int aint;
+    Sock_size_t len;
 
     if (!io || !IoIFP(io))
        goto nuts;
 
     sv = sv_2mortal(NEWSV(22, 257));
     (void)SvPOK_only(sv);
-    SvCUR_set(sv,256);
+    len = 256;
+    SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
-    aint = SvCUR(sv);
     fd = PerlIO_fileno(IoIFP(io));
     switch (optype) {
     case OP_GETSOCKNAME:
-       if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+       if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
            goto nuts2;
        break;
     case OP_GETPEERNAME:
-       if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+       if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
            goto nuts2;
        break;
     }
 #ifdef BOGUS_GETNAME_RETURN
     /* Interactive Unix, getpeername() and getsockname()
       does not return valid namelen */
-    if (aint == BOGUS_GETNAME_RETURN)
-       aint = sizeof(struct sockaddr);
+    if (len == BOGUS_GETNAME_RETURN)
+       len = sizeof(struct sockaddr);
 #endif
-    SvCUR_set(sv,aint);
+    SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     PUSHs(sv);
     RETURN;
@@ -2572,55 +2585,68 @@ dooneliner(cmd, filename)
 char *cmd;
 char *filename;
 {
-    char mybuf[8192];
-    char *s,
-        *save_filename = filename;
-    int anum = 1;
+    char *save_filename = filename;
+    char *cmdline;
+    char *s;
     PerlIO *myfp;
+    int anum = 1;
 
-    strcpy(mybuf, cmd);
-    strcat(mybuf, " ");
-    for (s = mybuf+strlen(mybuf); *filename; ) {
+    New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
+    strcpy(cmdline, cmd);
+    strcat(cmdline, " ");
+    for (s = cmdline + strlen(cmdline); *filename; ) {
        *s++ = '\\';
        *s++ = *filename++;
     }
     strcpy(s, " 2>&1");
-    myfp = my_popen(mybuf, "r");
+    myfp = my_popen(cmdline, "r");
+    Safefree(cmdline);
+
     if (myfp) {
-       *mybuf = '\0';
+       SV *tmpsv = sv_newmortal();
        /* Need to save/restore 'rs' ?? */
        s = sv_gets(tmpsv, myfp, 0);
        (void)my_pclose(myfp);
        if (s != Nullch) {
-           for (errno = 1; errno < sys_nerr; errno++) {
+           int e;
+           for (e = 1;
 #ifdef HAS_SYS_ERRLIST
-               if (instr(mybuf, sys_errlist[errno]))   /* you don't see this */
-                   return 0;
+                e <= sys_nerr
+#endif
+                ; e++)
+           {
+               /* you don't see this */
+               char *errmsg =
+#ifdef HAS_SYS_ERRLIST
+                   sys_errlist[e]
 #else
-               char *errmsg;                           /* especially if it isn't there */
-
-               if (instr(mybuf,
-                         (errmsg = strerror(errno)) ? errmsg : "NoErRoR"))
-                   return 0;
+                   strerror(e)
 #endif
+                   ;
+               if (!errmsg)
+                   break;
+               if (instr(s, errmsg)) {
+                   SETERRNO(e,0);
+                   return 0;
+               }
            }
            SETERRNO(0,0);
 #ifndef EACCES
 #define EACCES EPERM
 #endif
-           if (instr(mybuf, "cannot make"))
+           if (instr(s, "cannot make"))
                SETERRNO(EEXIST,RMS$_FEX);
-           else if (instr(mybuf, "existing file"))
+           else if (instr(s, "existing file"))
                SETERRNO(EEXIST,RMS$_FEX);
-           else if (instr(mybuf, "ile exists"))
+           else if (instr(s, "ile exists"))
                SETERRNO(EEXIST,RMS$_FEX);
-           else if (instr(mybuf, "non-exist"))
+           else if (instr(s, "non-exist"))
                SETERRNO(ENOENT,RMS$_FNF);
-           else if (instr(mybuf, "does not exist"))
+           else if (instr(s, "does not exist"))
                SETERRNO(ENOENT,RMS$_FNF);
-           else if (instr(mybuf, "not empty"))
+           else if (instr(s, "not empty"))
                SETERRNO(EBUSY,SS$_DEVOFFLINE);
-           else if (instr(mybuf, "cannot access"))
+           else if (instr(s, "cannot access"))
                SETERRNO(EACCES,RMS$_PRV);
            else
                SETERRNO(EPERM,RMS$_PRV);
@@ -2867,7 +2893,7 @@ PP(pp_fork)
     if (!childpid) {
        /*SUPPRESS 560*/
        if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
-           sv_setiv(GvSV(tmpgv), (I32)getpid());
+           sv_setiv(GvSV(tmpgv), (IV)getpid());
        hv_clear(pidstatus);    /* no kids, so don't wait for 'em */
     }
     PUSHi(childpid);
@@ -2921,7 +2947,6 @@ PP(pp_system)
     int status;
     Sigsave_t ihand,qhand;     /* place to save signals during system() */
 
-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
     if (SP - MARK == 1) {
        if (tainting) {
            char *junk = SvPV(TOPs, na);
@@ -2929,6 +2954,7 @@ PP(pp_system)
            TAINT_PROPER("system");
        }
     }
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
     while ((childpid = vfork()) == -1) {
        if (errno != EAGAIN) {
            value = -1;
@@ -3475,10 +3501,10 @@ PP(pp_ghostent)
                sv_catpvn(sv, " ", 1);
        }
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)hent->h_addrtype);
+       sv_setiv(sv, (IV)hent->h_addrtype);
        PUSHs(sv = sv_mortalcopy(&sv_no));
        len = hent->h_length;
-       sv_setiv(sv, (I32)len);
+       sv_setiv(sv, (IV)len);
 #ifdef h_addr
        for (elem = hent->h_addr_list; elem && *elem; elem++) {
            XPUSHs(sv = sv_mortalcopy(&sv_no));
@@ -3541,7 +3567,7 @@ PP(pp_gnetent)
        PUSHs(sv = sv_newmortal());
        if (nent) {
            if (which == OP_GNBYNAME)
-               sv_setiv(sv, (I32)nent->n_net);
+               sv_setiv(sv, (IV)nent->n_net);
            else
                sv_setpv(sv, nent->n_name);
        }
@@ -3558,9 +3584,9 @@ PP(pp_gnetent)
                sv_catpvn(sv, " ", 1);
        }
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)nent->n_addrtype);
+       sv_setiv(sv, (IV)nent->n_addrtype);
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)nent->n_net);
+       sv_setiv(sv, (IV)nent->n_net);
     }
 
     RETURN;
@@ -3611,7 +3637,7 @@ PP(pp_gprotoent)
        PUSHs(sv = sv_newmortal());
        if (pent) {
            if (which == OP_GPBYNAME)
-               sv_setiv(sv, (I32)pent->p_proto);
+               sv_setiv(sv, (IV)pent->p_proto);
            else
                sv_setpv(sv, pent->p_name);
        }
@@ -3628,7 +3654,7 @@ PP(pp_gprotoent)
                sv_catpvn(sv, " ", 1);
        }
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)pent->p_proto);
+       sv_setiv(sv, (IV)pent->p_proto);
     }
 
     RETURN;
@@ -3694,9 +3720,9 @@ PP(pp_gservent)
        if (sent) {
            if (which == OP_GSBYNAME) {
 #ifdef HAS_NTOHS
-               sv_setiv(sv, (I32)ntohs(sent->s_port));
+               sv_setiv(sv, (IV)ntohs(sent->s_port));
 #else
-               sv_setiv(sv, (I32)(sent->s_port));
+               sv_setiv(sv, (IV)(sent->s_port));
 #endif
            }
            else
@@ -3716,9 +3742,9 @@ PP(pp_gservent)
        }
        PUSHs(sv = sv_mortalcopy(&sv_no));
 #ifdef HAS_NTOHS
-       sv_setiv(sv, (I32)ntohs(sent->s_port));
+       sv_setiv(sv, (IV)ntohs(sent->s_port));
 #else
-       sv_setiv(sv, (I32)(sent->s_port));
+       sv_setiv(sv, (IV)(sent->s_port));
 #endif
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, sent->s_proto);
@@ -3860,7 +3886,7 @@ PP(pp_gpwent)
        PUSHs(sv = sv_newmortal());
        if (pwent) {
            if (which == OP_GPWNAM)
-               sv_setiv(sv, (I32)pwent->pw_uid);
+               sv_setiv(sv, (IV)pwent->pw_uid);
            else
                sv_setpv(sv, pwent->pw_name);
        }
@@ -3873,15 +3899,15 @@ PP(pp_gpwent)
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, pwent->pw_passwd);
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)pwent->pw_uid);
+       sv_setiv(sv, (IV)pwent->pw_uid);
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)pwent->pw_gid);
+       sv_setiv(sv, (IV)pwent->pw_gid);
        PUSHs(sv = sv_mortalcopy(&sv_no));
 #ifdef PWCHANGE
-       sv_setiv(sv, (I32)pwent->pw_change);
+       sv_setiv(sv, (IV)pwent->pw_change);
 #else
 #ifdef PWQUOTA
-       sv_setiv(sv, (I32)pwent->pw_quota);
+       sv_setiv(sv, (IV)pwent->pw_quota);
 #else
 #ifdef PWAGE
        sv_setpv(sv, pwent->pw_age);
@@ -3904,7 +3930,7 @@ PP(pp_gpwent)
        sv_setpv(sv, pwent->pw_shell);
 #ifdef PWEXPIRE
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)pwent->pw_expire);
+       sv_setiv(sv, (IV)pwent->pw_expire);
 #endif
     }
     RETURN;
@@ -3974,7 +4000,7 @@ PP(pp_ggrent)
        PUSHs(sv = sv_newmortal());
        if (grent) {
            if (which == OP_GGRNAM)
-               sv_setiv(sv, (I32)grent->gr_gid);
+               sv_setiv(sv, (IV)grent->gr_gid);
            else
                sv_setpv(sv, grent->gr_name);
        }
@@ -3987,7 +4013,7 @@ PP(pp_ggrent)
        PUSHs(sv = sv_mortalcopy(&sv_no));
        sv_setpv(sv, grent->gr_passwd);
        PUSHs(sv = sv_mortalcopy(&sv_no));
-       sv_setiv(sv, (I32)grent->gr_gid);
+       sv_setiv(sv, (IV)grent->gr_gid);
        PUSHs(sv = sv_mortalcopy(&sv_no));
        for (elem = grent->gr_mem; *elem; elem++) {
            sv_catpv(sv, *elem);
index 9e4d692..4eeca6b 100755 (executable)
@@ -74,13 +74,13 @@ sub bits ($) {
     # reason that the diagnostic message might get the
     # wrong value is that Config.pm is incorrect.)
     #
-    if ($max <= 0) {   # Just in case...
+    if ($max <= 0 or $max >= (1 << $randbits)) {       # Just in case...
        print "not ok 1\n";
        print "# This perl was compiled with randbits=$randbits\n";
        print "# which is _way_ off. Or maybe your system rand is broken,\n";
        print "# or your C compiler can't multiply, or maybe Martians\n";
        print "# have taken over your computer. For starters, see about\n";
-       print "# trying a better value for randbits.\n";
+       print "# trying a better value for randbits, probably smaller.\n";
        # If that isn't the problem, we'll have
        # to put d_martians into Config.pm 
        print "# Skipping remaining tests until randbits is fixed.\n";
@@ -329,7 +329,12 @@ AUTOSRAND:
 
     my($pid, $first);
     for (1..5) {
-       $pid = open PERL, "./perl -e 'print rand'|";
+       if ($^O eq 'VMS') {
+           $pid = open PERL, qq[MCR $^X -e "print rand"|];
+       }
+       else {
+           $pid = open PERL, "./perl -e 'print rand'|";
+       }
        die "Couldn't pipe from perl: $!" unless defined $pid;
        if (defined $first) {
            if ($first ne <PERL>) {
diff --git a/t/op/runlevel.t b/t/op/runlevel.t
new file mode 100644 (file)
index 0000000..ca6aac5
--- /dev/null
@@ -0,0 +1,308 @@
+#!./perl
+
+##
+## all of these tests are from Michael Schroeder
+## <Michael.Schroeder@informatik.uni-erlangen.de>
+##
+## The more esoteric failure modes require Michael's
+## stack-of-stacks patch (so we don't test them here,
+## and they are commented out before the __END__).
+##
+## The remaining tests pass with a simpler fix
+## intended for 5.004
+##
+## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
+##
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "runltmp000";
+1 while -f ++$tmpfile;
+END { unlink $tmpfile if $tmpfile; }
+
+for (@prgs){
+    my $switch;
+    if (s/^\s*-\w+//){
+       $switch = $&;
+    }
+    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+    open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
+    print TEST $prog, "\n";
+    close TEST;
+    $status = $?;
+    $results = `cat $tmpfile`;
+    $results =~ s/\n+$//;
+    $expected =~ s/\n+$//;
+    if ( $results ne $expected){
+       print STDERR "PROG: $switch\n$prog\n";
+       print STDERR "EXPECTED:\n$expected\n";
+       print STDERR "GOT:\n$results\n";
+       print "not ";
+    }
+    print "ok ", ++$i, "\n";
+}
+
+=head2 stay out of here (the real tests are after __END__)
+
+##
+## these tests don't pass yet (need the full stack-of-stacks patch)
+## GSAR 97-02-24
+##
+
+########
+# sort within sort
+sub sortfn {
+  (split(/./, 'x'x10000))[0];
+  my (@y) = ( 4, 6, 5);
+  @y = sort { $a <=> $b } @y;
+  print "sortfn ".join(', ', @y)."\n";
+  return $_[0] <=> $_[1];
+}
+@x = ( 3, 2, 1 );
+@x = sort { &sortfn($a, $b) } @x;
+print "---- ".join(', ', @x)."\n";
+EXPECT
+sortfn 4, 5, 6
+---- 1, 2, 3
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+@a = (3, 2, 1);
+@a = sort { eval('die("no way")') ,  $a <=> $b} @a;
+print join(", ", @a)."\n";
+EXPECT
+1, 2, 3
+########
+# this actually works fine, but results in a poor error message
+@a = (1, 2, 3);
+foo:
+{
+  @a = sort { last foo; } @a;
+}
+EXPECT
+cannot reach destination block at - line 2.
+########
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  next;
+  return "ZZZ";
+}
+sub STORE {
+}
+package main;
+tie $bar, TEST;
+{
+  print "- $bar\n";
+}
+print "OK\n";
+EXPECT
+cannot reach destination block at - line 8.
+########
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  goto bbb;
+  return "ZZZ";
+}
+package main;
+tie $bar, TEST;
+print "- $bar\n";
+exit;
+bbb:
+print "bbb\n";
+EXPECT
+bbb
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+sub foo {
+  $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  next;
+  return bless \$foo;
+}
+package main;
+{
+tie $bar, TEST;
+}
+EXPECT
+cannot reach destination block at - line 4.
+########
+# large stack extension causes realloc, and segfault
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  return "fetch";
+}
+sub STORE {
+(split(/./, 'x'x10000))[0];
+}
+package main;
+tie $bar, TEST;
+$bar = "x";
+
+=cut
+
+##
+##
+## The real tests begin here
+##
+##
+
+__END__
+@a = (1, 2, 3);
+{
+  @a = sort { last ; } @a;
+}
+EXPECT
+Can't "last" outside a block at - line 3.
+########
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  eval 'die("test")';
+  print "still in fetch\n";
+  return ">$@<";
+}
+package main;
+tie $bar, TEST;
+print "- $bar\n";
+EXPECT
+still in fetch
+- >test at (eval 1) line 1.
+<
+########
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  eval('die("foo\n")');
+  print "after eval\n";
+  return bless \$foo;
+}
+sub FETCH {
+  return "ZZZ";
+}
+package main;
+tie $bar, TEST;
+print "- $bar\n";
+print "OK\n";
+EXPECT
+after eval
+- ZZZ
+OK
+########
+package TEST;
+sub TIEHANDLE {
+  my $foo;
+  return bless \$foo;
+}
+sub PRINT {
+print STDERR "PRINT CALLED\n";
+(split(/./, 'x'x10000))[0];
+eval('die("test\n")');
+}
+package main;
+open FH, ">&STDOUT";
+tie *FH, TEST;
+print FH "OK\n";
+print "DONE\n";
+EXPECT
+PRINT CALLED
+DONE
+########
+sub warnhook {
+  print "WARNHOOK\n";
+  eval('die("foooo\n")');
+}
+$SIG{'__WARN__'} = 'warnhook';
+warn("dfsds\n");
+print "END\n";
+EXPECT
+WARNHOOK
+END
+########
+package TEST;
+use overload
+     "\"\""   =>  \&str
+;
+sub str {
+  eval('die("test\n")');
+  return "STR";
+}
+package main;
+$bar = bless {}, TEST;
+print "$bar\n";
+print "OK\n";
+EXPECT
+STR
+OK
+########
+sub foo {
+  $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+sub foo {
+  goto bar if $a == 0;
+  $a <=> $b;
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+exit;
+bar:
+print "bar reached\n";
+EXPECT
+Can't "goto" outside a block at - line 2.
diff --git a/t/op/taint.t b/t/op/taint.t
new file mode 100644 (file)
index 0000000..3227718
--- /dev/null
@@ -0,0 +1,414 @@
+#!./perl -T
+#
+# Taint tests by Tom Phoenix <rootbeer@teleport.com>.
+#
+# I don't claim to know all about tainting. If anyone sees
+# tests that I've missed here, please add them. But this is 
+# better than having no tests at all, right?
+#
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib' if -d '../lib';
+}
+
+use strict;
+use Config;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : './perl';
+if ($Is_VMS) {
+    eval <<EndOfCleanup;
+       END {
+           \$ENV{PATH} = '';
+           warn "# Note: logical name 'PATH' may have been deleted\n";
+           \$ENV{IFS} =  "$ENV{IFS}";
+           \$ENV{'DCL\$PATH'} = "$ENV{'DCL$PATH'}";
+       }
+EndOfCleanup
+}
+
+# Sources of taint:
+#   The empty tainted value, for tainting strings
+my $TAINT = substr($^X, 0, 0);
+#   A tainted zero, useful for tainting numbers
+my $TAINT0 = 0 + $TAINT;
+
+# This taints each argument passed. All must be lvalues.
+# Side effect: It also stringifies them. :-(
+sub taint_these (@) {
+    for (@_) { $_ .= $TAINT }
+}
+
+# How to identify taint when you see it
+sub any_tainted (@) {
+    not eval { join("",@_), kill 0; 1 };
+}
+sub tainted ($) {
+    any_tainted @_;
+}
+sub all_tainted (@) {
+    for (@_) { return 0 unless tainted $_ }
+    1;
+}
+
+sub test ($$;$) {
+    my($serial, $boolean, $diag) = @_;
+    if ($boolean) {
+       print "ok $serial\n";
+    } else {
+       print "not ok $serial\n";
+       for (split m/^/m, $diag) {
+           print "# $_";
+       }
+       print "\n" unless 
+           $diag eq ''
+           or substr($diag, -1) eq "\n";
+    }
+}
+
+# We need an external program to call.
+my $ECHO = "./echo$$";
+END { unlink $ECHO }
+open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
+print PROG 'print "@ARGV\n"', "\n";
+close PROG;
+my $echo = "$Invoke_Perl $ECHO";
+
+print "1..96\n";
+
+# First, let's make sure that Perl is checking the dangerous
+# environment variables. Maybe they aren't set yet, so we'll
+# taint them ourselves.
+{
+    $ENV{'DCL$PATH'} = '' if $Is_VMS;
+
+    $ENV{PATH} = $TAINT;
+    $ENV{IFS} = '';
+    test 1, eval { `$echo 1` } eq '';
+    test 2, $@ =~ /^Insecure \$ENV{PATH}/, $@;
+
+    $ENV{PATH} = '';
+    $ENV{IFS} = $TAINT;
+    test 3, eval { `$echo 1` } eq '';
+    test 4, $@ =~ /^Insecure \$ENV{IFS}/, $@;
+
+    my ($tmp) = grep { (stat)[2] & 2 } '/tmp', '/var/tmp', '/usr/tmp';
+    if ($tmp) {
+       $ENV{PATH} = $tmp;
+       test 5, eval { `$echo 1` } eq '';
+       test 6, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
+    }
+    else {
+       print "# can't find writeable directory to test PATH tainting\n";
+       for (5..6) { print "ok $_\n" }
+    }
+
+    $ENV{PATH} = '';
+    $ENV{IFS} = '';
+    test 7, eval { `$echo 1` } eq "1\n";
+    test 8, $@ eq '', $@;
+
+    if ($Is_VMS) {
+       $ENV{'DCL$PATH'} = $TAINT;
+       test 9,  eval { `$echo 1` } eq '';
+       test 10, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
+       $ENV{'DCL$PATH'} = '';
+    }
+    else {
+       print "# This is not VMS\n";
+       for (9..10) { print "ok $_\n"; }
+    }
+}
+
+# Let's see that we can taint and untaint as needed.
+{
+    my $foo = $TAINT;
+    test 11, tainted $foo;
+
+    $foo = "foo";
+    test 12, not tainted $foo;
+
+    taint_these($foo);
+    test 13, tainted $foo;
+
+    my @list = 1..10;
+    test 14, not any_tainted @list;
+    taint_these @list[1,3,5,7,9];
+    test 15, any_tainted @list;
+    test 16, all_tainted @list[1,3,5,7,9];
+    test 17, not any_tainted @list[0,2,4,6,8];
+
+    ($foo) = $foo =~ /(.+)/;
+    test 18, not tainted $foo;
+
+    $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
+    test 19, not tainted $foo;
+    test 20, $foo eq 'bar';
+
+    my $pi = 4 * atan2(1,1) + $TAINT0;
+    test 21, tainted $pi;
+
+    ($pi) = $pi =~ /(\d+\.\d+)/;
+    test 22, not tainted $pi;
+    test 23, sprintf("%.5f", $pi) eq '3.14159';
+}
+
+# How about command-line arguments? The problem is that we don't
+# always get some, so we'll run another process with some.
+{
+    my $arg = "./arg$$";
+    open PROG, "> $arg" or die "Can't create $arg: $!";
+    print PROG q{
+       eval { join('', @ARGV), kill 0 };
+       exit 0 if $@ =~ /^Insecure dependency/;
+       print "# Oops: \$@ was [$@]\n";
+       exit 1;
+    };
+    close PROG;
+    print `$Invoke_Perl "-T" $arg and some suspect arguments`;
+    test 24, !$?, "Exited with status $?";
+    unlink $arg;
+}
+
+# Reading from a file should be tainted
+{
+    my $file = './perl' . $Config{exe_ext};
+    test 25, open(FILE, $file), "Couldn't open '$file': $!";
+
+    my $block;
+    sysread(FILE, $block, 100);
+    my $line = <FILE>;         # Should "work"
+    close FILE;
+    test 26, tainted $block;
+    test 27, tainted $line;
+}
+
+# Globs should be tainted. 
+{
+    my @globs = <*>;
+    test 28, all_tainted @globs;
+
+    @globs = glob '*';
+    test 29, all_tainted @globs;
+}
+
+# Output of commands should be tainted
+{
+    my $foo = `$echo abc`;
+    test 30, tainted $foo;
+}
+
+# Certain system variables should be tainted
+{
+    test 31, all_tainted $^X, $0;
+}
+
+# Results of matching should all be untainted
+{
+    my $foo = "abcdefghi" . $TAINT;
+    test 32, tainted $foo;
+
+    $foo =~ /def/;
+    test 33, not any_tainted $`, $&, $';
+
+    $foo =~ /(...)(...)(...)/;
+    test 34, not any_tainted $1, $2, $3, $+;
+
+    my @bar = $foo =~ /(...)(...)(...)/;
+    test 35, not any_tainted @bar;
+
+    test 36, tainted $foo;     # $foo should still be tainted!
+    test 37, $foo eq "abcdefghi";
+}
+
+# Operations which affect files can't use tainted data.
+{
+    test 38, eval { chmod 0, $TAINT } eq '', 'chmod';
+    test 39, $@ =~ /^Insecure dependency/, $@;
+
+    test 40, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
+    test 41, $@ =~ /^Insecure dependency/, $@;
+
+    test 42, eval { rename '', $TAINT } eq '', 'rename';
+    test 43, $@ =~ /^Insecure dependency/, $@;
+
+    test 44, eval { unlink $TAINT } eq '', 'unlink';
+    test 45, $@ =~ /^Insecure dependency/, $@;
+
+    test 46, eval { utime $TAINT } eq '', 'utime';
+    test 47, $@ =~ /^Insecure dependency/, $@;
+
+    if ($Config{d_chown}) {
+       test 48, eval { chown -1, -1, $TAINT } eq '', 'chown';
+       test 49, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# chown() is not available\n";
+       for (48..49) { print "ok $_\n" }
+    }
+
+    if ($Config{d_link}) {
+       test 50, eval { link $TAINT, '' } eq '', 'link';
+       test 51, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# link() is not available\n";
+       for (50..51) { print "ok $_\n" }
+    }
+
+    if ($Config{d_symlink}) {
+       test 52, eval { symlink $TAINT, '' } eq '', 'symlink';
+       test 53, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# symlink() is not available\n";
+       for (52..53) { print "ok $_\n" }
+    }
+}
+
+# Operations which affect directories can't use tainted data.
+{
+    test 54, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
+    test 55, $@ =~ /^Insecure dependency/, $@;
+
+    test 56, eval { rmdir $TAINT } eq '', 'rmdir';
+    test 57, $@ =~ /^Insecure dependency/, $@;
+
+    test 58, eval { chdir $TAINT } eq '', 'chdir';
+    test 59, $@ =~ /^Insecure dependency/, $@;
+
+    if ($Config{d_chroot}) {
+       test 60, eval { chroot $TAINT } eq '', 'chroot';
+       test 61, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# chroot() is not available\n";
+       for (60..61) { print "ok $_\n" }
+    }
+}
+
+# Some operations using files can't use tainted data.
+{
+    my $foo = "imaginary library" . $TAINT;
+    test 62, eval { require $foo } eq '', 'require';
+    test 63, $@ =~ /^Insecure dependency/, $@;
+
+    my $filename = "./taintB$$";       # NB: $filename isn't tainted!
+    END { unlink $filename if defined $filename }
+    $foo = $filename . $TAINT;
+    unlink $filename;  # in any case
+
+    test 64, eval { open FOO, $foo } eq '', 'open for read';
+    test 65, $@ eq '', $@;             # NB: This should be allowed
+    test 66, $! == 2;                  # File not found
+
+    test 67, eval { open FOO, "> $foo" } eq '', 'open for write';
+    test 68, $@ =~ /^Insecure dependency/, $@;
+}
+
+# Commands to the system can't use tainted data
+{
+    my $foo = $TAINT;
+
+    if ($^O eq 'amigaos') {
+       print "# open(\"|\") is not available\n";
+       for (69..72) { print "ok $_\n" }
+    }
+    else {
+       test 69, eval { open FOO, "| $foo" } eq '', 'popen to';
+       test 70, $@ =~ /^Insecure dependency/, $@;
+
+       test 71, eval { open FOO, "$foo |" } eq '', 'popen from';
+       test 72, $@ =~ /^Insecure dependency/, $@;
+    }
+
+    test 73, eval { exec $TAINT } eq '', 'exec';
+    test 74, $@ =~ /^Insecure dependency/, $@;
+
+    test 75, eval { system $TAINT } eq '', 'system';
+    test 76, $@ =~ /^Insecure dependency/, $@;
+
+    $foo = "*";
+    taint_these $foo;
+
+    test 77, eval { `$echo 1$foo` } eq '', 'backticks';
+    test 78, $@ =~ /^Insecure dependency/, $@;
+
+    if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe
+       test 79, join('', eval { glob $foo } ) ne '', 'globbing';
+       test 80, $@ eq '', $@;
+    }
+    else {
+       test 79, join('', eval { glob $foo } ) eq '', 'globbing';
+       test 80, $@ =~ /^Insecure dependency/, $@;
+    }
+}
+
+# Operations which affect processes can't use tainted data.
+{
+    test 81, eval { kill 0, $TAINT } eq '', 'kill';
+    test 82, $@ =~ /^Insecure dependency/, $@;
+
+    if ($Config{d_setpgrp}) {
+       test 83, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
+       test 84, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# setpgrp() is not available\n";
+       for (83..84) { print "ok $_\n" }
+    }
+
+    if ($Config{d_setprior}) {
+       test 85, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
+       test 86, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# setpriority() is not available\n";
+       for (85..86) { print "ok $_\n" }
+    }
+}
+
+# Some miscellaneous operations can't use tainted data.
+{
+    if ($Config{d_syscall}) {
+       test 87, eval { syscall $TAINT } eq '', 'syscall';
+       test 88, $@ =~ /^Insecure dependency/, $@;
+    }
+    else {
+       print "# syscall() is not available\n";
+       for (87..88) { print "ok $_\n" }
+    }
+
+    {
+       my $foo = "x" x 979;
+       taint_these $foo;
+       local *FOO;
+       my $temp = "./taintC$$";
+       END { unlink $temp }
+       test 89, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
+
+       test 90, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
+       test 91, $@ =~ /^Insecure dependency/, $@;
+
+       if ($Config{d_fcntl}) {
+           test 92, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
+           test 93, $@ =~ /^Insecure dependency/, $@;
+       }
+       else {
+           print "# fcntl() is not available\n";
+           for (92..93) { print "ok $_\n" }
+       }
+
+       close FOO;
+    }
+}
+
+# Some tests involving references 
+{
+    my $foo = 'abc' . $TAINT;
+    my $fooref = \$foo;
+    test 94, not tainted $fooref;
+    test 95, tainted $$fooref;
+    test 96, tainted $foo;
+}
diff --git a/taint.c b/taint.c
index dbb0a1e..584c9f4 100644 (file)
--- a/taint.c
+++ b/taint.c
@@ -14,9 +14,10 @@ char *s;
 {
     char *ug;
 
+    DEBUG_u(PerlIO_printf(PerlIO_stderr(),
+            "%s %d %d %d\n", s, tainted, uid, euid));
+
     if (tainted) {
-       DEBUG_u(PerlIO_printf(PerlIO_stderr(),
-                             "%s %d %d %d\n", s, tainted, uid, euid));
        if (euid != uid)
            ug = " while running setuid";
        else if (egid != gid)
@@ -34,23 +35,44 @@ void
 taint_env()
 {
     SV** svp;
-    MAGIC *mg = 0;
+    MAGIC *mg;
+
+#ifdef VMS
+    int i = 0;
+    char name[14] = "DCL$PATH";
+
+    while (1) {
+       if (i)
+           (void)sprintf(name,"DCL$PATH;%d", i);
+       svp = hv_fetch(GvHVn(envgv), name, strlen(name), FALSE);
+       if (!svp || *svp == &sv_undef)
+           break;
+       if (SvTAINTED(*svp)) {
+           TAINT;
+           taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
+       }
+       if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+           TAINT;
+           taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
+       }
+       i++;
+    }
+#endif /* VMS */
 
     svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
-    if (!svp || *svp == &sv_undef ||
-       ((mg = mg_find(*svp, 't')) && mg->mg_len & 1))
-    {
-       TAINT;
-       if (mg && MgTAINTEDDIR(mg))
-           taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
-       else
+    if (svp && *svp) {
+       if (SvTAINTED(*svp)) {
+           TAINT;
            taint_proper("Insecure %s%s", "$ENV{PATH}");
+       }
+       if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+           TAINT;
+           taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
+       }
     }
 
     svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE);
-    if (svp && *svp != &sv_undef &&
-       (mg = mg_find(*svp, 't')) && mg->mg_len & 1)
-    {
+    if (svp && *svp != &sv_undef && SvTAINTED(*svp)) {
        TAINT;
        taint_proper("Insecure %s%s", "$ENV{IFS}");
     }
diff --git a/toke.c b/toke.c
index 110fd24..076e22f 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -4877,7 +4877,7 @@ char *start;
 {
     register char *s = start;
     register char *d;
-    I32 tryi32;
+    I32 tryiv;
     double value;
     SV *sv;
     I32 floatit;
@@ -4978,11 +4978,11 @@ char *start;
        sv = NEWSV(92,0);
        SET_NUMERIC_STANDARD();
        value = atof(tokenbuf);
-       tryi32 = I_32(value);
-       if (!floatit && (double)tryi32 == value)
-           sv_setiv(sv,tryi32);
+       tryiv = I_V(value);
+       if (!floatit && (double)tryiv == value)
+           sv_setiv(sv, tryiv);
        else
-           sv_setnv(sv,value);
+           sv_setnv(sv, value);
        break;
     }
 
diff --git a/util.c b/util.c
index c93663c..94aeccf 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1700,7 +1700,7 @@ char      *mode;
        }
        /*SUPPRESS 560*/
        if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
-           sv_setiv(GvSV(tmpgv),(I32)getpid());
+           sv_setiv(GvSV(tmpgv), (IV)getpid());
        forkprocess = 0;
        hv_clear(pidstatus);    /* we have no children */
        return Nullfp;
index b311c76..7febd01 100644 (file)
@@ -252,11 +252,11 @@ unless($Is_VMS) {
 unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
 
 if ($opt_m) {
-    foreach $pager (@pagers) {
-       my($sts) = system("$pager @found");
-       exit 0 if ($Is_VMS ? ($sts & 1) : !$sts);
-    }
-    exit $Is_VMS ? $sts : 1;
+       foreach $pager (@pagers) {
+               system("$pager @found") or exit;
+       }
+       if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
+       exit 1;
 } 
 
 if ($opt_f) {
@@ -301,16 +301,14 @@ foreach (@found) {
                Pod::Text::pod2text($_,*TMP);
                close(TMP);
        } elsif(not $opt_u) {
-               open(TMP,">>$tmp");
-               if($^O =~ /hpux/) {
-                       $rslt = `pod2man $_ | nroff -man | col -x`;
-               } else {
-                       $rslt = `pod2man $_ | nroff -man`;
+               my $cmd = "pod2man --lax $_ | nroff -man";
+               $cmd .= " | col -x" if $^O =~ /hpux/;
+               $rslt = `$cmd`;
+               unless(($err = $?)) {
+                       open(TMP,">>$tmp");
+                       print TMP $rslt;
+                       close TMP;
                }
-               if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
-               else      { $err = $?; }
-               print TMP $rslt unless $err;
-               close TMP;
        }
                                                        
        if( $opt_u or $err or -z $tmp) {
@@ -333,9 +331,7 @@ if( $no_tty ) {
        close(TMP);
 } else {
        foreach $pager (@pagers) {
-               $sts = system("$pager $tmp");
-               last if $Is_VMS && ($sts & 1);
-               last unless $sts;
+               system("$pager $tmp") or last;
        }
 }
 
index 2cec4f2..5a24c33 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_00390"  /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00391"  /**/
 #define ARCHLIB ARCHLIB_EXP    /*config-skip*/
 
 /* ARCHNAME:
index 358ec35..fc264ff 100644 (file)
@@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O)
 .endif
 
 # Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00390#
+PERL_VERSION = 5_00391#
 
 
 ARCHDIR =  [.lib.$(ARCH).$(PERL_VERSION)]
@@ -796,6 +796,19 @@ perly$(O) : perly.c, perly.h, $(h)
 test : all [.t.lib]vmsfspec.t
        - @[.VMS]Test.Com "$(E)"
 
+archify : all
+       @ Write Sys$Output "Moving files to architecture-specific locations for $(ARCH)"
+       archroot = "$(ARCHAUTO)" - "]" + "...]"
+       Backup/Log/Verify [.lib.auto...]*.*;/Exclude=(*.al,*.ix) 'archroot'
+       Delete/Log/NoConfirm [.lib.auto...]*.*;*/exclude=(*.al,*.ix)
+       Delete/Log/NoConfirm [.lib]Config.pm;*
+       Copy/Log/NoConfirm *$(E);,[.x2p]a2p$(E); $(ARCHDIR)
+       Delete/Log/NoConfirm Perl*$(E);*,[.x2p]a2p$(E);*
+       @ Write Sys$Output "Architecture-specific setup completed."
+       @ Write Sys$Output "Before building for another architecture, be sure to"
+       @ Write Sys$Output "    1. $(MMS)$(MMSQUALIFIERS) clean"
+       @ Write Sys$Output "    2. Delete Miniperl$(E)"
+
 # CORE subset for MakeMaker, so we can build Perl without sources
 # Should move to VMS installperl when we get one
 $(ARCHCORE)EXTERN.h : EXTERN.h
index b544569..107ad32 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -162,6 +162,8 @@ my_getenv(char *lnm)
 }  /* end of my_getenv() */
 /*}}}*/
 
+static FILE *safe_popen(char *, char *);
+
 /*{{{ void prime_env_iter() */
 void
 prime_env_iter(void)
@@ -188,9 +190,9 @@ prime_env_iter(void)
   (void) hv_fetch(envhv,"USER",4,TRUE);
 
   /* Now, go get the logical names */
-  if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
+  if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp)
     _ckvmssts(vaxc$errno);
-  /* We use Perl's sv_gets to read from the pipe, since my_popen is
+  /* We use Perl's sv_gets to read from the pipe, since safe_popen is
    * tied to Perl's I/O layer, so it may not return a simple FILE * */
   oldrs = rs;
   rs = newSVpv("\n",1);
@@ -502,7 +504,8 @@ static int waitpid_asleep = 0;
 static unsigned long int
 pipe_exit_routine()
 {
-    unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
+    unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
+    int sts;
 
     while (open_pipes != NULL) {
       if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
@@ -511,7 +514,8 @@ pipe_exit_routine()
       }
       if (!open_pipes->done)  /* We tried to be nice . . . */
         _ckvmssts(sys$delprc(&open_pipes->pid,0));
-      if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
+      if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
+      else if (!(sts & 1)) retsts = sts;
     }
     return retsts;
 }
@@ -531,9 +535,8 @@ popen_completion_ast(struct pipe_details *thispipe)
   }
 }
 
-/*{{{  FILE *my_popen(char *cmd, char *mode)*/
-FILE *
-my_popen(char *cmd, char *mode)
+static FILE *
+safe_popen(char *cmd, char *mode)
 {
     static int handler_set_up = FALSE;
     char mbxname[64];
@@ -591,7 +594,18 @@ my_popen(char *cmd, char *mode)
         
     forkprocess = info->pid;
     return info->fp;
+}  /* end of safe_popen */
+
+
+/*{{{  FILE *my_popen(char *cmd, char *mode)*/
+FILE *
+my_popen(char *cmd, char *mode)
+{
+    TAINT_ENV();
+    TAINT_PROPER("popen");
+    return safe_popen(cmd,mode);
 }
+
 /*}}}*/
 
 /*{{{  I32 my_pclose(FILE *fp)*/
@@ -603,9 +617,11 @@ I32 my_pclose(FILE *fp)
     for (info = open_pipes; info != NULL; last = info, info = info->next)
         if (info->fp == fp) break;
 
-    if (info == NULL)
-      /* get here => no such pipe open */
-      croak("No such pipe open");
+    if (info == NULL) {  /* no such pipe open */
+      set_errno(ECHILD); /* quoth POSIX */
+      set_vaxc_errno(SS$_NONEXPR);
+      return -1;
+    }
 
     /* If we were writing to a subprocess, insure that someone reading from
      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
@@ -2741,6 +2757,8 @@ vms_do_exec(char *cmd)
   {                               /* no vfork - act VMSish */
     unsigned long int retsts;
 
+    TAINT_ENV();
+    TAINT_PROPER("exec");
     if ((retsts = setup_cmddsc(cmd,1)) & 1)
       retsts = lib$do_command(&VMScmd);
 
@@ -2774,6 +2792,8 @@ do_spawn(char *cmd)
 {
   unsigned long int substs, hadcmd = 1;
 
+  TAINT_ENV();
+  TAINT_PROPER("spawn");
   if (!cmd || !*cmd) {
     hadcmd = 0;
     _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));