diff options
| -rw-r--r-- | Changes | 192 | ||||
| -rwxr-xr-x | Configure | 161 | ||||
| -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-- | hv.c | 12 | ||||
| -rw-r--r-- | hv.h | 2 | ||||
| -rw-r--r-- | mg.c | 53 | ||||
| -rw-r--r-- | mg.h | 5 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.c | 6 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | plan9/buildinfo | 2 | ||||
| -rw-r--r-- | pod/perl.pod | 60 | ||||
| -rw-r--r-- | pod/perldelta.pod | 23 | ||||
| -rw-r--r-- | pod/perlguts.pod | 6 | ||||
| -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 | 48 | ||||
| -rw-r--r-- | pp_ctl.c | 5 | ||||
| -rw-r--r-- | pp_hot.c | 4 | ||||
| -rw-r--r-- | pp_sys.c | 156 | ||||
| -rwxr-xr-x | t/op/rand.t | 11 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/op/runlevel.t | 0 | ||||
| -rwxr-xr-x | 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 |
37 files changed, 1128 insertions, 397 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 @@ -5440,95 +5446,6 @@ esac set useperlio eval $setvar -: see if sfio.h is available -set sfio.h i_sfio -eval $inhdr - -: see if sfio library is available -case "$i_sfio" in -$define) - val='' - set sfreserve val - eval $inlibc - ;; -*) - val="$undef" - ;; -esac -: Ok, but do we want to use it. -case "$val" in -$define) - case "$usesfio" in - true|$define|[yY]*) dflt='y';; - *) dflt='n';; - esac - echo "$package can use the sfio library, but it is experimental." - rp="You seem to have sfio available, do you want to try using it?" - . ./myread - case "$ans" in - y|Y) - # If sfio is mis-configured, then the following test program - # might run and exit with 0 status but generate no output!. - # I think it has to do with sfio's use of _exit vs. exit, - # but I don't know for sure. --Andy Dougherty 2/25/97. - echo "Checking if I can use sfio in a simple test program." - $cat > try.c <<'EOM' -#include <stdio.h> -main() -{ - printf("42\n"); - exit(0); -} -EOM - echo 42 > try.42 - : Deliberately let user see errors and warnings. - if $cc $optimize $ccflags $ldflags -o try try.c $libs && - ./try > try.out && cmp try.42 try.out ; then - echo Sfio looks ok. >&4 - else - $cat >&4 <<'EOM' - -Help! I can't compile and run the following simple test program: -'EOM' - $cat try.c >&4 - $cat >&4 <<'EOM' - -(This is probably a misconfiguration in your system or libraries, and -you really ought to fix it. In the meantime, I'll just skip sfio.) - -EOM - val=$undef - fi - $rm -f try.c try try.out try.42 - ;; - *) echo "Ok, avoiding sfio this time. I'll use stdio instead." - val="$undef" - ;; - esac - case $val in - $undef) echo Removing sfio from list of libraries to use >&4 - set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'` - shift - libs="$*" - echo "libs = $libs" >&4 - ;; - esac - ;; -*) case "$usesfio" in - true|$define|[yY]*) - echo "Sorry, cannot find sfio on this machine" >&4 - echo "Ignoring your setting of usesfio=$usesfio" >&4 - ;; - esac - ;; -esac -set d_sfio -eval $setvar -case "$d_sfio" in -$define) usesfio='true';; -*) usesfio='false';; -esac - : Check how to convert floats to strings. echo " " echo "Checking for an efficient way to convert floats to strings." @@ -7429,6 +7346,59 @@ eval $inlibc set setsid d_setsid eval $inlibc +: see if sfio.h is available +set sfio.h i_sfio +eval $inhdr + + +: see if sfio library is available +case "$i_sfio" in +$define) + val='' + set sfreserve val + eval $inlibc + ;; +*) + val="$undef" + ;; +esac +: Ok, but do we want to use it. +case "$val" in +$define) + case "$usesfio" in + true|$define|[yY]*) dflt='y';; + *) dflt='n';; + esac + echo "$package can use the sfio library, but it is experimental." + rp="You seem to have sfio available, do you want to try using it?" + . ./myread + case "$ans" in + y|Y) ;; + *) echo "Ok, avoiding sfio this time. I'll use stdio instead." + val="$undef" + : Remove sfio from list of libraries to use + set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'` + shift + libs="$*" + echo "libs = $libs" >&4 + ;; + esac + ;; +*) case "$usesfio" in + true|$define|[yY]*) + echo "Sorry, cannot find sfio on this machine" >&4 + echo "Ignoring your setting of usesfio=$usesfio" >&4 + ;; + esac + ;; +esac +set d_sfio +eval $setvar +case "$d_sfio" in +$define) usesfio='true';; +*) usesfio='false';; +esac + : see if shmctl exists set shmctl d_shmctl eval $inlibc @@ -8609,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 @@ -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); } } @@ -214,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); } } @@ -315,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' @@ -110,7 +110,7 @@ struct xpvhv { sv_2mortal(newSVpv(HeKEY(he), \ HeKLEN(he)))) : \ &sv_undef) -#define HeSVKEY_set(he,sv) ((HeKEY_sv(he) = sv), (HeKLEN(he) = HEf_SVKEY)) +#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]) @@ -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. @@ -509,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; } @@ -800,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; @@ -1030,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; @@ -1140,6 +1143,7 @@ restart: my_exit_jump(); /* NOTREACHED */ case 3: + mustcatch = FALSE; if (restartop) { op = restartop; restartop = 0; @@ -2259,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 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 d202e70e56..bfdf9031ef 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -673,15 +673,14 @@ 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 that way. 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). All 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 whole C<HE*>s (hash entries), -allowing for more efficient handling of hash data. See L<perlguts> for -details. +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 @@ -692,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. @@ -1035,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 5766cc0589..95bd4eccbd 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1502,7 +1502,7 @@ mortal C<SV*> if the hash entry contains only a C<char*> key. =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. +to indicate the presence of an C<SV*> key, and returns the same C<SV*>. HeSVKEY_set(HE* he, SV* sv) @@ -1644,7 +1644,7 @@ 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. @@ -2908,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) @@ -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; @@ -1946,10 +1946,10 @@ OP *o; { int ret; int oldrunlevel = runlevel; + OP *oldop = op; Sigjmp_buf oldtop; op = o; - runlevel--; /* pretense */ Copy(top_env, oldtop, 1, Sigjmp_buf); #ifdef DEBUGGING assert(mustcatch == TRUE); @@ -1960,6 +1960,7 @@ OP *o; Copy(oldtop, top_env, 1, Sigjmp_buf); runlevel = oldrunlevel; mustcatch = TRUE; + op = oldop; Siglongjmp(top_env, ret); /* NOTREACHED */ case 3: @@ -1967,6 +1968,7 @@ OP *o; PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); break; } + mustcatch = FALSE; op = restartop; restartop = 0; /* FALL THROUGH */ @@ -1977,6 +1979,7 @@ OP *o; Copy(oldtop, top_env, 1, Sigjmp_buf); runlevel = oldrunlevel; mustcatch = TRUE; + op = oldop; return Nullop; } @@ -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; @@ -1123,7 +1123,7 @@ PP(pp_sysread) IO *io; char *buffer; int length; - int bufsize; + Sock_size_t bufsize; SV *bufsv; STRLEN blen; @@ -1339,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) @@ -1351,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; @@ -1359,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) @@ -1685,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; @@ -1777,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)); @@ -1798,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); } @@ -1853,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; @@ -2578,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); @@ -2873,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); @@ -2927,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); @@ -2935,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; @@ -3481,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)); @@ -3547,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); } @@ -3564,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; @@ -3617,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); } @@ -3634,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; @@ -3700,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 @@ -3722,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); @@ -3866,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); } @@ -3879,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); @@ -3910,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; @@ -3980,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); } @@ -3993,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 index ca6aac5e5b..ca6aac5e5b 100644..100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t diff --git a/t/op/taint.t b/t/op/taint.t new file mode 100755 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)); |