diff options
| author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-02-25 13:12:02 +1200 |
|---|---|---|
| committer | Chip Salzenberg <chip@atlantic.net> | 1997-02-25 13:12:02 +1200 |
| commit | 1e422769b80038b1bfc4f5af33438b87cc1c7a22 (patch) | |
| tree | 0f5d892c1c73cebd66d4336f658f001935d92898 | |
| parent | 2f9daededa74ef1264bd2c46743008f84bff0cfc (diff) | |
| download | perl-1e422769b80038b1bfc4f5af33438b87cc1c7a22.tar.gz | |
[inseparable changes from match from perl-5.003_90 to perl-5.003_91]
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 907a881cde89c56bc61d3f314c0efb8754ca472a, 20efc0829f6564c44574762adb07e8865bc14026)
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
| -rw-r--r-- | Changes | 192 | ||||
| -rwxr-xr-x | Configure | 19 | ||||
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rwxr-xr-x | configure | 2 | ||||
| -rwxr-xr-x | configure.gnu | 2 | ||||
| -rw-r--r-- | doio.c | 2 | ||||
| -rw-r--r-- | embed.h | 3 | ||||
| -rw-r--r-- | gv.c | 3 | ||||
| -rw-r--r-- | hv.c | 13 | ||||
| -rw-r--r-- | hv.h | 10 | ||||
| -rw-r--r-- | interp.sym | 1 | ||||
| -rw-r--r-- | mg.c | 53 | ||||
| -rw-r--r-- | mg.h | 5 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.c | 15 | ||||
| -rw-r--r-- | perl.h | 9 | ||||
| -rw-r--r-- | plan9/buildinfo | 2 | ||||
| -rw-r--r-- | pod/perl.pod | 60 | ||||
| -rw-r--r-- | pod/perldelta.pod | 17 | ||||
| -rw-r--r-- | pod/perlguts.pod | 162 | ||||
| -rw-r--r-- | pod/perllocale.pod | 2 | ||||
| -rw-r--r-- | pod/perlrun.pod | 68 | ||||
| -rw-r--r-- | pod/perlsec.pod | 25 | ||||
| -rw-r--r-- | pod/perltoc.pod | 79 | ||||
| -rw-r--r-- | pod/pod2man.PL | 23 | ||||
| -rw-r--r-- | pp.c | 50 | ||||
| -rw-r--r-- | pp_ctl.c | 56 | ||||
| -rw-r--r-- | pp_hot.c | 4 | ||||
| -rw-r--r-- | pp_sys.c | 162 | ||||
| -rwxr-xr-x | t/op/rand.t | 11 | ||||
| -rw-r--r-- | t/op/runlevel.t | 308 | ||||
| -rw-r--r-- | t/op/taint.t | 414 | ||||
| -rw-r--r-- | taint.c | 48 | ||||
| -rw-r--r-- | toke.c | 10 | ||||
| -rw-r--r-- | util.c | 2 | ||||
| -rw-r--r-- | utils/perldoc.PL | 30 | ||||
| -rw-r--r-- | vms/config.vms | 2 | ||||
| -rw-r--r-- | vms/descrip.mms | 15 | ||||
| -rw-r--r-- | vms/vms.c | 40 |
39 files changed, 1618 insertions, 305 deletions
@@ -9,6 +9,198 @@ 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 ---------------- @@ -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 @@ -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 @@ -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/configure.gnu b/configure.gnu index 98876ccff8..fa46532094 100755 --- a/configure.gnu +++ b/configure.gnu @@ -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 ;; @@ -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; @@ -1256,6 +1256,7 @@ #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) @@ -1408,6 +1409,7 @@ #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 @@ -1569,6 +1571,7 @@ #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 @@ -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; @@ -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' @@ -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]) diff --git a/interp.sym b/interp.sym index ec9c038986..a82c2c4843 100644 --- a/interp.sym +++ b/interp.sym @@ -85,6 +85,7 @@ minus_l minus_n minus_p multiline +mustcatch mystack_base mystack_mark mystack_max @@ -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; } @@ -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) : \ diff --git a/patchlevel.h b/patchlevel.h index 47ca5dd51a..0d6595bf41 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 90 +#define SUBVERSION 91 /* local_patches -- list of locally applied less-than-subversion patches. @@ -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 @@ -256,6 +256,12 @@ #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 */ diff --git a/plan9/buildinfo b/plan9/buildinfo index 4d4407eade..96639c3eb2 100644 --- a/plan9/buildinfo +++ b/plan9/buildinfo @@ -1 +1 @@ -p9pvers = 5.003_90 +p9pvers = 5.003_91 diff --git a/pod/perl.pod b/pod/perl.pod index e306037551..99f996f130 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -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 diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 23f216fce6..bfdf9031ef 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -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 diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 77acc98aae..95bd4eccbd 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -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 diff --git a/pod/perllocale.pod b/pod/perllocale.pod index 41a0bc5d8b..15138677d2 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -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. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index df606bf0ea..f90e642d40 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -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'}; + diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 3e44e5bea4..6089431a2a 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -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 diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 01a03f3e05..551f444c31 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -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 diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 934d525cd8..d1ba2287cd 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -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\\&}); } @@ -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; @@ -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; } @@ -1935,6 +1941,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) @@ -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; @@ -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); diff --git a/t/op/rand.t b/t/op/rand.t index 9e4d69284e..4eeca6b10c 100755 --- a/t/op/rand.t +++ b/t/op/rand.t @@ -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 index 0000000000..ca6aac5e5b --- /dev/null +++ b/t/op/runlevel.t @@ -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 index 0000000000..32277181f6 --- /dev/null +++ b/t/op/taint.t @@ -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; +} @@ -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}"); } @@ -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; } @@ -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; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index b311c7652d..7febd0127d 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -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; } } diff --git a/vms/config.vms b/vms/config.vms index 2cec4f20be..5a24c33609 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -76,7 +76,7 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00390" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00391" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ /* ARCHNAME: diff --git a/vms/descrip.mms b/vms/descrip.mms index 358ec3553f..fc264ff99d 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_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 @@ -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)); |