diff options
54 files changed, 1787 insertions, 432 deletions
@@ -31,6 +31,273 @@ or any other branch. Version v5.7.2 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 13884] By: jhi on 2001/12/25 16:20:19 + Log: Make -t equal -tw. + Branch: perl + ! perl.c pod/perlrun.pod +____________________________________________________________________________ +[ 13883] By: jhi on 2001/12/25 15:56:49 + Log: Subject: Re: Not OK 13881 + From: John Peacock <jpeacock@rowman.com> + Date: Tue, 25 Dec 2001 06:02:12 -0500 + Message-ID: <3C285CB4.8040006@rowman.com> + Branch: perl + ! embed.h embed.pl global.sym pod/perlapi.pod util.c +____________________________________________________________________________ +[ 13882] By: jhi on 2001/12/25 15:45:52 + Log: Subject: Re: Not OK 13881 + From: andreas.koenig@anima.de (Andreas J. Koenig) + Date: 25 Dec 2001 07:33:23 +0100 + Message-ID: <m3bsgnajws.fsf@anima.de> + Branch: perl + ! op.c +____________________________________________________________________________ +[ 13881] By: jhi on 2001/12/24 23:47:53 + Log: Subject: PATCH: Restore "Can't declare scalar dereference in my" error + From: Mark-Jason Dominus <mjd@plover.com> + Date: Mon, 24 Dec 2001 18:14:48 -0500 + Message-ID: <20011224231448.25826.qmail@plover.com> + Branch: perl + ! op.c t/op/eval.t +____________________________________________________________________________ +[ 13880] By: jhi on 2001/12/24 22:58:18 + Log: Subject: [PATCH]: ExtUtils::MM_* and File::Spec + From: Dave Rolsky <autarch@urth.org> + Date: Mon, 24 Dec 2001 13:27:23 -0600 (CST) + Message-ID: <Pine.LNX.4.43.0112241305020.21723-100000@urth.org> + Branch: perl + + lib/File/Spec/Cygwin.pm lib/File/Spec/NW5.pm + ! MANIFEST lib/ExtUtils/MM_Cygwin.pm lib/ExtUtils/MM_NW5.pm + ! lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm + ! lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MM_Win32.pm + ! lib/File/Spec.pm lib/File/Spec/Win32.pm +____________________________________________________________________________ +[ 13879] By: jhi on 2001/12/24 18:52:10 + Log: Subject: [PATCH] and [BUG] \X and \C fixed, \X still dorked + From: Jeffrey Friedl <jfriedl@yahoo.com> + Date: Fri, 21 Dec 2001 23:18:17 -0800 (PST) + Message-Id: <200112220718.fBM7IHG25075@ventrue.corp.yahoo.com> + + The rest of the tests for plus few extras. + Branch: perl + ! t/op/pat.t +____________________________________________________________________________ +[ 13877] By: jhi on 2001/12/24 17:13:53 + Log: No-op. + Branch: perl + ! Configure +____________________________________________________________________________ +[ 13876] By: jhi on 2001/12/24 17:13:16 + Log: More constant casting. + Branch: perl + ! regexec.c +____________________________________________________________________________ +[ 13875] By: jhi on 2001/12/24 16:47:30 + Log: Subject: perlhack.pod + From: "John P. Linderman" <jpl@research.att.com> + Date: Sun, 23 Dec 2001 16:16:10 -0500 (EST) + Message-Id: <200112232116.QAA18463@raptor.research.att.com> + Branch: perl + ! pod/perlhack.pod +____________________________________________________________________________ +[ 13874] By: jhi on 2001/12/24 16:41:03 + Log: File::Find patch patches from Thomas Wegner. + Branch: perl + ! lib/File/Find.pm +____________________________________________________________________________ +[ 13873] By: jhi on 2001/12/24 16:38:10 + Log: Subject: Re: socketpair emulation + From: Nicholas Clark <nick@unfortu.net> + Date: Mon, 24 Dec 2001 16:11:30 +0000 + Message-ID: <20011224161129.A1520@Bagpuss.unfortu.net> + Branch: perl + ! ext/Socket/socketpair.t +____________________________________________________________________________ +[ 13872] By: jhi on 2001/12/24 02:53:02 + Log: Must cast constants if they can be quads. + Branch: perl + ! regcomp.c +____________________________________________________________________________ +[ 13871] By: jhi on 2001/12/24 01:40:12 + Log: Promote the e/uid to wide enough un/signed integers + and printf them as such. + Branch: perl + ! taint.c +____________________________________________________________________________ +[ 13869] By: jhi on 2001/12/24 01:14:06 + Log: The U32 alignment test wasn't really working, noticed + by Paul Green. Now the test works, but this means that + we may see coredumps from the test. I sure hope MMUless + places don't crash on the test. + Branch: perl + ! Configure +____________________________________________________________________________ +[ 13867] By: jhi on 2001/12/23 23:46:18 + Log: More VOS tweaks. + Branch: perl + ! Configure +____________________________________________________________________________ +[ 13866] By: jhi on 2001/12/23 16:43:29 + Log: The funky final sigma casefolding. + Branch: perl + ! regcomp.c regexec.c t/op/pat.t utf8.h +____________________________________________________________________________ +[ 13865] By: jhi on 2001/12/23 13:55:23 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ +[ 13864] By: jhi on 2001/12/23 13:50:25 + Log: Move the \C and \X to pat.t. + Branch: perl + ! t/op/pat.t t/op/re_tests +____________________________________________________________________________ +[ 13863] By: jhi on 2001/12/23 04:04:20 + Log: More logical test ordering. + Branch: perl + ! perl.h +____________________________________________________________________________ +[ 13862] By: jhi on 2001/12/23 01:47:23 + Log: Integrate perlio; + + Add at least the "important" PerlIO_xxxx functions to embed.pl + so that they get implicit pTHX_ and we can avoid slow dTHX. + + Put PerlIO stuff inside EXTERN C + + Win32 and makedef.pl fall-out of PerlIO/pTHX stuff + Branch: perl + !> embed.h embed.pl ext/IO/IO.xs global.sym globals.c makedef.pl + !> perlio.c perlio.h perlio.sym pod/perlapi.pod proto.h + !> win32/win32.c +____________________________________________________________________________ +[ 13861] By: jhi on 2001/12/23 01:38:54 + Log: Even more \X fixing. + Branch: perl + ! regexec.c t/op/pat.t +____________________________________________________________________________ +[ 13860] By: jhi on 2001/12/23 01:29:45 + Log: More \X fixing. + Branch: perl + ! regexec.c t/op/pat.t +____________________________________________________________________________ +[ 13859] By: jhi on 2001/12/23 00:57:10 + Log: Fix encoding pragma. + Branch: perl + ! regcomp.c +____________________________________________________________________________ +[ 13858] By: jhi on 2001/12/23 00:12:51 + Log: Subject: socketpair emulation + From: Nicholas Clark <nick@unfortu.net> + Date: Sat, 22 Dec 2001 18:38:18 +0000 + Message-ID: <20011222183817.A12020@Bagpuss.unfortu.net> + Branch: perl + + ext/Socket/socketpair.t + ! MANIFEST embed.h embed.pl global.sym perl.h pod/perlfunc.pod + ! pp_sys.c proto.h util.c +____________________________________________________________________________ +[ 13857] By: jhi on 2001/12/22 23:53:26 + Log: Subject: [PATCH] and [BUG] \X and \C fixed, \X still dorked + From: Jeffrey Friedl <jfriedl@yahoo.com> + Date: Fri, 21 Dec 2001 23:18:17 -0800 (PST) + Message-Id: <200112220718.fBM7IHG25075@ventrue.corp.yahoo.com> + + (partially applied, most of the new tests need to be rethought) + Branch: perl + ! regcomp.c t/op/re_tests +____________________________________________________________________________ +[ 13856] By: jhi on 2001/12/22 23:45:35 + Log: Small tweaks. + Branch: perl + ! handy.h regexec.c +____________________________________________________________________________ +[ 13855] By: jhi on 2001/12/22 20:10:01 + Log: Unicode casefolding continues. + (lib/encoding.t still failing.) + Branch: perl + ! regexec.c t/op/pat.t +____________________________________________________________________________ +[ 13850] By: jhi on 2001/12/22 17:41:40 + Log: Rework the make logic (again). + Branch: perl + ! Configure +____________________________________________________________________________ +[ 13849] By: jhi on 2001/12/22 16:40:24 + Log: Integrate perlio; + Fix mis-parse of autoloaded usage code by declaring the sub + Correct checking code which Ilya spotted was tripped by CR at EOF. + The CR at EOF fix earlier broke CR at end-of-buffer. + Branch: perl + ! regexec.c + !> ext/POSIX/POSIX.pm perlio.c sv.c +____________________________________________________________________________ +[ 13844] By: jhi on 2001/12/22 04:27:46 + Log: More Unicode casing fixes. + Branch: perl + ! regexec.c t/op/pat.t +____________________________________________________________________________ +[ 13843] By: jhi on 2001/12/22 02:47:08 + Log: Unicode casefolding fixes. + Branch: perl + ! op.c regcomp.c regexec.c t/op/pat.t +____________________________________________________________________________ +[ 13842] By: jhi on 2001/12/21 22:32:14 + Log: Subject: [PATCH B::Deparse] __DATA__ and packages + From: Rafael Garcia-Suarez <rgarciasuarez@free.fr> + Date: Sat, 22 Dec 2001 00:01:29 +0100 + Message-ID: <20011222000129.A713@rafael> + Branch: perl + ! ext/B/B/Deparse.pm +____________________________________________________________________________ +[ 13841] By: jhi on 2001/12/21 20:38:28 + Log: VOS config from Paul Green. + Branch: perl + ! hints/vos.sh +____________________________________________________________________________ +[ 13840] By: jhi on 2001/12/21 20:00:43 + Log: Subject: [PATCH @13746] CreateTTY on OS/2 + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 21 Dec 2001 15:59:45 -0500 + Message-ID: <20011221155945.A6806@math.ohio-state.edu> + Branch: perl + ! lib/perl5db.pl +____________________________________________________________________________ +[ 13839] By: jhi on 2001/12/21 19:52:49 + Log: Subject: [PATCH @13746] uninstalled build of modules broken + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 21 Dec 2001 15:49:09 -0500 + Message-ID: <20011221154909.A6760@math.ohio-state.edu> + Branch: perl + ! lib/ExtUtils/MM_Unix.pm +____________________________________________________________________________ +[ 13838] By: jhi on 2001/12/21 19:52:09 + Log: Subject: [PATCH @13746] OS/2 File::* modules + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Fri, 21 Dec 2001 15:43:24 -0500 + Message-ID: <20011221154324.A6524@math.ohio-state.edu> + Branch: perl + ! lib/File/Basename.pm lib/File/Spec/OS2.pm +____________________________________________________________________________ +[ 13837] By: jhi on 2001/12/21 19:49:41 + Log: Subject: [PATCH] perltie.pod (or what does it mean?) + From: Wolfgang Laun <Wolfgang.Laun@alcatel.at> + Date: Fri, 21 Dec 2001 17:29:07 +0100 + Message-ID: <3C236353.6625C4C0@alcatel.at> + Branch: perl + ! pod/perltie.pod +____________________________________________________________________________ +[ 13835] By: jhi on 2001/12/21 19:47:03 + Log: Further VOS tweaks: the _exe needs to be introduced + in the very beginning, and the make/gmake needs special + VOS logic. + Branch: perl + ! Configure Makefile.SH +____________________________________________________________________________ +[ 13834] By: jhi on 2001/12/21 15:12:26 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 13832] By: jhi on 2001/12/21 14:46:24 Log: Also the search for cat needs to be _exe-aware. Branch: perl @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Fri Dec 21 20:17:57 EET 2001 [metaconfig 3.0 PL70] +# Generated on Wed Dec 26 20:19:46 EET 2001 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <<EOF @@ -1162,12 +1162,12 @@ if `$sh -c '#' >/dev/null 2>&1`; then if test ! -f $xcat$_exe; then for p in $paths; do if test -f $p/cat$_exe; then - xcat=$p/cat$_exe + xcat=$p/cat break fi done - if test ! -f $xcat; then - echo "Can't find cat anywhere!" >&4 + if test ! -f $xcat$_exe; then + echo "Can't find cat anywhere!" exit 1 fi fi @@ -2169,9 +2169,20 @@ ln) ln=$cp ;; esac -case "$make$gmake" in -*/gmake|?:[\\/]gmake) - # We can't have osname yet. +case "$make" in +make) + case "$gmake" in + gmake) + echo "I can't find make or gmake, and my life depends on it." >&4 + echo "Go find a public domain implementation or fix your PATH setting!" >&4 + exit 1 + ;; + esac + ;; +esac +case "$gmake" in +gmake) ;; +*) # We can't have osname yet. if test -f "/system/gnu_library/bin/ar.pm"; then # Stratus VOS # Assume that gmake, if found, is definitely GNU make # and prefer it over the system make. @@ -2179,13 +2190,6 @@ case "$make$gmake" in make=$gmake fi ;; -*/make|?:[\\/]make) - ;; -*) - echo "I can't find make or gmake, and my life depends on it." >&4 - echo "Go find a public domain implementation or fix your PATH setting!" >&4 - exit 1 - ;; esac case "$test" in test) @@ -2806,7 +2810,7 @@ EOM $test -d /usr/apollo/bin && osname=apollo $test -f /etc/saf/_sactab && osname=svr4 $test -d /usr/include/minix && osname=minix - $test -d /system && osname=vos + $test -f /system/gnu_library/bin/ar.pm && osname=vos if $test -d /MachTen -o -d /MachTen_Folder; then osname=machten if $test -x /sbin/version; then @@ -9984,6 +9988,10 @@ case "$eagain" in #include <signal.h> #include <stdio.h> #include <stdlib.h> +#$i_fcntl I_FCNTL +#ifdef I_FCNTL +#include <fcntl.h> +#endif #define MY_O_NONBLOCK $o_nonblock #ifndef errno /* XXX need better Configure test */ extern int errno; @@ -13467,7 +13475,8 @@ EOM $cat >try.c <<EOCP #include <stdio.h> #define U32 $u32type -#define BYTEORDER $byteorder +#define BYTEORDER 0x$byteorder +#define U8 $u8type int main() { #if BYTEORDER == 0x1234 || BYTEORDER == 0x4321 U8 buf[] = "\0\0\0\1\0\0\0\0"; @@ -13513,7 +13522,7 @@ int main() { EOCP set try if eval $compile_ok; then - echo "(Testing for character data alignment may dump core.)" >&4 + echo "(Testing for character data alignment may crash the test. That's okay.)" >&4 $run ./try 2>&1 >/dev/null case "$?" in 0) cat >&4 <<EOM @@ -535,6 +535,7 @@ ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.t See if Socket works ext/Socket/Socket.xs Socket extension external subroutines +ext/Socket/socketpair.t See if socketpair works ext/Storable/ChangeLog Storable extension ext/Storable/Makefile.PL Storable extension ext/Storable/MANIFEST Storable extension @@ -981,6 +982,8 @@ lib/File/Spec.pm portable operations on file names lib/File/Spec/Epoc.pm portable operations on EPOC file names lib/File/Spec/Functions.pm Function interface to File::Spec object methods lib/File/Spec/Mac.pm portable operations on Mac file names +lib/File/Spec/Cygwin.pm portable operations on Cygwin file names +lib/File/Spec/NW5.pm portable operations on NetWare file names lib/File/Spec/OS2.pm portable operations on OS2 file names lib/File/Spec/t/Functions.t See if File::Spec::Functions works lib/File/Spec/t/rel2abs2rel.t See if File::Spec->rel2abs/abs2rel works diff --git a/README.beos b/README.beos index 7458672cee..155f291d97 100644 --- a/README.beos +++ b/README.beos @@ -57,3 +57,47 @@ please email me. Tom Spindler dogcow@isi.net +=head2 Update 2001-12-26 + +I managed to compile one of the developer snapshots (13885 plus a few +tweaks) leading up to (some day) Perl 5.8.0, and the following tests +fail: + + op/magic 24-26 + ext/POSIX/t/sigaction 13 + ext/POSIX/t/waitpid 1 + lib/ExtUtils/t/Installed 9-10 25-27 29-30 33-36 + +None of the failures look too serious: + +=over 4 + +=item * + +The op/magic failures look like something funny going on with $0 and +$^X that I can't now figure out: none of the generated pathnames are +wrong as such, they just seem to accumulate "./" prefixes and infixes +in ways that define logic. + +=item * + +The sigaction #13 means that signal mask doesn't get properly restored +if sigaction returns early. + +=item * + +The waitpid failure means that after there are no more child +processes, waitpid is supposed to start returning -1 (and set errno +to ECHILD). In BeOS, it doesn't seem to. + +=item * + +The Installed test has some filesystem portability assumptions. + +=back + +Disclaimer: I just installed BeOS Personal Edition 5.0 and the +Developer Tools, that is the whole extent of my BeOS expertise, +so pelase don't ask for further help in BeOS Perl problems, sorry. + +jhi@iki.fi diff --git a/README.hpux b/README.hpux index f99096485c..dd11e49c33 100644 --- a/README.hpux +++ b/README.hpux @@ -201,10 +201,13 @@ library that is already linked into perl. Some extensions, like DB_File and Compress::Zlib use/require prebuilt libraries for the perl extensions/modules to work. If these libraries -are built using the default configuration, it might happen that you run -into an error like "invalid loader fixup" during load phase. HP is aware -of this problem and address it at - http://h21007.www2.hp.com/dspp/tech/tech_TechDocumentDetailPage_IDX/1,,392!0!,00.html +are built using the default configuration, it might happen that you +run into an error like "invalid loader fixup" during load phase. +HP is aware of this problem. Search the HP-UX cxx-dev forums for +discussions about the subject. The short answer is that B<everything> +(all libraries, everything) must be compiled with C<+z> or C<+Z> to be +PIC (position independent code). In HP-UX 11.00 or newer the linker +error message should tell the name of the offending object file. A more general approach is to intervene manually, as with an example for the DB_File module, which requires SleepyCat's libdb.sl: diff --git a/beos/beos.c b/beos/beos.c index d5f7fbab48..7e799caf54 100644 --- a/beos/beos.c +++ b/beos/beos.c @@ -5,14 +5,16 @@ #include <sys/wait.h> /* In BeOS 5.0 the waitpid() seems to misbehave in that the status - * is _not_ shifted left by eight (multiplied by 256), as it is in - * POSIX/UNIX. To undo the surpise effect to the rest of Perl we - * need this wrapper. (The rest of BeOS might be surprised because - * of this, though.) */ + * has the upper and lower bytes swapped compared with the usual + * POSIX/UNIX implementations. To undo the surpise effect to the + * rest of Perl we need this wrapper. (The rest of BeOS might be + * surprised because of this, though.) */ pid_t beos_waitpid(pid_t process_id, int *status_location, int options) { pid_t got = waitpid(process_id, status_location, options); if (status_location) - *status_location <<= 8; /* What about the POSIX low bits? */ + *status_location = + (*status_location & 0x00FF) << 8 | + (*status_location & 0xFF00) >> 8; return got; } @@ -951,21 +951,7 @@ Perl_do_eof(pTHX_ GV *gv) if (!io) return TRUE; else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY)) - { - /* integrate to report_evil_fh()? */ - char *name = NULL; - if (isGV(gv)) { - SV* sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ WARN_IO, - "Filehandle %s opened only for output", name); - else - Perl_warner(aTHX_ WARN_IO, - "Filehandle opened only for output"); - } + report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); while (IoIFP(io)) { @@ -1203,6 +1203,9 @@ #define sv_pvn_force_flags Perl_sv_pvn_force_flags #define sv_2pv_flags Perl_sv_2pv_flags #define my_atof2 Perl_my_atof2 +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) +#define my_socketpair Perl_my_socketpair +#endif #if defined(USE_PERLIO) && !defined(USE_SFIO) #define PerlIO_close Perl_PerlIO_close #define PerlIO_fill Perl_PerlIO_fill @@ -2741,6 +2744,9 @@ #define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c) #define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c) #define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b) +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) +#define my_socketpair(a,b,c,d) Perl_my_socketpair(aTHX_ a,b,c,d) +#endif #if defined(USE_PERLIO) && !defined(USE_SFIO) #define PerlIO_close(a) Perl_PerlIO_close(aTHX_ a) #define PerlIO_fill(a) Perl_PerlIO_fill(aTHX_ a) @@ -1277,7 +1277,7 @@ p |PADOFFSET|find_threadsv|const char *name #endif p |OP* |force_list |OP* arg p |OP* |fold_constants |OP* arg -Afp |char* |form |const char* pat|... +Afpd |char* |form |const char* pat|... Ap |char* |vform |const char* pat|va_list* args Ap |void |free_tmps p |OP* |gen_constant_list|OP* o @@ -2353,6 +2353,37 @@ Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags Apd |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags Ap |char* |my_atof2 |const char *s|NV* value +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) +Ap |int |my_socketpair |int family|int type|int protocol|int fd[2] +#endif + + +#if defined(USE_PERLIO) && !defined(USE_SFIO) +Ap |int |PerlIO_close |PerlIO * +Ap |int |PerlIO_fill |PerlIO * +Ap |int |PerlIO_fileno |PerlIO * +Ap |int |PerlIO_eof |PerlIO * +Ap |int |PerlIO_error |PerlIO * +Ap |int |PerlIO_flush |PerlIO * +Ap |void |PerlIO_clearerr |PerlIO * +Ap |void |PerlIO_set_cnt |PerlIO *|int +Ap |void |PerlIO_set_ptrcnt |PerlIO *|STDCHAR *|int +Ap |void |PerlIO_setlinebuf |PerlIO * +Ap |SSize_t|PerlIO_read |PerlIO *|void *|Size_t +Ap |SSize_t|PerlIO_write |PerlIO *|const void *|Size_t +Ap |SSize_t|PerlIO_unread |PerlIO *|const void *|Size_t +Ap |Off_t |PerlIO_tell |PerlIO * +Ap |int |PerlIO_seek |PerlIO *|Off_t|int + +Ap |STDCHAR *|PerlIO_get_base |PerlIO * +Ap |STDCHAR *|PerlIO_get_ptr |PerlIO * +Ap |int |PerlIO_get_bufsiz |PerlIO * +Ap |int |PerlIO_get_cnt |PerlIO * + +Ap |PerlIO *|PerlIO_stdin +Ap |PerlIO *|PerlIO_stdout +Ap |PerlIO *|PerlIO_stderr +#endif /* PERLIO_LAYERS */ #if defined(USE_PERLIO) && !defined(USE_SFIO) diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 7094f59087..4b727c53c1 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -191,7 +191,7 @@ to change file and directory owners and groups, see L<perlfunc/chown>. =item clearerr -Use the method L<IO::Handle::clearerr()> instead, to reset the error +Use the method C<IO::Handle::clearerr()> instead, to reset the error state (if any) and EOF state (if any) of the given stream. =item clock @@ -1043,7 +1043,7 @@ argument means 'query'.) The following will set the LC_CTYPE behaviour according to the locale environment variables (the second argument C<"">). -Please see your systems L<setlocale(3)> documentation for the locale +Please see your systems C<setlocale(3)> documentation for the locale environment variables' meaning or consult L<perllocale>. $loc = setlocale( LC_CTYPE, "" ); @@ -1983,9 +1983,56 @@ R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_ WNOHANG WUNTRACED +=over 16 + +=item WNOHANG + +Do not suspend the calling process until a child process +changes state but instead return immediately. + +=item WUNTRACED + +Catch stopped child processes. + +=back + =item Macros WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG +=over 16 + +=item WIFEXITED + +WIFEXITED($?) returns true if the child process exited normally +(C<exit()> or by falling off the end of C<main()>) + +=item WEXITSTATUS + +WEXITSTATUS($?) returns the normal exit status of the child process +(only meaningful if WIFEXITED($?) is true) + +=item WIFSIGNALED + +WIFSIGNALED($?) returns true if the child process terminated because +of a signal + +=item WTERMSIG + +WTERMSIG($?) returns the signal the child process terminated for +(only meaningful if WIFSIGNALED($?) is true) + +=item WIFSTOPPED + +WIFSTOPPED($?) returns true if the child process is currently stopped +(can happen only if you specified the WUNTRACED flag to waitpid()) + +=item WSTOPSIG + +WSTOPSIG($?) returns the signal the child process was stopped for +(only meaningful if WIFSTOPPED($?) is true) + +=back + =back diff --git a/ext/Socket/socketpair.t b/ext/Socket/socketpair.t new file mode 100644 index 0000000000..804e3af0e8 --- /dev/null +++ b/ext/Socket/socketpair.t @@ -0,0 +1,164 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSocket\b/ && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } +} + +use Socket; +use Test::More; +use strict; +use warnings; +use Errno 'EPIPE'; + +my $skip_reason; + +if( !$Config{d_alarm} ) { + plan skip_all => "alarm() not implemented on this platform"; +} else { + # This should fail but not die if there is real socketpair + eval {socketpair LEFT, RIGHT, -1, -1, -1}; + if ($@ =~ /^Unsupported socket function "socketpair" called/) { + plan skip_all => 'No socketpair (real or emulated)'; + } else { + eval {AF_UNIX}; + if ($@ =~ /^Your vendor has not defined Socket macro AF_UNIX/) { + plan skip_all => 'No AF_UNIX'; + } else { + plan tests => 44; + } + } +} + +# Too many things in this test will hang forever if something is wrong, so +# we need a self destruct timer. +$SIG{ALRM} = sub {die "Something unexpectedly hung during testing"}; +alarm(60); + +ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC), + "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") + or print "# \$\! = $!\n"; + +my @left = ("hello ", "world\n"); +my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here. + +foreach (@left) { + # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left"); + is (syswrite (LEFT, $_), length $_, "syswrite to left"); +} +foreach (@right) { + # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right"); + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); +} + +# stream socket, so our writes will become joined: +my ($buffer, $expect); +$expect = join '', @right; +is (read (LEFT, $buffer, length $expect), length $expect, "read on left"); +is ($buffer, $expect, "content what we expected?"); +$expect = join '', @left; +is (read (RIGHT, $buffer, length $expect), length $expect, "read on right"); +is ($buffer, $expect, "content what we expected?"); + +ok (shutdown(LEFT, SHUT_WR), "shutdown left for writing"); +# This will hang forever if eof is buggy. +{ + local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" }; + alarm 3; + ok (eof RIGHT, "right is at EOF"); + alarm 60; +} + +$SIG{PIPE} = 'IGNORE'; +{ + local $SIG{ALRM} + = sub { warn "syswrite to left didn't fail within 3 seconds" }; + alarm 3; + is (syswrite (LEFT, "void"), undef, "syswrite to shutdown left should fail"); + alarm 60; +} +SKIP: { + # This may need skipping on some OSes + ok ($! == EPIPE, '$! should be EPIPE') + or printf "\$\!=%d(%s)\n", $!, $!; +} + +my @gripping = (chr 255, chr 127); +foreach (@gripping) { + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); +} + +ok (!eof LEFT, "left is not at EOF"); + +$expect = join '', @gripping; +is (read (LEFT, $buffer, length $expect), length $expect, "read on left"); +is ($buffer, $expect, "content what we expected?"); + +ok (close LEFT, "close left"); +ok (close RIGHT, "close right"); + +# And now datagrams +# I suspect we also need a self destruct time-bomb for these, as I don't see any +# guarantee that the stack won't drop a UDP packet, even if it is for localhost. + +ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC), + "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)") + or print "# \$\! = $!\n"; + +foreach (@left) { + # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left"); + is (syswrite (LEFT, $_), length $_, "syswrite to left"); +} +foreach (@right) { + # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right"); + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); +} + +# stream socket, so our writes will become joined: +my ($total); +$total = join '', @right; +foreach $expect (@right) { + is (sysread (LEFT, $buffer, length $total), length $expect, "read on left"); + is ($buffer, $expect, "content what we expected?"); +} +$total = join '', @left; +foreach $expect (@left) { + is (sysread (RIGHT, $buffer, length $total), length $expect, "read on right"); + is ($buffer, $expect, "content what we expected?"); +} + +ok (shutdown(LEFT, 1), "shutdown left for writing"); +# eof uses buffering. eof is indicated by a sysread of zero. +# but for a datagram socket there's no way it can know nothing will ever be +# sent +{ + my $alarmed = 0; + local $SIG{ALRM} = sub { $alarmed = 1; }; + print "# Approximate forever as 3 seconds. Wait 'forever'...\n"; + alarm 3; + is (sysread (RIGHT, $buffer, 1), undef, + "read on right should be interrupted"); + is ($alarmed, 1, "alarm should have fired"); +} +alarm 30; + +#ok (eof RIGHT, "right is at EOF"); + +foreach (@gripping) { + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); +} + +$total = join '', @gripping; +foreach $expect (@gripping) { + is (sysread (LEFT, $buffer, length $total), length $expect, "read on left"); + is ($buffer, $expect, "content what we expected?"); +} + +ok (close LEFT, "close left"); +ok (close RIGHT, "close right"); diff --git a/global.sym b/global.sym index a9fb16aca5..4710ebb225 100644 --- a/global.sym +++ b/global.sym @@ -604,6 +604,7 @@ Perl_sv_utf8_upgrade_flags Perl_sv_pvn_force_flags Perl_sv_2pv_flags Perl_my_atof2 +Perl_my_socketpair Perl_PerlIO_close Perl_PerlIO_fill Perl_PerlIO_fileno @@ -428,6 +428,7 @@ Converts the specified character to lowercase. #define toUPPER_uni(c,s,l) to_uni_upper(c,s,l) #define toTITLE_uni(c,s,l) to_uni_title(c,s,l) #define toLOWER_uni(c,s,l) to_uni_lower(c,s,l) +#define toFOLD_uni(c,s,l) to_uni_fold(c,s,l) #define isPSXSPC_uni(c) (isSPACE_uni(c) ||(c) == '\f') #define isBLANK_uni(c) isBLANK(c) /* could be wrong */ diff --git a/lib/ExtUtils/MM_Cygwin.pm b/lib/ExtUtils/MM_Cygwin.pm index 45833ca259..3d03d321f3 100644 --- a/lib/ExtUtils/MM_Cygwin.pm +++ b/lib/ExtUtils/MM_Cygwin.pm @@ -12,12 +12,13 @@ require Exporter; require ExtUtils::MakeMaker; ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); +use File::Spec; + unshift @MM::ISA, 'ExtUtils::MM_Cygwin'; sub canonpath { - my($self,$path) = @_; - $path =~ s|\\|/|g; - return $self->ExtUtils::MM_Unix::canonpath($path); + shift; + return File::Spec->canonpath(@_); } sub cflags { @@ -46,9 +47,9 @@ sub manifypods { my($dist); my($pod2man_exe); if (defined $self->{PERL_SRC}) { - $pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man'); + $pod2man_exe = File::Spec->catfile($self->{PERL_SRC},'pod','pod2man'); } else { - $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); + $pod2man_exe = File::Spec->catfile($Config{scriptdirexp},'pod2man'); } unless ($self->perl_script($pod2man_exe)) { # No pod2man but some MAN3PODS to be installed diff --git a/lib/ExtUtils/MM_NW5.pm b/lib/ExtUtils/MM_NW5.pm index c4b1be92f3..59080df5f5 100644 --- a/lib/ExtUtils/MM_NW5.pm +++ b/lib/ExtUtils/MM_NW5.pm @@ -133,8 +133,8 @@ sub maybe_command { } sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; + shift; + return File::Spec->file_name_is_absolute(@_); } sub find_perl { @@ -151,12 +151,12 @@ in these dirs: next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ my ($abs, $val); - if ($self->file_name_is_absolute($name)) { # /foo/bar + if (File::Spec->file_name_is_absolute($name)) { # /foo/bar $abs = $name; - } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo - $abs = $self->catfile($dir, $name); + } elsif (File::Spec->canonpath($name) eq File::Spec->canonpath(basename($name))) { # foo + $abs = File::Spec->catfile($dir, $name); } else { # foo/bar - $abs = $self->canonpath($self->catfile($self->curdir, $name)); + $abs = File::Spec->canonpath(File::Spec->catfile($self->curdir, $name)); } print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); @@ -175,14 +175,8 @@ in these dirs: } sub catdir { - my $self = shift; - my @args = @_; - for (@args) { - # append a slash to each argument unless it has one there - $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; - } - my $result = $self->canonpath(join('', @args)); - $result; + shift; + return File::Spec->catdir(@_); } =item catfile @@ -193,13 +187,8 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; - my $file = pop @_; - return $file unless @_; - my $dir = $self->catdir(@_); - $dir =~ s/(\\\.)$//; - $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; - return $dir.$file; + shift; + return File::Spec->catfile(@_); } sub init_others @@ -403,11 +392,11 @@ CONFIGDEP = \$(PERL_ARCHLIB)\\Config.pm \$(PERL_INC)\\config.h my @parentdir = split(/::/, $self->{PARENT_NAME}); push @m, q{ # Where to put things: -INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{ -INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{ +INST_LIBDIR = }. File::Spec->catdir('$(INST_LIB)',@parentdir) .q{ +INST_ARCHLIBDIR = }. File::Spec->catdir('$(INST_ARCHLIB)',@parentdir) .q{ -INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ -INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ +INST_AUTODIR = }. File::Spec->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ +INST_ARCHAUTODIR = }. File::Spec->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ }; if ($self->has_link_code()) { @@ -450,11 +439,7 @@ PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ sub path { - my($self) = @_; - my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; - my @path = split(';',$path); - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + return File::Spec->path(); } =item static_lib (o) @@ -688,7 +673,7 @@ destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> sub pm_to_blib { my $self = shift; - my($autodir) = $self->catdir('$(INST_LIB)','auto'); + my($autodir) = File::Spec->catdir('$(INST_LIB)','auto'); return q{ pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ @@ -922,9 +907,9 @@ sub htmlifypods { my($dist); my($pod2html_exe); if (defined $self->{PERL_SRC}) { - $pod2html_exe = $self->catfile($self->{PERL_SRC},'pod','pod2html'); + $pod2html_exe = File::Spec->catfile($self->{PERL_SRC},'pod','pod2html'); } else { - $pod2html_exe = $self->catfile($Config{scriptdirexp},'pod2html'); + $pod2html_exe = File::Spec->catfile($Config{scriptdirexp},'pod2html'); } unless ($pod2html_exe = $self->perl_script($pod2html_exe)) { # No pod2html but some HTMLxxxPODS to be installed diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index a4bcf73c37..f598c71aaf 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -12,6 +12,8 @@ require Exporter; require ExtUtils::MakeMaker; ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue)); +use File::Spec; + unshift @MM::ISA, 'ExtUtils::MM_OS2'; =pod @@ -110,8 +112,8 @@ sub maybe_command { } sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; + shift; + return File::Spec->file_name_is_absolute(@_); } sub perl_archive diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 0efe2d8782..b8bfe1471d 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -5,6 +5,7 @@ use strict; use Exporter (); use Config; use File::Basename qw(basename dirname fileparse); +use File::Spec; use DirHandle; use strict; our ($Is_Mac,$Is_OS2,$Is_VMS,$Is_Win32,$Is_Dos, @@ -105,13 +106,8 @@ trailing slash :-) # '; sub catdir { - my $self = shift @_; - my @args = @_; - for (@args) { - # append a slash to each argument unless it has one there - $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; - } - $self->canonpath(join('', @args)); + shift; + return File::Spec->catdir(@_); } =item catfile @@ -122,14 +118,8 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; - my $file = pop @_; - return $self->canonpath($file) unless @_; - my $dir = $self->catdir(@_); - for ($dir) { - $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; - } - return $self->canonpath($dir.$file); + shift; + return File::Spec->catdir(@_); } =item curdir @@ -139,7 +129,7 @@ Returns a string representing of the current directory. "." on UNIX. =cut sub curdir { - return "." ; + return File::Spec->curdir(); } =item rootdir @@ -149,7 +139,7 @@ Returns a string representing of the root directory. "/" on UNIX. =cut sub rootdir { - return "/"; + return File::Spec->rootdir(); } =item updir @@ -159,7 +149,7 @@ Returns a string representing of the parent directory. ".." on UNIX. =cut sub updir { - return ".."; + return File::Spec->updir(); } sub c_o; @@ -652,11 +642,11 @@ CONFIGDEP = \$(PERL_ARCHLIB)/Config.pm \$(PERL_INC)/config.h my @parentdir = split(/::/, $self->{PARENT_NAME}); push @m, q{ # Where to put things: -INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{ -INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{ +INST_LIBDIR = }. File::Spec->catdir('$(INST_LIB)',@parentdir) .q{ +INST_ARCHLIBDIR = }. File::Spec->catdir('$(INST_ARCHLIB)',@parentdir) .q{ -INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ -INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ +INST_AUTODIR = }. File::Spec->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ +INST_ARCHAUTODIR = }. File::Spec->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ }; if ($self->has_link_code()) { @@ -739,8 +729,8 @@ sub dir_target { my($self,@dirs) = @_; my(@m,$dir,$targdir); foreach $dir (@dirs) { - my($src) = $self->catfile($self->{PERL_INC},'perl.h'); - my($targ) = $self->catfile($dir,'.exists'); + my($src) = File::Spec->catfile($self->{PERL_INC},'perl.h'); + my($targ) = File::Spec->catfile($dir,'.exists'); # catfile may have adapted syntax of $dir to target OS, so... if ($Is_VMS) { # Just remove file name; dirspec is often in macro ($targdir = $targ) =~ s:/?\.exists\z::; @@ -1152,13 +1142,8 @@ Takes as argument a path and returns true, if it is an absolute path. =cut sub file_name_is_absolute { - my($self,$file) = @_; - if ($Is_Dos){ - $file =~ m{^([a-z]:)?[\\/]}is ; - } - else { - $file =~ m:^/:s ; - } + shift; + return File::Spec->file_name_is_absolute(@_); } =item find_perl @@ -1181,12 +1166,12 @@ in these dirs: foreach $dir (@$dirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined my ($abs, $val); - if ($self->file_name_is_absolute($name)) { # /foo/bar + if (File::Spec->file_name_is_absolute($name)) { # /foo/bar $abs = $name; - } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo - $abs = $self->catfile($dir, $name); + } elsif (File::Spec->canonpath($name) eq File::Spec->canonpath(basename($name))) { # foo + $abs = File::Spec->catfile($dir, $name); } else { # foo/bar - $abs = $self->canonpath($self->catfile($self->curdir, $name)); + $abs = File::Spec->canonpath(File::Spec->catfile(File::Spec->curdir, $name)); } print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); @@ -1243,13 +1228,13 @@ sub fixin { # stolen from the pink Camel book, more or less $interpreter = $Config{perlpath}; } } else { - my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; + my(@absdirs) = reverse grep {File::Spec->file_name_is_absolute} File::Spec->path; $interpreter = ''; my($dir); foreach $dir (@absdirs) { if ($self->maybe_command($cmd)) { warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; - $interpreter = $self->catfile($dir,$cmd); + $interpreter = File::Spec->catfile($dir,$cmd); } } } @@ -1384,9 +1369,9 @@ sub htmlifypods { my($dist); my($pod2html_exe); if (defined $self->{PERL_SRC}) { - $pod2html_exe = $self->catfile($self->{PERL_SRC},'pod','pod2html'); + $pod2html_exe = File::Spec->catfile($self->{PERL_SRC},'pod','pod2html'); } else { - $pod2html_exe = $self->catfile($Config{scriptdirexp},'pod2html'); + $pod2html_exe = File::Spec->catfile($Config{scriptdirexp},'pod2html'); } unless ($pod2html_exe = $self->perl_script($pod2html_exe)) { # No pod2html but some HTMLxxxPODS to be installed @@ -1432,13 +1417,13 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) local(%pm); #the sub in find() has to see this hash @ignore{qw(Makefile.PL test.pl)} = (1,1); $ignore{'makefile.pl'} = 1 if $Is_VMS; - foreach $name ($self->lsdir($self->curdir)){ + foreach $name ($self->lsdir(File::Spec->curdir)){ next if $name =~ /\#/; - next if $name eq $self->curdir or $name eq $self->updir or $ignore{$name}; + next if $name eq File::Spec->curdir or $name eq File::Spec->updir or $ignore{$name}; next unless $self->libscan($name); if (-d $name){ next if -l $name; # We do not support symlinks at all - $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL")); + $dir{$name} = $name if (-f File::Spec->catfile($name,"Makefile.PL")); } elsif ($name =~ /\.xs\z/){ my($c); ($c = $name) =~ s/\.xs\z/.c/; $xs{$name} = $c; @@ -1457,9 +1442,9 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) if ($txt =~ /Extracting \S+ \(with variable substitutions/) { ($pl_files{$name} = $name) =~ s/[._]pl\z//i ; } - else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } + else { $pm{$name} = File::Spec->catfile('$(INST_LIBDIR)',$name); } } elsif ($name =~ /\.(p[ml]|pod)\z/){ - $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); + $pm{$name} = File::Spec->catfile('$(INST_LIBDIR)',$name); } } @@ -1519,7 +1504,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($striplibpath,$striplibname); $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:i); ($striplibname,$striplibpath) = fileparse($striplibpath); - my($inst) = $self->catfile($prefix,$striplibpath,$striplibname); + my($inst) = File::Spec->catfile($prefix,$striplibpath,$striplibname); local($_) = $inst; # for backwards compatibility $inst = $self->libscan($inst); print "libscan($path) => '$inst'\n" if ($Verbose >= 2); @@ -1566,11 +1551,11 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) next unless $ispod; if ($pods{HTMLSCRIPT}) { $self->{HTMLSCRIPTPODS}->{$name} = - $self->catfile("\$(INST_HTMLSCRIPTDIR)", basename($name).".\$(HTMLEXT)"); + File::Spec->catfile("\$(INST_HTMLSCRIPTDIR)", basename($name).".\$(HTMLEXT)"); } if ($pods{MAN1}) { $self->{MAN1PODS}->{$name} = - $self->catfile("\$(INST_MAN1DIR)", basename($name).".\$(MAN1EXT)"); + File::Spec->catfile("\$(INST_MAN1DIR)", basename($name).".\$(MAN1EXT)"); } } } @@ -1612,15 +1597,15 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $manpagename =~ s/\.p(od|m|l)\z//; if ($pods{HTMLLIB}) { $self->{HTMLLIBPODS}->{$name} = - $self->catfile("\$(INST_HTMLLIBDIR)", "$manpagename.\$(HTMLEXT)"); + File::Spec->catfile("\$(INST_HTMLLIBDIR)", "$manpagename.\$(HTMLEXT)"); } unless ($manpagename =~ s!^\W*lib\W+!!s) { # everything below lib is ok - $manpagename = $self->catfile(split(/::/,$self->{PARENT_NAME}),$manpagename); + $manpagename = File::Spec->catfile(split(/::/,$self->{PARENT_NAME}),$manpagename); } if ($pods{MAN3}) { $manpagename = $self->replace_manpage_separator($manpagename); $self->{MAN3PODS}->{$name} = - $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); + File::Spec->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); } } } @@ -1648,7 +1633,7 @@ sub init_main { ### Only UNIX: ### ($self->{FULLEXT} = ### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket - $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME}); + $self->{FULLEXT} = File::Spec->catdir(split /::/, $self->{NAME}); # Copied from DynaLoader: @@ -1687,13 +1672,13 @@ sub init_main { unless ($self->{PERL_SRC}){ my($dir); - foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir(),$self->updir())){ + foreach $dir (File::Spec->updir(),File::Spec->catdir(File::Spec->updir(),File::Spec->updir()),File::Spec->catdir(File::Spec->updir(),File::Spec->updir(),File::Spec->updir()),File::Spec->catdir(File::Spec->updir(),File::Spec->updir(),File::Spec->updir(),File::Spec->updir())){ if ( - -f $self->catfile($dir,"config.sh") + -f File::Spec->catfile($dir,"config.sh") && - -f $self->catfile($dir,"perl.h") + -f File::Spec->catfile($dir,"perl.h") && - -f $self->catfile($dir,"lib","Exporter.pm") + -f File::Spec->catfile($dir,"lib","Exporter.pm") ) { $self->{PERL_SRC}=$dir ; last; @@ -1701,17 +1686,17 @@ sub init_main { } } if ($self->{PERL_SRC}){ - $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib"); + $self->{PERL_LIB} ||= File::Spec->catdir("$self->{PERL_SRC}","lib"); $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; - $self->{PERL_INC} = ($Is_Win32) ? $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; + $self->{PERL_INC} = ($Is_Win32) ? File::Spec->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; # catch a situation that has occurred a few times in the past: unless ( - -s $self->catfile($self->{PERL_SRC},'cflags') + -s File::Spec->catfile($self->{PERL_SRC},'cflags') or $Is_VMS && - -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') + -s File::Spec->catfile($self->{PERL_SRC},'perlshr_attr.opt') or $Is_Mac or @@ -1736,21 +1721,21 @@ from the perl source tree. my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC}; $self->{PERL_LIB} ||= $Config::Config{privlibexp}; $self->{PERL_ARCHLIB} ||= $Config::Config{archlibexp}; - $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now + $self->{PERL_INC} = File::Spec->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; no warnings 'uninitialized' ; - if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) + if (not -f ($perl_h = File::Spec->catfile($self->{PERL_INC},"perl.h")) and not $old){ # Maybe somebody tries to build an extension with an # uninstalled Perl outside of Perl build tree my $found; for my $dir (@INC) { - $found = $dir, last if -e $self->catdir($dir, "Config.pm"); + $found = $dir, last if -e File::Spec->catdir($dir, "Config.pm"); } if ($found) { my $inc = dirname $found; - if (-e $self->catdir($inc, "perl.h")) { + if (-e File::Spec->catdir($inc, "perl.h")) { $self->{PERL_LIB} = $found; $self->{PERL_ARCHLIB} = $found; $self->{PERL_INC} = $inc; @@ -1798,22 +1783,22 @@ usually solves this kind of problem. if (defined $self->{PERL_SRC} and $self->{INSTALLDIRS} eq "perl") { $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB}; } else { - $self->{INST_LIB} = $self->catdir($self->curdir,"blib","lib"); + $self->{INST_LIB} = File::Spec->catdir(File::Spec->curdir,"blib","lib"); } } - $self->{INST_ARCHLIB} ||= $self->catdir($self->curdir,"blib","arch"); - $self->{INST_BIN} ||= $self->catdir($self->curdir,'blib','bin'); + $self->{INST_ARCHLIB} ||= File::Spec->catdir(File::Spec->curdir,"blib","arch"); + $self->{INST_BIN} ||= File::Spec->catdir(File::Spec->curdir,'blib','bin'); # We need to set up INST_LIBDIR before init_libscan() for VMS my @parentdir = split(/::/, $self->{PARENT_NAME}); - $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)',@parentdir); - $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)',@parentdir); - $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)','auto','$(FULLEXT)'); - $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)'); + $self->{INST_LIBDIR} = File::Spec->catdir('$(INST_LIB)',@parentdir); + $self->{INST_ARCHLIBDIR} = File::Spec->catdir('$(INST_ARCHLIB)',@parentdir); + $self->{INST_AUTODIR} = File::Spec->catdir('$(INST_LIB)','auto','$(FULLEXT)'); + $self->{INST_ARCHAUTODIR} = File::Spec->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)'); # INST_EXE is deprecated, should go away March '97 - $self->{INST_EXE} ||= $self->catdir($self->curdir,'blib','script'); - $self->{INST_SCRIPT} ||= $self->catdir($self->curdir,'blib','script'); + $self->{INST_EXE} ||= File::Spec->catdir(File::Spec->curdir,'blib','script'); + $self->{INST_SCRIPT} ||= File::Spec->catdir(File::Spec->curdir,'blib','script'); # The user who requests an installation directory explicitly # should not have to tell us an architecture installation directory @@ -1902,14 +1887,14 @@ usually solves this kind of problem. $self->prefixify($install_variable,$search_prefix,$replace_prefix); } } - my $funkymandir = $self->catdir($configure_prefix,"lib","perl5","man"); + my $funkymandir = File::Spec->catdir($configure_prefix,"lib","perl5","man"); $funkymandir = '' unless -d $funkymandir; - $search_prefix = $funkymandir || $self->catdir($configure_prefix,"man"); - if (-d $self->catdir($self->{PREFIX},"lib","perl5", "man")) { - $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5", "man"); + $search_prefix = $funkymandir || File::Spec->catdir($configure_prefix,"man"); + if (-d File::Spec->catdir($self->{PREFIX},"lib","perl5", "man")) { + $replace_prefix = File::Spec->catdir(qq[\$\(PREFIX\)],"lib", "perl5", "man"); } else { - $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"man"); + $replace_prefix = File::Spec->catdir(qq[\$\(PREFIX\)],"man"); } for $install_variable (qw/ INSTALLMAN1DIR @@ -1927,7 +1912,7 @@ usually solves this kind of problem. if ($self->{INSTALLMAN1DIR} =~ /^(none|\s*)$/){ $self->{INST_MAN1DIR} = $self->{INSTALLMAN1DIR}; } else { - $self->{INST_MAN1DIR} = $self->catdir($self->curdir,'blib','man1'); + $self->{INST_MAN1DIR} = File::Spec->catdir(File::Spec->curdir,'blib','man1'); } } $self->{MAN1EXT} ||= $Config::Config{man1ext}; @@ -1938,7 +1923,7 @@ usually solves this kind of problem. if ($self->{INSTALLMAN3DIR} =~ /^(none|\s*)$/){ $self->{INST_MAN3DIR} = $self->{INSTALLMAN3DIR}; } else { - $self->{INST_MAN3DIR} = $self->catdir($self->curdir,'blib','man3'); + $self->{INST_MAN3DIR} = File::Spec->catdir(File::Spec->curdir,'blib','man3'); } } $self->{MAN3EXT} ||= $Config::Config{man3ext}; @@ -1952,7 +1937,7 @@ usually solves this kind of problem. if ($self->{INSTALLHTMLSITELIBDIR} =~ /^(none|\s*)$/){ $self->{INST_HTMLLIBDIR} = $self->{INSTALLHTMLSITELIBDIR}; } else { - $self->{INST_HTMLLIBDIR} = $self->catdir($self->curdir,'blib','html','lib'); + $self->{INST_HTMLLIBDIR} = File::Spec->catdir(File::Spec->curdir,'blib','html','lib'); } } @@ -1962,7 +1947,7 @@ usually solves this kind of problem. if ($self->{INSTALLHTMLSCRIPTDIR} =~ /^(none|\s*)$/){ $self->{INST_HTMLSCRIPTDIR} = $self->{INSTALLHTMLSCRIPTDIR}; } else { - $self->{INST_HTMLSCRIPTDIR} = $self->catdir($self->curdir,'blib','html','bin'); + $self->{INST_HTMLSCRIPTDIR} = File::Spec->catdir(File::Spec->curdir,'blib','html','bin'); } } $self->{HTMLEXT} ||= $Config::Config{htmlext} || 'html'; @@ -2004,7 +1989,7 @@ usually solves this kind of problem. # make a simple check if we find Exporter warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory (Exporter.pm not found)" - unless -f $self->catfile("$self->{PERL_LIB}","Exporter.pm") || + unless -f File::Spec->catfile("$self->{PERL_LIB}","Exporter.pm") || $self->{NAME} eq "ExtUtils::MakeMaker"; # Determine VERSION and VERSION_FROM @@ -2185,8 +2170,8 @@ doc__install : doc_site_install pure_perl_install :: }.$self->{NOECHO}.q{$(MOD_INSTALL) \ - read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ - write }.$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ + read }.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ + write }.File::Spec->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ $(INST_LIB) $(INSTALLPRIVLIB) \ $(INST_ARCHLIB) $(INSTALLARCHLIB) \ $(INST_BIN) $(INSTALLBIN) \ @@ -2196,13 +2181,13 @@ pure_perl_install :: $(INST_MAN1DIR) $(INSTALLMAN1DIR) \ $(INST_MAN3DIR) $(INSTALLMAN3DIR) }.$self->{NOECHO}.q{$(WARN_IF_OLD_PACKLIST) \ - }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{ + }.File::Spec->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{ pure_site_install :: }.$self->{NOECHO}.q{$(MOD_INSTALL) \ - read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \ - write }.$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \ + read }.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \ + write }.File::Spec->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \ $(INST_LIB) $(INSTALLSITELIB) \ $(INST_ARCHLIB) $(INSTALLSITEARCH) \ $(INST_BIN) $(INSTALLBIN) \ @@ -2212,7 +2197,7 @@ pure_site_install :: $(INST_MAN1DIR) $(INSTALLMAN1DIR) \ $(INST_MAN3DIR) $(INSTALLMAN3DIR) }.$self->{NOECHO}.q{$(WARN_IF_OLD_PACKLIST) \ - }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ + }.File::Spec->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{ doc_perl_install :: -}.$self->{NOECHO}.q{$(MKPATH) $(INSTALLARCHLIB) @@ -2222,7 +2207,7 @@ doc_perl_install :: LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ - >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ + >> }.File::Spec->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ doc_site_install :: -}.$self->{NOECHO}.q{$(MKPATH) $(INSTALLARCHLIB) @@ -2232,7 +2217,7 @@ doc_site_install :: LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ - >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ + >> }.File::Spec->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ }; @@ -2241,11 +2226,11 @@ uninstall :: uninstall_from_$(INSTALLDIRS)dirs uninstall_from_perldirs :: }.$self->{NOECHO}. - q{$(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ + q{$(UNINSTALL) }.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ uninstall_from_sitedirs :: }.$self->{NOECHO}. - q{$(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ + q{$(UNINSTALL) }.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ }; join("",@m); @@ -2264,7 +2249,7 @@ sub installbin { my(@m, $from, $to, %fromto, @to); push @m, $self->dir_target(qw[$(INST_SCRIPT)]); for $from (@{$self->{EXE_FILES}}) { - my($path)= $self->catfile('$(INST_SCRIPT)', basename($from)); + my($path)= File::Spec->catfile('$(INST_SCRIPT)', basename($from)); local($_) = $path; # for backwards compatibility $to = $self->libscan($path); print "libscan($from) => '$to'\n" if ($Verbose >=2); @@ -2291,7 +2276,7 @@ realclean :: last unless defined $from; my $todir = dirname($to); push @m, " -$to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . " +$to: $from $self->{MAKEFILE} " . File::Spec->catdir($todir,'.exists') . " $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to \$(FIXIN) $to @@ -2594,7 +2579,7 @@ doc_inst_perl: MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ MAP_LIBPERL "$(MAP_LIBPERL)" \ - >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ + >> }.File::Spec->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ }; @@ -2602,7 +2587,7 @@ doc_inst_perl: inst_perl: pure_inst_perl doc_inst_perl pure_inst_perl: $(MAP_TARGET) - }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(INSTALLBIN)','$(MAP_TARGET)').q{ + }.$self->{CP}.q{ $(MAP_TARGET) }.File::Spec->catfile('$(INSTALLBIN)','$(MAP_TARGET)').q{ clean :: map_clean @@ -2666,13 +2651,13 @@ sub manifypods { my($dist); my($pod2man_exe); if (defined $self->{PERL_SRC}) { - $pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man'); + $pod2man_exe = File::Spec->catfile($self->{PERL_SRC},'pod','pod2man'); } else { - $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); + $pod2man_exe = File::Spec->catfile($Config{scriptdirexp},'pod2man'); } unless ($pod2man_exe = $self->perl_script($pod2man_exe)) { # Maybe a build by uninstalled Perl? - $pod2man_exe = $self->catfile($self->{PERL_INC}, "pod", "pod2man"); + $pod2man_exe = File::Spec->catfile($self->{PERL_INC}, "pod", "pod2man"); } unless ($pod2man_exe = $self->perl_script($pod2man_exe)) { # No pod2man but some MAN3PODS to be installed @@ -2731,12 +2716,12 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ my($abs,$tryabs); - if ($self->file_name_is_absolute($name)) { # /foo/bar + if (File::Spec->file_name_is_absolute($name)) { # /foo/bar $abs = $name; - } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # bar - $abs = $self->catfile($dir, $name); + } elsif (File::Spec->canonpath($name) eq File::Spec->canonpath(basename($name))) { # bar + $abs = File::Spec->catfile($dir, $name); } else { # foo/bar - $abs = $self->catfile($self->curdir, $name); + $abs = File::Spec->catfile(File::Spec->curdir, $name); } print "Checking $abs for $name\n" if ($trace >= 2); next unless $tryabs = $self->maybe_command($abs); @@ -2900,13 +2885,7 @@ Takes no argument, returns the environment variable PATH as an array. =cut sub path { - my($self) = @_; - my $path_sep = ($Is_OS2 || $Is_Dos) ? ";" : ":"; - my $path = $ENV{PATH}; - $path =~ s:\\:/:g if $Is_OS2; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + return File::Spec->path(); } =item perl_script @@ -3108,7 +3087,7 @@ q{ }.$self->{NOECHO}.q[$(PERLRUNINST) -MExtUtils::Install \ sub pm_to_blib { my $self = shift; - my($autodir) = $self->catdir('$(INST_LIB)','auto'); + my($autodir) = File::Spec->catdir('$(INST_LIB)','auto'); my $r = q{ pm_to_blib: $(TO_INST_PM) }; @@ -3377,7 +3356,7 @@ sub staticmake { # And as it's not yet built, we add the current extension # but only if it has some C code (or XS code, which implies C code) if (@{$self->{C}}) { - @static = $self->catfile($self->{INST_ARCHLIB}, + @static = File::Spec->catfile($self->{INST_ARCHLIB}, "auto", $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" @@ -3648,8 +3627,8 @@ Determines typemaps, xsubpp version, prototype behaviour. sub tool_xsubpp { my($self) = shift; return "" unless $self->needs_linking; - my($xsdir) = $self->catdir($self->{PERL_LIB},"ExtUtils"); - my(@tmdeps) = $self->catdir('$(XSUBPPDIR)','typemap'); + my($xsdir) = File::Spec->catdir($self->{PERL_LIB},"ExtUtils"); + my(@tmdeps) = File::Spec->catdir('$(XSUBPPDIR)','typemap'); if( $self->{TYPEMAPS} ){ my $typemap; foreach $typemap (@{$self->{TYPEMAPS}}){ @@ -3668,7 +3647,7 @@ sub tool_xsubpp { } - my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,"xsubpp")); + my $xsubpp_version = $self->xsubpp_version(File::Spec->catfile($xsdir,"xsubpp")); # What are the correct thresholds for version 1 && 2 Paul? if ( $xsubpp_version > 1.923 ){ diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index a3b236a4ed..fc05da2368 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -19,7 +19,6 @@ our($Revision, @ISA, $VERSION, $Verbose); # All on one line so MakeMaker can see it. ($VERSION) = ($Revision = '5.56 (27-Apr-1999)') =~ /^([\d.]+)/; -@ISA = qw( File::Spec ); unshift @MM::ISA, 'ExtUtils::MM_VMS'; require ExtUtils::MakeMaker; @@ -74,7 +73,7 @@ Returns a string representing of the root directory. =cut sub rootdir { - return ''; + return File::Spec->rootdir();' } package ExtUtils::MM_VMS; @@ -241,8 +240,8 @@ sub find_perl { local *TCF; # Check in relative directories first, so we pick up the current # version of Perl if we're running MakeMaker as part of the main build. - @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); - my($absb) = $self->file_name_is_absolute($b); + @sdirs = sort { my($absa) = File::Spec->file_name_is_absolute($a); + my($absb) = File::Spec->file_name_is_absolute($b); if ($absa && $absb) { return $a cmp $b } else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } } @$dirs; @@ -268,7 +267,7 @@ sub find_perl { } foreach $dir (@sdirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined - $inabs++ if $self->file_name_is_absolute($dir); + $inabs++ if File::Spec->file_name_is_absolute($dir); if ($inabs == 1) { # We've covered relative dirs; everything else is an absolute # dir (probably an installed location). First, we'll try potential @@ -277,7 +276,7 @@ sub find_perl { $inabs++; # Should happen above in next $dir, but just in case . . . } foreach $name (@snames){ - if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); } + if ($name !~ m![/:>\]]!) { push(@cand,File::Spec->catfile($dir,$name)); } else { push(@cand,$self->fixpath($name,0)); } } } @@ -322,9 +321,7 @@ to C<split> string value of C<$ENV{'PATH'}>. =cut sub path { - my(@dirs,$dir,$i); - while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } - @dirs; + return File::Spec->path(); } =item maybe_command (override) @@ -374,10 +371,10 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ my($abs,$tryabs); - if ($self->file_name_is_absolute($name)) { + if (File::Spec->file_name_is_absolute($name)) { $abs = $name; } else { - $abs = $self->catfile($dir, $name); + $abs = File::Spec->catfile($dir, $name); } print "Checking $abs for $name\n" if ($trace >= 2); next unless $tryabs = $self->maybe_command($abs); @@ -420,10 +417,8 @@ Checks for VMS directory spec as well as Unix separators. =cut sub file_name_is_absolute { - my($self,$file) = @_; - # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; - $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; + shift; + return File::Spec->file_name_is_absolute(@_); } =item replace_manpage_separator @@ -520,7 +515,7 @@ sub constants { next unless defined $self->{$macro}; $self->{$macro} = $self->fixpath($self->{$macro},1); } - $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC},q(VMS)) + $self->{PERL_VMS} = File::Spec->catdir($self->{PERL_SRC},q(VMS)) if ($self->{PERL_SRC}); @@ -552,7 +547,7 @@ DEFINE_VERSION = "$(VERSION_MACRO)=""$(VERSION)""" XS_VERSION_MACRO = XS_VERSION XS_DEFINE_VERSION = "$(XS_VERSION_MACRO)=""$(XS_VERSION)""" -MAKEMAKER = ],$self->catfile($self->{PERL_LIB},'ExtUtils','MakeMaker.pm'),qq[ +MAKEMAKER = ],File::Spec->catfile($self->{PERL_LIB},'ExtUtils','MakeMaker.pm'),qq[ MM_VERSION = $ExtUtils::MakeMaker::VERSION MM_REVISION = $ExtUtils::MakeMaker::Revision MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision @@ -808,7 +803,7 @@ command line to find args. sub pm_to_blib { my($self) = @_; my($line,$from,$to,@m); - my($autodir) = $self->catdir('$(INST_LIB)','auto'); + my($autodir) = File::Spec->catdir('$(INST_LIB)','auto'); my(@files) = @{$self->{PM_TO_BLIB}}; push @m, q{ @@ -867,9 +862,9 @@ Use VMS-style quoting on xsubpp command line. sub tool_xsubpp { my($self) = @_; return '' unless $self->needs_linking; - my($xsdir) = $self->catdir($self->{PERL_LIB},'ExtUtils'); + my($xsdir) = File::Spec->catdir($self->{PERL_LIB},'ExtUtils'); # drop back to old location if xsubpp is not in new location yet - $xsdir = $self->catdir($self->{PERL_SRC},'ext') unless (-f $self->catfile($xsdir,'xsubpp')); + $xsdir = File::Spec->catdir($self->{PERL_SRC},'ext') unless (-f File::Spec->catfile($xsdir,'xsubpp')); my(@tmdeps) = '$(XSUBPPDIR)typemap'; if( $self->{TYPEMAPS} ){ my $typemap; @@ -893,7 +888,7 @@ sub tool_xsubpp { (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)) { unshift(@tmargs,'-nolinenumbers'); } - my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,'xsubpp')); + my $xsubpp_version = $self->xsubpp_version(File::Spec->catfile($xsdir,'xsubpp')); # What are the correct thresholds for version 1 && 2 Paul? if ( $xsubpp_version > 1.923 ){ @@ -1371,9 +1366,9 @@ sub manifypods { my($dist); my($pod2man_exe); if (defined $self->{PERL_SRC}) { - $pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man'); + $pod2man_exe = File::Spec->catfile($self->{PERL_SRC},'pod','pod2man'); } else { - $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); + $pod2man_exe = File::Spec->catfile($Config{scriptdirexp},'pod2man'); } if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) { # No pod2man but some MAN3PODS to be installed @@ -1551,7 +1546,7 @@ clean :: } } push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]); - push(@otherfiles,$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); + push(@otherfiles,File::Spec->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); my($file,$line); $line = ''; #avoid unitialized var warning # Occasionally files are repeated several times from different sources @@ -1792,8 +1787,8 @@ doc__install : doc_site_install # This hack brought to you by DCL's 255-character command line limit pure_perl_install :: - $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp - $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print 'read ].File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'write ].File::Spec->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp @@ -1802,12 +1797,12 @@ pure_perl_install :: $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp $(MOD_INSTALL) <.MM_tmp $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; - $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ # Likewise pure_site_install :: - $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp - $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp + $(NOECHO) $(PERL) -e "print 'read ].File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp + $(NOECHO) $(PERL) -e "print 'write ].File::Spec->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp @@ -1816,7 +1811,7 @@ pure_site_install :: $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp $(MOD_INSTALL) <.MM_tmp $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; - $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ # Ditto doc_perl_install :: @@ -1827,7 +1822,7 @@ q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp $(NOECHO) $(PERL) -e "print q[print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp - $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.File::Spec->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp; # And again @@ -1839,7 +1834,7 @@ q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp $(NOECHO) $(PERL) -e "print q[print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp - $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.File::Spec->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp; ]; @@ -1849,13 +1844,13 @@ uninstall :: uninstall_from_$(INSTALLDIRS)dirs $(NOECHO) $(NOOP) uninstall_from_perldirs :: - $(NOECHO) $(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) $(UNINSTALL) ].File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes." $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove" $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience." uninstall_from_sitedirs :: - $(NOECHO) $(UNINSTALL) ],$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist'),"\n",q[ + $(NOECHO) $(UNINSTALL) ],File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist'),"\n",q[ $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes." $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove" $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience." @@ -2214,15 +2209,15 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE) # that's what we're building here). push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2]; if ($libperl) { - unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { + unless (-f $libperl || -f ($libperl = File::Spec->catfile($Config{'installarchlib'},'CORE',$libperl))) { print STDOUT "Warning: $libperl not found\n"; undef $libperl; } } unless ($libperl) { if (defined $self->{PERL_SRC}) { - $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); - } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { + $libperl = File::Spec->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); + } elsif (-f ($libperl = File::Spec->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { } else { print STDOUT "Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed @@ -2273,9 +2268,9 @@ $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt" doc_inst_perl : $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp - $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp + $(NOECHO) $(PERL) -pl040 -e " " ].File::Spec->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp $(NOECHO) $(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp - $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + $(DOC_INSTALL) <.MM_tmp >>].File::Spec->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp; ]; diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index 7b5d142fde..478424958d 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -23,6 +23,7 @@ the semantics. use Config; #use Cwd; use File::Basename; +use File::Spec; require Exporter; require ExtUtils::MakeMaker; @@ -137,8 +138,8 @@ sub maybe_command { } sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; + shift; + return File::Spec->file_name_is_absolute(@_); } sub find_perl { @@ -155,12 +156,12 @@ in these dirs: next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ my ($abs, $val); - if ($self->file_name_is_absolute($name)) { # /foo/bar + if (File::Spec->file_name_is_absolute($name)) { # /foo/bar $abs = $name; - } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo - $abs = $self->catfile($dir, $name); + } elsif (File::Spec->canonpath($name) eq File::Spec->canonpath(basename($name))) { # foo + $abs = File::Spec->catfile($dir, $name); } else { # foo/bar - $abs = $self->canonpath($self->catfile($self->curdir, $name)); + $abs = File::Spec->canonpath(File::Spec->catfile(File::Spec->curdir, $name)); } print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); @@ -179,14 +180,8 @@ in these dirs: } sub catdir { - my $self = shift; - my @args = @_; - for (@args) { - # append a slash to each argument unless it has one there - $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; - } - my $result = $self->canonpath(join('', @args)); - $result; + shift; + return File::Spec->catdir(@_); } =item catfile @@ -197,13 +192,8 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; - my $file = pop @_; - return $file unless @_; - my $dir = $self->catdir(@_); - $dir =~ s/(\\\.)$//; - $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; - return $dir.$file; + shift; + return File::Spec->catfile(@_); } sub init_others @@ -347,11 +337,11 @@ CONFIGDEP = \$(PERL_ARCHLIB)\\Config.pm \$(PERL_INC)\\config.h my @parentdir = split(/::/, $self->{PARENT_NAME}); push @m, q{ # Where to put things: -INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{ -INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{ +INST_LIBDIR = }. File::Spec->catdir('$(INST_LIB)',@parentdir) .q{ +INST_ARCHLIBDIR = }. File::Spec->catdir('$(INST_ARCHLIB)',@parentdir) .q{ -INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ -INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ +INST_AUTODIR = }. File::Spec->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ +INST_ARCHAUTODIR = }. File::Spec->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ }; if ($self->has_link_code()) { @@ -394,11 +384,7 @@ PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ sub path { - my($self) = @_; - my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; - my @path = split(';',$path); - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + return File::Spec->path(); } =item static_lib (o) @@ -608,7 +594,7 @@ destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> sub pm_to_blib { my $self = shift; - my($autodir) = $self->catdir('$(INST_LIB)','auto'); + my($autodir) = File::Spec->catdir('$(INST_LIB)','auto'); return q{ pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ @@ -842,9 +828,9 @@ sub htmlifypods { my($dist); my($pod2html_exe); if (defined $self->{PERL_SRC}) { - $pod2html_exe = $self->catfile($self->{PERL_SRC},'pod','pod2html'); + $pod2html_exe = File::Spec->catfile($self->{PERL_SRC},'pod','pod2html'); } else { - $pod2html_exe = $self->catfile($Config{scriptdirexp},'pod2html'); + $pod2html_exe = File::Spec->catfile($Config{scriptdirexp},'pod2html'); } unless ($pod2html_exe = $self->perl_script($pod2html_exe)) { # No pod2html but some HTMLxxxPODS to be installed diff --git a/lib/File/Find.pm b/lib/File/Find.pm index a0cfcb9932..dbc1b78343 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -44,7 +44,7 @@ I<the wanted() function> below. Reports the name of a directory only AFTER all its entries have been reported. Entry point finddepth() is a shortcut for -specifying C<{ bydepth => 1 }> in the first argument of find(). +specifying C<{ bydepth =E<gt> 1 }> in the first argument of find(). =item C<preprocess> @@ -565,8 +565,6 @@ sub _find_opt { $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety if ($top_item eq $File::Find::current_dir) { - # avoid empty name after return to '/' - $name = '/' unless length( $name ); $abs_dir = $cwd; } else { @@ -733,8 +731,6 @@ sub _find_dir($$$) { $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ # prune may happen here $prune= 0; - # guarantee lstat for directory - lstat( $dir_name ); { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -886,8 +882,6 @@ sub _find_dir($$$) { substr($_, length($_) == 2 ? -1 : -2) = ''; } } - # guarantee lstat at return to directory - lstat( $dir_name ); { &$wanted_callback }; # protect against wild "next" } else { @@ -1071,12 +1065,12 @@ sub _find_dir_symlnk($$$) { } else { if ( substr($name,-2) eq '/.' ) { - $name =~ s|/\.$||; # $File::Find::name + substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name } $dir = $p_dir; # $File::Find::dir $_ = ($no_chdir ? $dir_name : $dir_rel); # $_ if ( substr($_,-2) eq '/.' ) { - s|/\.$||; + substr($_, length($_) == 2 ? -1 : -2) = ''; } } diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index f177f68831..9d9d5b676e 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -9,9 +9,19 @@ my %module = (MacOS => 'Mac', MSWin32 => 'Win32', os2 => 'OS2', VMS => 'VMS', - epoc => 'Epoc'); + epoc => 'Epoc', + cygwin => 'Cygwin'); + my $module = $module{$^O} || 'Unix'; + +if ($^O eq 'MSWin32') { + require Config; + if ($Config::Config{osname} eq 'NetWare') { + $module = 'NW5'; + } +} + require "File/Spec/$module.pm"; @ISA = ("File::Spec::$module"); diff --git a/lib/File/Spec/Cygwin.pm b/lib/File/Spec/Cygwin.pm new file mode 100644 index 0000000000..23fed18f50 --- /dev/null +++ b/lib/File/Spec/Cygwin.pm @@ -0,0 +1,35 @@ +package File::Spec::Cygwin; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '1.0'; + +@ISA = qw(File::Spec::Unix); + +sub canonpath { + my($self,$path) = @_; + $path =~ s|\\|/|g; + return $self->SUPER::canonpath($path); +} + +1; +__END__ + +=head1 NAME + +File::Spec::Cygwin - methods for Cygwin file specs + +=head1 SYNOPSIS + + require File::Spec::Cygwin; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This module is still in beta. Cygwin-knowledgeable folks are invited +to offer patches and suggestions. diff --git a/lib/File/Spec/NW5.pm b/lib/File/Spec/NW5.pm new file mode 100644 index 0000000000..772a93df56 --- /dev/null +++ b/lib/File/Spec/NW5.pm @@ -0,0 +1,48 @@ +package File::Spec::NW5; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Win32; + +$VERSION = '1.0'; + +@ISA = qw(File::Spec::Win32); + +sub catdir { + my $self = shift; + my @args = @_; + for (@args) { + # append a slash to each argument unless it has one there + $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + } + my $result = $self->canonpath(join('', @args)); + $result; +} + +sub canonpath { + my $self = shift; + my $path = $self->SUPER::canonpath(@_); + $path .= '.' if $path =~ m#\\$#; + return $path; +} + + +1; +__END__ + +=head1 NAME + +File::Spec::NW5 - methods for NetWare file specs + +=head1 SYNOPSIS + + require File::Spec::NW5; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Win32 and File::Spec::Unix for a documentation of the +methods provided there. This package overrides the implementation of +these methods, not the semantics. + +This module is still in beta. NetWare-knowledgeable folks are invited +to offer patches and suggestions. diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index ceebb2d100..c2e463b80c 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -117,11 +117,11 @@ sub canonpath { my ($self,$path) = @_; $path =~ s/^([a-z]:)/\u$1/s; $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx - $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # ./xx -> xx + $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx + $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx + $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx $path =~ s|\\\Z(?!\n)|| - unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx/ -> xx + unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx\ -> xx return $path; } diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index c3673b1030..642338c89d 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,6 +1,6 @@ package Net::Ping; -# $Id: Ping.pm,v 1.13 2001/12/07 02:18:44 rob Exp $ +# $Id: Ping.pm,v 1.15 2001/12/26 20:55:55 rob Exp $ require 5.002; require Exporter; @@ -15,7 +15,7 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(pingecho); -$VERSION = 2.09; +$VERSION = "2.10"; # Constants @@ -86,6 +86,8 @@ sub new $self->{"data"} .= chr($cnt % 256); } + $self->{"local_addr"} = undef; # Don't bind by default + $self->{"seq"} = 0; # For counting packets if ($self->{"proto"} eq "udp") # Open a socket { @@ -94,7 +96,7 @@ sub new $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] || croak("Can't get udp echo port by name"); $self->{"fh"} = FileHandle->new(); - socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(), + socket($self->{"fh"}, PF_INET, SOCK_DGRAM, $self->{"proto_num"}) || croak("udp socket error - $!"); } @@ -105,7 +107,7 @@ sub new croak("Can't get icmp protocol by name"); $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid $self->{"fh"} = FileHandle->new(); - socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) || + socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) || croak("icmp socket error - $!"); } elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream") @@ -117,10 +119,43 @@ sub new $self->{"fh"} = FileHandle->new(); } - return($self); } +# Description: Set the local IP address from which pings will be sent. +# For ICMP and UDP pings, this calls bind() on the already-opened socket; +# for TCP pings, just saves the address to be used when the socket is +# opened. Returns non-zero if successful; croaks on error. +sub bind +{ + my ($self, + $local_addr # Name or IP number of local interface + ) = @_; + my ($ip # Packed IP number of $local_addr + ); + + croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; + croak("already bound") if defined($self->{"local_addr"}) && + ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp"); + + $ip = inet_aton($local_addr); + croak("nonexistent local address $local_addr") unless defined($ip); + $self->{"local_addr"} = $ip; # Only used if proto is tcp + + if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp") + { + CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) || + croak("$self->{'proto'} bind error - $!"); + } + elsif ($self->{"proto"} ne "tcp") + { + croak("Unknown protocol \"$self->{proto}\" in bind()"); + } + + return 1; +} + + # Description: Ping a host name or IP number with an optional timeout. # First lookup the host, and return undef if it is not found. Otherwise # perform the specific ping method based on the protocol. Return the @@ -165,6 +200,13 @@ sub ping_external { return Net::Ping::External::ping(ip => $ip, timeout => $timeout); } +use constant ICMP_ECHOREPLY => 0; # ICMP packet types +use constant ICMP_ECHO => 8; +use constant ICMP_STRUCT => "C2 S3 A"; # Structure of a minimal ICMP packet +use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY +use constant ICMP_FLAGS => 0; # No special flags for send or recv +use constant ICMP_PORT => 0; # No port with ICMP + sub ping_icmp { my ($self, @@ -172,13 +214,6 @@ sub ping_icmp $timeout # Seconds after which ping times out ) = @_; - my $ICMP_ECHOREPLY = 0; # ICMP packet types - my $ICMP_ECHO = 8; - my $icmp_struct = "C2 S3 A"; # Structure of a minimal ICMP packet - my $subcode = 0; # No ICMP subcode for ECHO and ECHOREPLY - my $flags = 0; # No special flags when opening a socket - my $port = 0; # No port with ICMP - my ($saddr, # sockaddr_in with port and ip $checksum, # Checksum of ICMP packet $msg, # ICMP packet to send @@ -202,14 +237,14 @@ sub ping_icmp $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence $checksum = 0; # No checksum for starters - $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE, $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); $checksum = Net::Ping->checksum($msg); - $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode, + $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE, $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"}); $len_msg = length($msg); - $saddr = sockaddr_in($port, $ip); - send($self->{"fh"}, $msg, $flags, $saddr); # Send the message + $saddr = sockaddr_in(ICMP_PORT, $ip); + send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message $rbits = ""; vec($rbits, $self->{"fh"}->fileno(), 1) = 1; @@ -228,14 +263,14 @@ sub ping_icmp elsif ($nfound) # Got a packet from somewhere { $recv_msg = ""; - $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags); + $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS); ($from_port, $from_ip) = sockaddr_in($from_saddr); ($from_type, $from_subcode, $from_chk, $from_pid, $from_seq, $from_msg) = - unpack($icmp_struct . $self->{"data_size"}, + unpack(ICMP_STRUCT . $self->{"data_size"}, substr($recv_msg, length($recv_msg) - $len_msg, $len_msg)); - if (($from_type == $ICMP_ECHOREPLY) && + if (($from_type == ICMP_ECHOREPLY) && ($from_ip eq $ip) && ($from_pid == $self->{"pid"}) && # Does the packet check out? ($from_seq == $self->{"seq"})) @@ -318,8 +353,12 @@ sub tcp_connect my $ret = 0; # Default to unreachable my $do_socket = sub { - socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) || + socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) || croak("tcp socket error - $!"); + if (defined $self->{"local_addr"} && + !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) { + croak("tcp bind error - $!"); + } }; my $do_connect = sub { eval { @@ -513,6 +552,8 @@ sub open # done. Otherwise go back and wait for the message until we run out # of time. Return the result of our efforts. +use constant UDP_FLAGS => 0; # Nothing special on send or recv + sub ping_udp { my ($self, @@ -520,8 +561,6 @@ sub ping_udp $timeout # Seconds after which ping times out ) = @_; - my $flags = 0; # Nothing special on open - my ($saddr, # sockaddr_in with port and ip $ret, # The return value $msg, # Message to be echoed @@ -538,7 +577,7 @@ sub ping_udp $saddr = sockaddr_in($self->{"port_num"}, $ip); $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any - send($self->{"fh"}, $msg, $flags, $saddr); # Send it + send($self->{"fh"}, $msg, UDP_FLAGS, $saddr); # Send it $rbits = ""; vec($rbits, $self->{"fh"}->fileno(), 1) = 1; @@ -558,7 +597,7 @@ sub ping_udp elsif ($nfound) # A packet is waiting { $from_msg = ""; - $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags) + $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS) or last; # For example an unreachable host will make recv() fail. ($from_port, $from_ip) = sockaddr_in($from_saddr); if (($from_ip eq $ip) && # Does the packet check out? @@ -595,7 +634,7 @@ __END__ Net::Ping - check a remote host for reachability -$Id: Ping.pm,v 1.13 2001/12/07 02:18:44 rob Exp $ +$Id: Ping.pm,v 1.15 2001/12/26 20:55:55 rob Exp $ =head1 SYNOPSIS @@ -606,6 +645,7 @@ $Id: Ping.pm,v 1.13 2001/12/07 02:18:44 rob Exp $ $p->close(); $p = Net::Ping->new("icmp"); + $p->bind($my_addr); # Specify source interface of pings foreach $host (@host_array) { print "$host is "; @@ -692,6 +732,20 @@ default) number of data bytes is 1 if the protocol is "udp" and 0 otherwise. The maximum number of data bytes that can be specified is 1024. +=item $p->bind($local_addr); + +Sets the source address from which pings will be sent. This must be +the address of one of the interfaces on the local host. $local_addr +may be specified as a hostname or as a text IP address such as +"192.168.1.1". + +If the protocol is set to "tcp", this method may be called any +number of times, and each call to the ping() method (below) will use +the most recent $local_addr. If the protocol is "icmp" or "udp", +then bind() must be called at most once per object, and (if it is +called at all) must be called before the first call to ping() for that +object. + =item $p->ping($host [, $timeout]); Ping the remote host and wait for a response. $host can be either the @@ -778,10 +832,11 @@ routines to pack and unpack ICMP packets. It would be better for a separate module to be written which understands all of the different kinds of ICMP packets. -=head1 AUTHOR(S) +=head1 AUTHORS - Current maintainer Net::Ping base code: + Current maintainers: colinm@cpan.org (Colin McMillen) + bbb@cpan.org (Rob Brown) Stream protocol: bronson@trestle.com (Scott Bronson) @@ -793,12 +848,10 @@ kinds of ICMP packets. Original Net::Ping author: mose@ns.ccsn.edu (Russell Mosemann) - Compatibility porting: - bbb@cpan.org (Rob Brown) - =head1 COPYRIGHT Copyright (c) 2001, Colin McMillen. All rights reserved. + Copyright (c) 2001, Rob Brown. All rights reserved. This program is free software; you may redistribute it and/or diff --git a/lib/Net/Ping/CHANGES b/lib/Net/Ping/CHANGES index fb327f123e..143de044bb 100644 --- a/lib/Net/Ping/CHANGES +++ b/lib/Net/Ping/CHANGES @@ -1,6 +1,14 @@ CHANGES ------- +2.10 Dec 26 12:00 2001 + - Added bind() function useful for clients with multiple + network interfaces performing the ping check thanks to + sethb@clarkhill.com (Seth Blumberg). + - Execution optimizations for several constants (Seth). + - More test changes in case Socket module is not available + (Jarkko Hietaniemi). + 2.09 Dec 06 19:00 2001 - Documental and test changes only. - No functional changes. diff --git a/lib/Net/Ping/t/100_load.t b/lib/Net/Ping/t/100_load.t index d6a71e0235..de84247632 100644 --- a/lib/Net/Ping/t/100_load.t +++ b/lib/Net/Ping/t/100_load.t @@ -3,6 +3,13 @@ ######################### We start with some black magic to print on failure. +BEGIN { + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } +} + use Test; BEGIN { plan tests => 1; $loaded = 0} END { ok $loaded;} diff --git a/lib/Net/Ping/t/110_icmp_inst.t b/lib/Net/Ping/t/110_icmp_inst.t index 2e67a5972a..c617135271 100644 --- a/lib/Net/Ping/t/110_icmp_inst.t +++ b/lib/Net/Ping/t/110_icmp_inst.t @@ -1,6 +1,13 @@ # Test to make sure object can be instantiated for icmp protocol. # Root access is required to actually perform icmp testing. +BEGIN { + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } +} + use Test; use Net::Ping; plan tests => 2; diff --git a/lib/Net/Ping/t/120_udp_inst.t b/lib/Net/Ping/t/120_udp_inst.t index ee53bd40bf..0dc64ad4cb 100644 --- a/lib/Net/Ping/t/120_udp_inst.t +++ b/lib/Net/Ping/t/120_udp_inst.t @@ -1,6 +1,13 @@ # Test to make sure object can be instantiated for udp protocol. # I do not know of any servers that support udp echo anymore. +BEGIN { + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } +} + use Test; use Net::Ping; plan tests => 2; diff --git a/lib/Net/Ping/t/130_tcp_inst.t b/lib/Net/Ping/t/130_tcp_inst.t index 6a547e161e..af6ddaac17 100644 --- a/lib/Net/Ping/t/130_tcp_inst.t +++ b/lib/Net/Ping/t/130_tcp_inst.t @@ -1,5 +1,12 @@ # Test to make sure object can be instantiated for tcp protocol. +BEGIN { + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } +} + use Test; use Net::Ping; plan tests => 2; diff --git a/lib/Net/Ping/t/140_stream_inst.t b/lib/Net/Ping/t/140_stream_inst.t index 142f6db74f..ce1b9e62e7 100644 --- a/lib/Net/Ping/t/140_stream_inst.t +++ b/lib/Net/Ping/t/140_stream_inst.t @@ -1,5 +1,12 @@ # Test to make sure object can be instantiated for stream protocol. +BEGIN { + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } +} + use Test; use Net::Ping; plan tests => 2; diff --git a/lib/Net/Ping/t/200_ping_tcp.t b/lib/Net/Ping/t/200_ping_tcp.t index 7bdc8e7378..6fbd78b5c9 100644 --- a/lib/Net/Ping/t/200_ping_tcp.t +++ b/lib/Net/Ping/t/200_ping_tcp.t @@ -7,6 +7,10 @@ BEGIN { chdir 't' if -d 't'; @INC = qw(../lib); } + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } } # Remote network test using tcp protocol. diff --git a/lib/Net/Ping/t/300_ping_stream.t b/lib/Net/Ping/t/300_ping_stream.t index 4c32a64f6b..b60a500884 100644 --- a/lib/Net/Ping/t/300_ping_stream.t +++ b/lib/Net/Ping/t/300_ping_stream.t @@ -7,6 +7,10 @@ BEGIN { chdir 't' if -d 't'; @INC = qw(../lib); } + unless (eval "require Socket") { + print "1..0 \# Skip: no Socket\n"; + exit; + } } # Test of stream protocol using loopback interface. @@ -53,3 +57,8 @@ service echo server = /bin/cat disable = no } + +Or if you are using inetd, before restarting, add +this line to your /etc/inetd.conf: + +echo stream tcp nowait root internal @@ -2043,6 +2043,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o))); + } if (attrs) { GV *gv = cGVOPx_gv(cUNOPo->op_first); PL_in_my = FALSE; diff --git a/patchlevel.h b/patchlevel.h index 15ac32ceb7..b4d229b95b 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -70,7 +70,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL13832" + ,"DEVEL13884" ,NULL }; @@ -1099,8 +1099,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; break; - case 't': - PL_taint_warn = TRUE; + case 't': + PL_taint_warn = TRUE; + if (! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; case 'T': PL_tainting = TRUE; s++; @@ -755,6 +755,12 @@ int sockatmark(int); # endif #endif +#ifndef HAS_SOCKETPAIR +# ifdef HAS_SOCKET +# define socketpair Perl_my_socketpair +# endif +#endif + #if INTSIZE == 2 # define htoni htons # define ntohi ntohs @@ -3937,12 +3943,13 @@ int flock(int fd, int op); #if O_TEXT != O_BINARY /* If you have different O_TEXT and O_BINARY and you are a CLRF shop, * that is, you are somehow DOSish. */ -# if !defined(__BEOS__) -# define PERLIO_USING_CRLF 1 -# else +# if defined(__BEOS__) /* If you have O_TEXT different from your O_BINARY but you still are * not a CRLF shop. */ # undef PERLIO_USING_CRLF +# else + /* If you really are DOSish. */ +# define PERLIO_USING_CRLF 1 # endif #endif @@ -89,6 +89,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode) # endif #else # if defined(USEMYBINMODE) + dTHX; if (my_binmode(fp, iotype, mode) != FALSE) return 1; else diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 3f82777366..ee5d65abeb 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -465,6 +465,26 @@ then. =for hackers Found in file util.c +=item form + +Takes a sprintf-style format pattern and conventional +(non-SV) arguments and returns the formatted string. + + (char *) Perl_form(pTHX_ const char* pat, ...) + +can be used any place a string (char *) is required: + + char * s = Perl_form("%d.%d",major,minor); + +Uses a single private buffer so if you want to format several strings you +must explicitly copy the earlier strings away (and free the copies when you +are done). + + char* form(const char* pat, ...) + +=for hackers +Found in file util.c + =item FREETMPS Closing bracket for temporaries on a callback. See C<SAVETMPS> and @@ -1420,17 +1440,6 @@ SV is B<not> incremented. =for hackers Found in file sv.c -=item newSV - -Create a new null SV, or if len > 0, create a new empty SVt_PV type SV -with an initial PV allocation of len+1. Normally accessed via the C<NEWSV> -macro. - - SV* newSV(STRLEN len) - -=for hackers -Found in file sv.c - =item NEWSV Creates a new SV. A non-zero C<len> parameter indicates the number of @@ -1444,6 +1453,17 @@ C<id> is an integer id between 0 and 1299 (used to identify leaks). =for hackers Found in file handy.h +=item newSV + +Create a new null SV, or if len > 0, create a new empty SVt_PV type SV +with an initial PV allocation of len+1. Normally accessed via the C<NEWSV> +macro. + + SV* newSV(STRLEN len) + +=for hackers +Found in file sv.c + =item newSViv Creates a new SV and copies an integer into it. The reference count for the @@ -2996,22 +3016,22 @@ for a version which guarantees to evaluate sv only once. =for hackers Found in file sv.h -=item SvUVX +=item SvUVx -Returns the raw value in the SV's UV slot, without checks or conversions. -Only use when you are sure SvIOK is true. See also C<SvUV()>. +Coerces the given SV to an unsigned integer and returns it. Guarantees to +evaluate sv only once. Use the more efficient C<SvUV> otherwise. - UV SvUVX(SV* sv) + UV SvUVx(SV* sv) =for hackers Found in file sv.h -=item SvUVx +=item SvUVX -Coerces the given SV to an unsigned integer and returns it. Guarantees to -evaluate sv only once. Use the more efficient C<SvUV> otherwise. +Returns the raw value in the SV's UV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C<SvUV()>. - UV SvUVx(SV* sv) + UV SvUVX(SV* sv) =for hackers Found in file sv.h diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index 7604f14484..80a8fb6fff 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq5 - Files and Formats ($Revision: 1.5 $, $Date: 2001/12/18 09:01:14 $) +perlfaq5 - Files and Formats ($Revision: 1.6 $, $Date: 2001/12/19 18:17:00 $) =head1 DESCRIPTION @@ -902,7 +902,7 @@ for instance, gets treated as two paragraphs and not three), or C<"\n\n"> to accept empty paragraphs. Note that a blank line must have no blanks in it. Thus -C<"fred\n \nstuff\n\n"> is one paragraph, but C<"fred\n\nstuff\n\n"> is two. +S<C<"fred\n \nstuff\n\n">> is one paragraph, but C<"fred\n\nstuff\n\n"> is two. =head2 How can I read a single character from a file? From the keyboard? diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 1d65ca6fde..516d875fcf 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -4421,7 +4421,9 @@ to C<pipe(Rdr, Wtr)> is essentially: shutdown(Rdr, 1); # no more writing for reader shutdown(Wtr, 0); # no more reading for writer -See L<perlipc> for an example of socketpair use. +See L<perlipc> for an example of socketpair use. Perl 5.8 and later will +emulate socketpair using IP sockets to localhost if your system implements +sockets but not socketpair. =item sort SUBNAME LIST @@ -5374,9 +5376,9 @@ supported on some platforms (see L<perlport>). To be safe, you may need to set C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> method of C<IO::Handle> on any open handles. -The return value is the exit status of the program as -returned by the C<wait> call. To get the actual exit value divide by -256. See also L</exec>. This is I<not> what you want to use to capture +The return value is the exit status of the program as returned by the +C<wait> call. To get the actual exit value shift left by eight (see below). +See also L</exec>. This is I<not> what you want to use to capture the output from a command, for that you should use merely backticks or C<qx//>, as described in L<perlop/"`STRING`">. Return value of -1 indicates a failure to start the program (inspect $! for the reason). @@ -5384,8 +5386,9 @@ indicates a failure to start the program (inspect $! for the reason). Like C<exec>, C<system> allows you to lie to a program about its name if you use the C<system PROGRAM LIST> syntax. Again, see L</exec>. -Because C<system> and backticks block C<SIGINT> and C<SIGQUIT>, killing the -program they're running doesn't actually interrupt your program. +Because C<system> and backticks block C<SIGINT> and C<SIGQUIT>, +killing the program they're running doesn't actually interrupt +your program. @args = ("command", "arg1", "arg2"); system(@args) == 0 @@ -5398,6 +5401,9 @@ C<$?> like this: $signal_num = $? & 127; $dumped_core = $? & 128; +or more portably by using the W*() calls of the POSIX extension, +see L<perlport> for more information. + When the arguments get executed via the system shell, results and return codes will be subject to its quirks and capabilities. See L<perlop/"`STRING`"> and L</exec> for details. diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 1f69c969ee..4efe90bfe2 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -37,12 +37,13 @@ in what does and does not change in the Perl language. Various releases of Perl are shepherded by a ``pumpking'', a porter responsible for gathering patches, deciding on a patch-by-patch feature-by-feature basis what will and will not go into the release. -For instance, Gurusamy Sarathy is the pumpking for the 5.6 release of -Perl. +For instance, Gurusamy Sarathy was the pumpking for the 5.6 release of +Perl, and Jarkko Hietaniemi is the pumpking for the 5.8 release, and +Hugo van der Sanden will be the pumpking for the 5.10 release. In addition, various people are pumpkings for different things. For instance, Andy Dougherty and Jarkko Hietaniemi share the I<Configure> -pumpkin, and Tom Christiansen is the documentation pumpking. +pumpkin. Larry sees Perl development along the lines of the US government: there's the Legislature (the porters), the Executive branch (the diff --git a/pod/perlport.pod b/pod/perlport.pod index 588b55d14b..a2133484dd 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -1779,6 +1779,16 @@ OS>, OS/390, VM/ESA) =item system LIST +In general, do not assume the UNIX/POSIX semantics that you can shift +the C<$?> left by eight to get the exit value, or that C<$? & 127> +would give you the number of the signal that terminated the program, +or that C<$? & 128> would test true if the program was terminated by a +coredump. Instead, use the POSIX W*() interfaces: for example, use +WIFEXITED($?) an WEXITVALUE($?) to test for a normal exit and the exit +value, and WIFSIGNALED($?) and WTERMSIG($?) for a signal exit and the +signal. Core dumping is not a portable concept so there's no portable +way to test for that. + Only implemented if ToolServer is installed. (S<Mac OS>) As an optimization, may not call the command shell specified in diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 2b7cca11ce..137ecd30d8 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -700,11 +700,13 @@ program will be searched for strictly on the PATH. =item B<-t> Like B<-T>, but taint checks will issue warnings rather than fatal -errors. Since these are warnings, the B<-w> switch (or C<use -warnings>) must be used along with this option. B<NOTE: this is -not a substitute for -T.> This is meant only to be used as a temporary -aid while securing legacy code: for real production code and for new -secure code written from scratch always use the real B<-T>. +errors. Also, all warnings are turned on as if you had used also +a B<-w>. + +B<NOTE: this is not a substitute for -T.> This is meant only to be +used as a temporary development aid while securing legacy code: +for real production code and for new secure code written from scratch +always use the real B<-T>. =item B<-T> @@ -2280,7 +2280,7 @@ PP(pp_socket) PP(pp_sockpair) { -#ifdef HAS_SOCKETPAIR +#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET) dSP; GV *gv1; GV *gv2; @@ -4312,6 +4312,10 @@ PP(pp_time) it's supported. --AD 9/96. */ +#ifdef __BEOS__ +# define HZ 1000000 +#endif + #ifndef HZ # ifdef CLK_TCK # define HZ CLK_TCK @@ -1331,6 +1331,37 @@ PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags); PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags); PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags); PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value); +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) +PERL_CALLCONV int Perl_my_socketpair(pTHX_ int family, int type, int protocol, int fd[2]); +#endif + + +#if defined(USE_PERLIO) && !defined(USE_SFIO) +PERL_CALLCONV int Perl_PerlIO_close(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_fill(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_fileno(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_eof(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_error(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_flush(pTHX_ PerlIO *); +PERL_CALLCONV void Perl_PerlIO_clearerr(pTHX_ PerlIO *); +PERL_CALLCONV void Perl_PerlIO_set_cnt(pTHX_ PerlIO *, int); +PERL_CALLCONV void Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *, STDCHAR *, int); +PERL_CALLCONV void Perl_PerlIO_setlinebuf(pTHX_ PerlIO *); +PERL_CALLCONV SSize_t Perl_PerlIO_read(pTHX_ PerlIO *, void *, Size_t); +PERL_CALLCONV SSize_t Perl_PerlIO_write(pTHX_ PerlIO *, const void *, Size_t); +PERL_CALLCONV SSize_t Perl_PerlIO_unread(pTHX_ PerlIO *, const void *, Size_t); +PERL_CALLCONV Off_t Perl_PerlIO_tell(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_seek(pTHX_ PerlIO *, Off_t, int); + +PERL_CALLCONV STDCHAR * Perl_PerlIO_get_base(pTHX_ PerlIO *); +PERL_CALLCONV STDCHAR * Perl_PerlIO_get_ptr(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *); +PERL_CALLCONV int Perl_PerlIO_get_cnt(pTHX_ PerlIO *); + +PERL_CALLCONV PerlIO * Perl_PerlIO_stdin(pTHX); +PERL_CALLCONV PerlIO * Perl_PerlIO_stdout(pTHX); +PERL_CALLCONV PerlIO * Perl_PerlIO_stderr(pTHX); +#endif /* PERLIO_LAYERS */ #if defined(USE_PERLIO) && !defined(USE_SFIO) @@ -3017,6 +3017,8 @@ tryagain: case '\\': switch (*++p) { case 'A': + case 'C': + case 'X': case 'G': case 'Z': case 'z': @@ -3129,7 +3131,7 @@ tryagain: if (RExC_flags16 & PMf_EXTENDED) p = regwhite(p, RExC_end); if (UTF && FOLD) { - toLOWER_uni(ender, tmpbuf, &ulen); + toFOLD_uni(ender, tmpbuf, &ulen); ender = utf8_to_uvchr(tmpbuf, 0); } if (ISMULT2(p)) { /* Back off on ?+*. */ @@ -3178,20 +3180,26 @@ tryagain: break; } - if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT && !RExC_utf8) { + if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) { STRLEN oldlen = STR_LEN(ret); SV *sv = sv_2mortal(newSVpvn(STRING(ret), oldlen)); - char *s = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); - STRLEN newlen = SvCUR(sv); - if (!SIZE_ONLY) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n", - (int)oldlen, STRING(ret), (int)newlen, s)); - Copy(s, STRING(ret), newlen, char); - STR_LEN(ret) += newlen - oldlen; - RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen); - } else - RExC_size += STR_SZ(newlen) - STR_SZ(oldlen); - RExC_utf8 = 1; + + if (RExC_utf8) + SvUTF8_on(sv); + if (sv_utf8_downgrade(sv, TRUE)) { + char *s = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); + STRLEN newlen = SvCUR(sv); + + if (!SIZE_ONLY) { + DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n", + (int)oldlen, STRING(ret), + (int)newlen, s)); + Copy(s, STRING(ret), newlen, char); + STR_LEN(ret) += newlen - oldlen; + RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen); + } else + RExC_size += STR_SZ(newlen) - STR_SZ(oldlen); + } } return(ret); @@ -3973,9 +3981,21 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state) if (prevvalue < value) Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n", (UV)prevvalue, (UV)value); - else if (prevvalue == value) + else if (prevvalue == value) { Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", (UV)value); + if (FOLD) { + if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) { + Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", + (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA); + Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", + (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA); + } + else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA) + Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", + (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA); + } + } } } @@ -393,11 +393,22 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, SV *dsv = PERL_DEBUG_PAD_ZERO(0); #endif + if (prog->reganch & ROPT_UTF8) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "UTF-8 regex...\n")); + PL_reg_flags |= RF_utf8; + } + DEBUG_r({ - char*s = UTF ? sv_uni_display(dsv, sv, 60, 0) : strpos; - int len = UTF ? strlen(s) : strend - strpos; + char *s = PL_reg_match_utf8 ? + sv_uni_display(dsv, sv, 60, 0) : strpos; + int len = PL_reg_match_utf8 ? + strlen(s) : strend - strpos; if (!PL_colorset) reginitcolors(); + if (PL_reg_match_utf8) + DEBUG_r(PerlIO_printf(Perl_debug_log, + "UTF-8 target...\n")); PerlIO_printf(Perl_debug_log, "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n", PL_colors[4],PL_colors[5],PL_colors[0], @@ -411,9 +422,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ); }); - if (prog->reganch & ROPT_UTF8) - PL_reg_flags |= RF_utf8; - if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) { DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short... [re_intuit_start]\n")); @@ -967,27 +975,32 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta * Fortunately, not getting this right is allowed * for Unicode Regular Expression Support level 1, * only one-to-one matching is required. --jhi */ - if (c1 == c2) + if (c1 == c2) { while (s <= e) { if ( utf8_to_uvchr((U8*)s, &len) == c1 - && (ln == 1 || + && (ln == len || ibcmp_utf8(s, do_utf8, strend - s, m, UTF, ln)) && (norun || regtry(prog, s)) ) goto got_it; s += len; } - else + } + else { while (s <= e) { UV c = utf8_to_uvchr((U8*)s, &len); + if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA || + c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) + c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA; if ( (c == c1 || c == c2) - && (ln == 1 || + && (ln == len || ibcmp_utf8(s, do_utf8, strend - s, m, UTF, ln)) && (norun || regtry(prog, s)) ) goto got_it; s += len; } + } } else { if (c1 == c2) @@ -2232,10 +2245,10 @@ S_regmatch(pTHX_ regnode *prog) s = STRING(scan); ln = STR_LEN(scan); if (do_utf8 != (UTF!=0)) { - /* The target and the pattern have differing "utf8ness". */ + /* The target and the pattern have differing utf8ness. */ char *l = locinput; char *e = s + ln; - STRLEN len; + STRLEN ulen; if (do_utf8) { /* The target is utf8, the pattern is not utf8. */ @@ -2243,9 +2256,9 @@ S_regmatch(pTHX_ regnode *prog) if (l >= PL_regeol) sayNO; if (NATIVE_TO_UNI(*(U8*)s) != - utf8_to_uvchr((U8*)l, &len)) + utf8_to_uvchr((U8*)l, &ulen)) sayNO; - l += len; + l += ulen; s ++; } } @@ -2255,9 +2268,9 @@ S_regmatch(pTHX_ regnode *prog) if (l >= PL_regeol) sayNO; if (NATIVE_TO_UNI(*((U8*)l)) != - utf8_to_uvchr((U8*)s, &len)) + utf8_to_uvchr((U8*)s, &ulen)) sayNO; - s += len; + s += ulen; l ++; } } @@ -2265,7 +2278,7 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); break; } - /* The target and the pattern have the same "utf8ness". */ + /* The target and the pattern have the same utf8ness. */ /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchr) sayNO; @@ -2283,26 +2296,85 @@ S_regmatch(pTHX_ regnode *prog) s = STRING(scan); ln = STR_LEN(scan); - if (do_utf8) { + { char *l = locinput; - char *e; - STRLEN ulen; - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - e = s + ln; - while (s < e) { - if (l >= PL_regeol) - sayNO; - toLOWER_utf8((U8*)l, tmpbuf, &ulen); - if (memNE(s, (char*)tmpbuf, ulen)) - sayNO; - s += UTF8SKIP(s); - l += ulen; + char *e = s + ln; + U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; + + if (do_utf8 != (UTF!=0)) { + /* The target and the pattern have differing utf8ness. */ + STRLEN ulen1, ulen2; + UV cs, cl; + + if (do_utf8) { + /* The target is utf8, the pattern is not utf8. */ + while (s < e) { + if (l >= PL_regeol) + sayNO; + + cs = to_uni_fold(NATIVE_TO_UNI(*(U8*)s), + (U8*)s, &ulen1); + cl = utf8_to_uvchr((U8*)l, &ulen2); + + if (cs != cl) { + cl = to_uni_fold(cl, (U8*)l, &ulen2); + if (ulen1 != ulen2 || cs != cl) + sayNO; + } + l += ulen1; + s ++; + } + } + else { + /* The target is not utf8, the pattern is utf8. */ + while (s < e) { + if (l >= PL_regeol) + sayNO; + + cs = utf8_to_uvchr((U8*)s, &ulen1); + + cl = to_uni_fold(NATIVE_TO_UNI(*(U8*)l), + (U8*)l, &ulen2); + + if (cs != cl) { + cs = to_uni_fold(cs, (U8*)s, &ulen1); + if (ulen1 != ulen2 || cs != cl) + sayNO; + } + l ++; + s += ulen1; + } + } + locinput = l; + nextchr = UCHARAT(locinput); + break; + } + + if (do_utf8 && UTF) { + /* Both the target and the pattern are utf8. */ + STRLEN ulen; + + while (s < e) { + if (l >= PL_regeol) + sayNO; + if (UTF8SKIP(s) != UTF8SKIP(l) || + memNE(s, (char*)l, UTF8SKIP(s))) { + to_utf8_fold((U8*)l, tmpbuf, &ulen); + if (UTF8SKIP(s) != ulen || + memNE(s, (char*)tmpbuf, ulen)) + sayNO; + } + l += UTF8SKIP(l); + s += UTF8SKIP(s); + } + locinput = l; + nextchr = UCHARAT(locinput); + break; } - locinput = l; - nextchr = UCHARAT(locinput); - break; } + /* Neither the target and the pattern are utf8. */ + /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchr && UCHARAT(s) != ((OP(scan) == EXACTF) @@ -2524,16 +2596,21 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(++locinput); break; case CLUMP: - LOAD_UTF8_CHARCLASS(mark,"~"); - if (locinput >= PL_regeol || - swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) - sayNO; - locinput += PL_utf8skip[nextchr]; - while (locinput < PL_regeol && - swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) - locinput += UTF8SKIP(locinput); - if (locinput > PL_regeol) + if (locinput >= PL_regeol) sayNO; + if (do_utf8) { + LOAD_UTF8_CHARCLASS(mark,"~"); + if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) + sayNO; + locinput += PL_utf8skip[nextchr]; + while (locinput < PL_regeol && + swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) + locinput += UTF8SKIP(locinput); + if (locinput > PL_regeol) + sayNO; + } + else + locinput++; nextchr = UCHARAT(locinput); break; case REFFL: diff --git a/t/op/eval.t b/t/op/eval.t index 42a71e2593..17b8d9d689 100755 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -1,6 +1,6 @@ #!./perl -print "1..41\n"; +print "1..45\n"; eval 'print "ok 1\n";'; @@ -221,3 +221,16 @@ print $@; }; print "not ok 41\n" if $@; } + +# Make sure that "my $$x" is forbidden +# 20011224 MJD +{ + eval q{my $$x}; + print $@ ? "ok 42\n" : "not ok 42\n"; + eval q{my @$x}; + print $@ ? "ok 43\n" : "not ok 43\n"; + eval q{my %$x}; + print $@ ? "ok 44\n" : "not ok 44\n"; + eval q{my $$$x}; + print $@ ? "ok 45\n" : "not ok 45\n"; +} diff --git a/t/op/pat.t b/t/op/pat.t index e4556ee1e7..0eda689cc5 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -6,7 +6,7 @@ $| = 1; -print "1..770\n"; +print "1..825\n"; BEGIN { chdir 't' if -d 't'; @@ -2290,6 +2290,55 @@ print "# some Unicode properties\n"; print "not " unless "A\x{100}" =~ /A/i; print "ok 757\n"; + + print "not " unless "\x{101}a" =~ /\x{100}/i; + print "ok 758\n"; + + print "not " unless "\x{100}a" =~ /\x{100}/i; + print "ok 759\n"; + + print "not " unless "\x{101}a" =~ /\x{101}/i; + print "ok 760\n"; + + print "not " unless "\x{100}a" =~ /\x{101}/i; + print "ok 761\n"; + + print "not " unless "a\x{100}" =~ /A\x{100}/i; + print "ok 762\n"; + + print "not " unless "A\x{100}" =~ /A\x{100}/i; + print "ok 763\n"; + + print "not " unless "a\x{100}" =~ /a\x{100}/i; + print "ok 764\n"; + + print "not " unless "A\x{100}" =~ /A\x{100}/i; + print "ok 765\n"; + + print "not " unless "a\x{100}" =~ /[A]/i; + print "ok 766\n"; + + print "not " unless "A\x{100}" =~ /[A]/i; + print "ok 767\n"; + + print "not " unless "a\x{100}" =~ /[a]/i; + print "ok 768\n"; + + print "not " unless "A\x{100}" =~ /[A]/i; + print "ok 769\n"; + + print "not " unless "\x{101}a" =~ /[\x{100}]/i; + print "ok 770\n"; + + print "not " unless "\x{100}a" =~ /[\x{100}]/i; + print "ok 771\n"; + + print "not " unless "\x{101}a" =~ /[\x{101}]/i; + print "ok 772\n"; + + print "not " unless "\x{100}a" =~ /[\x{101}]/i; + print "ok 773\n"; + } { @@ -2299,30 +2348,29 @@ print "# some Unicode properties\n"; my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}"; my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}"; - print $lower =~ m/$UPPER/i ? "ok 758\n" : "not ok 758\n"; - print $UPPER =~ m/$lower/i ? "ok 759\n" : "not ok 759\n"; - print $lower =~ m/[$UPPER]/i ? "ok 760\n" : "not ok 760\n"; - print $UPPER =~ m/[$lower]/i ? "ok 761\n" : "not ok 761\n"; + print $lower =~ m/$UPPER/i ? "ok 774\n" : "not ok 774\n"; + print $UPPER =~ m/$lower/i ? "ok 775\n" : "not ok 775\n"; + print $lower =~ m/[$UPPER]/i ? "ok 776\n" : "not ok 776\n"; + print $UPPER =~ m/[$lower]/i ? "ok 777\n" : "not ok 777\n"; print "# GREEK LETTER ALPHA WITH VRACHY\n"; $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}"; $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}"; - print $lower =~ m/$UPPER/i ? "ok 762\n" : "not ok 762\n"; - print $UPPER =~ m/$lower/i ? "ok 763\n" : "not ok 763\n"; - print $lower =~ m/[$UPPER]/i ? "ok 764\n" : "not ok 764\n"; - print $UPPER =~ m/[$lower]/i ? "ok 765\n" : "not ok 765\n"; + print $lower =~ m/$UPPER/i ? "ok 778\n" : "not ok 778\n"; + print $UPPER =~ m/$lower/i ? "ok 779\n" : "not ok 779\n"; + print $lower =~ m/[$UPPER]/i ? "ok 780\n" : "not ok 780\n"; + print $UPPER =~ m/[$lower]/i ? "ok 781\n" : "not ok 781\n"; print "# LATIN LETTER Y WITH DIAERESIS\n"; $lower = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}"; $UPPER = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"; - - print $lower =~ m/$UPPER/i ? "ok 766\n" : "not ok 766\n"; - print $UPPER =~ m/$lower/i ? "ok 767\n" : "not ok 767\n"; - print $lower =~ m/[$UPPER]/i ? "ok 768\n" : "not ok 768\n"; - print $UPPER =~ m/[$lower]/i ? "ok 769\n" : "not ok 769\n"; + print $lower =~ m/$UPPER/i ? "ok 782\n" : "not ok 782\n"; + print $UPPER =~ m/$lower/i ? "ok 783\n" : "not ok 783\n"; + print $lower =~ m/[$UPPER]/i ? "ok 784\n" : "not ok 784\n"; + print $UPPER =~ m/[$lower]/i ? "ok 785\n" : "not ok 785\n"; } { @@ -2338,6 +2386,137 @@ print "# some Unicode properties\n"; my $char = "\N{COMBINING GREEK PERISPOMENI}"; my $code = sprintf "%04x", ord($char); - # Before #13843 this was failing. - print "_:$char:_" =~ m/_:$SIGMA:_/i ? "not ok 770\n" : "ok 770\n"; + # Before #13843 this was failing by matching falsely. + print "_:$char:_" =~ m/_:$SIGMA:_/i ? "not ok 786\n" : "ok 786\n"; +} + +{ + print "# \\X\n"; + + use charnames ':full'; + + print "a!" =~ /^(\X)!/ && $1 eq "a" ? + "ok 787\n" : "not ok 787 # $1\n"; + print "\xDF!" =~ /^(\X)!/ && $1 eq "\xDF" ? + "ok 788\n" : "not ok 788 # $1\n"; + print "\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}" ? + "ok 789\n" : "not ok 789 # $1\n"; + print "\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}" ? + "ok 790\n" : "not ok 790 # $1\n"; + print "\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ && + $1 eq "\N{LATIN CAPITAL LETTER E}" ? + "ok 791\n" : "not ok 791 # $1\n"; + print "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!" =~ + /^(\X)!/ && + $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}" ? + "ok 792\n" : "not ok 792 # $1\n"; +} + +{ + print "#\\C and \\X\n"; + + print "!abc!" =~ /a\Cc/ ? "ok 793\n" : "not ok 793\n"; + print "!abc!" =~ /a\Xc/ ? "ok 794\n" : "not ok 794\n"; +} + +{ + print "# FINAL SIGMA\n"; + + my $SIGMA = "\x{03A3}"; # CAPITAL + my $Sigma = "\x{03C2}"; # SMALL FINAL + my $sigma = "\x{03C3}"; # SMALL + + print $SIGMA =~ /$SIGMA/i ? "ok 795\n" : "not ok 795\n"; + print $SIGMA =~ /$Sigma/i ? "ok 796\n" : "not ok 796\n"; + print $SIGMA =~ /$sigma/i ? "ok 797\n" : "not ok 797\n"; + + print $Sigma =~ /$SIGMA/i ? "ok 798\n" : "not ok 798\n"; + print $Sigma =~ /$Sigma/i ? "ok 799\n" : "not ok 799\n"; + print $Sigma =~ /$sigma/i ? "ok 800\n" : "not ok 800\n"; + + print $sigma =~ /$SIGMA/i ? "ok 801\n" : "not ok 801\n"; + print $sigma =~ /$Sigma/i ? "ok 802\n" : "not ok 802\n"; + print $sigma =~ /$sigma/i ? "ok 803\n" : "not ok 803\n"; + + print $SIGMA =~ /[$SIGMA]/i ? "ok 804\n" : "not ok 804\n"; + print $SIGMA =~ /[$Sigma]/i ? "ok 805\n" : "not ok 805\n"; + print $SIGMA =~ /[$sigma]/i ? "ok 806\n" : "not ok 806\n"; + + print $Sigma =~ /[$SIGMA]/i ? "ok 807\n" : "not ok 807\n"; + print $Sigma =~ /[$Sigma]/i ? "ok 808\n" : "not ok 808\n"; + print $Sigma =~ /[$sigma]/i ? "ok 809\n" : "not ok 809\n"; + + print $sigma =~ /[$SIGMA]/i ? "ok 810\n" : "not ok 810\n"; + print $sigma =~ /[$Sigma]/i ? "ok 811\n" : "not ok 811\n"; + print $sigma =~ /[$sigma]/i ? "ok 812\n" : "not ok 812\n"; +} + +{ + print "# parlez-vous?\n"; + + use charnames ':full'; + + print "fran\N{LATIN SMALL LETTER C}ais" =~ + /fran.ais/ && + $& eq "francais" ? + "ok 813\n" : "not ok 813\n"; + + print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ + /fran.ais/ && + $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? + "ok 814\n" : "not ok 814\n"; + + print "fran\N{LATIN SMALL LETTER C}ais" =~ + /fran\Cais/ && + $& eq "francais" ? + "ok 815\n" : "not ok 815\n"; + + print "franc\N{COMBINING CEDILLA}ais" =~ + /franc\C\Cais/ ? # COMBINING CEDILLA is two bytes when encoded + "ok 816\n" : "not ok 816\n"; + + print "fran\N{LATIN SMALL LETTER C}ais" =~ + /fran\Xais/ && + $& eq "francais" ? + "ok 817\n" : "not ok 817\n"; + + print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ + /fran\Xais/ && + $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? + "ok 818\n" : "not ok 818\n"; + + print "franc\N{COMBINING CEDILLA}ais" =~ + /fran\Xais/ && + $& eq "franc\N{COMBINING CEDILLA}ais" ? + "ok 819\n" : "not ok 819\n"; + + print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ + /fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ && + $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? + "ok 820\n" : "not ok 820\n"; + + print "franc\N{COMBINING CEDILLA}ais" =~ + /franc\N{COMBINING CEDILLA}ais/ && + $& eq "franc\N{COMBINING CEDILLA}ais" ? + "ok 821\n" : "not ok 821\n"; + + print "fran\N{LATIN SMALL LETTER C}ais" =~ + /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && + $& eq "francais" ? + "ok 822\n" : "not ok 822\n"; + + print "fran\N{LATIN SMALL LETTER C}ais" =~ + /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && + $& eq "francais" ? + "ok 823\n" : "not ok 823\n"; + + print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ + /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && + $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? + "ok 824\n" : "not ok 824\n"; + + print "franc\N{COMBINING CEDILLA}ais" =~ + /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && + $& eq "franc\N{COMBINING CEDILLA}ais" ? + "ok 825\n" : "not ok 825\n"; } diff --git a/t/op/stat.t b/t/op/stat.t index 57460fcfd1..2f18382fa8 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -215,6 +215,11 @@ SKIP: { $DEV =~ s{^[cp].+?\sstdout$}{}m; @DEV = grep { $_ ne 'stdout' } @DEV; + # /dev/printer is also naughty: in IRIX it shows up as + # Srwx-----, not srwx------. + $DEV =~ s{^.+?\sprinter$}{}m; + @DEV = grep { $_ ne 'printer' } @DEV; + # If running as root, we will see .files in the ls result, # and readdir() will see them always. Potential for conflict, # so let's weed them out. @@ -13,9 +13,26 @@ Perl_taint_proper(pTHX_ const char *f, const char *s) { char *ug; -#ifdef HAS_SETEUID - DEBUG_u(PerlIO_printf(Perl_debug_log, - "%s %d %"Uid_t_f" %"Uid_t_f"\n", s, PL_tainted, (Uid_t)PL_uid, (Uid_t)PL_euid)); +#if defined(HAS_SETEUID) && defined(DEBUGGING) +# if Uid_t_size == 1 + { + UV uid = PL_uid; + UV euid = PL_euid; + + DEBUG_u(PerlIO_printf(Perl_debug_log, + "%s %d %"UVuf" %"UVuf"\n", + s, PL_tainted, uid, euid)); + } +# else + { + IV uid = PL_uid; + IV euid = PL_euid; + + DEBUG_u(PerlIO_printf(Perl_debug_log, + "%s %d %"IVdf" %"IVdf"\n", + s, PL_tainted, uid, euid)); + } +# endif #endif if (PL_tainted) { @@ -188,3 +188,8 @@ END_EXTERN_C #endif #define UTF8_IS_ASCII(c) UTF8_IS_INVARIANT(c) + +#define UNICODE_GREEK_CAPITAL_LETTER_SIGMA 0x03A3 +#define UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA 0x03C2 +#define UNICODE_GREEK_SMALL_LETTER_SIGMA 0x03C3 + @@ -948,6 +948,25 @@ Perl_form_nocontext(const char* pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=for apidoc form + +Takes a sprintf-style format pattern and conventional +(non-SV) arguments and returns the formatted string. + + (char *) Perl_form(pTHX_ const char* pat, ...) + +can be used any place a string (char *) is required: + + char * s = Perl_form("%d.%d",major,minor); + +Uses a single private buffer so if you want to format several strings you +must explicitly copy the earlier strings away (and free the copies when you +are done). + +=cut +*/ + char * Perl_form(pTHX_ const char* pat, ...) { @@ -3967,4 +3986,229 @@ Perl_new_vstring(pTHX_ char *s, SV *sv) return s; } +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) +static int +S_socketpair_udp (int fd[2]) { + /* Fake a datagram socketpair using UDP to localhost. */ + int sockets[2] = {-1, -1}; + struct sockaddr_in addresses[2]; + int i; + Sock_size_t size = sizeof (struct sockaddr_in); + unsigned short port; + int got; + + memset (&addresses, 0, sizeof (addresses)); + i = 1; + do { + sockets[i] = socket (AF_INET, SOCK_DGRAM, 0); + if (sockets[i] == -1) + goto tidy_up_and_fail; + + addresses[i].sin_family = AF_INET; + addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK); + addresses[i].sin_port = 0; /* kernel choses port. */ + if (bind (sockets[i], (struct sockaddr *) &addresses[i], + sizeof (struct sockaddr_in)) + == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now have 2 UDP sockets. Find out which port each is connected to, and + for each connect the other socket to it. */ + i = 1; + do { + if (getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size) + == -1) + goto tidy_up_and_fail; + if (size != sizeof (struct sockaddr_in)) + goto abort_tidy_up_and_fail; + /* !1 is 0, !0 is 1 */ + if (connect(sockets[!i], (struct sockaddr *) &addresses[i], + sizeof (struct sockaddr_in)) == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now we have 2 sockets connected to each other. I don't trust some other + process not to have already sent a packet to us (by random) so send + a packet from each to the other. */ + i = 1; + do { + /* I'm going to send my own port number. As a short. + (Who knows if someone somewhere has sin_port as a bitfield and needs + this routine. (I'm assuming crays have socketpair)) */ + port = addresses[i].sin_port; + got = write (sockets[i], &port, sizeof(port)); + if (got != sizeof(port)) { + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } while (i--); + + /* Packets sent. I don't trust them to have arrived though. + (As I understand it Solaris TCP stack is multithreaded. Non-blocking + connect to localhost will use a second kernel thread. In 2.6 the + first thread running the connect() returns before the second completes, + so EINPROGRESS> In 2.7 the improved stack is faster and connect() + returns 0. Poor programs have tripped up. One poor program's authors' + had a 50-1 reverse stock split. Not sure how connected these were.) + So I don't trust someone not to have an unpredictable UDP stack. + */ + + { + struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ + int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; + fd_set rset; + + FD_ZERO (&rset); + FD_SET (sockets[0], &rset); + FD_SET (sockets[1], &rset); + + got = select (max + 1, &rset, NULL, NULL, &waitfor); + if (got != 2 || !FD_ISSET (sockets[0], &rset) + || !FD_ISSET (sockets[1], &rset)) { + /* I hope this is portable and appropriate. */ + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } + + /* And the paranoia department even now doesn't trust it to have arrive + (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ + { + struct sockaddr_in readfrom; + unsigned short buffer[2]; + + i = 1; + do { + got = recvfrom (sockets[i], (char *) &buffer, sizeof(buffer), +#ifdef MSG_DONTWAIT + MSG_DONTWAIT, +#else + 0, +#endif + (struct sockaddr *) &readfrom, &size); + + if (got == -1) + goto tidy_up_and_fail; + if (got != sizeof(port) + || size != sizeof (struct sockaddr_in) + /* Check other socket sent us its port. */ + || buffer[0] != (unsigned short) addresses[!i].sin_port + /* Check kernel says we got the datagram from that socket. */ + || readfrom.sin_family != addresses[!i].sin_family + || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr + || readfrom.sin_port != addresses[!i].sin_port) + goto abort_tidy_up_and_fail; + } while (i--); + } + /* My caller (my_socketpair) has validated that this is non-NULL */ + fd[0] = sockets[0]; + fd[1] = sockets[1]; + /* I hereby declare this connection open. May God bless all who cross + her. */ + return 0; + + abort_tidy_up_and_fail: + errno = ECONNABORTED; + tidy_up_and_fail: + { + int save_errno = errno; + if (sockets[0] != -1) + close (sockets[0]); + if (sockets[1] != -1) + close (sockets[1]); + errno = save_errno; + return -1; + } +} + +int +Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { + /* Stevens says that family must be AF_LOCAL, protocol 0. + I'm going to enforce that, then ignore it, and use TCP. */ + int listener = -1; + int connector = -1; + int acceptor = -1; + struct sockaddr_in listen_addr; + struct sockaddr_in connect_addr; + Sock_size_t size; + + if (protocol +#ifdef AF_UNIX + || family != AF_UNIX +#endif + ) { + errno = EAFNOSUPPORT; + return -1; + } + if (!fd) + return EINVAL; + + if (type == SOCK_DGRAM) + return S_socketpair_udp (fd); + + listener = socket (AF_INET, type, 0); + if (listener == -1) + return -1; + memset (&listen_addr, 0, sizeof (listen_addr)); + listen_addr.sin_family = AF_INET; + listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK); + listen_addr.sin_port = 0; /* kernel choses port. */ + if (bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr)) + == -1) + goto tidy_up_and_fail; + if (listen(listener, 1) == -1) + goto tidy_up_and_fail; + + connector = socket (AF_INET, type, 0); + if (connector == -1) + goto tidy_up_and_fail; + /* We want to find out the port number to connect to. */ + size = sizeof (connect_addr); + if (getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof (connect_addr)) + goto abort_tidy_up_and_fail; + if (connect(connector, (struct sockaddr *) &connect_addr, + sizeof (connect_addr)) == -1) + goto tidy_up_and_fail; + + size = sizeof (listen_addr); + acceptor = accept (listener, (struct sockaddr *) &listen_addr, &size); + if (acceptor == -1) + goto tidy_up_and_fail; + if (size != sizeof (listen_addr)) + goto abort_tidy_up_and_fail; + close (listener); + /* Now check we are talking to ourself by matching port and host on the + two sockets. */ + if (getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof (connect_addr) + || listen_addr.sin_family != connect_addr.sin_family + || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr + || listen_addr.sin_port != connect_addr.sin_port) { + goto abort_tidy_up_and_fail; + } + fd[0] = connector; + fd[1] = acceptor; + return 0; + abort_tidy_up_and_fail: + errno = ECONNABORTED; /* I hope this is portable and appropriate. */ + tidy_up_and_fail: + { + int save_errno = errno; + if (listener != -1) + close (listener); + if (connector != -1) + close (connector); + if (acceptor != -1) + close (acceptor); + errno = save_errno; + return -1; + } +} +#endif /* !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) */ |