From c90c0ff485be15aaf3ee20121299cb014ee6b1ff Mon Sep 17 00:00:00 2001 From: Perl 5 Porters Date: Fri, 16 May 1997 10:15:00 +1200 Subject: [PATCH] [inseparable changes from match from perl-5.003_99a to perl5.004] BUILD PROCESS Subject: Don't use 'unset' in Configure From: Chip Salzenberg Files: Configure Subject: Protect against having no such command as 'cc' Date: Mon, 12 May 1997 16:35:34 -0400 (EDT) From: Hans Mulder Files: Configure Msg-ID: 1997May12.163534.2006434@hmivax.humgen.upenn.edu (applied based on p5p patch as commit 3bf198a5e20d135d4136d3233d58cf49a70772d9) Subject: minor wording enhancement for Configure Date: Sat, 10 May 1997 13:38:31 +0300 (EET DST) From: Jarkko Hietaniemi Files: Configure private-msgid: 199705101038.NAA00471@alpha.hut.fi CORE LANGUAGE CHANGES Subject: Make C reset pos on failure; make C not reset From: Chip Salzenberg Files: dump.c op.c op.h pod/perldelta.pod pod/perlfaq6.pod pod/perlop.pod pod/perlre.pod pp_ctl.c pp_hot.c regcomp.c t/op/pat.t toke.c Subject: SECURITY: Forbid exec() if $ENV{BASH_ENV} is tainted From: Chip Salzenberg Files: pod/perldelta.pod pod/perlrun.pod pod/perlsec.pod t/op/taint.t taint.c Subject: Allow exec() if $ENV{TERM} is tainted but innocuous From: Chip Salzenberg Files: pod/perldelta.pod pod/perlrun.pod pod/perlsec.pod t/op/taint.t taint.c Subject: Allow globbing when tainted under VMS (no external program) From: Chip Salzenberg Files: pp_sys.c t/op/taint.t CORE PORTABILITY Subject: Win32 update (three patches) From: Gurusamy Sarathy Files: README.win32 perl.c win32/Makefile win32/config.H win32/config_h.PL win32/config_sh.PL win32/makedef.pl win32/win32.c win32/win32.h win32/win32io.c win32/win32io.h win32/win32iop.h Subject: Don't require executable bit on perl -S if DOSISH Date: Fri, 09 May 1997 12:33:18 -0400 From: Danny Sadinoff Files: perl.c Msg-ID: 337351CE.79B28DE3@olf.com (applied based on p5p patch as commit 7596f71a28f72f9e3abd6d3962d29a7752cd9303) DOCUMENTATION Subject: Tweaks for perldelta Date: Sun, 11 May 97 01:46:00 +0200 From: Unknown Contributor Files: pod/perldelta.pod Msg-ID: 199705102346.BAA17300@mail.euronet.nl (applied based on p5p patch as commit 3e10809228cc961223b894e1639b44f8e2b64de0) Subject: Mention perlfaq.pod and perlmodlib.pod in perldelta.pod From: Chip Salzenberg Files: pod/perldelta.pod Subject: Fix example of use of lexicals with formats From: Chip Salzenberg Files: pod/perldelta.pod OTHER CORE CHANGES Subject: In C, always call &func in scalar context From: Chip Salzenberg Files: op.c Subject: Fix recursive substitution From: Chip Salzenberg Files: cop.h global.sym pp_ctl.c proto.h scope.c Subject: Fix core dump from get*() functions returning no alias array From: Chip Salzenberg Files: pp_sys.c Subject: Fix typo Date: Sat, 10 May 1997 17:28:35 -0500 From: Mark K Trettin Files: pp_sys.c private-msgid: 199705102228.RAA11163@gv18c.ih.lucent.com --- Changes | 176 +++++++++++++++++++++++++++++ Configure | 14 ++- README.win32 | 54 +++++++-- cop.h | 12 +- dump.c | 10 +- embed.h | 3 + global.sym | 3 + installperl | 2 +- op.c | 12 +- op.h | 5 +- patchlevel.h | 5 +- perl.c | 9 +- plan9/buildinfo | 2 +- pod/perldelta.pod | 83 +++++++++----- pod/perlfaq1.pod | 12 +- pod/perlfaq6.pod | 20 ++-- pod/perlop.pod | 56 +++++----- pod/perlrun.pod | 5 +- pod/perlsec.pod | 5 +- pod/perltoc.pod | 37 +++++-- pp_ctl.c | 81 +++++++++++++- pp_hot.c | 7 ++ pp_sys.c | 12 +- proto.h | 3 + regcomp.c | 2 +- scope.c | 4 +- t/op/pat.t | 7 +- t/op/taint.t | 317 +++++++++++++++++++++++++++-------------------------- taint.c | 25 ++++- toke.c | 6 +- win32/Makefile | 28 +++-- win32/config.H | 5 +- win32/config_h.PL | 6 +- win32/config_sh.PL | 6 +- win32/makedef.pl | 1 + win32/win32.c | 41 +------ win32/win32.h | 9 +- win32/win32io.c | 47 ++++++++ win32/win32io.h | 1 + win32/win32iop.h | 10 ++ 40 files changed, 790 insertions(+), 353 deletions(-) diff --git a/Changes b/Changes index 8677e9e..0b1317d 100644 --- a/Changes +++ b/Changes @@ -45,6 +45,182 @@ And the Keepers of the Patch Pumpkin: Chip Salzenberg +------------- +Version 5.004 +------------- + +"Hey, Rocky! Watch me pull a release out of my hat!" +"Aww, that trick never works..." + + CORE LANGUAGE CHANGES + + Title: "Make C reset pos on failure; make C not reset" + From: Chip Salzenberg + Files: dump.c op.c op.h pod/perldelta.pod pod/perlfaq6.pod + pod/perlop.pod pod/perlre.pod pp_ctl.c pp_hot.c regcomp.c + t/op/pat.t toke.c + + Title: "SECURITY: Forbid exec() if $ENV{BASH_ENV} is tainted" + From: Chip Salzenberg + Files: pod/perldelta.pod pod/perlrun.pod pod/perlsec.pod t/op/taint.t + taint.c + + Title: "Allow exec() if $ENV{TERM} is tainted but innocuous" + From: Chip Salzenberg + Files: pod/perldelta.pod pod/perlrun.pod pod/perlsec.pod t/op/taint.t + taint.c + + Title: "Allow globbing when tainted under VMS (no external program)" + From: Chip Salzenberg + Files: pp_sys.c t/op/taint.t + + CORE PORTABILITY + + Title: "Make Irix hints adapt when n32 libm.so is missing" + From: Chip Salzenberg + Files: hints/irix_6.sh + + Title: "Fix default HP-UX installation path" + From: Jeff Okamoto + Msg-ID: <199705132228.AA227042483@hpcc123.corp.hp.com> + Date: Tue, 13 May 1997 15:28:04 -0700 + Files: hints/hpux.sh + + Title: "VMS update, including socket support (four patches)" + From: Jonathan Hudson , + Peter Prymmer , + Dan Sugalski + Files: vms/config.vms vms/descrip.mms vms/sockadapt.h vms/vms.c + vms/vmsish.h + + Title: "Win32 update (three patches)" + From: Gurusamy Sarathy + Files: README.win32 perl.c win32/Makefile win32/config.H + win32/config_h.PL win32/config_sh.PL win32/makedef.pl + win32/win32.c win32/win32.h win32/win32io.c win32/win32io.h + win32/win32iop.h + + Title: "Don't require executable bit on perl -S if DOSISH" + From: Danny Sadinoff + Msg-ID: <337351CE.79B28DE3@olf.com> + Date: Fri, 09 May 1997 12:33:18 -0400 + Files: perl.c + + OTHER CORE CHANGES + + Title: "In C, always call &func in scalar context" + From: Chip Salzenberg + Files: op.c + + Title: "Fix recursive substitution" + From: Chip Salzenberg; test from Tim Bunce + Files: cop.h global.sym pp_ctl.c proto.h scope.c t/op/subst.t + + Title: "Make read with <> from a TTY notice EOF" + From: Jonathan I. Kamens + Msg-ID: <199705121147.HAA03845@jik.saturn.net> + Date: Mon, 12 May 1997 07:47:13 -0400 + Files: sv.c + + Title: "Fix core dump from get*() functions returning no alias array" + From: Chip Salzenberg + Files: pp_sys.c + + Title: "Fix typo" + From: Mark K Trettin + Msg-ID: <199705102228.RAA11163@gv18c.ih.lucent.com> + Date: Sat, 10 May 1997 17:28:35 -0500 + Files: pp_sys.c + + BUILD PROCESS + + Title: "Don't use 'unset' in Configure" + From: Chip Salzenberg + Files: Configure + + Title: "Protect against having no such command as 'cc'" + From: Hans Mulder + Msg-ID: <1997May12.163534.2006434@hmivax.humgen.upenn.edu> + Date: Mon, 12 May 1997 16:35:34 -0400 (EDT) + Files: Configure + + Title: "minor wording enhancement for Configure" + From: Jarkko Hietaniemi + Msg-ID: <199705101038.NAA00471@alpha.hut.fi> + Date: Sat, 10 May 1997 13:38:31 +0300 (EET DST) + Files: Configure + + LIBRARY AND EXTENSIONS + + Title: "Refresh CGI.pm to 2.36" + From: Lincoln Stein + Files: eg/cgi/frameset.cgi eg/cgi/javascript.cgi lib/CGI.pm + + Title: "In IO::File::open, prepend './' less often (for Win32 et al)" + From: Chip Salzenberg + Files: ext/IO/lib/IO/File.pm + + Title: "Fix core dump on IO::Seekable::setpos($fh, undef)" + From: Chip Salzenberg + Files: ext/IO/IO.xs t/lib/io_xs.t + + TESTS + + Title: "Make rand.t vanishingly unlikely to give false failure" + From: Tom Phoenix + Msg-ID: + Date: Sat, 10 May 1997 19:57:30 -0700 (PDT) + Files: t/op/rand.t + + Title: "Fix sleep test: sleep(N) is defined to allow sleeping N-1" + From: Chuck D. Phillips + Msg-ID: <199705151735.KAA01143@palrel1.hp.com> + Date: Thu, 15 May 1997 11:35:41 -0600 + Files: t/op/sleep.t + + UTILITIES + + Title: "h2xs and @EXPORT_OK" + From: Jeff Okamoto + Msg-ID: <199705092348.AA057881699@hpcc123.corp.hp.com> + Date: Fri, 9 May 1997 16:48:20 -0700 + Files: utils/h2xs.PL + + DOCUMENTATION + + Title: "Tweaks for perldelta" + From: hansm@euronet.nl + Msg-ID: <199705102346.BAA17300@mail.euronet.nl> + Date: Sun, 11 May 97 01:46:00 +0200 + Files: pod/perldelta.pod + + Title: "Mention perlfaq.pod and perlmodlib.pod in perldelta.pod" + From: Chip Salzenberg + Files: pod/perldelta.pod + + Title: "Fix example of use of lexicals with formats" + From: Chip Salzenberg + Files: pod/perldelta.pod + + Title: "Explain that destruction order is not defined" + From: Gurusamy Sarathy + Msg-ID: <199705150600.CAA13550@aatma.engin.umich.edu> + Date: Thu, 15 May 1997 02:00:23 -0400 + Files: pod/perltoot.pod + + Title: "Note that DATA filehandle is unavailable during BEGIN {}" + From: neilb@cre.canon.co.uk (Neil Bowers) + Msg-ID: <199705121227.NAA29718@tardis.cre.canon.co.uk> + Date: Mon, 12 May 1997 13:27:43 +0100 + Files: pod/perldata.pod + + Title: "More detailed IO::Socket documentation" + From: Tom Christiansen + Msg-ID: <199705141456.IAA19061@jhereg.perl.com> + Date: Wed, 14 May 1997 08:56:30 -0600 + Files: pod/perlipc.pod + + ----------------- Version 5.003_99a ----------------- diff --git a/Configure b/Configure index 6eedea8..0071a7c 100755 --- a/Configure +++ b/Configure @@ -85,8 +85,11 @@ done PATH=.$p_$PATH export PATH -: This should not matter in a script, but apparently it does sometimes -unset CDPATH +: This should not matter in scripts, but apparently it does, sometimes +case "$CDPATH" in +'') ;; +*) CDPATH='' ;; +esac : Sanity checks if test ! -t 0; then @@ -115,6 +118,7 @@ EOM especially on older exotic systems. If yours does, try the Bourne shell instead.) EOM + unset ENV fi fi else @@ -2997,8 +3001,8 @@ main() { #endif } EOP - cc -o pdp11 pdp11.c >/dev/null 2>&1 - if ./pdp11 2>/dev/null; then + (cc -o pdp11 pdp11.c) >/dev/null 2>&1 + if $test -f pdp11 && ./pdp11 2>/dev/null; then dflt='unsplit split' else tans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge` @@ -8285,7 +8289,7 @@ EOCP if $cc $optimize $ccflags $ldflags -o try try.c $libs && ./try; then echo 'Looks OK. (Perl supports up to version 1.86).' >&4 else - echo "I can't use your Berkeley DB. I'll disable it." >&4 + echo "I can't use Berkeley DB with your . I'll disable Berkeley DB." >&4 i_db=$undef case " $libs " in *"-ldb "*) diff --git a/README.win32 b/README.win32 index 8f1ff1b..fe5d85a 100644 --- a/README.win32 +++ b/README.win32 @@ -49,7 +49,7 @@ compilers that can generally be used to build Win32 applications. This port currently supports MakeMaker (the set of modules that is used to build extensions to perl). Therefore, you should be able to build and install most extensions found in the CPAN sites. -See the L section for general hints about this. +See L below for general hints about this. =head2 Setting Up @@ -59,8 +59,9 @@ See the L section for general hints about this. Use the default "cmd" shell that comes with NT. In particular, do *not* use the 4DOS/NT shell. The Makefile has commands that are not -compatible with that shell. You are mostly on your own if you can -muster the temerity to attempt this with Windows95. +compatible with that shell. The Makefile also has known +incompatibilites with the default shell that comes with Windows95, +so building under Windows95 should be considered "unsupported". =item * @@ -98,10 +99,22 @@ versions of NMAKE that come with Visual C++ ver. 2.0 and above. Edit the Makefile and change the values of INST_DRV and INST_TOP if you want perl to be installed in a location other than "C:\PERL". +If you want to build a perl capable of running on the Windows95 +platform, you will have to uncomment the line that sets "RUNTIME=-MT". +(The default settings use the Microsoft-recommended -MD option for +compiling, which uses the DLL version of the C RunTime Library. There +currently exists a bug in the Microsoft CRTL that causes failure of +the socket calls only on the Windows95 platform. This bug cannot be +worked around if the DLL version of the CRTL is used, which is why you +need to enable the -MT flag.) Perl compiled with -MT can be used on +both Windows NT and Windows95. + +If you are using Visual C++ ver. 2.0, uncomment the line that +sets "CCTYPE=MSVC20". + =item * -If you are using Visual C++ ver. 4.0 and above: type "nmake". -If you are using a Visual C++ ver. 2.0: type "nmake CCTYPE=MSVC20". +Type "nmake". This should build everything. Specifically, it will create perl.exe, perl.dll, and perlglob.exe at the perl toplevel, and various other @@ -221,7 +234,7 @@ This pipes "foo" to the pager and writes "bar" in the file "blurch": perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less -Discovering the usage of the "command.com" shell on Windows 95 +Discovering the usage of the "command.com" shell on Windows95 is left as an exercise to the reader :) =item Building Extensions @@ -253,6 +266,33 @@ it looks like the extension building support is at fault, report that with full details of how the build failed using the perlbug utility. +=item Win32 Specific Extensions + +A number of extensions specific to the Win32 platform are available +from CPAN. You may find that many of these extensions are meant to +be used under the Activeware port of Perl, which used to be the only +native port for the Win32 platform. Since the Activeware port does not +have adequate support for Perl's extension building tools, these +extensions typically do not support those tools either, and therefore +cannot be built using the generic steps shown in the previous section. + +To ensure smooth transitioning of existing code that uses the +Activeware port, there is a bundle of Win32 extensions that contains +all of the Activeware extensions and most other Win32 extensions from +CPAN in source form, along with many added bugfixes, and with MakeMaker +support. This bundle is available at: + + http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.06.tar.gz + +See the README in that distribution for building and installation +instructions. Look for later versions that may be available at the +same location. + +It is expected that authors of Win32 specific extensions will begin +distributing their work in MakeMaker compatible form subsequent to +the 5.004 release of perl, at which point the need for a dedicated +bundle such as the above should diminish. + =item Miscellaneous Things A full set of HTML documentation is installed, so you should be @@ -379,6 +419,6 @@ at the time. Nick Ing-Simmons and Gurusamy Sarathy have made numerous and sundry hacks since then. -Last updated: 13 April 1997 +Last updated: 15 May 1997 =cut diff --git a/cop.h b/cop.h index 3383ceb..baedc5a 100644 --- a/cop.h +++ b/cop.h @@ -210,7 +210,7 @@ struct subst { char * sbu_s; char * sbu_m; char * sbu_strend; - char * sbu_subbase; + void * sbu_rxres; REGEXP * sbu_rx; }; #define sb_iters cx_u.cx_subst.sbu_iters @@ -225,7 +225,7 @@ struct subst { #define sb_s cx_u.cx_subst.sbu_s #define sb_m cx_u.cx_subst.sbu_m #define sb_strend cx_u.cx_subst.sbu_strend -#define sb_subbase cx_u.cx_subst.sbu_subbase +#define sb_rxres cx_u.cx_subst.sbu_rxres #define sb_rx cx_u.cx_subst.sbu_rx #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \ @@ -241,11 +241,13 @@ struct subst { cx->sb_s = s, \ cx->sb_m = m, \ cx->sb_strend = strend, \ - cx->sb_subbase = Nullch, \ + cx->sb_rxres = Null(void*), \ cx->sb_rx = rx, \ - cx->cx_type = CXt_SUBST + cx->cx_type = CXt_SUBST; \ + rxres_save(&cx->sb_rxres, rx) -#define POPSUBST(cx) cxstack_ix-- +#define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \ + rxres_free(&cx->sb_rxres) struct context { I32 cx_type; /* what kind of context this is */ diff --git a/dump.c b/dump.c index 2a45e75..9bd51ac 100644 --- a/dump.c +++ b/dump.c @@ -354,7 +354,11 @@ register PMOP *pm; else ch = '/'; if (pm->op_pmregexp) - dump("PMf_PRE %c%s%c\n",ch,pm->op_pmregexp->precomp,ch); + dump("PMf_PRE %c%s%c%s\n", + ch, pm->op_pmregexp->precomp, ch, + (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); + else + dump("PMf_PRE (RUNTIME)\n"); if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) { dump("PMf_REPL = "); dump_op(pm->op_pmreplroot); @@ -380,8 +384,8 @@ register PMOP *pm; sv_catpv(tmpsv, ",KEEP"); if (pm->op_pmflags & PMf_GLOBAL) sv_catpv(tmpsv, ",GLOBAL"); - if (pm->op_pmflags & PMf_RUNTIME) - sv_catpv(tmpsv, ",RUNTIME"); + if (pm->op_pmflags & PMf_CONTINUE) + sv_catpv(tmpsv, ",CONTINUE"); if (pm->op_pmflags & PMf_EVAL) sv_catpv(tmpsv, ",EVAL"); dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); diff --git a/embed.h b/embed.h index 7246cf2..0ad53a7 100644 --- a/embed.h +++ b/embed.h @@ -903,6 +903,9 @@ #define rsignal_save Perl_rsignal_save #define rsignal_state Perl_rsignal_state #define runops Perl_runops +#define rxres_free Perl_rxres_free +#define rxres_restore Perl_rxres_restore +#define rxres_save Perl_rxres_save #define same_dirent Perl_same_dirent #define save_I16 Perl_save_I16 #define save_I32 Perl_save_I32 diff --git a/global.sym b/global.sym index 49d6df0..50f8c53 100644 --- a/global.sym +++ b/global.sym @@ -997,6 +997,9 @@ rsignal_save rsignal_state rsignal_restore runops +rxres_free +rxres_restore +rxres_save safecalloc safemalloc safefree diff --git a/installperl b/installperl index ad1ad91..9686bfb 100755 --- a/installperl +++ b/installperl @@ -1,7 +1,7 @@ #!./perl BEGIN { - require 5.003_90; + require 5.004; @INC = 'lib'; $ENV{PERL5LIB} = 'lib'; } diff --git a/op.c b/op.c index 75d7583..6c85530 100644 --- a/op.c +++ b/op.c @@ -831,8 +831,11 @@ OP *op; for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_ENTEREVAL: + scalarkids(op); + break; case OP_REQUIRE: - /* since all requires must return a value, they're never void */ + /* all requires must return a boolean value */ op->op_flags &= ~OPf_WANT; return scalar(op); case OP_SPLIT: @@ -918,6 +921,10 @@ OP *op; } curcop = &compiling; break; + case OP_REQUIRE: + /* all requires must return a boolean value */ + op->op_flags &= ~OPf_WANT; + return scalar(op); } return op; } @@ -4276,8 +4283,7 @@ OP * ck_match(op) OP *op; { - cPMOP->op_pmflags |= PMf_RUNTIME; - cPMOP->op_pmpermflags |= PMf_RUNTIME; + op->op_private |= OPpRUNTIME; return op; } diff --git a/op.h b/op.h index 961ebcf..d58f825 100644 --- a/op.h +++ b/op.h @@ -89,6 +89,9 @@ typedef U32 PADOFFSET; /* Private for OP_SASSIGN */ #define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */ +/* Private for OP_MATCH and OP_SUBST{,CONST} */ +#define OPpRUNTIME 64 /* Pattern coming in on the stack */ + /* Private for OP_TRANS */ #define OPpTRANS_SQUASH 16 #define OPpTRANS_DELETE 32 @@ -185,7 +188,7 @@ struct pmop { #define PMf_CONST 0x0040 /* subst replacement is constant */ #define PMf_KEEP 0x0080 /* keep 1st runtime pattern forever */ #define PMf_GLOBAL 0x0100 /* pattern had a g modifier */ -#define PMf_RUNTIME 0x0200 /* pattern coming in on the stack */ +#define PMf_CONTINUE 0x0200 /* don't reset pos() if //g fails */ #define PMf_EVAL 0x0400 /* evaluating replacement as expr */ #define PMf_WHITE 0x0800 /* pattern is \s+ */ #define PMf_MULTILINE 0x1000 /* assume multiple lines */ diff --git a/patchlevel.h b/patchlevel.h index 4d3c4dd..6d795a0 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ -#define PATCHLEVEL 3 -#define SUBVERSION 99 +#define PATCHLEVEL 4 +#define SUBVERSION 0 /* local_patches -- list of locally applied less-than-subversion patches. @@ -38,7 +38,6 @@ */ static char *local_patches[] = { NULL - ,"Dev99A - First post-gamma development patch" ,NULL }; diff --git a/perl.c b/perl.c index 8af7172..3b57a48 100644 --- a/perl.c +++ b/perl.c @@ -1706,7 +1706,12 @@ SV *sv; if (retval < 0) continue; if (S_ISREG(statbuf.st_mode) - && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { + && cando(S_IRUSR,TRUE,&statbuf) +#ifndef DOSISH + && cando(S_IXUSR,TRUE,&statbuf) +#endif + ) + { xfound = tokenbuf; /* bingo! */ break; } @@ -2387,7 +2392,7 @@ init_perllib() #endif /* VMS */ } -/* Use the ~-expanded versions of APPLIB (undocumented), +/* Use the ~-expanded versions of APPLLIB (undocumented), ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB */ #ifdef APPLLIB_EXP diff --git a/plan9/buildinfo b/plan9/buildinfo index f2d685c..9ec2c59 100644 --- a/plan9/buildinfo +++ b/plan9/buildinfo @@ -1 +1 @@ -p9pvers = 5.003_99 +p9pvers = 5.004 diff --git a/pod/perldelta.pod b/pod/perldelta.pod index a8c0909..9c85450 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -16,8 +16,8 @@ cannot be built there, for lack of a reasonable command interpreter. =head1 Core Changes -Most importantly, many bugs were fixed. See the F -file in the distribution for details. +Most importantly, many bugs were fixed, including several security +problems. See the F file in the distribution for details. =head2 Compilation option: Binary compatibility with 5.003 @@ -36,7 +36,7 @@ variable as if its contents had appeared on a "#!perl" line at the beginning of your script, except that hyphens are optional. PERL5OPT may only be used to set the following switches: B<-[DIMUdmw]>. -=head2 Limitations on B<-M>, and C<-m>, and B<-T> options +=head2 Limitations on B<-M>, B<-m>, and B<-T> options The C<-M> and C<-m> options are no longer allowed on the C<#!> line of a script. If a script needs a module, it should invoke it with the @@ -158,6 +158,33 @@ previously-working script to now fail -- which should be construed as a blessing, since that indicates a potentially-serious security hole was just plugged. +The new restrictions when tainting include: + +=over + +=item No glob() or <*> + +These operators may spawn the C shell (csh), which cannot be made +safe. This restriction will be lifted in a future version of Perl +when globbing is implemented without the use of an external program. + +=item No spawning if tainted $CDPATH, $ENV, $BASH_ENV + +These environment variables may alter the behavior of spawned programs +(especially shells) in ways that subvert security. So now they are +treated as dangerous, in the manner of $IFS and $PATH. + +=item No spawning if tainted $TERM doesn't look like a terminal name + +Some termcap libraries do unsafe things with $TERM. However, it would be +unnecessarily harsh to treat all $TERM values as unsafe, since only shell +metacharacters can cause trouble in $TERM. So a tainted $TERM is +considered to be safe if it contains only alphanumerics, underscores, +dashes, and colons, and unsafe if it contains other characters (including +whitespace). + +=back + =head2 New Opcode module and revised Safe module A new Opcode module supports the creation, manipulation and @@ -182,8 +209,8 @@ it is now merely a front end to the IO::* modules -- specifically, IO::Handle, IO::Seekable, and IO::File. We suggest, but do not require, that you use the IO::* modules in new code. -In harmony with this change, C<*GLOB{FILEHANDLE}> is now a -backward-compatible synonym for C<*STDOUT{IO}>. +In harmony with this change, C<*GLOB{FILEHANDLE}> is now just a +backward-compatible synonym for C<*GLOB{IO}>. =head2 Internal change: PerlIO abstraction interface @@ -415,25 +442,16 @@ of course, or if you want a seed other than the default. Functions documented in the Camel to default to $_ now in fact do, and all those that do are so documented in L. -=item C does not reset search position on failure +=item C does not reset search position on failure -The C match iteration construct used to reset its target string's -search position (which is visible through the C operator) when a -match failed; as a result, the next C match would start at the -beginning of the string). With Perl 5.004, the search position must be -reset explicitly, as with C, or by modifying the target -string. This change in Perl makes it possible to chain matches together -in conjunction with the C<\G> zero-width assertion. See L and -L. - -Here is an illustration of what it takes to get the old behavior: - - for ( qw(this and that are not what you think you got) ) { - while ( /(\w*t\w*)/g ) { print "t word is: $1\n" } - pos = 0; # REQUIRED FOR 5.004 - while ( /(\w*a\w*)/g ) { print "a word is: $1\n" } - print "\n"; - } +The C match iteration construct has always reset its target +string's search position (which is visible through the C operator) +when a match fails; as a result, the next C match after a failure +starts again at the beginning of the string. With Perl 5.004, this +reset may be disabled by adding the "c" (for "continue") modifier, +i.e. C. This feature, in conjunction with the C<\G> zero-width +assertion, makes it possible to chain matches together. See L +and L. =item C ignores whitespace before ?*+{} @@ -452,16 +470,16 @@ right. They do now. Just like anonymous functions that contain lexical variables that change (like a lexical index variable for a C loop), formats now work properly. For example, this silently failed -before, and is fine now: +before (printed only zeros), but is fine now: my $i; foreach $i ( 1 .. 10 ) { - format = + write; + } + format = my i is @# $i . - write; - } =back @@ -1057,6 +1075,10 @@ new pods are included in section 1: This document. +=item L + +Frequently asked questions. + =item L Locale support (internationalization and localization). @@ -1069,6 +1091,11 @@ Tutorial on Perl OO programming. Perl internal IO abstraction interface. +=item L + +Perl module library and recommended practice for module creation. +Extracted from L (which is much smaller as a result). + =item L Although not new, this has been massively updated. @@ -1519,4 +1546,4 @@ Constructed by Tom Christiansen, grabbing material with permission from innumerable contributors, with kibitzing by more than a few Perl porters. -Last update: Sat Mar 8 19:51:26 EST 1997 +Last update: Wed May 14 11:14:09 EDT 1997 diff --git a/pod/perlfaq1.pod b/pod/perlfaq1.pod index 6af40ae..a9a5fd4 100644 --- a/pod/perlfaq1.pod +++ b/pod/perlfaq1.pod @@ -50,12 +50,12 @@ users the informal support will more than suffice. See the answer to =head2 Which version of Perl should I use? You should definitely use version 5. Version 4 is old, limited, and -no longer maintained. Its last patch (4.036) was in 1992. The last -production release was 5.003, and the current experimental release for -those at the bleeding edge (as of 27/03/97) is 5.003_92, considered a beta -for production release 5.004, which will probably be out by the time -you read this. Further references to the Perl language in this document -refer to the current production release unless otherwise specified. +no longer maintained; its last patch (4.036) was in 1992. The most +recent production release is 5.004. Further references to the Perl +language in this document refer to this production release unless +otherwise specified. There may be one or more official bug fixes for +5.004 by the time you read this, and also perhaps some experimental +versions on the way to the next release. =head2 What are perl4 and perl5? diff --git a/pod/perlfaq6.pod b/pod/perlfaq6.pod index d21a111..535e464 100644 --- a/pod/perlfaq6.pod +++ b/pod/perlfaq6.pod @@ -479,15 +479,17 @@ Or, using C<\G>, the much simpler (and faster): A more sophisticated use might involve a tokenizer. The following lex-like example is courtesy of Jeffrey Friedl. It did not work in -5.003 due to bugs in that release, but does work in 5.004 or better: +5.003 due to bugs in that release, but does work in 5.004 or better. +(Note the use of C, which prevents a failed match with C from +resetting the search position back to the beginning of the string.) while (<>) { chomp; PARSER: { - m/ \G( \d+\b )/gx && do { print "number: $1\n"; redo; }; - m/ \G( \w+ )/gx && do { print "word: $1\n"; redo; }; - m/ \G( \s+ )/gx && do { print "space: $1\n"; redo; }; - m/ \G( [^\w\d]+ )/gx && do { print "other: $1\n"; redo; }; + m/ \G( \d+\b )/gcx && do { print "number: $1\n"; redo; }; + m/ \G( \w+ )/gcx && do { print "word: $1\n"; redo; }; + m/ \G( \s+ )/gcx && do { print "space: $1\n"; redo; }; + m/ \G( [^\w\d]+ )/gcx && do { print "other: $1\n"; redo; }; } } @@ -496,19 +498,19 @@ Of course, that could have been written as while (<>) { chomp; PARSER: { - if ( /\G( \d+\b )/gx { + if ( /\G( \d+\b )/gcx { print "number: $1\n"; redo PARSER; } - if ( /\G( \w+ )/gx { + if ( /\G( \w+ )/gcx { print "word: $1\n"; redo PARSER; } - if ( /\G( \s+ )/gx { + if ( /\G( \s+ )/gcx { print "space: $1\n"; redo PARSER; } - if ( /\G( [^\w\d]+ )/gx { + if ( /\G( [^\w\d]+ )/gcx { print "other: $1\n"; redo PARSER; } diff --git a/pod/perlop.pod b/pod/perlop.pod index 7f39b9d..d853865 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -697,18 +697,22 @@ If there are no parentheses, it returns a list of all the matched strings, as if there were parentheses around the whole pattern. In a scalar context, C iterates through the string, returning TRUE -each time it matches, and FALSE when it eventually runs out of -matches. (In other words, it remembers where it left off last time and -restarts the search at that point. You can actually find the current -match position of a string or set it using the pos() function--see -L.) Note that you can use this feature to stack C -matches or intermix C matches with C. Note that -the C<\G> zero-width assertion is not supported without the C -modifier; currently, without C, C<\G> behaves just like C<\A>, but -that's accidental and may change in the future. - -If you modify the string in any way, the match position is reset to the -beginning. Examples: +each time it matches, and FALSE when it eventually runs out of matches. +(In other words, it remembers where it left off last time and restarts +the search at that point. You can actually find the current match +position of a string or set it using the pos() function; see +L.) A failed match normally resets the search position to +the beginning of the string, but you can avoid that by adding the "c" +modifier (e.g. C). Modifying the target string also resets the +search position. + +You can intermix C matches with C, where C<\G> is a +zero-width assertion that matches the exact position where the previous +C, if any, left off. The C<\G> assertion is not supported without +the C modifier; currently, without C, C<\G> behaves just like +C<\A>, but that's accidental and may change in the future. + +Examples: # list context ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g); @@ -722,15 +726,15 @@ beginning. Examples: } print "$sentences\n"; - # using m//g with \G + # using m//gc with \G $_ = "ppooqppqq"; while ($i++ < 2) { print "1: '"; - print $1 while /(o)/g; print "', pos=", pos, "\n"; + print $1 while /(o)/gc; print "', pos=", pos, "\n"; print "2: '"; - print $1 if /\G(q)/g; print "', pos=", pos, "\n"; + print $1 if /\G(q)/gc; print "', pos=", pos, "\n"; print "3: '"; - print $1 while /(p)/g; print "', pos=", pos, "\n"; + print $1 while /(p)/gc; print "', pos=", pos, "\n"; } The last example should print: @@ -742,23 +746,23 @@ The last example should print: 2: 'q', pos=8 3: '', pos=8 -A useful idiom for C-like scanners is C. You can +A useful idiom for C-like scanners is C. You can combine several regexps like this to process a string part-by-part, -doing different actions depending on which regexp matched. The next -regexp would step in at the place the previous one left off. +doing different actions depending on which regexp matched. Each +regexp tries to match where the previous one leaves off. $_ = <<'EOL'; $url = new URI::URL "http://www/"; die if $url eq "xXx"; EOL LOOP: { - print(" digits"), redo LOOP if /\G\d+\b[,.;]?\s*/g; - print(" lowercase"), redo LOOP if /\G[a-z]+\b[,.;]?\s*/g; - print(" UPPERCASE"), redo LOOP if /\G[A-Z]+\b[,.;]?\s*/g; - print(" Capitalized"), redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/g; - print(" MiXeD"), redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/g; - print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/g; - print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/g; + print(" digits"), redo LOOP if /\G\d+\b[,.;]?\s*/gc; + print(" lowercase"), redo LOOP if /\G[a-z]+\b[,.;]?\s*/gc; + print(" UPPERCASE"), redo LOOP if /\G[A-Z]+\b[,.;]?\s*/gc; + print(" Capitalized"), redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/gc; + print(" MiXeD"), redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/gc; + print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/gc; + print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/gc; print ". That's all!\n"; } diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 6d8ee20..c4679e1 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -593,8 +593,5 @@ honest: $ENV{PATH} = '/bin:/usr/bin'; # or whatever you need $ENV{SHELL} = '/bin/sh' if exists $ENV{SHELL}; - delete $ENV{IFS}; - delete $ENV{ENV}; - delete $ENV{CDPATH}; - $ENV{TERM} = 'dumb' if exists $ENV{TERM}; + delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 29a9167..1a1ae21 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -58,10 +58,7 @@ For example: $path = $ENV{'PATH'}; # $path now tainted $ENV{'PATH'} = '/bin:/usr/bin'; - delete $ENV{'IFS'}; - delete $ENV{'CDPATH'}; - delete $ENV{'ENV'}; - $ENV{'TERM'} = 'dumb'; + delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; $path = $ENV{'PATH'}; # $path now NOT tainted system "echo $data"; # Is secure now! diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 0340059..d58f12c 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -898,7 +898,7 @@ CGI script to do bad things? =item $PERL5OPT environment variable -=item Limitations on B<-M>, and C<-m>, and B<-T> options +=item Limitations on B<-M>, B<-m>, and B<-T> options =item More precise warnings @@ -916,6 +916,9 @@ CGI script to do bad things? =item Changes to tainting checks +No glob() or <*>, No spawning if tainted $CDPATH, $ENV, $BASH_ENV, No +spawning if tainted $TERM doesn't look like a terminal name + =item New Opcode module and revised Safe module =item Embedding improvements @@ -940,7 +943,7 @@ $^E, $^H, $^M delete on slices, flock, printf and sprintf, keys as an lvalue, my() in Control Structures, pack() and unpack(), sysseek(), use VERSION, use Module -VERSION LIST, prototype(FUNCTION), srand, $_ as Default, C does not +VERSION LIST, prototype(FUNCTION), srand, $_ as Default, C does not reset search position on failure, C ignores whitespace before ?*+{}, nested C closures work now, formats work right on changing lexicals @@ -1027,8 +1030,8 @@ manipulating hashes =item Documentation Changes -L, L, L, L, L, -L +L, L, L, L, L, +L, L, L =item New Diagnostics @@ -1941,7 +1944,7 @@ safe subprocesses, sockets, and semaphores) =item Safe Pipe Opens -=item Bidirectional Communication +=item Bidirectional Communication with Another Process =back @@ -1953,13 +1956,29 @@ safe subprocesses, sockets, and semaphores) =item Unix-Domain TCP Clients and Servers -=item UDP: Message Passing +=back + +=item TCP Clients with IO::Socket + +=over + +=item A Simple Client + +C, C, C + +=item A Webget Client + +=item Interactive Client with IO::Socket =back -=item SysV IPC +=item TCP Servers with IO::Socket -=item WARNING +Proto, LocalPort, Listen, Reuse + +=item UDP: Message Passing + +=item SysV IPC =item NOTES @@ -3005,6 +3024,8 @@ B<-name>, B<-value>, B<-path>, B<-domain>, B<-expires>, B<-secure> document in the HTTP header, 3. Specify the destination for the document in the
tag +=item LIMITED SUPPORT FOR CASCADING STYLE SHEETS + =item DEBUGGING =over diff --git a/pp_ctl.c b/pp_ctl.c index c14c2c3..bc3ebb1 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -94,7 +94,7 @@ PP(pp_regcomp) { pm->op_pmflags |= PMf_WHITE; if (pm->op_pmflags & PMf_KEEP) { - pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */ + pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ hoistmust(pm); cLOGOP->op_first->op_next = op->op_next; } @@ -112,6 +112,8 @@ PP(pp_substcont) char *orig = cx->sb_orig; register REGEXP *rx = cx->sb_rx; + rxres_restore(&cx->sb_rxres, rx); + if (cx->sb_iters++) { if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); @@ -157,9 +159,75 @@ PP(pp_substcont) sv_catpvn(dstr, s, m-s); cx->sb_s = rx->endp[0]; cx->sb_rxtainted |= rx->exec_tainted; + rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); } +void +rxres_save(rsp, rx) +void **rsp; +REGEXP *rx; +{ + UV *p = (UV*)*rsp; + U32 i; + + if (!p || p[1] < rx->nparens) { + i = 6 + rx->nparens * 2; + if (!p) + New(501, p, i, UV); + else + Renew(p, i, UV); + *rsp = (void*)p; + } + + *p++ = (UV)rx->subbase; + rx->subbase = Nullch; + + *p++ = rx->nparens; + + *p++ = (UV)rx->subbeg; + *p++ = (UV)rx->subend; + for (i = 0; i <= rx->nparens; ++i) { + *p++ = (UV)rx->startp[i]; + *p++ = (UV)rx->endp[i]; + } +} + +void +rxres_restore(rsp, rx) +void **rsp; +REGEXP *rx; +{ + UV *p = (UV*)*rsp; + U32 i; + + Safefree(rx->subbase); + rx->subbase = (char*)(*p); + *p++ = 0; + + rx->nparens = *p++; + + rx->subbeg = (char*)(*p++); + rx->subend = (char*)(*p++); + for (i = 0; i <= rx->nparens; ++i) { + rx->startp[i] = (char*)(*p++); + rx->endp[i] = (char*)(*p++); + } +} + +void +rxres_free(rsp) +void **rsp; +{ + UV *p = (UV*)*rsp; + + if (p) { + Safefree((char*)(*p)); + Safefree(p); + *rsp = Null(void*); + } +} + PP(pp_formline) { dSP; dMARK; dORIGMARK; @@ -926,11 +994,14 @@ I32 cxix; I32 optype; while (cxstack_ix > cxix) { - cx = &cxstack[cxstack_ix--]; - DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1, - block_type[cx->cx_type])); + cx = &cxstack[cxstack_ix]; + DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", + (long) cxstack_ix+1, block_type[cx->cx_type])); /* Note: we don't need to restore the base context info till the end. */ switch (cx->cx_type) { + case CXt_SUBST: + POPSUBST(cx); + continue; /* not break */ case CXt_SUB: POPSUB(cx); break; @@ -941,9 +1012,9 @@ I32 cxix; POPLOOP(cx); break; case CXt_NULL: - case CXt_SUBST: break; } + cxstack_ix--; } } diff --git a/pp_hot.c b/pp_hot.c index d8b1976..e48a010 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -964,6 +964,13 @@ nope: ++BmUSEFUL(pm->op_pmshort); ret_no: + if (global && !(pm->op_pmflags & PMf_CONTINUE)) { + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { + MAGIC* mg = mg_find(TARG, 'g'); + if (mg) + mg->mg_len = -1; + } + } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) RETURN; diff --git a/pp_sys.c b/pp_sys.c index 200db75..03a10fe 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -224,6 +224,7 @@ PP(pp_glob) OP *result; ENTER; +#ifndef VMS if (tainting) { /* * The external globbing program may use things we can't control, @@ -232,6 +233,7 @@ PP(pp_glob) TAINT; taint_proper(no_security, "glob"); } +#endif /* !VMS */ SAVESPTR(last_in_gv); /* We don't want this to be permanent. */ last_in_gv = (GV*)*stack_sp--; @@ -3213,7 +3215,7 @@ PP(pp_setpgrp) #ifdef BSD_SETPGRP SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else - if ((pgrp != 0 && pgrp != getpid())) || (pid != 0 && pid != getpid())) + if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid())) DIE("POSIX setpgrp can't take an argument"); SETi( setpgrp() >= 0 ); #endif /* USE_BSDPGRP */ @@ -3684,7 +3686,7 @@ PP(pp_gnetent) PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, nent->n_name); PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = nent->n_aliases; *elem; elem++) { + for (elem = nent->n_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) sv_catpvn(sv, " ", 1); @@ -3754,7 +3756,7 @@ PP(pp_gprotoent) PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, pent->p_name); PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = pent->p_aliases; *elem; elem++) { + for (elem = pent->p_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) sv_catpvn(sv, " ", 1); @@ -3841,7 +3843,7 @@ PP(pp_gservent) PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setpv(sv, sent->s_name); PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = sent->s_aliases; *elem; elem++) { + for (elem = sent->s_aliases; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) sv_catpvn(sv, " ", 1); @@ -4121,7 +4123,7 @@ PP(pp_ggrent) PUSHs(sv = sv_mortalcopy(&sv_no)); sv_setiv(sv, (IV)grent->gr_gid); PUSHs(sv = sv_mortalcopy(&sv_no)); - for (elem = grent->gr_mem; *elem; elem++) { + for (elem = grent->gr_mem; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) sv_catpvn(sv, " ", 1); diff --git a/proto.h b/proto.h index 732aa3d..654e51b 100644 --- a/proto.h +++ b/proto.h @@ -381,6 +381,9 @@ int rsignal_restore _((int, Sigsave_t*)); int rsignal_save _((int, Sighandler_t, Sigsave_t*)); Sighandler_t rsignal_state _((int)); int runops _((void)); +void rxres_free _((void** rsp)); +void rxres_restore _((void** rsp, REGEXP* rx)); +void rxres_save _((void** rsp, REGEXP* rx)); #ifndef HAS_RENAME I32 same_dirent _((char* a, char* b)); #endif diff --git a/regcomp.c b/regcomp.c index 9b0d4fc..d3788c8 100644 --- a/regcomp.c +++ b/regcomp.c @@ -469,7 +469,7 @@ I32 *flagp; return NULL; default: --regparse; - while (*regparse && strchr("iogmsx", *regparse)) + while (*regparse && strchr("iogcmsx", *regparse)) pmflag(®flags, *regparse++); if (*regparse != ')') croak("Sequence (?%c...) not recognized", *regparse); diff --git a/scope.c b/scope.c index f7835b7..0487ebe 100644 --- a/scope.c +++ b/scope.c @@ -697,8 +697,8 @@ CONTEXT* cx; (long)cx->sb_m); PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n", (long)cx->sb_strend); - PerlIO_printf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n", - (long)cx->sb_subbase); + PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%lx\n", + (long)cx->sb_rxres); break; } } diff --git a/t/op/pat.t b/t/op/pat.t index d9941fa..0478911 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2,7 +2,7 @@ # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..61\n"; +print "1..62\n"; $x = "abc\ndef\n"; @@ -211,6 +211,9 @@ print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; $_ = "abdc"; pos $_ = 2; -/\Gc/g; +/\Gc/gc; print "not " if (pos $_) != 2; print "ok 61\n"; +/\Gc/g; +print "not " if defined pos $_; +print "ok 62\n"; diff --git a/t/op/taint.t b/t/op/taint.t index a33edde..1667152 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -19,7 +19,7 @@ my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : $Is_MSWin32 ? '.\perl' : './perl'; -my @MoreEnv = qw/IFS ENV CDPATH TERM/; +my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; if ($Is_VMS) { my (%old, $x); @@ -82,7 +82,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..132\n"; +print "1..135\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -91,16 +91,14 @@ print "1..132\n"; $ENV{'DCL$PATH'} = '' if $Is_VMS; $ENV{PATH} = ''; - delete $ENV{IFS}; - delete $ENV{ENV}; - delete $ENV{CDPATH}; + delete @ENV{@MoreEnv}; $ENV{TERM} = 'dumb'; test 1, eval { `$echo 1` } eq "1\n"; if ($Is_MSWin32) { print "# Environment tainting tests skipped\n"; - for (2) { print "ok $_\n" } + for (2..5) { print "ok $_\n" } } else { my @vars = ('PATH', @MoreEnv); @@ -111,6 +109,14 @@ print "1..132\n"; shift @vars; } test 2, !@vars, "\$$vars[0]"; + + # tainted $TERM is unsafe only if it contains metachars + local $ENV{TERM}; + $ENV{TERM} = 'e=mc2'; + test 3, eval { `$echo 1` } eq "1\n"; + $ENV{TERM} = 'e=mc2' . $TAINT; + test 4, eval { `$echo 1` } eq ''; + test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@; } my $tmp; @@ -126,68 +132,68 @@ print "1..132\n"; if ($tmp) { local $ENV{PATH} = $tmp; - test 3, eval { `$echo 1` } eq ''; - test 4, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; + test 6, eval { `$echo 1` } eq ''; + test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; } else { - for (3..4) { print "ok $_\n" } + for (6..7) { print "ok $_\n" } } if ($Is_VMS) { $ENV{'DCL$PATH'} = $TAINT; - test 5, eval { `$echo 1` } eq ''; - test 6, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; + test 8, eval { `$echo 1` } eq ''; + test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; if ($tmp) { $ENV{'DCL$PATH'} = $tmp; - test 7, eval { `$echo 1` } eq ''; - test 8, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; + test 10, eval { `$echo 1` } eq ''; + test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; } else { print "# can't find world-writeable directory to test DCL\$PATH\n"; - for (7..8) { print "ok $_\n" } + for (10..11) { print "ok $_\n" } } $ENV{'DCL$PATH'} = ''; } else { print "# This is not VMS\n"; - for (5..8) { print "ok $_\n"; } + for (8..11) { print "ok $_\n"; } } } # Let's see that we can taint and untaint as needed. { my $foo = $TAINT; - test 9, tainted $foo; + test 12, tainted $foo; # That was a sanity check. If it failed, stop the insanity! die "Taint checks don't seem to be enabled" unless tainted $foo; $foo = "foo"; - test 10, not tainted $foo; + test 13, not tainted $foo; taint_these($foo); - test 11, tainted $foo; + test 14, tainted $foo; my @list = 1..10; - test 12, not any_tainted @list; + test 15, not any_tainted @list; taint_these @list[1,3,5,7,9]; - test 13, any_tainted @list; - test 14, all_tainted @list[1,3,5,7,9]; - test 15, not any_tainted @list[0,2,4,6,8]; + test 16, any_tainted @list; + test 17, all_tainted @list[1,3,5,7,9]; + test 18, not any_tainted @list[0,2,4,6,8]; ($foo) = $foo =~ /(.+)/; - test 16, not tainted $foo; + test 19, not tainted $foo; $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; - test 17, not tainted $foo; - test 18, $foo eq 'bar'; + test 20, not tainted $foo; + test 21, $foo eq 'bar'; my $pi = 4 * atan2(1,1) + $TAINT0; - test 19, tainted $pi; + test 22, tainted $pi; ($pi) = $pi =~ /(\d+\.\d+)/; - test 20, not tainted $pi; - test 21, sprintf("%.5f", $pi) eq '3.14159'; + test 23, not tainted $pi; + test 24, sprintf("%.5f", $pi) eq '3.14159'; } # How about command-line arguments? The problem is that we don't @@ -203,150 +209,150 @@ print "1..132\n"; }; close PROG; print `$Invoke_Perl "-T" $arg and some suspect arguments`; - test 22, !$?, "Exited with status $?"; + test 25, !$?, "Exited with status $?"; unlink $arg; } # Reading from a file should be tainted { my $file = './TEST'; - test 23, open(FILE, $file), "Couldn't open '$file': $!"; + test 26, open(FILE, $file), "Couldn't open '$file': $!"; my $block; sysread(FILE, $block, 100); my $line = ; close FILE; - test 24, tainted $block; - test 25, tainted $line; + test 27, tainted $block; + test 28, tainted $line; } -# Globs should be forbidden. -{ - # Some glob implementations need to spawn system programs. - local $ENV{PATH} = ''; - $ENV{PATH} = (-l '/bin' ? '' : '/bin:') . '/usr/bin' unless $Is_VMS; - +# Globs should be forbidden, except under VMS, +# which doesn't spawn an external program. +if ($Is_VMS) { + for (29..30) { print "ok $_\n"; } +} +else { my @globs = eval { <*> }; - test 26, @globs == 0 && $@ =~ /^Insecure dependency/; + test 29, @globs == 0 && $@ =~ /^Insecure dependency/; @globs = eval { glob '*' }; - test 27, @globs == 0 && $@ =~ /^Insecure dependency/; + test 30, @globs == 0 && $@ =~ /^Insecure dependency/; } # Output of commands should be tainted { my $foo = `$echo abc`; - test 28, tainted $foo; + test 31, tainted $foo; } # Certain system variables should be tainted { - test 29, all_tainted $^X, $0; + test 32, all_tainted $^X, $0; } # Results of matching should all be untainted { my $foo = "abcdefghi" . $TAINT; - test 30, tainted $foo; + test 33, tainted $foo; $foo =~ /def/; - test 31, not any_tainted $`, $&, $'; + test 34, not any_tainted $`, $&, $'; $foo =~ /(...)(...)(...)/; - test 32, not any_tainted $1, $2, $3, $+; + test 35, not any_tainted $1, $2, $3, $+; my @bar = $foo =~ /(...)(...)(...)/; - test 33, not any_tainted @bar; + test 36, not any_tainted @bar; - test 34, tainted $foo; # $foo should still be tainted! - test 35, $foo eq "abcdefghi"; + test 37, tainted $foo; # $foo should still be tainted! + test 38, $foo eq "abcdefghi"; } # Operations which affect files can't use tainted data. { - test 36, eval { chmod 0, $TAINT } eq '', 'chmod'; - test 37, $@ =~ /^Insecure dependency/, $@; + test 39, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 40, $@ =~ /^Insecure dependency/, $@; # There is no feature test in $Config{} for truncate, # so we allow for the possibility that it's missing. - test 38, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; - test 39, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; + test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - test 40, eval { rename '', $TAINT } eq '', 'rename'; - test 41, $@ =~ /^Insecure dependency/, $@; + test 43, eval { rename '', $TAINT } eq '', 'rename'; + test 44, $@ =~ /^Insecure dependency/, $@; - test 42, eval { unlink $TAINT } eq '', 'unlink'; - test 43, $@ =~ /^Insecure dependency/, $@; + test 45, eval { unlink $TAINT } eq '', 'unlink'; + test 46, $@ =~ /^Insecure dependency/, $@; - test 44, eval { utime $TAINT } eq '', 'utime'; - test 45, $@ =~ /^Insecure dependency/, $@; + test 47, eval { utime $TAINT } eq '', 'utime'; + test 48, $@ =~ /^Insecure dependency/, $@; if ($Config{d_chown}) { - test 46, eval { chown -1, -1, $TAINT } eq '', 'chown'; - test 47, $@ =~ /^Insecure dependency/, $@; + test 49, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 50, $@ =~ /^Insecure dependency/, $@; } else { print "# chown() is not available\n"; - for (46..47) { print "ok $_\n" } + for (49..50) { print "ok $_\n" } } if ($Config{d_link}) { - test 48, eval { link $TAINT, '' } eq '', 'link'; - test 49, $@ =~ /^Insecure dependency/, $@; + test 51, eval { link $TAINT, '' } eq '', 'link'; + test 52, $@ =~ /^Insecure dependency/, $@; } else { print "# link() is not available\n"; - for (48..49) { print "ok $_\n" } + for (51..52) { print "ok $_\n" } } if ($Config{d_symlink}) { - test 50, eval { symlink $TAINT, '' } eq '', 'symlink'; - test 51, $@ =~ /^Insecure dependency/, $@; + test 53, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 54, $@ =~ /^Insecure dependency/, $@; } else { print "# symlink() is not available\n"; - for (50..51) { print "ok $_\n" } + for (53..54) { print "ok $_\n" } } } # Operations which affect directories can't use tainted data. { - test 52, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; - test 53, $@ =~ /^Insecure dependency/, $@; + test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; + test 56, $@ =~ /^Insecure dependency/, $@; - test 54, eval { rmdir $TAINT } eq '', 'rmdir'; - test 55, $@ =~ /^Insecure dependency/, $@; + test 57, eval { rmdir $TAINT } eq '', 'rmdir'; + test 58, $@ =~ /^Insecure dependency/, $@; - test 56, eval { chdir $TAINT } eq '', 'chdir'; - test 57, $@ =~ /^Insecure dependency/, $@; + test 59, eval { chdir $TAINT } eq '', 'chdir'; + test 60, $@ =~ /^Insecure dependency/, $@; if ($Config{d_chroot}) { - test 58, eval { chroot $TAINT } eq '', 'chroot'; - test 59, $@ =~ /^Insecure dependency/, $@; + test 61, eval { chroot $TAINT } eq '', 'chroot'; + test 62, $@ =~ /^Insecure dependency/, $@; } else { print "# chroot() is not available\n"; - for (58..59) { print "ok $_\n" } + for (61..62) { print "ok $_\n" } } } # Some operations using files can't use tainted data. { my $foo = "imaginary library" . $TAINT; - test 60, eval { require $foo } eq '', 'require'; - test 61, $@ =~ /^Insecure dependency/, $@; + test 63, eval { require $foo } eq '', 'require'; + test 64, $@ =~ /^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 62, eval { open FOO, $foo } eq '', 'open for read'; - test 63, $@ eq '', $@; # NB: This should be allowed - test 64, $! == 2; # File not found + test 65, eval { open FOO, $foo } eq '', 'open for read'; + test 66, $@ eq '', $@; # NB: This should be allowed + test 67, $! == 2; # File not found - test 65, eval { open FOO, "> $foo" } eq '', 'open for write'; - test 66, $@ =~ /^Insecure dependency/, $@; + test 68, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 69, $@ =~ /^Insecure dependency/, $@; } # Commands to the system can't use tainted data @@ -355,71 +361,70 @@ print "1..132\n"; if ($^O eq 'amigaos') { print "# open(\"|\") is not available\n"; - for (67..70) { print "ok $_\n" } + for (70..73) { print "ok $_\n" } } else { - test 67, eval { open FOO, "| $foo" } eq '', 'popen to'; - test 68, $@ =~ /^Insecure dependency/, $@; + test 70, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 71, $@ =~ /^Insecure dependency/, $@; - test 69, eval { open FOO, "$foo |" } eq '', 'popen from'; - test 70, $@ =~ /^Insecure dependency/, $@; + test 72, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 73, $@ =~ /^Insecure dependency/, $@; } - test 71, eval { exec $TAINT } eq '', 'exec'; - test 72, $@ =~ /^Insecure dependency/, $@; + test 74, eval { exec $TAINT } eq '', 'exec'; + test 75, $@ =~ /^Insecure dependency/, $@; - test 73, eval { system $TAINT } eq '', 'system'; - test 74, $@ =~ /^Insecure dependency/, $@; + test 76, eval { system $TAINT } eq '', 'system'; + test 77, $@ =~ /^Insecure dependency/, $@; $foo = "*"; taint_these $foo; - test 75, eval { `$echo 1$foo` } eq '', 'backticks'; - test 76, $@ =~ /^Insecure dependency/, $@; + test 78, eval { `$echo 1$foo` } eq '', 'backticks'; + test 79, $@ =~ /^Insecure dependency/, $@; if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe - test 77, join('', eval { glob $foo } ) ne '', 'globbing'; - test 78, $@ eq '', $@; + test 80, join('', eval { glob $foo } ) ne '', 'globbing'; + test 81, $@ eq '', $@; } else { - test 77, join('', eval { glob $foo } ) eq '', 'globbing'; - test 78, $@ =~ /^Insecure dependency/, $@; + for (80..81) { print "ok $_\n"; } } } # Operations which affect processes can't use tainted data. { - test 79, eval { kill 0, $TAINT } eq '', 'kill'; - test 80, $@ =~ /^Insecure dependency/, $@; + test 82, eval { kill 0, $TAINT } eq '', 'kill'; + test 83, $@ =~ /^Insecure dependency/, $@; if ($Config{d_setpgrp}) { - test 81, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; - test 82, $@ =~ /^Insecure dependency/, $@; + test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 85, $@ =~ /^Insecure dependency/, $@; } else { print "# setpgrp() is not available\n"; - for (81..82) { print "ok $_\n" } + for (84..85) { print "ok $_\n" } } if ($Config{d_setprior}) { - test 83, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; - test 84, $@ =~ /^Insecure dependency/, $@; + test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 87, $@ =~ /^Insecure dependency/, $@; } else { print "# setpriority() is not available\n"; - for (83..84) { print "ok $_\n" } + for (86..87) { print "ok $_\n" } } } # Some miscellaneous operations can't use tainted data. { if ($Config{d_syscall}) { - test 85, eval { syscall $TAINT } eq '', 'syscall'; - test 86, $@ =~ /^Insecure dependency/, $@; + test 88, eval { syscall $TAINT } eq '', 'syscall'; + test 89, $@ =~ /^Insecure dependency/, $@; } else { print "# syscall() is not available\n"; - for (85..86) { print "ok $_\n" } + for (88..89) { print "ok $_\n" } } { @@ -428,18 +433,18 @@ print "1..132\n"; local *FOO; my $temp = "./taintC$$"; END { unlink $temp } - test 87, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; - test 88, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; - test 89, $@ =~ /^Insecure dependency/, $@; + test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 92, $@ =~ /^Insecure dependency/, $@; if ($Config{d_fcntl}) { - test 90, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; - test 91, $@ =~ /^Insecure dependency/, $@; + test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 94, $@ =~ /^Insecure dependency/, $@; } else { print "# fcntl() is not available\n"; - for (90..91) { print "ok $_\n" } + for (93..94) { print "ok $_\n" } } close FOO; @@ -450,63 +455,63 @@ print "1..132\n"; { my $foo = 'abc' . $TAINT; my $fooref = \$foo; - test 92, not tainted $fooref; - test 93, tainted $$fooref; - test 94, tainted $foo; + test 95, not tainted $fooref; + test 96, tainted $$fooref; + test 97, tainted $foo; } # Some tests involving assignment { my $foo = $TAINT0; my $bar = $foo; - test 95, all_tainted $foo, $bar; - test 96, tainted($foo = $bar); - test 97, tainted($bar = $bar); - test 98, tainted($bar += $bar); - test 99, tainted($bar -= $bar); - test 100, tainted($bar *= $bar); - test 101, tainted($bar++); - test 102, tainted($bar /= $bar); - test 103, tainted($bar += 0); - test 104, tainted($bar -= 2); - test 105, tainted($bar *= -1); - test 106, tainted($bar /= 1); - test 107, tainted($bar--); - test 108, $bar == 0; + test 98, all_tainted $foo, $bar; + test 99, tainted($foo = $bar); + test 100, tainted($bar = $bar); + test 101, tainted($bar += $bar); + test 102, tainted($bar -= $bar); + test 103, tainted($bar *= $bar); + test 104, tainted($bar++); + test 105, tainted($bar /= $bar); + test 106, tainted($bar += 0); + test 107, tainted($bar -= 2); + test 108, tainted($bar *= -1); + test 109, tainted($bar /= 1); + test 110, tainted($bar--); + test 111, $bar == 0; } # Test assignment and return of lists { my @foo = ("A", "tainted" . $TAINT, "B"); - test 109, not tainted $foo[0]; - test 110, tainted $foo[1]; - test 111, not tainted $foo[2]; + test 112, not tainted $foo[0]; + test 113, tainted $foo[1]; + test 114, not tainted $foo[2]; my @bar = @foo; - test 112, not tainted $bar[0]; - test 113, tainted $bar[1]; - test 114, not tainted $bar[2]; + test 115, not tainted $bar[0]; + test 116, tainted $bar[1]; + test 117, not tainted $bar[2]; my @baz = eval { "A", "tainted" . $TAINT, "B" }; - test 115, not tainted $baz[0]; - test 116, tainted $baz[1]; - test 117, not tainted $baz[2]; + test 118, not tainted $baz[0]; + test 119, tainted $baz[1]; + test 120, not tainted $baz[2]; my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - test 118, not tainted $plugh[0]; - test 119, tainted $plugh[1]; - test 120, not tainted $plugh[2]; + test 121, not tainted $plugh[0]; + test 122, tainted $plugh[1]; + test 123, not tainted $plugh[2]; my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - test 121, not tainted ((&$nautilus)[0]); - test 122, tainted ((&$nautilus)[1]); - test 123, not tainted ((&$nautilus)[2]); + test 124, not tainted ((&$nautilus)[0]); + test 125, tainted ((&$nautilus)[1]); + test 126, not tainted ((&$nautilus)[2]); my @xyzzy = &$nautilus; - test 124, not tainted $xyzzy[0]; - test 125, tainted $xyzzy[1]; - test 126, not tainted $xyzzy[2]; + test 127, not tainted $xyzzy[0]; + test 128, tainted $xyzzy[1]; + test 129, not tainted $xyzzy[2]; my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - test 127, not tainted ((&$red_october)[0]); - test 128, tainted ((&$red_october)[1]); - test 129, not tainted ((&$red_october)[2]); + test 130, not tainted ((&$red_october)[0]); + test 131, tainted ((&$red_october)[1]); + test 132, not tainted ((&$red_october)[2]); my @corge = &$red_october; - test 130, not tainted $corge[0]; - test 131, tainted $corge[1]; - test 132, not tainted $corge[2]; + test 133, not tainted $corge[0]; + test 134, tainted $corge[1]; + test 135, not tainted $corge[2]; } diff --git a/taint.c b/taint.c index eda48d4..cd9e4ec 100644 --- a/taint.c +++ b/taint.c @@ -39,9 +39,9 @@ taint_env() char** e; static char* misc_env[] = { "IFS", /* most shells' inter-field separators */ - "ENV", /* ksh dain bramage #1 */ - "CDPATH", /* ksh dain bramage #2 */ - "TERM", /* some termcap libraries' dain bramage */ + "CDPATH", /* ksh dain bramage #1 */ + "ENV", /* ksh dain bramage #2 */ + "BASH_ENV", /* bash dain bramage -- I guess it's contagious */ NULL }; @@ -79,6 +79,25 @@ taint_env() } } +#ifndef VMS + /* tainted $TERM is okay if it contains no metachars */ + svp = hv_fetch(GvHVn(envgv),"TERM",4,FALSE); + if (svp && *svp && SvTAINTED(*svp)) { + bool was_tainted = tainted; + char *t = SvPV(*svp, na); + char *e = t + na; + tainted = was_tainted; + if (t < e && isALNUM(*t)) + t++; + while (t < e && (isALNUM(*t) || *t == '-' || *t == ':')) + t++; + if (t < e) { + TAINT; + taint_proper("Insecure $ENV{%s}%s", "TERM"); + } + } +#endif /* !VMS */ + for (e = misc_env; *e; e++) { svp = hv_fetch(GvHVn(envgv), *e, strlen(*e), FALSE); if (svp && *svp != &sv_undef && SvTAINTED(*svp)) { diff --git a/toke.c b/toke.c index 9c4f487..b443bb2 100644 --- a/toke.c +++ b/toke.c @@ -4482,6 +4482,8 @@ int ch; *pmfl |= PMf_FOLD; else if (ch == 'g') *pmfl |= PMf_GLOBAL; + else if (ch == 'c') + *pmfl |= PMf_CONTINUE; else if (ch == 'o') *pmfl |= PMf_KEEP; else if (ch == 'm') @@ -4510,7 +4512,7 @@ char *start; pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogmsx", *s)) + while (*s && strchr("iogcmsx", *s)) pmflag(&pm->op_pmflags,*s++); pm->op_pmpermflags = pm->op_pmflags; @@ -4556,7 +4558,7 @@ char *start; multi_start = first_start; /* so whole substitution is taken together */ pm = (PMOP*)newPMOP(OP_SUBST, 0); - while (*s && strchr("iogmsex", *s)) { + while (*s && strchr("iogcmsex", *s)) { if (*s == 'e') { s++; es++; diff --git a/win32/Makefile b/win32/Makefile index 80e37e3..8c99ef7 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -9,11 +9,20 @@ # # Set these to wherever you want "nmake install" to put your # newly built perl. -# - INST_DRV=c: INST_TOP=$(INST_DRV)\perl +# +# uncomment next line if you wish perl to run on Windows95 also +#RUNTIME=-MT + +# +# uncomment next line if you are using Visual C++ 2.x +#CCTYPE=MSVC20 + +# +# uncomment next line if you want debug version of perl (big,slow) +#CFG=Debug ##################### CHANGE THESE ONLY IF YOU MUST ##################### @@ -28,7 +37,9 @@ LIB32=$(LINK32) -lib # Options # PERLDLL = -D "PERLDLL" +!IF "$(RUNTIME)" == "" RUNTIME = -MD +!ENDIF INCLUDES = -I ".\include" -I "." -I ".." #PCHFLAGS = -Fp"$(INTDIR)/modules.pch" -YX DEFINES = -D "WIN32" -D "_CONSOLE" -D "PERLDLL" @@ -98,7 +109,8 @@ MINIMOD=..\lib\ExtUtils\Miniperl.pm PL2BAT=bin\PL2BAT.BAT MAKE=nmake -nologo -XCOPY=xcopy /i /d /f /r +XCOPY=xcopy /f /r /i /d +RCOPY=xcopy /f /r /i /e /d NULL= # @@ -256,11 +268,11 @@ perlglob.obj : perlglob.c $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl cd .. && miniperl configpm - if exist lib\* $(XCOPY) /e lib\*.* ..\lib\$(NULL) + if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) $(XCOPY) ..\*.h ..\lib\CORE\*.* $(XCOPY) *.h ..\lib\CORE\*.* - $(XCOPY) /S include ..\lib\CORE\*.* - $(MINIPERL) -I..\lib config_h.PL || $(MAKE) RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM) + $(RCOPY) include ..\lib\CORE\*.* + $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM) $(MINIPERL) : ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ) $(LINK32) -subsystem:console -out:$@ @<< @@ -374,7 +386,7 @@ install : ALL doc utils $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* $(XCOPY) bin\*.* $(INST_BIN)\*.* - $(XCOPY) /e ..\lib $(INST_LIB)\*.* + $(RCOPY) ..\lib $(INST_LIB)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* $(XCOPY) ..\pod\*.html $(INST_HTML)\*.* @@ -382,7 +394,7 @@ install : ALL doc utils inst_lib : $(CONFIGPM) copy splittree.pl .. $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" - $(XCOPY) /e ..\lib $(INST_LIB)\*.* + $(RCOPY) ..\lib $(INST_LIB)\*.* minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) $(XCOPY) $(MINIPERL) ..\t\perl.exe diff --git a/win32/config.H b/win32/config.H index e375c56..2018198 100644 --- a/win32/config.H +++ b/win32/config.H @@ -1414,7 +1414,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define ARCHLIB "c:\\perl\\lib" /**/ -#define ARCHLIB_EXP "c:\\perl\\lib" /**/ +#define ARCHLIB_EXP (win32PerlLibPath()) /**/ /* BINCOMPAT3: * This symbol, if defined, indicates that Perl 5.004 should be @@ -1776,5 +1776,6 @@ #endif #include -#define ARCHLIBEXP (win32PerlLibPath()) +#ifndef DEBUGGING #define DEBUGGING +#endif diff --git a/win32/config_h.PL b/win32/config_h.PL index d266f65..98b474a 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -35,14 +35,16 @@ while () munge(); s/\\\$/\$/g; s#/[ *\*]*\*/#/**/#; - if (/#define\s+ARCHLIBEXP/) + if (/^\s*#define\s+ARCHLIB_EXP/) { + $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n"; } print H; } print H "#include -#define ARCHLIBEXP (win32PerlLibPath()) +#ifndef DEBUGGING #define DEBUGGING +#endif "; close(H); close(SH); diff --git a/win32/config_sh.PL b/win32/config_sh.PL index e62e47f..020485d 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -5,7 +5,11 @@ while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) shift(@ARGV); } -@opt{'PATCHLEVEL','SUBVERSION'} = ($] =~ /\.0*([1-9]+)(\d\d)$/); +if ($] =~ /\.(\d\d\d)?(\d\d)?$/) { # should always be true + $opt{PATCHLEVEL} = int($1 || 0); + $opt{SUBVERSION} = $2 || '00'; +} + while (<>) { s/~([\w_]+)~/$opt{$1}/g; diff --git a/win32/makedef.pl b/win32/makedef.pl index a0a0536..f868203 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -264,6 +264,7 @@ win32_spawnle win32_mkdir win32_rmdir win32_chdir +win32_flock win32_htons win32_ntohs win32_htonl diff --git a/win32/win32.c b/win32/win32.c index 9a0f910..7fb0416 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1121,56 +1121,17 @@ stolen_get_osfhandle(int fd) return pIOSubSystem->pfn_get_osfhandle(fd); } - /* * Extras. */ -/* simulate flock by locking a range on the file */ - -#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError())) -#define LK_LEN 0xffff0000 - DllExport int win32_flock(int fd, int oper) { - OVERLAPPED o; - int i = -1; - HANDLE fh; - if (!IsWinNT()) { croak("flock() unimplemented on this platform"); return -1; } - - fh = (HANDLE)stolen_get_osfhandle(fd); - memset(&o, 0, sizeof(o)); - - switch(oper) { - case LOCK_SH: /* shared lock */ - LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i); - break; - case LOCK_EX: /* exclusive lock */ - LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i); - break; - case LOCK_SH|LOCK_NB: /* non-blocking shared lock */ - LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i); - break; - case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */ - LK_ERR(LockFileEx(fh, - LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, - 0, LK_LEN, 0, &o),i); - break; - case LOCK_UN: /* unlock lock */ - LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i); - break; - default: /* unknown */ - errno = EINVAL; - break; - } - return i; + return pIOSubSystem->pfnflock(fd, oper); } -#undef LK_ERR -#undef LK_LEN - diff --git a/win32/win32.h b/win32/win32.h index 7114033..ec9eb7c 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -65,20 +65,13 @@ extern FILE *myfdopen(int, char *); #undef alarm #define alarm myalarm -#undef flock -#define flock(fd,o) win32_flock(fd,o) -#define LOCK_SH 1 -#define LOCK_EX 2 -#define LOCK_NB 4 -#define LOCK_UN 8 - struct tms { long tms_utime; long tms_stime; long tms_cutime; long tms_cstime; }; - + unsigned int sleep(unsigned int); char *win32PerlLibPath(); int mytimes(struct tms *timebuf); diff --git a/win32/win32io.c b/win32/win32io.c index e75754a..db156cf 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -190,6 +190,52 @@ my_get_osfhandle( int filehandle ) return _get_osfhandle(filehandle); } + +/* simulate flock by locking a range on the file */ + + +#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError())) +#define LK_LEN 0xffff0000 + +int +my_flock(int fd, int oper) +{ + OVERLAPPED o; + int i = -1; + HANDLE fh; + + fh = (HANDLE)my_get_osfhandle(fd); + memset(&o, 0, sizeof(o)); + + switch(oper) { + case LOCK_SH: /* shared lock */ + LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i); + break; + case LOCK_EX: /* exclusive lock */ + LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i); + break; + case LOCK_SH|LOCK_NB: /* non-blocking shared lock */ + LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i); + break; + case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */ + LK_ERR(LockFileEx(fh, + LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, + 0, LK_LEN, 0, &o),i); + break; + case LOCK_UN: /* unlock lock */ + LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i); + break; + default: /* unknown */ + errno = EINVAL; + break; + } + return i; +} + +#undef LK_ERR +#undef LK_LEN + + #ifdef PERLDLL __declspec(dllexport) #endif @@ -247,6 +293,7 @@ WIN32_IOSUBSYSTEM win32stdio = { _mkdir, _rmdir, _chdir, + my_flock, /* (*pfunc_flock)(int fd, int oper) */ 87654321L, /* end of structure */ }; diff --git a/win32/win32io.h b/win32/win32io.h index 4955973..45a31f7 100644 --- a/win32/win32io.h +++ b/win32/win32io.h @@ -55,6 +55,7 @@ int (*pfnspawnvpe)(int mode, const char *cmdname, const char *const *argv, const int (*pfnmkdir)(const char *path); int (*pfnrmdir)(const char *path); int (*pfnchdir)(const char *path); +int (*pfnflock)(int fd, int oper); int signature_end; } WIN32_IOSUBSYSTEM; diff --git a/win32/win32iop.h b/win32/win32iop.h index f630000..c33d944 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -63,6 +63,7 @@ EXT int win32_spawnle(int mode, const char *cmdname, const char *,...); EXT int win32_mkdir(const char *dir, int mode); EXT int win32_rmdir(const char *dir); EXT int win32_chdir(const char *dir); +EXT int win32_flock(int fd, int oper); /* * these two are win32 specific but still io related @@ -70,6 +71,14 @@ EXT int win32_chdir(const char *dir); int stolen_open_osfhandle(long handle, int flags); long stolen_get_osfhandle(int fd); +/* + * defines for flock emulation + */ +#define LOCK_SH 1 +#define LOCK_EX 2 +#define LOCK_NB 4 +#define LOCK_UN 8 + #include /* pull in the io sub system structure */ void * SetIOSubSystem(void *piosubsystem); @@ -140,6 +149,7 @@ void * SetIOSubSystem(void *piosubsystem); #define mkdir win32_mkdir #define rmdir win32_rmdir #define chdir win32_chdir +#define flock(fd,o) win32_flock(fd,o) #endif /* WIN32IO_IS_STDIO */ #endif /* WIN32IOP_H */ -- 1.8.3.1