Chip Salzenberg <chip@perl.com>
+-------------
+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<m//g> reset pos on failure; make C<m//gc> 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 <Jonathan.Hudson@jrhudson.demon.co.uk>,
+ Peter Prymmer <pvhp@forte.com>,
+ Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ 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 <sadinoff@olf.com>
+ Msg-ID: <337351CE.79B28DE3@olf.com>
+ Date: Fri, 09 May 1997 12:33:18 -0400
+ Files: perl.c
+
+ OTHER CORE CHANGES
+
+ Title: "In C<eval &func>, 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 <jik@kamens.brookline.ma.us>
+ 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 <mkt@lucent.com>
+ 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 <hansm@icgned.nl>
+ 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 <lstein@genome.wi.mit.edu>
+ 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: <Pine.GSO.3.96.970510190846.23340K-100000@kelly.teleport.com>
+ 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 <cdp@hpescdp.fc.hp.com>
+ 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 <gsar@engin.umich.edu>
+ 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
-----------------
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
especially on older exotic systems. If yours does, try the Bourne
shell instead.)
EOM
+ unset ENV
fi
fi
else
#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`
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 <db.h>. I'll disable Berkeley DB." >&4
i_db=$undef
case " $libs " in
*"-ldb "*)
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<Usage Hints> section for general hints about this.
+See L<Usage Hints> below for general hints about this.
=head2 Setting Up
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 *
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
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
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
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
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
#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], \
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 */
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);
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 : "");
#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
rsignal_state
rsignal_restore
runops
+rxres_free
+rxres_restore
+rxres_save
safecalloc
safemalloc
safefree
#!./perl
BEGIN {
- require 5.003_90;
+ require 5.004;
@INC = 'lib';
$ENV{PERL5LIB} = 'lib';
}
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:
}
curcop = &compiling;
break;
+ case OP_REQUIRE:
+ /* all requires must return a boolean value */
+ op->op_flags &= ~OPf_WANT;
+ return scalar(op);
}
return op;
}
ck_match(op)
OP *op;
{
- cPMOP->op_pmflags |= PMf_RUNTIME;
- cPMOP->op_pmpermflags |= PMf_RUNTIME;
+ op->op_private |= OPpRUNTIME;
return op;
}
/* 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
#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 */
-#define PATCHLEVEL 3
-#define SUBVERSION 99
+#define PATCHLEVEL 4
+#define SUBVERSION 0
/*
local_patches -- list of locally applied less-than-subversion patches.
*/
static char *local_patches[] = {
NULL
- ,"Dev99A - First post-gamma development patch"
,NULL
};
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;
}
#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
-p9pvers = 5.003_99
+p9pvers = 5.004
=head1 Core Changes
-Most importantly, many bugs were fixed. See the F<Changes>
-file in the distribution for details.
+Most importantly, many bugs were fixed, including several security
+problems. See the F<Changes> file in the distribution for details.
=head2 Compilation option: Binary compatibility with 5.003
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
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
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
Functions documented in the Camel to default to $_ now in
fact do, and all those that do are so documented in L<perlfunc>.
-=item C<m//g> does not reset search position on failure
+=item C<m//gc> does not reset search position on failure
-The C<m//g> match iteration construct used to reset its target string's
-search position (which is visible through the C<pos> operator) when a
-match failed; as a result, the next C<m//g> match would start at the
-beginning of the string). With Perl 5.004, the search position must be
-reset explicitly, as with C<pos $str = 0;>, 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<perlop> and
-L<perlre>.
-
-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<m//g> match iteration construct has always reset its target
+string's search position (which is visible through the C<pos> operator)
+when a match fails; as a result, the next C<m//g> 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<m//gc>. This feature, in conjunction with the C<\G> zero-width
+assertion, makes it possible to chain matches together. See L<perlop>
+and L<perlre>.
=item C<m//x> ignores whitespace before ?*+{}
Just like anonymous functions that contain lexical variables
that change (like a lexical index variable for a C<foreach> 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
This document.
+=item L<perlfaq>
+
+Frequently asked questions.
+
=item L<perllocale>
Locale support (internationalization and localization).
Perl internal IO abstraction interface.
+=item L<perlmodlib>
+
+Perl module library and recommended practice for module creation.
+Extracted from L<perlmod> (which is much smaller as a result).
+
=item L<perldebug>
Although not new, this has been massively updated.
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
=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?
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</c>, which prevents a failed match with C</g> 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; };
}
}
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;
}
strings, as if there were parentheses around the whole pattern.
In a scalar context, C<m//g> 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<perlfunc/pos>.) Note that you can use this feature to stack C<m//g>
-matches or intermix C<m//g> matches with C<m/\G.../g>. Note that
-the C<\G> zero-width assertion is not supported without the C</g>
-modifier; currently, without C</g>, 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<perlfunc/pos>.) 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<m//gc>). Modifying the target string also resets the
+search position.
+
+You can intermix C<m//g> matches with C<m/\G.../g>, where C<\G> is a
+zero-width assertion that matches the exact position where the previous
+C<m//g>, if any, left off. The C<\G> assertion is not supported without
+the C</g> modifier; currently, without C</g>, 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);
}
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:
2: 'q', pos=8
3: '', pos=8
-A useful idiom for C<lex>-like scanners is C</\G.../g>. You can
+A useful idiom for C<lex>-like scanners is C</\G.../gc>. 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";
}
$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)};
$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!
=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
=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
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<m//g> does not
+VERSION LIST, prototype(FUNCTION), srand, $_ as Default, C<m//gc> does not
reset search position on failure, C<m//x> ignores whitespace before ?*+{},
nested C<sub{}> closures work now, formats work right on changing lexicals
=item Documentation Changes
-L<perldelta>, L<perllocale>, L<perltoot>, L<perlapio>, L<perldebug>,
-L<perlsec>
+L<perldelta>, L<perlfaq>, L<perllocale>, L<perltoot>, L<perlapio>,
+L<perlmodlib>, L<perldebug>, L<perlsec>
=item New Diagnostics
=item Safe Pipe Opens
-=item Bidirectional Communication
+=item Bidirectional Communication with Another Process
=back
=item Unix-Domain TCP Clients and Servers
-=item UDP: Message Passing
+=back
+
+=item TCP Clients with IO::Socket
+
+=over
+
+=item A Simple Client
+
+C<Proto>, C<PeerAddr>, C<PeerPort>
+
+=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
document in the HTTP header, 3. Specify the destination for the document in
the <FORM> tag
+=item LIMITED SUPPORT FOR CASCADING STYLE SHEETS
+
=item DEBUGGING
=over
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;
}
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");
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;
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;
POPLOOP(cx);
break;
case CXt_NULL:
- case CXt_SUBST:
break;
}
+ cxstack_ix--;
}
}
++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;
OP *result;
ENTER;
+#ifndef VMS
if (tainting) {
/*
* The external globbing program may use things we can't control,
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--;
#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 */
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);
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);
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);
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);
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
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);
(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;
}
}
# $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";
$_ = "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";
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);
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
$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);
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;
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
};
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 = <FILE>;
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
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" }
}
{
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;
{
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];
}
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
};
}
}
+#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)) {
*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')
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;
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++;
#
# 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 #####################
# 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"
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=
#
$(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:$@ @<<
$(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)\*.*
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
* 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
#endif
#include <win32.h>
-#define ARCHLIBEXP (win32PerlLibPath())
+#ifndef DEBUGGING
#define DEBUGGING
+#endif
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 <win32.h>
-#define ARCHLIBEXP (win32PerlLibPath())
+#ifndef DEBUGGING
#define DEBUGGING
+#endif
";
close(H);
close(SH);
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;
win32_mkdir
win32_rmdir
win32_chdir
+win32_flock
win32_htons
win32_ntohs
win32_htonl
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
-
#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);
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
_mkdir,
_rmdir,
_chdir,
+ my_flock, /* (*pfunc_flock)(int fd, int oper) */
87654321L, /* end of structure */
};
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;
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
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 <win32io.h> /* pull in the io sub system structure */
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 */
projects / p5sagit/p5-mst-13.2.git / commitdiff