diff options
| -rw-r--r-- | Changes | 155 | ||||
| -rwxr-xr-x | Configure | 32 | ||||
| -rw-r--r-- | EXTERN.h | 15 | ||||
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | README.win32 | 216 | ||||
| -rwxr-xr-x | config_h.SH | 19 | ||||
| -rw-r--r-- | hints/next_3.sh | 41 | ||||
| -rw-r--r-- | hints/next_4.sh | 84 | ||||
| -rwxr-xr-x | installperl | 4 | ||||
| -rw-r--r-- | lib/Sys/Hostname.pm | 5 | ||||
| -rw-r--r-- | op.c | 3 | ||||
| -rw-r--r-- | patchlevel.h | 1 | ||||
| -rw-r--r-- | pod/perldelta.pod | 75 | ||||
| -rw-r--r-- | pod/perldiag.pod | 7 | ||||
| -rw-r--r-- | pod/perlfaq8.pod | 3 | ||||
| -rw-r--r-- | pod/perlop.pod | 8 | ||||
| -rw-r--r-- | pod/perlrun.pod | 9 | ||||
| -rw-r--r-- | pod/perlsec.pod | 8 | ||||
| -rw-r--r-- | pod/perlsub.pod | 5 | ||||
| -rw-r--r-- | pod/perltoc.pod | 75 | ||||
| -rw-r--r-- | pp_sys.c | 9 | ||||
| -rw-r--r-- | sv.c | 12 | ||||
| -rwxr-xr-x | t/op/sort.t | 27 | ||||
| -rwxr-xr-x | t/op/taint.t | 345 | ||||
| -rw-r--r-- | taint.c | 20 | ||||
| -rw-r--r-- | win32/config.H | 29 | ||||
| -rw-r--r-- | win32/config.w32 | 6 | ||||
| -rw-r--r-- | win32/config_sh.PL | 2 | ||||
| -rw-r--r-- | win32/include/sys/socket.h | 6 | ||||
| -rw-r--r-- | win32/perllib.c | 244 | ||||
| -rw-r--r-- | win32/win32.c | 54 | ||||
| -rw-r--r-- | win32/win32.h | 7 |
32 files changed, 1165 insertions, 362 deletions
@@ -45,6 +45,161 @@ And the Keepers of the Patch Pumpkin: Chip Salzenberg <chip@perl.com> +----------------- +Version 5.003_99a +----------------- + +Herein we find the fruits of the gamma. + + CORE LANGUAGE CHANGES + + Title: "SECURITY: Forbid glob() when tainting (-T or setuid)" + From: Chip Salzenberg + Files: pod/perlrun.pod pod/perlsec.pod pp_sys.c + + Title: "SECURITY: Forbid exec() if $ENV{TERM} or $ENV{ENV} is tainted" + From: Chip Salzenberg + Files: pod/perlrun.pod pod/perlsec.pod t/op/taint.t taint.c + + CORE PORTABILITY + + Title: "(NeXT|Open)Step update" + From: Gerd Knops <gerti@BITart.com> + Msg-ID: <9705072247.AA18882@BITart.com> + Date: Wed, 7 May 97 17:47:02 -0500 + Files: Configure MANIFEST config_h.SH hints/next_3.sh hints/next_4.sh + + Title: "NetBSD hint update" + From: Giles Lean <giles@nemeton.com.au> + Msg-ID: <199705051346.XAA13584@topaz.nemeton.com.au> + Date: Mon, 5 May 1997 23:46:37 +1000 (EST) + Files: hints/netbsd.sh + + Title: "Irix hint update" + From: Scott Henry <scotth@sgi.com> + Msg-ID: <yd83es0fp57.fsf@hoshi.engr.sgi.com> + Date: 06 May 1997 11:09:56 -0700 + Files: hints/irix_6.sh + + Title: "HPUX: patch for ext/DynaLoader/dl_hpux.xs" + From: Chuck D. Phillips <cdp@hpescdp.fc.hp.com> + Msg-ID: <199705050548.WAA21260@palrel1.hp.com> + Date: Sun, 4 May 1997 23:48:39 -0600 + Files: ext/DynaLoader/dl_hpux.xs + + Title: "Win32 update (consolidated patch plus three followups)" + From: Gurusamy Sarathy + Files: EXTERN.h README.win32 lib/Sys/Hostname.pm pod/perldelta.pod + win32/config.H win32/config.w32 win32/config_sh.PL win32/perllib.c + win32/win32.c win32/win32.h win32/include/sys/socket.h + + Title: "Win32 boot_DynaLoader problem in 99" + From: Gary Clark <GaryC@mail.jeld-wen.com> + Msg-ID: <1997May05.105000.1708.84476@mail.jeld-wen.com> + Date: Mon, 05 May 1997 10:49:03 -0700 + Files: win32/makedef.pl + + OTHER CORE CHANGES + + Title: "Fix wantarray() in sort subs [fixes metaconfig]" + From: Chip Salzenberg + Files: pp_ctl.c + + Title: "Fix for redefined sort subs nastiness" + From: Gurusamy Sarathy + Msg-ID: <199705090004.UAA15032@aatma.engin.umich.edu> + Date: Thu, 08 May 1997 20:04:18 -0400 + Files: op.c pod/perldelta.pod pod/perldiag.pod sv.c t/op/sort.t + + BUILD PROCESS + + Title: "AFS patches" + From: Chip Salzenberg, Larry Schwimmer <rosebud@cyclone.Stanford.EDU> + Files: Configure installperl + + LIBRARY AND EXTENSIONS + + Title: "Another blank line patch to Pod::Text" + From: Russ Allbery <rra@stanford.edu> + Msg-ID: <m3afm5g6ar.fsf@windlord.Stanford.EDU> + Date: 08 May 1997 11:36:12 -0700 + Files: lib/Pod/Text.pm + + TESTS + + (no other changes) + + UTILITIES + + Title: "Three bugs in pod2html" + From: hansm@euronet.nl + Msg-ID: <199705052228.AAA25351@mail.euronet.nl> + Date: Tue, 6 May 97 00:28:06 +0200 + Files: lib/Pod/Html.pm + + Title: "Trivial bugfix for pod of xsubpp" + From: Ralf S. Engelschall <rse@engelschall.com> + Msg-ID: <199705051447.QAA09995@en1.engelschall.com> + Date: Mon, 5 May 1997 16:47:03 +0200 + Files: lib/ExtUtils/xsubpp + + Title: "Newer CPerl mode" + From: Ilya Zakharevich + Msg-ID: <199705080032.UAA22532@monk.mps.ohio-state.edu> + Date: Wed, 7 May 1997 20:32:46 -0400 (EDT) + Files: emacs/cperl-mode.el + + DOCUMENTATION + + Title: "Updates to perldelta" + From: Chip Salzenberg and Dominic Dunlop + Files: pod/perldelta.pod + + Title: "More explicit Solaris instructions" + From: Andy Dougherty + Msg-ID: <Pine.SOL.3.95q.970508171206.438A-100000@fractal.lafayette.ed + Date: Thu, 08 May 1997 17:14:54 -0400 (EDT) + Files: INSTALL hints/solaris_2.sh + + Title: "Document 'Possible attempt to separate words with commas'" + From: Gisle Aas + Msg-ID: <hyb9snvdw.fsf@bergen.sn.no> + Date: 06 May 1997 23:27:55 +0200 + Files: pod/perlop.pod + + Title: "perlfaq9, hostname" + From: John D Groenveld <groenvel@cse.psu.edu> + Msg-ID: <199705061741.NAA22777@cse.psu.edu> + Date: Tue, 06 May 1997 13:41:12 EDT + Files: pod/perlfaq9.pod + + Title: "Debugger docs patch" + From: Ilya Zakharevich + Msg-ID: <199705080107.VAA24317@monk.mps.ohio-state.edu> + Date: Wed, 7 May 1997 21:07:14 -0400 (EDT) + Files: pod/perldebug.pod + + Title: "Document that C<m?x?> is just like C<?x?>" + From: Chip Salzenberg + Files: pod/perlop.pod + + Title: "Refresh description of sprintf()" + From: Chip Salzenberg + Files: pod/perl.pod pod/perlfunc.pod + + Title: "Mention the Regular Expressions book" + From: Stephen Potter <spp@psa.pencom.com> + Msg-ID: <199705071737.MAA18799@psa.pencom.com> + Date: Wed, 07 May 1997 12:37:37 -0500 + Files: pod/perlbook.pod pod/perlre.pod + + Title: "OS/2 doc patch for _99" + From: Ilya Zakharevich + Msg-ID: <199705080046.UAA23466@monk.mps.ohio-state.edu> + Date: Wed, 7 May 1997 20:46:45 -0400 (EDT) + Files: README.os2 + + ---------------- Version 5.003_99 ---------------- @@ -1360,7 +1360,7 @@ If you are in a hurry, you may run 'Configure -d'. This will bypass nearly all the questions and use the computed defaults (or the previous answers if there was already a config.sh file). Type 'Configure -h' for a list of options. You may also start interactively and then answer '& -d' at any prompt to turn -on the non-interactive behaviour for the remaining of the execution. +on the non-interactive behavior for the remainder of the execution. EOH . ./myread @@ -2527,9 +2527,10 @@ archlibexp="$ansexp" if $afs; then $cat <<EOM -Since you are running AFS, I need to distinguish the directory in which -private files reside from the directory in which they are installed (and from -which they are presumably copied to the former directory by occult means). +Since you are running AFS, I need to distinguish the directory in +which architecture-dependent library files reside from the directory +in which they are installed (and from which they are presumably copied +to the former directory by occult means). EOM case "$installarchlib" in @@ -2828,9 +2829,10 @@ sitelibexp="$ansexp" if $afs; then $cat <<EOM -Since you are running AFS, I need to distinguish the directory in which -private files reside from the directory in which they are installed (and from -which they are presumably copied to the former directory by occult means). +Since you are running AFS, I need to distinguish the directory in +which site-specific files reside from the directory in which they are +installed (and from which they are presumably copied to the former +directory by occult means). EOM case "$installsitelib" in @@ -2838,7 +2840,7 @@ EOM *) dflt="$installsitelib";; esac fn=de~ - rp='Where will private files be installed?' + rp='Where will site-specific files be installed?' . ./getfile installsitelib="$ans" else @@ -2871,9 +2873,10 @@ sitearchexp="$ansexp" if $afs; then $cat <<EOM -Since you are running AFS, I need to distinguish the directory in which -private files reside from the directory in which they are installed (and from -which they are presumably copied to the former directory by occult means). +Since you are running AFS, I need to distinguish the directory in +which site-specific architecture-dependent library files reside from +the directory in which they are installed (and from which they are +presumably copied to the former directory by occult means). EOM case "$installsitearch" in @@ -2881,7 +2884,7 @@ EOM *) dflt="$installsitearch";; esac fn=de~ - rp='Where will private files be installed?' + rp='Where will site-specific architecture-dependent files be installed?' . ./getfile installsitearch="$ans" else @@ -3697,7 +3700,7 @@ EOM -*) ftry="$flag";; *) ftry="$previous $flag";; esac - if $cppstdin -DLFRULB=bar $ftry $cppminus <cpp.c \ + if $cppstdin -DLFRULB=bar $cppflags $ftry $cppminus <cpp.c \ >cpp1.out 2>/dev/null && \ $cpprun -DLFRULB=bar $ftry $cpplast <cpp.c \ >cpp2.out 2>/dev/null && \ @@ -4741,6 +4744,9 @@ if "$useshrplib"; then linux|irix*|dec_osf) xxx="-Wl,-rpath,$shrpdir" ;; + next) + # next doesn't like the default... + ;; *) tmp_shrpenv="env LD_RUN_PATH=$shrpdir" ;; @@ -30,10 +30,17 @@ # define EXTCONST __declspec(dllexport) const # define dEXTCONST const # else -# define EXT __declspec(dllimport) -# define dEXT -# define EXTCONST __declspec(dllimport) const -# define dEXTCONST const +# if defined(__cplusplus) +# define EXT extern __declspec(dllimport) +# define dEXT +# define EXTCONST extern __declspec(dllimport) const +# define dEXTCONST const +# else +# define EXT __declspec(dllimport) +# define dEXT +# define EXTCONST __declspec(dllimport) const +# define dEXTCONST const +# endif # endif # else # define EXT extern @@ -227,7 +227,6 @@ h2pl/tcbreak2 cbreak test routine using .pl handy.h Handy definitions hints/3b1.sh Hints for named architecture hints/3b1cc Hints for named architecture -hints/README.NeXT Notes about NeXT hints hints/README.hints Notes about hints hints/aix.sh Hints for named architecture hints/altos486.sh Hints for named architecture diff --git a/README.win32 b/README.win32 index 40badf2901..8f1ff1bcf0 100644 --- a/README.win32 +++ b/README.win32 @@ -8,7 +8,7 @@ perlwin32 - Perl under Win32 =head1 SYNOPSIS -These are instructions for building Perl under WindowsNT (versions +These are instructions for building Perl under Windows NT (versions 3.51 or 4.0), using Visual C++ (versions 2.0 through 5.0). Currently, this port may also build under Windows95, but you can expect problems stemming from the unmentionable command shell that infests that @@ -31,22 +31,25 @@ only relevant to people building Perl on Unix-like systems. In particular, you can safely ignore any information that talks about "Configure". -You should probably also read the README.os2 file, which gives a -different set of rules to build a Perl that will work on Win32 -platforms. That method will probably enable you to build a more -Unix-compatible perl, but you will also need to download and use -various other support software described in that file. +You may also want to look at two other options for building +a perl that will work on Windows NT: the README.cygwin32 and +README.os2 files, which give a different set of rules to build a +Perl that will work on Win32 platforms. Those two methods will +probably enable you to build a more Unix-compatible perl, but you +will also need to download and use various other build-time and +run-time support software described in those files. This set of instructions is meant to describe a so-called "native" port of Perl to Win32 platforms. The resulting Perl requires no additional software to run (other than what came with your operating system). Currently, this port is only capable of using Microsoft's Visual C++ compiler. The ultimate goal is to support the other major -compilers that can be used to build Win32 applications. +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<Usage Hints> section for general hints about this. =head2 Setting Up @@ -61,13 +64,15 @@ muster the temerity to attempt this with Windows95. =item * -Run the VCVARS32.BAT file usually found somewhere like C:\MSDEV4.2\BIN. -This will set your build environment. +If you did not choose to always initialize the Visual C++ compilation +environment variables when you installed Visual C++ on your system, you +will need to run the VCVARS32.BAT file usually found somewhere like +C:\MSDEV4.2\BIN. This will set your build environment. =item * Depending on how you extracted the distribution, you have to make sure -all the files are writable by you. The easiest way to make sure of +some of the files are writable by you. The easiest way to make sure of this is to execute: attrib -R *.* /S @@ -100,7 +105,7 @@ If you are using a Visual C++ ver. 2.0: type "nmake CCTYPE=MSVC20". This should build everything. Specifically, it will create perl.exe, perl.dll, and perlglob.exe at the perl toplevel, and various other -extension dll's under the lib\auto directory. If the make fails for +extension dll's under the lib\auto directory. If the build fails for any reason, make sure you have done the previous steps correctly. =back @@ -118,23 +123,172 @@ Please report any failures as described under L<BUGS AND CAVEATS>. =head2 Installation Type "nmake install". This will put the newly built perl and the -libraries under "C:\PERL" (actually whatever you set INST_TOP to -in the Makefile). To use the Perl you just installed, set your -PATH environment variable to "C:\PERL\BIN" (or $(INST_TOP)\BIN, if you +libraries under "C:\perl" (actually whatever you set C<INST_TOP> to +in the Makefile). It will also install the pod documentation under +C<$INST_TOP\lib\pod> and HTML versions of the same under +C<$INST_TOP\lib\pod\html>. To use the Perl you just installed, set your +PATH environment variable to "C:\perl\bin" (or C<$INST_TOP\bin>, if you changed the default as above). +=head2 Usage Hints + +=over 4 + +=item Environment Variables + +The installation paths that you set during the build get compiled +into perl, so you don't have to do anything additional to start +using that perl (except add its location to your PATH variable). + +If you put extensions in unusual places, you can set PERL5LIB +to a list of paths separated by semicolons where you want perl +to look for libraries. Look for descriptions of other environment +variables you can set in the perlrun podpage. + +Sometime in the future, some of the configuration information +for perl will be moved into the Windows registry. + +=item Using perl from the command line + +If you are accustomed to using perl from various command-line +shells found in UNIX environments, you will be less than pleased +with what Windows NT offers by way of a command shell. + +The crucial thing to understand about the "cmd" shell (which is +the default on Windows NT) is that it does not do any wildcard +expansions of command-line arguments (so wildcards need not be +quoted). It also provides only rudimentary quoting. The only +(useful) quote character is the double quote ("). It can be used to +protect spaces in arguments and other special characters. The +Windows NT documentation has almost no description of how the +quoting rules are implemented, but here are some general observations +based on experiments: The shell breaks arguments at spaces and +passes them to programs in argc/argv. Doublequotes can be used +to prevent arguments with spaces in them from being split up. +You can put a double quote in an argument by escaping it with +a backslash and enclosing the whole argument within double quotes. +The backslash and the pair of double quotes surrounding the +argument will be stripped by the shell. + +The file redirection characters "<", ">", and "|" cannot be quoted +by double quotes (there are probably more such). Single quotes +will protect those three file redirection characters, but the +single quotes don't get stripped by the shell (just to make this +type of quoting completely useless). The caret "^" has also +been observed to behave as a quoting character (and doesn't get +stripped by the shell also). + +Here are some examples of usage of the "cmd" shell: + +This prints two doublequotes: + + perl -e "print '\"\"' " + +This does the same: + + perl -e "print \"\\\"\\\"\" " + +This prints "bar" and writes "foo" to the file "blurch": + + perl -e "print 'foo'; print STDERR 'bar'" > blurch + +This prints "foo" ("bar" disappears into nowhereland): + + perl -e "print 'foo'; print STDERR 'bar'" 2> nul + +This prints "bar" and writes "foo" into the file "blurch": + + perl -e "print 'foo'; print STDERR 'bar'" 1> blurch + +This prints "foo" and writes "bar" to the file "blurch": + + perl -e "print 'foo'; print STDERR 'bar'" 2> blurch + +This pipes "foo" to the "less" pager and prints "bar" on the console: + + perl -e "print 'foo'; print STDERR 'bar'" | less + +This pipes "foo\nbar\n" to the less pager: + + perl -le "print 'foo'; print STDERR 'bar'" |& less + +This does the same thing as the above: + + perl -le "print 'foo'; print STDERR 'bar'" 2>&1 | less + +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 +is left as an exercise to the reader :) + +=item Building Extensions + +The Comprehensive Perl Archive Network (CPAN) offers a wealth +of extensions, some of which require a C compiler to build. +Look in http://www.perl.com/ for more information on CPAN. + +Most extensions (whether they require a C compiler or not) can +be built, tested and installed with the standard mantra: + + perl Makefile.PL + nmake + nmake test + nmake install + +Note the NMAKE that comes with Visual C++ is required. Some +extensions may not provide a testsuite (so "nmake test" +may not do anything, or fail), but most serious ones do. + +If a module implements XSUBs, you will need a C compiler (Visual C++ +versions 2.0 and above are currently supported). You must make sure +you have set up the environment for the compiler for command-line +compilation. + +If a module does not build for some reason, carefully look at +why it failed, and report problems to the module author. If +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 Miscellaneous Things + +A full set of HTML documentation is installed, so you should be +able to use it if you have a web browser installed on your +system. + +C<perldoc> is also a useful tool for browsing information contained +in the documentation, especially in conjunction with a pager +like C<less> (recent versions of which have Win32 support). You may +have to set the PAGER environment variable to use a specific pager. +"perldoc -f foo" will print information about the perl operator +"foo". + +If you find bugs in perl, you can run C<perlbug> to create a +bug report (you may have to send it manually if C<perlbug> cannot +find a mailer on your system). + +=back + =head1 BUGS AND CAVEATS -This is still very much an experimental port, and should be considered -alpha quality software. You can expect changes in virtually all of -these areas: build process, installation structure, supported -utilities/modules, and supported perl functionality. Specifically, -functionality specific to the Win32 environment may ultimately -be supported as either core modules or extensions. +This port has not been tested as extensively as we'd like, and +therefore should be considered beta quality software. You should +expect changes in virtually all of these areas: build process, +installation structure, supported utilities/modules, and supported +perl functionality. In particular, functionality specific to the +Win32 environment may ultimately be supported as either core modules +or extensions. This means that you should be prepared to recompile +extensions when binary incompatibilites arise due to changes in the +internal structure of the code. If you have had prior exposure to Perl on Unix platforms, you will notice this port exhibits behavior different from what is documented. Most of the -differences fall under one of these categories. +differences fall under one of these categories. We do not consider +any of them to be serious limitations (especially when compared to the +limited nature of some of the Win32 OSes themselves :) =over 8 @@ -142,7 +296,8 @@ differences fall under one of these categories. C<stat()> and C<lstat()> functions may not behave as documented. They may return values that bear no resemblance to those reported on Unix -platforms, and some fields may be completely bogus. +platforms, and some fields (like the the one for inode) may be completely +bogus. =item * @@ -163,11 +318,6 @@ The four-argument C<select()> call is only supported on sockets. =item * -The behavior of C<system()> or the C<qx[]> operator (a.k.a. "backticks"), -when used to call interactive commands, is ill-defined. - -=item * - C<$?> ends up with the exitstatus of the subprocess (this is different from Unix, where the exitstatus is actually given by "$? >> 8"). Failure to spawn() the subprocess is indicated by setting $? to @@ -191,12 +341,12 @@ Signal handling may not behave as on Unix platforms. =item * -File globbing may not behave as on Unix platforms. - -=item * - -Not all of the utilities that come with the Perl distribution -are supported yet. +File globbing may not behave as on Unix platforms. In particular, +globbing does not understand wildcards in the pathname component, +but only in the filename component. In other words, something like +"print <*/*.pl>" will not print all the perl scripts in all the +subdirectories one level under the current one (like it does on +UNIX platforms). =back diff --git a/config_h.SH b/config_h.SH index 938cf51a21..cfae03ad99 100755 --- a/config_h.SH +++ b/config_h.SH @@ -39,8 +39,25 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double. Usual values are 2, 4 and 8. + * On NeXT starting with 3.2, you can build "Fat" Multiple Architecture + * Binaries (MAB) for targets with varying alignment. This only matters + * for perl, where the config.h can be generated and installed on one + * system, and used by a different architecture to build an extension. + * The default is eight, for safety. */ +#ifndef NeXT #define MEM_ALIGNBYTES $alignbytes /**/ +#else /* NeXT */ +#ifdef __m68k__ +#define MEM_ALIGNBYTES 2 +#else +#ifdef __i386__ +#define MEM_ALIGNBYTES 4 +#else /* __hppa__, __sparc__ and default for unknown architectures */ +#define MEM_ALIGNBYTES 8 +#endif /* __i386__ */ +#endif /* __m68k__ */ +#endif /* NeXT */ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -1443,7 +1460,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... - * On NeXT 4 (and greater), you can build "Fat" Multiple Architecture + * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture * Binaries (MAB) on either big endian or little endian machines. * The endian-ness is available at compile-time. This only matters * for perl, where the config.h can be generated and installed on diff --git a/hints/next_3.sh b/hints/next_3.sh index 2ea3c654c0..829d273a27 100644 --- a/hints/next_3.sh +++ b/hints/next_3.sh @@ -62,25 +62,50 @@ lddlflags='-nostdlib -r' # using GNU cc and try to specify -fpic for cccdlflags. cccdlflags=' ' +###################################################################### +# MAB support +###################################################################### +# By default we will build for all architectures your development +# environment supports. If you only want to build for the platform +# you are on, simply comment or remove the line below. +# +# If you want to build for specific architectures, change the line +# below to something like # -# Change the line below if you do not want to build 'quad-fat' -# binaries +# archs=(m68k i386) # archs=`/bin/lipo -info /usr/lib/libm.a | sed 's/^[^:]*:[^:]*: //'` -for d in $archs -do - mab="$mab -arch $d" -done -archname='next-fat' +# +# leave the following part alone +# +archcount=`echo $archs |wc -w` +if [ $archcount -gt 1 ] +then + for d in $archs + do + mabflags="$mabflags -arch $d" + done + ccflags="$ccflags $mabflags" + ldflags="$ldflags $mabflags" + lddlflags="$lddlflags $mabflags" + archname='next-fat' +fi +###################################################################### +# END MAB support +###################################################################### ld='cc' i_utime='undef' groupstype='int' direntrytype='struct direct' d_strcoll='undef' - d_uname='define' +# +# At least on m68k there are situations when memcmp doesn't behave +# as expected. So we'll use perl's memcmp. +# +d_sanemcmp='undef' # setpgid() is in the posix library, but we don't use -posix, so # we don't see it. ext/POSIX/POSIX.xs *does* use -posix, so # setpgid is still available as POSIX::setpgid. diff --git a/hints/next_4.sh b/hints/next_4.sh index 651b5e40fc..1108794868 100644 --- a/hints/next_4.sh +++ b/hints/next_4.sh @@ -23,27 +23,37 @@ cccdlflags='none' ld='cc' #optimize='-g -O' +###################################################################### +# MAB support +###################################################################### +# By default we will build for all architectures your development +# environment supports. If you only want to build for the platform +# you are on, simply comment or remove the line below. +# +# If you want to build for specific architectures, change the line +# below to something like # -# Change the lines below if you do not want to build 'triple-fat' -# binaries +# archs=(m68k i386) # archs=`/bin/lipo -info /usr/lib/libm.a | sed 's/^[^:]*:[^:]*: //'` -for d in $archs -do - mab="$mab -arch $d" -done # -# Unfortunately, "cc -E - $mab" doesn't work. Since that's what -# Configure will try if we add $mab to $ccflags, we won't. If you want -# to build a fat binary, try changing $ccflags and $ccdlflags to look -# like this when Configure invites you to edit config.h manually: -# -# ccflags="$ccflags $mab" -# ccdlflags="$mab" -# -# (I wonder: Can we also set ld='libtool -xxx' ?) -# +# leave the following part alone +# +archcount=`echo $archs |wc -w` +if [ $archcount -gt 1 ] +then + for d in $archs + do + mabflags="$mabflags -arch $d" + done + ccflags="$ccflags $mabflags" + ldflags="$ldflags $mabflags" + lddlflags="$lddlflags $mabflags" +fi +###################################################################### +# END MAB support +###################################################################### useshprlib='true' dlext='bundle' @@ -53,48 +63,27 @@ so='dylib' # The default prefix would be '/usr/local'. But since many people are # likely to have still 3.3 machines on their network, we do not want # to overwrite possibly existing 3.3 binaries. -# Allow a Configure -Dprefix=/foo/bar override. +# You can use Configure -Dprefix=/foo/bar to override this, or simply +# remove the lines below. # case "$prefix" in '') prefix='/usr/local/OPENSTEP' ;; esac -#archlib='/usr/lib/perl5' -#archlibexp='/usr/lib/perl5' archname='OPENSTEP-Mach' +# +# At least on m68k there are situations when memcmp doesn't behave +# as expected. So we'll use perl's memcmp. +# +d_sanemcmp='undef' + d_strcoll='undef' i_dbm='define' i_utime='undef' groupstype='int' direntrytype='struct direct' -###################################################################### -# THE MALLOC STORY -###################################################################### -# 1994: -# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails -# with Larry's malloc on NS 3.2 due to broken sbrk() -# -# setting usemymalloc='n' was the solution back then. Later came -# reports that perl would run unstable on 3.2: -# -# From about perl5.002beta1h perl became unstable on the -# NeXT. Intermittent coredumps were frequent on 3.2 OS. There were -# reports, that the developer version of 3.3 didn't have problems, so it -# seemed pretty obvious that we had to work around an malloc bug in 3.2. -# This hints file reflects a patch to perl5.002_01 that introduces a -# home made sbrk routine (remember, NeXT's sbrk _never_ worked). This -# sbrk makes it possible to run perl with its own malloc. Thanks to -# Ilya who showed me the way to his sbrk for OS/2!! -# andreas koenig, 1996-06-16 -# -# So, this hintsfile is using perl's malloc. If you want to turn perl's -# malloc off, you need to change remove '-DUSE_PERL_SBRK' and -# '-DHIDEMYMALLOC' from the ccflags above and set usemymalloc below -# to 'n'. -# -###################################################################### usemymalloc='y' clocktype='int' @@ -104,8 +93,3 @@ clocktype='int' # running ranlib. The '5' is an empirical number that's "long enough." # (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>) ranlib='sleep 5; /bin/ranlib' -# -# There where reports that the compiler on HPPA machines -# fails with the -O flag on pp.c. -# But since there is no HPPA for OPENSTEP... -# pp_cflags='optimize="-g"' diff --git a/installperl b/installperl index 07b1e55627..ad1ad91c5a 100755 --- a/installperl +++ b/installperl @@ -349,7 +349,9 @@ sub link { eval { CORE::link($from, $to) ? $success++ - : warn "Couldn't link $from to $to: $!\n" + : ($from =~ m#^/afs/# || $to =~ m#^/afs/#) + ? die "AFS" # okay inside eval {} + : warn "Couldn't link $from to $to: $!\n" unless $nonono; }; if ($@) { diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm index ec04efc889..92207acb2b 100644 --- a/lib/Sys/Hostname.pm +++ b/lib/Sys/Hostname.pm @@ -60,6 +60,11 @@ sub hostname { Carp::croak "Cannot get host name of local machine"; } + elsif ($^O eq 'MSWin32') { + ($host) = gethostbyname('localhost'); + chomp($host = `hostname 2> NUL`) unless defined $host; + return $host; + } else { # Unix # method 2 - syscall is preferred since it avoids tainting problems @@ -3232,6 +3232,9 @@ OP *block; SAVEFREESV(compcv); goto done; } + /* ahem, death to those who redefine active sort subs */ + if (curstack == sortstack && sortcop == CvSTART(cv)) + croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); if (const_sv || dowarn) { line_t oldline = curcop->cop_line; diff --git a/patchlevel.h b/patchlevel.h index 25ab1c65ac..4d3c4dd891 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -38,6 +38,7 @@ */ static char *local_patches[] = { NULL + ,"Dev99A - First post-gamma development patch" ,NULL }; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 9574872791..a8c0909a4c 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -10,9 +10,9 @@ this one. =head1 Supported Environments -Perl5.004 builds out of the box on Unix, Plan9, LynxOS, VMS, OS/2, -QNX, AmigaOS, and Windows NT; once built on Windows NT, Perl runs -on Windows 95 as well. +Perl5.004 builds out of the box on Unix, Plan 9, LynxOS, VMS, OS/2, +QNX, AmigaOS, and Windows NT. Perl runs on Windows 95 as well, but it +cannot be built there, for lack of a reasonable command interpreter. =head1 Core Changes @@ -72,7 +72,7 @@ your scripts. Before Perl 5.004, C<AUTOLOAD> functions were looked up as methods (using the C<@ISA> hierarchy), even when the function to be autoloaded was called as a plain function (e.g. C<Foo::bar()>), not a method -(e.g. C<Foo->bar()> or C<$obj->bar()>). +(e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>). Perl 5.005 will use method lookup only for methods' C<AUTOLOAD>s. However, there is a significant base of existing code that may be using @@ -92,9 +92,9 @@ assigned to (via C<@_>). Earlier versions of Perl vary in their handling of such arguments. Perl versions 5.002 and 5.003 always brought them into existence. -Perl versions 5.000, 5.001, and 5.002 brought them into existence only -if they were not the first argument (which was almost certainly a -bug). Earlier versions of Perl never brought them into existence. +Perl versions 5.000 and 5.001 brought them into existence only if +they were not the first argument (which was almost certainly a bug). +Earlier versions of Perl never brought them into existence. For example, given this code: @@ -280,8 +280,8 @@ The new conversions in Perl's sprintf() are: %i a synonym for %d %p a pointer (the address of the Perl value, in hexadecimal) - %n special: B<stores> into the next variable in the parameter - list the number of characters printed so far + %n special: *stores* the number of characters output so far + into the next variable in the parameter list The new flags that go between the C<%> and the conversion are: @@ -665,6 +665,43 @@ Each unique hash key is only allocated once, no matter how many hashes have an entry with that key. So even if you have 100 copies of the same hash, the hash keys never have to be reallocated. +=head1 Support for More Operating Systems + +Support for the following operating systems is new in Perl 5.004. + +=head2 Win32 + +Perl 5.004 now includes support for building a "native" perl under +Windows NT, using the Microsoft Visual C++ compiler (versions 2.0 +and above). The resulting perl can be used under Windows 95 (if it +is installed in the same directory locations as it got installed +in Windows NT). This port includes support for perl extension +building tools like L<MakeMaker> and L<h2xs>, so that many extensions +available on the Comprehensive Perl Archive Network (CPAN) can now be +readily built under Windows NT. See http://www.perl.com/ for more +information on CPAN, and L<README.win32> for more details on how to +get started with building this port. + +There is also support for building perl under the Cygwin32 environment. +Cygwin32 is a set of GNU tools that make it possible to compile and run +many UNIX programs under Windows NT by providing a mostly UNIX-like +interface for compilation and execution. See L<README.cygwin32> for +more details on this port, and how to obtain the Cygwin32 toolkit. +This port has not been as well tested as the "native" port described +above (which is not as well tested as we'd like either :) + +=head2 Plan 9 + +See L<README.plan9>. + +=head2 QNX + +See L<README.qnx>. + +=head2 AmigaOS + +See L<README.amigaos>. + =head1 Pragmata Six new pragmatic modules exist: @@ -933,6 +970,19 @@ For example, you can now say =head1 Utility Changes +=head2 pod2html + +=over + +=item Sends converted HTML to standard output + +The I<pod2html> utility included with Perl 5.004 is entirely new. +By default, it sends the converted HTML to its standard output, +instead of writing it to a file like Perl 5.003's I<pod2html> did. +Use the B<--outfile=FILENAME> option to write to a file. + +=back + =head2 xsubpp =over @@ -1097,6 +1147,13 @@ that can no longer be found in the table. as an lvalue, which is pretty strange. Perhaps you forgot to dereference it first. See L<perlfunc/substr>. +=item Can't redefine active sort subroutine %s + +(F) Perl optimizes the internal handling of sort subroutines and keeps +pointers into them. You tried to redefine one such sort subroutine when it +was currently active, which is not allowed. If you really want to do +this, you should write C<sort { &func } @x> instead of C<sort func @x>. + =item Can't use bareword ("%s") as %s ref while "strict refs" in use (F) Only hard references are allowed by "strict refs". Symbolic references diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 448e39909d..ea33f50f9f 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -688,6 +688,13 @@ couldn't open the pipe into which to send data destined for stdout. (F) The script you specified can't be opened for the indicated reason. +=item Can't redefine active sort subroutine %s + +(F) Perl optimizes the internal handling of sort subroutines and keeps +pointers into them. You tried to redefine one such sort subroutine when it +was currently active, which is not allowed. If you really want to do +this, you should write C<sort { &func } @x> instead of C<sort func @x>. + =item Can't rename %s to %s: %s, skipping file (S) The rename done by the B<-i> switch failed for some reason, probably because diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index 0c91f1e8de..4fabce6f36 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -1183,6 +1183,3 @@ CPAN). No ONC::RPC module is known. Copyright (c) 1997 Tom Christiansen and Nathan Torkington. All rights reserved. See L<perlfaq> for distribution information. -END-of-perlfaq9.pod -exit - diff --git a/pod/perlop.pod b/pod/perlop.pod index 3734477ecf..7f39b9d4de 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -644,7 +644,8 @@ Options are: If "/" is the delimiter then the initial C<m> is optional. With the C<m> you can use any pair of non-alphanumeric, non-whitespace characters as delimiters. This is particularly useful for matching Unix path names -that contain "/", to avoid LTS (leaning toothpick syndrome). +that contain "/", to avoid LTS (leaning toothpick syndrome). If "?" is +the delimiter, then the match-only-once rule of C<?PATTERN?> applies. PATTERN may contain variables, which will be interpolated (and the pattern recompiled) every time the pattern search is evaluated. (Note @@ -817,6 +818,11 @@ Some frequently seen examples: use POSIX qw( setlocale localeconv ) @EXPORT = qw( foo bar baz ); +A common mistake is to try to separate the words with comma or to put +comments into a multi-line qw-string. For this reason the C<-w> +switch produce warnings if the STRING contains the "," or the "#" +character. + =item s/PATTERN/REPLACEMENT/egimosx Searches a string for a pattern, and if found, replaces that pattern diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 51e6942fcc..6d8ee20a72 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -591,7 +591,10 @@ processes. However, scripts running setuid would do well to execute the following lines before doing anything else, just to keep people honest: - $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need - $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; - $ENV{'IFS'} = '' if defined $ENV{'IFS'}; + $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}; diff --git a/pod/perlsec.pod b/pod/perlsec.pod index e21f97f21f..29a9167cf4 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -58,7 +58,10 @@ For example: $path = $ENV{'PATH'}; # $path now tainted $ENV{'PATH'} = '/bin:/usr/bin'; - $ENV{'IFS'} = '' if $ENV{'IFS'} ne ''; + delete $ENV{'IFS'}; + delete $ENV{'CDPATH'}; + delete $ENV{'ENV'}; + $ENV{'TERM'} = 'dumb'; $path = $ENV{'PATH'}; # $path now NOT tainted system "echo $data"; # Is secure now! @@ -79,6 +82,9 @@ For example: exec "echo", $arg; # Secure (doesn't use the shell) exec "sh", '-c', $arg; # Considered secure, alas! + @files = <*.c>; # Always insecure (uses csh) + @files = glob('*.c'); # Always insecure (uses csh) + If you try to do something insecure, you will get a fatal error saying something like "Insecure dependency" or "Insecure PATH". Note that you can still write an insecure B<system> or B<exec>, but only by explicitly diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 7cdd893ef4..c124f21c6a 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -320,8 +320,9 @@ otherwise. An inner block may countermand this with S<"no strict 'vars'">. A my() has both a compile-time and a run-time effect. At compile time, the compiler takes notice of it; the principle usefulness of this is to -quiet C<use strict 'vars'>. The actual initialization doesn't happen -until run time, so gets executed every time through a loop. +quiet C<use strict 'vars'>. The actual initialization is delayed until +run time, so it gets executed appropriately; every time through a loop, +for example. Variables declared with "my" are not part of any package and are therefore never fully qualified with the package name. In particular, you're not diff --git a/pod/perltoc.pod b/pod/perltoc.pod index f4d917d00e..0340059b15 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -961,6 +961,20 @@ LIST, READLINE this, GETC this, DESTROY this =back +=item Support for More Operating Systems + +=over + +=item Win32 + +=item Plan 9 + +=item QNX + +=item AmigaOS + +=back + =item Pragmata use autouse MODULE => qw(sub1 sub2 sub3), use blib, use blib 'dir', use @@ -996,6 +1010,10 @@ constant NAME => VALUE, use locale, use ops, use vmsish =over +=item pod2html + +Sends converted HTML to standard output + =item xsubpp C<void> XSUBs now default to returning nothing @@ -1018,26 +1036,27 @@ L<perlsec> not a HASH element or slice, Allocation too large: %lx, Allocation too large, Applying %s to %s will act on scalar(%s), Attempt to free nonexistent shared string, Attempt to use reference as lvalue in substr, -Can't use bareword ("%s") as %s ref while "strict refs" in use, Cannot -resolve method `%s' overloading `%s' in package `%s', Constant subroutine -%s redefined, Constant subroutine %s undefined, Copy method did not return -a reference, Died, Exiting pseudo-block via %s, Identifier too long, -Illegal character %s (carriage return), Illegal switch in PERL5OPT: %s, -Integer overflow in hex number, Integer overflow in octal number, internal -error: glob failed, Invalid conversion in %s: "%s", Invalid type in pack: -'%s', Invalid type in unpack: '%s', Name "%s::%s" used only once: possible -typo, Null picture in formline, Offset outside string, Out of memory!, Out -of memory during request for %s, panic: frexp, Possible attempt to put -comments in qw() list, Possible attempt to separate words with commas, -Scalar value @%s{%s} better written as $%s{%s}, Stub found while resolving -method `%s' overloading `%s' in package `%s', Too late for "B<-T>" option, -untie attempted while %d inner references still exist, Unrecognized -character %s, Unsupported function fork, Use of "$$<digit>" to mean -"${$}<digit>" is deprecated, Value of %s can be "0"; test with defined(), -Variable "%s" may be unavailable, Variable "%s" will not stay shared, -Warning: something's wrong, Ill-formed logical name |%s| in prime_env_iter, -Got an error from DosAllocMem, Malformed PERLLIB_PREFIX, PERL_SH_DIR too -long, Process terminated by SIG%s +Can't redefine active sort subroutine %s, Can't use bareword ("%s") as %s +ref while "strict refs" in use, Cannot resolve method `%s' overloading `%s' +in package `%s', Constant subroutine %s redefined, Constant subroutine %s +undefined, Copy method did not return a reference, Died, Exiting +pseudo-block via %s, Identifier too long, Illegal character %s (carriage +return), Illegal switch in PERL5OPT: %s, Integer overflow in hex number, +Integer overflow in octal number, internal error: glob failed, Invalid +conversion in %s: "%s", Invalid type in pack: '%s', Invalid type in unpack: +'%s', Name "%s::%s" used only once: possible typo, Null picture in +formline, Offset outside string, Out of memory!, Out of memory during +request for %s, panic: frexp, Possible attempt to put comments in qw() +list, Possible attempt to separate words with commas, Scalar value @%s{%s} +better written as $%s{%s}, Stub found while resolving method `%s' +overloading `%s' in package `%s', Too late for "B<-T>" option, untie +attempted while %d inner references still exist, Unrecognized character %s, +Unsupported function fork, Use of "$$<digit>" to mean "${$}<digit>" is +deprecated, Value of %s can be "0"; test with defined(), Variable "%s" may +be unavailable, Variable "%s" will not stay shared, Warning: something's +wrong, Ill-formed logical name |%s| in prime_env_iter, Got an error from +DosAllocMem, Malformed PERLLIB_PREFIX, PERL_SH_DIR too long, Process +terminated by SIG%s =item BUGS @@ -1190,6 +1209,8 @@ i, m, s, x =item WARNING on \1 vs $1 +=item SEE ALSO + =back =head2 perlrun - how to execute the Perl interpreter @@ -1966,13 +1987,13 @@ t, t expr, b [line] [condition], b subname [condition], b postpone subname command, A, O [opt[=val]] [opt"val"] [opt?].., C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>, C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>, C<PrintRet>, -C<frame>, C<maxTraceLen>, C<arrayDepth>, C<hashDepth>, C<compactDump>, -C<veryCompact>, C<globPrint>, C<DumpDBFiles>, C<DumpPackages>, C<quote>, -C<HighBit>, C<undefPrint>, C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, -C<NonStop>, E<lt> [ command ], E<lt>E<lt> command, E<gt> command, -E<gt>E<gt> command, { [ command ], {{ command, ! number, ! -number, ! -pattern, !! cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, = [alias value], -command, m expr, m package +C<ornaments>, C<frame>, C<maxTraceLen>, C<arrayDepth>, C<hashDepth>, +C<compactDump>, C<veryCompact>, C<globPrint>, C<DumpDBFiles>, +C<DumpPackages>, C<quote>, C<HighBit>, C<undefPrint>, C<UsageOnly>, C<TTY>, +C<noTTY>, C<ReadLine>, C<NonStop>, E<lt> [ command ], E<lt>E<lt> command, +E<gt> command, E<gt>E<gt> command, { [ command ], {{ command, ! number, ! +-number, ! pattern, !! cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, = +[alias value], command, m expr, m package =item Debugger input/output @@ -224,6 +224,15 @@ PP(pp_glob) OP *result; ENTER; + if (tainting) { + /* + * The external globbing program may use things we can't control, + * so for security reasons we must assume the worst. + */ + TAINT; + taint_proper(no_security, "glob"); + } + SAVESPTR(last_in_gv); /* We don't want this to be permanent. */ last_in_gv = (GV*)*stack_sp--; @@ -1928,6 +1928,11 @@ register SV *sstr; GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } + /* ahem, death to those who redefine active sort subs */ + else if (curstack == sortstack + && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) + croak("Can't redefine active sort subroutine %s", + GvNAME(dstr)); (void)SvOK_off(dstr); GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); @@ -2010,6 +2015,13 @@ register SV *sstr; if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { + /* ahem, death to those who redefine + * active sort subs */ + if (curstack == sortstack && + sortcop == CvSTART(cv)) + croak( + "Can't redefine active sort subroutine %s", + GvENAME((GV*)dstr)); if (cv_const_sv(cv)) warn("Constant subroutine %s redefined", GvENAME((GV*)dstr)); diff --git a/t/op/sort.t b/t/op/sort.t index 44c7c04185..c792bbb48e 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -2,7 +2,7 @@ # $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ -print "1..14\n"; +print "1..19\n"; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } @@ -66,3 +66,28 @@ print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; + +$^W = 0; +# redefining sort sub inside the sort sub should fail +sub twoface { *twoface = sub { $a <=> $b }; &twoface } +eval { @b = sort twoface 4,1,3,2 }; +print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); + +# redefining sort subs outside the sort should not fail +eval { *twoface = sub { &backwards } }; +print $@ ? "not ok 16\n" : "ok 16\n"; + +eval { @b = sort twoface 4,1,3,2 }; +print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); + +*twoface = sub { *twoface = *backwards; $a <=> $b }; +eval { @b = sort twoface 4,1 }; +print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); + +*twoface = sub { + eval 'sub twoface { $a <=> $b }'; + die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + $a <=> $b; + }; +eval { @b = sort twoface 4,1 }; +print $@ ? "$@" : "not ok 19\n"; diff --git a/t/op/taint.t b/t/op/taint.t index 8639fd60f5..a33edde0eb 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -19,15 +19,18 @@ 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/; + if ($Is_VMS) { - my ($olddcl) = $ENV{'DCL$PATH'} =~ /^(.*)$/; - my ($oldifs) = $ENV{IFS} =~ /^(.*)$/; + my (%old, $x); + for $x ('DCL$PATH', @MoreEnv) { + ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; + } eval <<EndOfCleanup; END { \$ENV{PATH} = ''; warn "# Note: logical name 'PATH' may have been deleted\n"; - \$ENV{IFS} = \$oldifs; - \$ENV{'DCL\$PATH'} = \$olddcl; + @ENV{keys %old} = values %old; } EndOfCleanup } @@ -79,7 +82,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..136\n"; +print "1..132\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -87,21 +90,29 @@ print "1..136\n"; { $ENV{'DCL$PATH'} = '' if $Is_VMS; + $ENV{PATH} = ''; + delete $ENV{IFS}; + delete $ENV{ENV}; + delete $ENV{CDPATH}; + $ENV{TERM} = 'dumb'; + + test 1, eval { `$echo 1` } eq "1\n"; + if ($Is_MSWin32) { - print "# PATH/IFS tainting tests skipped\n"; - for (1..4) { print "ok $_\n" } + print "# Environment tainting tests skipped\n"; + for (2) { print "ok $_\n" } } else { - $ENV{PATH} = $TAINT; - $ENV{IFS} = " \t\n"; - test 1, eval { `$echo 1` } eq ''; - test 2, $@ =~ /^Insecure \$ENV{PATH}/, $@; - - $ENV{PATH} = ''; - $ENV{IFS} = $TAINT; - test 3, eval { `$echo 1` } eq ''; - test 4, $@ =~ /^Insecure \$ENV{IFS}/, $@; + my @vars = ('PATH', @MoreEnv); + while (my $v = $vars[0]) { + local $ENV{$v} = $TAINT; + last if eval { `$echo 1` }; + last unless $@ =~ /^Insecure \$ENV{$v}/; + shift @vars; + } + test 2, !@vars, "\$$vars[0]"; } + my $tmp; if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32) { print "# all directories are writeable\n"; @@ -114,75 +125,69 @@ print "1..136\n"; } if ($tmp) { - $ENV{PATH} = $tmp; - $ENV{IFS} = " \t\n"; - test 5, eval { `$echo 1` } eq ''; - test 6, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; + local $ENV{PATH} = $tmp; + test 3, eval { `$echo 1` } eq ''; + test 4, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; } else { - for (5..6) { print "ok $_\n" } + for (3..4) { print "ok $_\n" } } - $ENV{PATH} = ''; - $ENV{IFS} = " \t\n"; - test 7, eval { `$echo 1` } eq "1\n"; - test 8, $@ eq '', $@; - if ($Is_VMS) { $ENV{'DCL$PATH'} = $TAINT; - test 9, eval { `$echo 1` } eq ''; - test 10, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; + test 5, eval { `$echo 1` } eq ''; + test 6, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; if ($tmp) { $ENV{'DCL$PATH'} = $tmp; - test 11, eval { `$echo 1` } eq ''; - test 12, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; + test 7, eval { `$echo 1` } eq ''; + test 8, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; } else { print "# can't find world-writeable directory to test DCL\$PATH\n"; - for (11..12) { print "ok $_\n" } + for (7..8) { print "ok $_\n" } } $ENV{'DCL$PATH'} = ''; } else { print "# This is not VMS\n"; - for (9..12) { print "ok $_\n"; } + for (5..8) { print "ok $_\n"; } } } # Let's see that we can taint and untaint as needed. { my $foo = $TAINT; - test 13, tainted $foo; + test 9, 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 14, not tainted $foo; + test 10, not tainted $foo; taint_these($foo); - test 15, tainted $foo; + test 11, tainted $foo; my @list = 1..10; - test 16, not any_tainted @list; + test 12, not any_tainted @list; taint_these @list[1,3,5,7,9]; - test 17, any_tainted @list; - test 18, all_tainted @list[1,3,5,7,9]; - test 19, not any_tainted @list[0,2,4,6,8]; + 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]; ($foo) = $foo =~ /(.+)/; - test 20, not tainted $foo; + test 16, not tainted $foo; $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; - test 21, not tainted $foo; - test 22, $foo eq 'bar'; + test 17, not tainted $foo; + test 18, $foo eq 'bar'; my $pi = 4 * atan2(1,1) + $TAINT0; - test 23, tainted $pi; + test 19, tainted $pi; ($pi) = $pi =~ /(\d+\.\d+)/; - test 24, not tainted $pi; - test 25, sprintf("%.5f", $pi) eq '3.14159'; + test 20, not tainted $pi; + test 21, sprintf("%.5f", $pi) eq '3.14159'; } # How about command-line arguments? The problem is that we don't @@ -198,150 +203,150 @@ print "1..136\n"; }; close PROG; print `$Invoke_Perl "-T" $arg and some suspect arguments`; - test 26, !$?, "Exited with status $?"; + test 22, !$?, "Exited with status $?"; unlink $arg; } # Reading from a file should be tainted { my $file = './TEST'; - test 27, open(FILE, $file), "Couldn't open '$file': $!"; + test 23, open(FILE, $file), "Couldn't open '$file': $!"; my $block; sysread(FILE, $block, 100); my $line = <FILE>; close FILE; - test 28, tainted $block; - test 29, tainted $line; + test 24, tainted $block; + test 25, tainted $line; } -# Globs should be tainted. +# 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; - my @globs = <*>; - test 30, all_tainted @globs; + my @globs = eval { <*> }; + test 26, @globs == 0 && $@ =~ /^Insecure dependency/; - @globs = glob '*'; - test 31, all_tainted @globs; + @globs = eval { glob '*' }; + test 27, @globs == 0 && $@ =~ /^Insecure dependency/; } # Output of commands should be tainted { my $foo = `$echo abc`; - test 32, tainted $foo; + test 28, tainted $foo; } # Certain system variables should be tainted { - test 33, all_tainted $^X, $0; + test 29, all_tainted $^X, $0; } # Results of matching should all be untainted { my $foo = "abcdefghi" . $TAINT; - test 34, tainted $foo; + test 30, tainted $foo; $foo =~ /def/; - test 35, not any_tainted $`, $&, $'; + test 31, not any_tainted $`, $&, $'; $foo =~ /(...)(...)(...)/; - test 36, not any_tainted $1, $2, $3, $+; + test 32, not any_tainted $1, $2, $3, $+; my @bar = $foo =~ /(...)(...)(...)/; - test 37, not any_tainted @bar; + test 33, not any_tainted @bar; - test 38, tainted $foo; # $foo should still be tainted! - test 39, $foo eq "abcdefghi"; + test 34, tainted $foo; # $foo should still be tainted! + test 35, $foo eq "abcdefghi"; } # Operations which affect files can't use tainted data. { - test 40, eval { chmod 0, $TAINT } eq '', 'chmod'; - test 41, $@ =~ /^Insecure dependency/, $@; + test 36, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 37, $@ =~ /^Insecure dependency/, $@; # There is no feature test in $Config{} for truncate, # so we allow for the possibility that it's missing. - test 42, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; - test 43, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; + test 38, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 39, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - test 44, eval { rename '', $TAINT } eq '', 'rename'; - test 45, $@ =~ /^Insecure dependency/, $@; + test 40, eval { rename '', $TAINT } eq '', 'rename'; + test 41, $@ =~ /^Insecure dependency/, $@; - test 46, eval { unlink $TAINT } eq '', 'unlink'; - test 47, $@ =~ /^Insecure dependency/, $@; + test 42, eval { unlink $TAINT } eq '', 'unlink'; + test 43, $@ =~ /^Insecure dependency/, $@; - test 48, eval { utime $TAINT } eq '', 'utime'; - test 49, $@ =~ /^Insecure dependency/, $@; + test 44, eval { utime $TAINT } eq '', 'utime'; + test 45, $@ =~ /^Insecure dependency/, $@; if ($Config{d_chown}) { - test 50, eval { chown -1, -1, $TAINT } eq '', 'chown'; - test 51, $@ =~ /^Insecure dependency/, $@; + test 46, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 47, $@ =~ /^Insecure dependency/, $@; } else { print "# chown() is not available\n"; - for (50..51) { print "ok $_\n" } + for (46..47) { print "ok $_\n" } } if ($Config{d_link}) { - test 52, eval { link $TAINT, '' } eq '', 'link'; - test 53, $@ =~ /^Insecure dependency/, $@; + test 48, eval { link $TAINT, '' } eq '', 'link'; + test 49, $@ =~ /^Insecure dependency/, $@; } else { print "# link() is not available\n"; - for (52..53) { print "ok $_\n" } + for (48..49) { print "ok $_\n" } } if ($Config{d_symlink}) { - test 54, eval { symlink $TAINT, '' } eq '', 'symlink'; - test 55, $@ =~ /^Insecure dependency/, $@; + test 50, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 51, $@ =~ /^Insecure dependency/, $@; } else { print "# symlink() is not available\n"; - for (54..55) { print "ok $_\n" } + for (50..51) { print "ok $_\n" } } } # Operations which affect directories can't use tainted data. { - test 56, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; - test 57, $@ =~ /^Insecure dependency/, $@; + test 52, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; + test 53, $@ =~ /^Insecure dependency/, $@; - test 58, eval { rmdir $TAINT } eq '', 'rmdir'; - test 59, $@ =~ /^Insecure dependency/, $@; + test 54, eval { rmdir $TAINT } eq '', 'rmdir'; + test 55, $@ =~ /^Insecure dependency/, $@; - test 60, eval { chdir $TAINT } eq '', 'chdir'; - test 61, $@ =~ /^Insecure dependency/, $@; + test 56, eval { chdir $TAINT } eq '', 'chdir'; + test 57, $@ =~ /^Insecure dependency/, $@; if ($Config{d_chroot}) { - test 62, eval { chroot $TAINT } eq '', 'chroot'; - test 63, $@ =~ /^Insecure dependency/, $@; + test 58, eval { chroot $TAINT } eq '', 'chroot'; + test 59, $@ =~ /^Insecure dependency/, $@; } else { print "# chroot() is not available\n"; - for (62..63) { print "ok $_\n" } + for (58..59) { print "ok $_\n" } } } # Some operations using files can't use tainted data. { my $foo = "imaginary library" . $TAINT; - test 64, eval { require $foo } eq '', 'require'; - test 65, $@ =~ /^Insecure dependency/, $@; + test 60, eval { require $foo } eq '', 'require'; + test 61, $@ =~ /^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 66, eval { open FOO, $foo } eq '', 'open for read'; - test 67, $@ eq '', $@; # NB: This should be allowed - test 68, $! == 2; # File not found + 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 69, eval { open FOO, "> $foo" } eq '', 'open for write'; - test 70, $@ =~ /^Insecure dependency/, $@; + test 65, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 66, $@ =~ /^Insecure dependency/, $@; } # Commands to the system can't use tainted data @@ -350,71 +355,71 @@ print "1..136\n"; if ($^O eq 'amigaos') { print "# open(\"|\") is not available\n"; - for (71..74) { print "ok $_\n" } + for (67..70) { print "ok $_\n" } } else { - test 71, eval { open FOO, "| $foo" } eq '', 'popen to'; - test 72, $@ =~ /^Insecure dependency/, $@; + test 67, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 68, $@ =~ /^Insecure dependency/, $@; - test 73, eval { open FOO, "$foo |" } eq '', 'popen from'; - test 74, $@ =~ /^Insecure dependency/, $@; + test 69, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 70, $@ =~ /^Insecure dependency/, $@; } - test 75, eval { exec $TAINT } eq '', 'exec'; - test 76, $@ =~ /^Insecure dependency/, $@; + test 71, eval { exec $TAINT } eq '', 'exec'; + test 72, $@ =~ /^Insecure dependency/, $@; - test 77, eval { system $TAINT } eq '', 'system'; - test 78, $@ =~ /^Insecure dependency/, $@; + test 73, eval { system $TAINT } eq '', 'system'; + test 74, $@ =~ /^Insecure dependency/, $@; $foo = "*"; taint_these $foo; - test 79, eval { `$echo 1$foo` } eq '', 'backticks'; - test 80, $@ =~ /^Insecure dependency/, $@; + test 75, eval { `$echo 1$foo` } eq '', 'backticks'; + test 76, $@ =~ /^Insecure dependency/, $@; if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe - test 81, join('', eval { glob $foo } ) ne '', 'globbing'; - test 82, $@ eq '', $@; + test 77, join('', eval { glob $foo } ) ne '', 'globbing'; + test 78, $@ eq '', $@; } else { - test 81, join('', eval { glob $foo } ) eq '', 'globbing'; - test 82, $@ =~ /^Insecure dependency/, $@; + test 77, join('', eval { glob $foo } ) eq '', 'globbing'; + test 78, $@ =~ /^Insecure dependency/, $@; } } # Operations which affect processes can't use tainted data. { - test 83, eval { kill 0, $TAINT } eq '', 'kill'; - test 84, $@ =~ /^Insecure dependency/, $@; + test 79, eval { kill 0, $TAINT } eq '', 'kill'; + test 80, $@ =~ /^Insecure dependency/, $@; if ($Config{d_setpgrp}) { - test 85, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; - test 86, $@ =~ /^Insecure dependency/, $@; + test 81, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 82, $@ =~ /^Insecure dependency/, $@; } else { print "# setpgrp() is not available\n"; - for (85..86) { print "ok $_\n" } + for (81..82) { print "ok $_\n" } } if ($Config{d_setprior}) { - test 87, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; - test 88, $@ =~ /^Insecure dependency/, $@; + test 83, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 84, $@ =~ /^Insecure dependency/, $@; } else { print "# setpriority() is not available\n"; - for (87..88) { print "ok $_\n" } + for (83..84) { print "ok $_\n" } } } # Some miscellaneous operations can't use tainted data. { if ($Config{d_syscall}) { - test 89, eval { syscall $TAINT } eq '', 'syscall'; - test 90, $@ =~ /^Insecure dependency/, $@; + test 85, eval { syscall $TAINT } eq '', 'syscall'; + test 86, $@ =~ /^Insecure dependency/, $@; } else { print "# syscall() is not available\n"; - for (89..90) { print "ok $_\n" } + for (85..86) { print "ok $_\n" } } { @@ -423,18 +428,18 @@ print "1..136\n"; local *FOO; my $temp = "./taintC$$"; END { unlink $temp } - test 91, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + test 87, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; - test 92, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; - test 93, $@ =~ /^Insecure dependency/, $@; + test 88, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 89, $@ =~ /^Insecure dependency/, $@; if ($Config{d_fcntl}) { - test 94, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; - test 95, $@ =~ /^Insecure dependency/, $@; + test 90, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 91, $@ =~ /^Insecure dependency/, $@; } else { print "# fcntl() is not available\n"; - for (94..95) { print "ok $_\n" } + for (90..91) { print "ok $_\n" } } close FOO; @@ -445,63 +450,63 @@ print "1..136\n"; { my $foo = 'abc' . $TAINT; my $fooref = \$foo; - test 96, not tainted $fooref; - test 97, tainted $$fooref; - test 98, tainted $foo; + test 92, not tainted $fooref; + test 93, tainted $$fooref; + test 94, tainted $foo; } # Some tests involving assignment { my $foo = $TAINT0; my $bar = $foo; - test 99, all_tainted $foo, $bar; - test 100, tainted($foo = $bar); - test 101, tainted($bar = $bar); - test 102, tainted($bar += $bar); - test 103, tainted($bar -= $bar); - test 104, tainted($bar *= $bar); - test 105, tainted($bar++); - test 106, tainted($bar /= $bar); - test 107, tainted($bar += 0); - test 108, tainted($bar -= 2); - test 109, tainted($bar *= -1); - test 110, tainted($bar /= 1); - test 111, tainted($bar--); - test 112, $bar == 0; + 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 assignment and return of lists { my @foo = ("A", "tainted" . $TAINT, "B"); - test 113, not tainted $foo[0]; - test 114, tainted $foo[1]; - test 115, not tainted $foo[2]; + test 109, not tainted $foo[0]; + test 110, tainted $foo[1]; + test 111, not tainted $foo[2]; my @bar = @foo; - test 116, not tainted $bar[0]; - test 117, tainted $bar[1]; - test 118, not tainted $bar[2]; + test 112, not tainted $bar[0]; + test 113, tainted $bar[1]; + test 114, not tainted $bar[2]; my @baz = eval { "A", "tainted" . $TAINT, "B" }; - test 119, not tainted $baz[0]; - test 120, tainted $baz[1]; - test 121, not tainted $baz[2]; + test 115, not tainted $baz[0]; + test 116, tainted $baz[1]; + test 117, not tainted $baz[2]; my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - test 122, not tainted $plugh[0]; - test 123, tainted $plugh[1]; - test 124, not tainted $plugh[2]; + test 118, not tainted $plugh[0]; + test 119, tainted $plugh[1]; + test 120, not tainted $plugh[2]; my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - test 125, not tainted ((&$nautilus)[0]); - test 126, tainted ((&$nautilus)[1]); - test 127, not tainted ((&$nautilus)[2]); + test 121, not tainted ((&$nautilus)[0]); + test 122, tainted ((&$nautilus)[1]); + test 123, not tainted ((&$nautilus)[2]); my @xyzzy = &$nautilus; - test 128, not tainted $xyzzy[0]; - test 129, tainted $xyzzy[1]; - test 130, not tainted $xyzzy[2]; + test 124, not tainted $xyzzy[0]; + test 125, tainted $xyzzy[1]; + test 126, not tainted $xyzzy[2]; my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - test 131, not tainted ((&$red_october)[0]); - test 132, tainted ((&$red_october)[1]); - test 133, not tainted ((&$red_october)[2]); + test 127, not tainted ((&$red_october)[0]); + test 128, tainted ((&$red_october)[1]); + test 129, not tainted ((&$red_october)[2]); my @corge = &$red_october; - test 134, not tainted $corge[0]; - test 135, tainted $corge[1]; - test 136, not tainted $corge[2]; + test 130, not tainted $corge[0]; + test 131, tainted $corge[1]; + test 132, not tainted $corge[2]; } @@ -35,7 +35,15 @@ void taint_env() { SV** svp; - MAGIC *mg; + MAGIC* mg; + 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 */ + NULL + }; #ifdef VMS int i = 0; @@ -71,9 +79,11 @@ taint_env() } } - svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE); - if (svp && *svp != &sv_undef && SvTAINTED(*svp)) { - TAINT; - taint_proper("Insecure %s%s", "$ENV{IFS}"); + for (e = misc_env; *e; e++) { + svp = hv_fetch(GvHVn(envgv), *e, strlen(*e), FALSE); + if (svp && *svp != &sv_undef && SvTAINTED(*svp)) { + TAINT; + taint_proper("Insecure $ENV{%s}%s", *e); + } } } diff --git a/win32/config.H b/win32/config.H index 37b50a5efd..e375c5692d 100644 --- a/win32/config.H +++ b/win32/config.H @@ -40,8 +40,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "C:\\perl\\bin" /**/ -#define BIN_EXP "C:\\perl\\bin" /**/ +#define BIN "c:\\perl\\bin" /**/ +#define BIN_EXP "c:\\perl\\bin" /**/ /* CAT2: * This macro catenates 2 tokens together. @@ -92,7 +92,7 @@ * This symbol, if defined, indicates that the alarm routine is * available. */ -#define HAS_ALARM /**/ +/*#define HAS_ALARM /**/ /* HASATTRIBUTE: * This symbol indicates the C compiler can check for function attributes, @@ -250,7 +250,7 @@ * This symbol, if defined, indicates that the flock routine is * available to do file locking. */ -/*#define HAS_FLOCK /**/ +#define HAS_FLOCK /**/ /* HAS_FORK: * This symbol, if defined, indicates that the fork routine is @@ -1068,7 +1068,7 @@ * This symbol, if defined, indicates that <ndbm.h> exists and should * be included. */ -#define I_NDBM /**/ +/*#define I_NDBM /**/ /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and @@ -1413,8 +1413,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * 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 "c:\\perl\\lib" /**/ +#define ARCHLIB_EXP "c:\\perl\\lib" /**/ /* BINCOMPAT3: * This symbol, if defined, indicates that Perl 5.004 should be @@ -1660,8 +1660,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "C:\\perl\\lib" /**/ -#define PRIVLIB_EXP "C:\\perl\\lib" /**/ +#define PRIVLIB "c:\\perl\\lib" /**/ +#define PRIVLIB_EXP "c:\\perl\\lib" /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this @@ -1670,7 +1670,7 @@ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ -#define SH_PATH "cmd /c" /**/ +#define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -1716,8 +1716,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "C:\\perl\\lib\\site" /**/ -#define SITEARCH_EXP "C:\\perl\\lib\\site" /**/ +#define SITEARCH "c:\\perl\\lib\\site" /**/ +#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1732,8 +1732,8 @@ * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITELIB "C:\\perl\\lib\\site" /**/ -#define SITELIB_EXP "C:\\perl\\lib\\site" /**/ +#define SITELIB "c:\\perl\\lib\\site" /**/ +#define SITELIB_EXP "c:\\perl\\lib\\site" /**/ /* STARTPERL: * This variable contains the string to put in front of a perl @@ -1778,4 +1778,3 @@ #include <win32.h> #define ARCHLIBEXP (win32PerlLibPath()) #define DEBUGGING -#define MULTIPLCITY diff --git a/win32/config.w32 b/win32/config.w32 index c8f3fc4eca..e977b17e07 100644 --- a/win32/config.w32 +++ b/win32/config.w32 @@ -35,11 +35,11 @@ Id='$Id' Locker='' Log='$Log' Mcc='Mcc' -PATCHLEVEL='3' +PATCHLEVEL='~PATCHLEVEL~' POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' RCSfile='$RCSfile' Revision='$Revision' -SUBVERSION='0' +SUBVERSION='~SUBVERSION~' Source='' State='' afs='false' @@ -123,7 +123,7 @@ d_fd_set='define' d_fds_bits='define' d_fgetpos='define' d_flexfnam='define' -d_flock='undef' +d_flock='define' d_fork='undef' d_fpathconf='undef' d_fsetpos='define' diff --git a/win32/config_sh.PL b/win32/config_sh.PL index d397a1b53b..e62e47f4f7 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -4,6 +4,8 @@ while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) $opt{$1}=$2; shift(@ARGV); } + +@opt{'PATCHLEVEL','SUBVERSION'} = ($] =~ /\.0*([1-9]+)(\d\d)$/); while (<>) { s/~([\w_]+)~/$opt{$1}/g; diff --git a/win32/include/sys/socket.h b/win32/include/sys/socket.h index 7485195590..701022a7fc 100644 --- a/win32/include/sys/socket.h +++ b/win32/include/sys/socket.h @@ -3,12 +3,12 @@ // djl // Provide UNIX compatibility -#ifdef __cplusplus -extern "C" { -#endif #ifndef _INC_SYS_SOCKET #define _INC_SYS_SOCKET +#ifdef __cplusplus +extern "C" { +#endif #ifndef _WINDOWS_ #define _WINDOWS_ diff --git a/win32/perllib.c b/win32/perllib.c index f40013b577..0f63938f5c 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -104,7 +104,7 @@ char *staticlinkmodules[] = { EXTERN_C void boot_DynaLoader _((CV* cv)); static -XS(w32_GetCurrentDirectory) +XS(w32_GetCwd) { dXSARGS; SV *sv = sv_newmortal(); @@ -126,22 +126,223 @@ XS(w32_GetCurrentDirectory) } static +XS(w32_SetCwd) +{ + dXSARGS; + if (items != 1) + croak("usage: Win32::SetCurrentDirectory($cwd)"); + if (SetCurrentDirectory(SvPV(ST(0),na))) + XSRETURN_YES; + + XSRETURN_NO; +} + +static +XS(w32_GetNextAvailDrive) +{ + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; +} + +static XS(w32_GetLastError) { - dXSARGS; - XSRETURN_IV(GetLastError()); + dXSARGS; + XSRETURN_IV(GetLastError()); } +static +XS(w32_LoginName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpv(name,size-1)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_NodeName) +{ + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpv(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +static +XS(w32_DomainName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + char sid[1024]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, &sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_FsType) +{ + dXSARGS; + char fsname[256]; + DWORD flags, filecomplen; + if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, + &flags, fsname, sizeof(fsname))) { + if (GIMME == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpv(fsname,0))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + XSRETURN_PV(fsname); + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetOSVersion) +{ + dXSARGS; + OSVERSIONINFO osver; + + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if (GetVersionEx(&osver)) { + XPUSHs(newSVpv(osver.szCSDVersion, 0)); + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + PUTBACK; + return; + } + XSRETURN_UNDEF; +} + +static XS(w32_IsWinNT) { - dXSARGS; - XSRETURN_IV(IsWinNT()); + dXSARGS; + XSRETURN_IV(IsWinNT()); } +static XS(w32_IsWin95) { - dXSARGS; - XSRETURN_IV(IsWin95()); + dXSARGS; + XSRETURN_IV(IsWin95()); +} + +static +XS(w32_FormatMessage) +{ + dXSARGS; + DWORD source = 0; + char msgbuf[1024]; + + if (items != 1) + croak("usage: Win32::FormatMessage($errno)"); + + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + XSRETURN_PV(msgbuf); + + XSRETURN_UNDEF; +} + +static +XS(w32_Spawn) +{ + dXSARGS; + char *cmd, *args; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if(items != 3) + croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV(ST(0),na); + args = SvPV(ST(1), na); + + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ + stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ + stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ + stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ + + if(CreateProcess( + cmd, /* Image path */ + args, /* Arguments for command line */ + NULL, /* Default process security */ + NULL, /* Default thread security */ + FALSE, /* Must be TRUE to use std handles */ + NORMAL_PRIORITY_CLASS, /* No special scheduling */ + NULL, /* Inherit our environment block */ + NULL, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + sv_setiv(ST(2), stProcInfo.dwProcessId); + bSuccess = TRUE; + } + XSRETURN_IV(bSuccess); +} + +static +XS(w32_GetTickCount) +{ + dXSARGS; + XSRETURN_IV(GetTickCount()); +} + +static +XS(w32_GetShortPathName) +{ + dXSARGS; + SV *shortpath; + + if(items != 1) + croak("usage: Win32::GetShortPathName($longPathName)"); + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + /* src == target is allowed */ + if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath))) + ST(0) = shortpath; + else + ST(0) = &sv_undef; + XSRETURN(1); } static void @@ -150,9 +351,36 @@ xs_init() char *file = __FILE__; dXSUB_SYS; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); - newXS("Win32::GetCurrentDirectory", w32_GetCurrentDirectory, file); + + /* XXX should be removed after checking with Nick */ + newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); + + /* these names are Activeware compatible */ + newXS("Win32::GetCwd", w32_GetCwd, file); + newXS("Win32::SetCwd", w32_SetCwd, file); + newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); newXS("Win32::GetLastError", w32_GetLastError, file); + newXS("Win32::LoginName", w32_LoginName, file); + newXS("Win32::NodeName", w32_NodeName, file); + newXS("Win32::DomainName", w32_DomainName, file); + newXS("Win32::FsType", w32_FsType, file); + newXS("Win32::GetOSVersion", w32_GetOSVersion, file); newXS("Win32::IsWinNT", w32_IsWinNT, file); newXS("Win32::IsWin95", w32_IsWin95, file); + newXS("Win32::FormatMessage", w32_FormatMessage, file); + newXS("Win32::Spawn", w32_Spawn, file); + newXS("Win32::GetTickCount", w32_GetTickCount, file); + newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + + /* XXX Bloat Alert! The following Activeware preloads really + * ought to be part of Win32::Sys::*, so they're not included + * here. + */ + /* LookupAccountName + * LookupAccountSID + * InitiateSystemShutdown + * AbortSystemShutdown + * ExpandEnvrironmentStrings + */ } diff --git a/win32/win32.c b/win32/win32.c index e6dfb6b024..9a0f910b42 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1120,3 +1120,57 @@ 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; +} + +#undef LK_ERR +#undef LK_LEN + diff --git a/win32/win32.h b/win32/win32.h index 31dfde05f2..711403315c 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -65,6 +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; |