From: Nick Ing-Simmons Date: Thu, 20 Dec 2001 08:20:11 +0000 (+0000) Subject: Integrate mainline (mostly) utf8.c does not compile. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c798bd2165d7b5d59c62ab6330f7cf77ff8b09dd;hp=f62ce20a4126b1e303e2d4d0a5c1e049ef2cb0c2;p=p5sagit%2Fp5-mst-13.2.git Integrate mainline (mostly) utf8.c does not compile. p4raw-id: //depot/perlio@13814 --- diff --git a/Changes b/Changes index 2bd9be1..b885220 100644 --- a/Changes +++ b/Changes @@ -31,6 +31,307 @@ or any other branch. Version v5.7.2 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 13810] By: jhi on 2001/12/19 16:50:12 + Log: Subject: Re: [BUG] bleadperl regexp (was ok in 5.6.0) + From: Wolfgang Laun + Date: Wed, 19 Dec 2001 12:35:07 +0100 + Message-ID: <3C207B6B.A687A8EC@alcatel.at> + + Subject: Re: [BUG] bleadperl regexp (was ok in 5.6.0) + From: Hugo van der Sanden + Date: Wed, 19 Dec 2001 17:34:51 +0000 + Message-Id: <200112191734.fBJHYpd30715@crypt.compulink.co.uk> + Branch: perl + ! pod/perlre.pod +____________________________________________________________________________ +[ 13809] By: jhi on 2001/12/19 16:47:11 + Log: Integrate perlio. + Branch: perl + !> ext/Encode/Encode.xs ext/PerlIO/Scalar/Scalar.xs + !> ext/PerlIO/Via/Via.xs perlio.c perliol.h +____________________________________________________________________________ +[ 13807] By: jhi on 2001/12/19 15:59:02 + Log: One more embedded (?sx) de-embedded, from Wolfgang Laun. + Branch: perl + ! ext/B/B/Assembler.pm +____________________________________________________________________________ +[ 13806] By: jhi on 2001/12/19 15:08:29 + Log: Reword the alarm explanation. + Branch: perl + ! pod/perlfunc.pod +____________________________________________________________________________ +[ 13805] By: jhi on 2001/12/19 15:04:03 + Log: Subject: [PATCH @13746] OS/2 build + From: Ilya Zakharevich + Date: Wed, 19 Dec 2001 02:45:41 -0500 + Message-ID: <20011219024541.A29803@math.ohio-state.edu> + + (skipped the t/TEST change) + Branch: perl + ! lib/English.t lib/ExtUtils/t/Embed.t lib/File/stat.t + ! lib/Shell.t os2/Makefile.SHs os2/OS2/REXX/DLL/Makefile.PL + ! os2/os2.c os2/perlrexx.c t/op/alarm.t util.c +____________________________________________________________________________ +[ 13804] By: jhi on 2001/12/19 14:55:26 + Log: Upgrade to Net::Ping 2.09. + Branch: perl + + lib/Net/Ping/CHANGES lib/Net/Ping/README + + lib/Net/Ping/t/100_load.t lib/Net/Ping/t/110_icmp_inst.t + + lib/Net/Ping/t/120_udp_inst.t lib/Net/Ping/t/130_tcp_inst.t + + lib/Net/Ping/t/140_stream_inst.t lib/Net/Ping/t/200_ping_tcp.t + + lib/Net/Ping/t/300_ping_stream.t + ! MANIFEST lib/Net/Ping.pm +____________________________________________________________________________ +[ 13802] By: jhi on 2001/12/19 14:25:27 + Log: B::Assembler/B::Disassembler patches and test; + from Wolfgang Laun. + + TODO: getting perlcc working. + Branch: perl + + ext/B/t/assembler.t + ! MANIFEST ext/B/B/Assembler.pm ext/B/B/Disassembler.pm +____________________________________________________________________________ +[ 13801] By: jhi on 2001/12/19 14:18:10 + Log: Can't printf U8s as UVs. + Branch: perl + ! utf8.c +____________________________________________________________________________ +[ 13800] By: jhi on 2001/12/19 14:12:02 + Log: Subject: Re: [PATCH] ...while $var = glob(...) + From: Robin Houston + Date: Wed, 19 Dec 2001 13:48:55 +0000 + Message-ID: <20011219134855.A20452@puffinry.freeserve.co.uk> + + Not exactly a glob test but internal-logically correct. + Branch: perl + ! t/op/glob.t +____________________________________________________________________________ +[ 13799] By: jhi on 2001/12/19 13:51:37 + Log: Subject: [PATCH lib/lib_pm.PL lib/lib.t] portability snag + From: Michael G Schwern + Date: Wed, 19 Dec 2001 07:42:54 -0500 + Message-ID: <20011219124254.GF8630@blackrider> + Branch: perl + + lib/lib.t + ! MANIFEST lib/lib_pm.PL +____________________________________________________________________________ +[ 13798] By: jhi on 2001/12/19 13:35:59 + Log: Integrate with perlio. + Branch: perl + !> hv.c hv.h scope.c util.c +____________________________________________________________________________ +[ 13793] By: jhi on 2001/12/19 04:58:51 + Log: Regen toc. + Branch: perl + ! pod/perltoc.pod +____________________________________________________________________________ +[ 13792] By: jhi on 2001/12/19 04:56:42 + Log: FAQ sync. + Branch: perl + ! pod/perlfaq5.pod +____________________________________________________________________________ +[ 13791] By: jhi on 2001/12/19 04:38:47 + Log: Reformat round. + Branch: perl + ! pod/perlunicode.pod +____________________________________________________________________________ +[ 13790] By: jhi on 2001/12/19 04:32:06 + Log: Subject: [PATCH] pod/perlunicode.pod + From: Jeffrey Friedl + Date: Tue, 18 Dec 2001 21:31:13 -0800 (PST) + Message-Id: <200112190531.fBJ5VDp57308@ventrue.corp.yahoo.com> + Branch: perl + ! pod/perlunicode.pod +____________________________________________________________________________ +[ 13789] By: jhi on 2001/12/19 04:16:39 + Log: Subject: Re: [PATCH] pod/perluniintro.pod (removes unnecessary UTF-8 references) + From: Jeffrey Friedl + Date: Tue, 18 Dec 2001 21:13:59 -0800 (PST) + Message-Id: <200112190513.fBJ5DxN56315@ventrue.corp.yahoo.com> + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 13788] By: jhi on 2001/12/19 03:54:08 + Log: Slight pod reformatting. + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 13787] By: jhi on 2001/12/19 03:41:45 + Log: Subject: [PATCH] pod/perluniintro.pod (removes unnecessary UTF-8 references) + From: Jeffrey Friedl + Date: Tue, 18 Dec 2001 20:27:42 -0800 (PST) + Message-Id: <200112190427.fBJ4RgP53458@ventrue.corp.yahoo.com> + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 13786] By: jhi on 2001/12/19 01:14:04 + Log: Subject: Re: [ID 20011213.001] Segfault with overload and Test + From: Hugo van der Sanden + Date: Wed, 19 Dec 2001 01:45:23 +0000 + Message-Id: <200112190145.fBJ1jNt23668@crypt.compulink.co.uk> + Branch: perl + ! sv.c +____________________________________________________________________________ +[ 13785] By: jhi on 2001/12/19 01:11:45 + Log: Subject: Porting/checkURL.pl + From: abigail@foad.org + Date: Tue, 18 Dec 2001 19:03:22 +0100 + Message-ID: <20011218180322.8278.qmail@foad.org> + Branch: perl + ! Porting/checkURL.pl +____________________________________________________________________________ +[ 13783] By: jhi on 2001/12/19 00:26:34 + Log: A bit too oversweeping matching in #13778. + Branch: perl + ! Configure +____________________________________________________________________________ +[ 13782] By: jhi on 2001/12/19 00:09:10 + Log: Re-gen Configure based on #13778..13781. + Branch: perl + ! Configure config_h.SH +____________________________________________________________________________ +[ 13767] By: jhi on 2001/12/18 22:13:14 + Log: Subject: Re: Benchmark.t failure on Linux + From: Nicholas Clark + Date: Tue, 18 Dec 2001 22:51:25 +0000 + Message-ID: <20011218225124.N21702@plum.flirble.org> + Branch: perl + ! lib/Benchmark.t +____________________________________________________________________________ +[ 13766] By: jhi on 2001/12/18 22:07:35 + Log: Re-applying #13752 until a better solution can be found. + Branch: perl + ! lib/ExtUtils/t/MM_Unix.t +____________________________________________________________________________ +[ 13765] By: jhi on 2001/12/18 21:05:13 + Log: Subject: [PATCH] Suggested doc enhancement(?) to Exporter.pm + From: "Giroux, Mike (Exchange)" + Date: Tue, 18 Dec 2001 12:05:40 -0500 + Message-ID: <03CF7D5B2CFFD211990300A0C95DEA0C080BEB5A@whmsx18.is.bear.com> + Branch: perl + ! lib/Exporter.pm +____________________________________________________________________________ +[ 13764] By: jhi on 2001/12/18 20:58:44 + Log: %g -> NVgf cleanup, based on Schwern's RedHat 7.1/Alpha + findings -- some of the warnings I can't explain except + by NVgf being detected wrong, though. + Branch: perl + ! dump.c pp.c sv.c x2p/a2p.h x2p/str.c +____________________________________________________________________________ +[ 13763] By: jhi on 2001/12/18 20:54:28 + Log: Subject: [PATCH] pod/perluniintro.pod + From: Jeffrey Friedl + Date: Tue, 18 Dec 2001 10:27:45 -0800 (PST) + Message-Id: <200112181827.fBIIRjv16547@ventrue.corp.yahoo.com> + Branch: perl + ! pod/perluniintro.pod +____________________________________________________________________________ +[ 13762] By: jhi on 2001/12/18 17:49:07 + Log: ".pm" is the native executable suffix in VOS. + Branch: perl + ! hints/vos.sh +____________________________________________________________________________ +[ 13761] By: jhi on 2001/12/18 15:57:39 + Log: Integrate perlio; + Tidied version of Jeffrey Friedl's restricted hashes + Branch: perl + !> ext/Devel/Peek/Peek.t hv.c hv.h scope.c sv.c t/lib/access.t +____________________________________________________________________________ +[ 13759] By: jhi on 2001/12/18 15:54:19 + Log: (Undone by #13766.) + Retract #13752. + Branch: perl + ! lib/ExtUtils/t/MM_Unix.t +____________________________________________________________________________ +[ 13758] By: jhi on 2001/12/18 15:26:18 + Log: Echoes of #13757. + Branch: perl + ! t/lib/warnings/utf8 +____________________________________________________________________________ +[ 13757] By: jhi on 2001/12/18 15:24:50 + Log: Make the utf8 malformedness messages more verbose. + Branch: perl + ! lib/utf8.t utf8.c +____________________________________________________________________________ +[ 13755] By: jhi on 2001/12/18 14:05:26 + Log: README.aix updates from Jens-Uwe Mager. + Branch: perl + ! README.aix +____________________________________________________________________________ +[ 13754] By: jhi on 2001/12/18 14:03:31 + Log: Subject: [PATCH lib/Benchmark.t] Show value of $fastslow on failure + From: Michael G Schwern + Date: Tue, 18 Dec 2001 00:58:18 -0500 + Message-ID: <20011218055818.GC4362@blackrider> + Branch: perl + ! lib/Benchmark.t +____________________________________________________________________________ +[ 13753] By: jhi on 2001/12/18 14:02:49 + Log: Subject: [PATCH lib/ExtUtils/t/Installed.t] Making it somewhat more portable + From: Michael G Schwern + Date: Tue, 18 Dec 2001 00:40:38 -0500 + Message-ID: <20011218054038.GB4362@blackrider> + Branch: perl + ! lib/ExtUtils/Installed.pm lib/ExtUtils/t/Installed.t +____________________________________________________________________________ +[ 13752] By: jhi on 2001/12/18 14:01:44 + Log: (reintroduced by #13766) + (retracted by #13759) + + Subject: [PATCH lib/ExtUtils/t/MM_Unix.t] All the world's not a Unix + From: Michael G Schwern + Date: Tue, 18 Dec 2001 00:00:23 -0500 + Message-ID: <20011218050023.GA27893@blackrider> + Branch: perl + ! lib/ExtUtils/t/MM_Unix.t +____________________________________________________________________________ +[ 13751] By: jhi on 2001/12/18 13:59:32 + Log: Re-patch #13749. + Branch: perl + ! t/op/glob.t +____________________________________________________________________________ +[ 13750] By: jhi on 2001/12/18 13:56:34 + Log: Subject: [doc patch] s{(?<=perldeb)ug}{guts} + From: Hugo van der Sanden + Date: Tue, 18 Dec 2001 12:55:43 +0000 + Message-Id: <200112181255.fBICthb09977@crypt.compulink.co.uk> + Branch: perl + ! ext/Devel/Peek/Peek.pm +____________________________________________________________________________ +[ 13749] By: jhi on 2001/12/18 13:55:12 + Log: Subject: Third time lucky? (Re: [PATCH] ...while $var = glob(...)) + From: Robin Houston + Date: Tue, 18 Dec 2001 14:54:33 +0000 + Message-ID: <20011218145433.A18835@puffinry.freeserve.co.uk> + Branch: perl + ! t/op/glob.t +____________________________________________________________________________ +[ 13748] By: jhi on 2001/12/17 23:54:41 + Log: Subject: [PATCH] slightly more for Exporter.pm + From: Nicholas Clark + Date: Tue, 18 Dec 2001 00:22:03 +0000 + Message-ID: <20011218002203.M21702@plum.flirble.org> + Branch: perl + ! lib/Exporter.pm +____________________________________________________________________________ +[ 13747] By: jhi on 2001/12/17 21:59:07 + Log: Subject: [PATCH] Re: chomp/chop prototype changed? + From: Rafael Garcia-Suarez + Date: Mon, 17 Dec 2001 16:37:18 +0100 + Message-ID: <20011217163718.A2292@rafael> + + Subject: Re: [PATCH] Re: chomp/chop prototype changed? + From: Rafael Garcia-Suarez + Date: Mon, 17 Dec 2001 23:17:06 +0100 + Message-ID: <20011217231706.A730@rafael> + Branch: perl + ! pod/perlsub.pod pp.c toke.c +____________________________________________________________________________ +[ 13746] By: jhi on 2001/12/17 20:22:08 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 13745] By: jhi on 2001/12/17 20:12:37 Log: New test warrants a MANIFEST entry. Branch: perl diff --git a/MANIFEST b/MANIFEST index b320b65..0fa46a2 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1139,6 +1139,15 @@ lib/Net/netent.t See if Net::netent works lib/Net/Netrc.pm libnet lib/Net/NNTP.pm libnet lib/Net/Ping.pm Hello, anybody home? +lib/Net/Ping/CHANGES Net::Ping +lib/Net/Ping/README Net::Ping +lib/Net/Ping/t/100_load.t Ping Net::Ping +lib/Net/Ping/t/110_icmp_inst.t Ping Net::Ping +lib/Net/Ping/t/120_udp_inst.t Ping Net::Ping +lib/Net/Ping/t/130_tcp_inst.t Ping Net::Ping +lib/Net/Ping/t/140_stream_inst.t Ping Net::Ping +lib/Net/Ping/t/200_ping_tcp.t Ping Net::Ping +lib/Net/Ping/t/300_ping_stream.t Ping Net::Ping lib/Net/POP3.pm libnet lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/protoent.t See if Net::protoent works diff --git a/embed.h b/embed.h index ea261bf..a748737 100644 --- a/embed.h +++ b/embed.h @@ -273,6 +273,9 @@ #define invert Perl_invert #define is_gv_magical Perl_is_gv_magical #define is_lvalue_sub Perl_is_lvalue_sub +#define to_uni_upper_lc Perl_to_uni_upper_lc +#define to_uni_title_lc Perl_to_uni_title_lc +#define to_uni_lower_lc Perl_to_uni_lower_lc #define is_uni_alnum Perl_is_uni_alnum #define is_uni_alnumc Perl_is_uni_alnumc #define is_uni_idfirst Perl_is_uni_idfirst @@ -1794,6 +1797,9 @@ #define invert(a) Perl_invert(aTHX_ a) #define is_gv_magical(a,b,c) Perl_is_gv_magical(aTHX_ a,b,c) #define is_lvalue_sub() Perl_is_lvalue_sub(aTHX) +#define to_uni_upper_lc(a) Perl_to_uni_upper_lc(aTHX_ a) +#define to_uni_title_lc(a) Perl_to_uni_title_lc(aTHX_ a) +#define to_uni_lower_lc(a) Perl_to_uni_lower_lc(aTHX_ a) #define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a) #define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a) #define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a) diff --git a/embed.pl b/embed.pl index 91c2ac0..74fd9a5 100755 --- a/embed.pl +++ b/embed.pl @@ -1344,7 +1344,10 @@ Ap |char* |instr |const char* big|const char* little p |bool |io_close |IO* io|bool not_implicit p |OP* |invert |OP* cmd dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags -p |I32 |is_lvalue_sub +Ap |I32 |is_lvalue_sub +Ap |U32 |to_uni_upper_lc|U32 c +Ap |U32 |to_uni_title_lc|U32 c +Ap |U32 |to_uni_lower_lc|U32 c Ap |bool |is_uni_alnum |UV c Ap |bool |is_uni_alnumc |UV c Ap |bool |is_uni_idfirst |UV c diff --git a/embedvar.h b/embedvar.h index 47d608c..16c8e46 100644 --- a/embedvar.h +++ b/embedvar.h @@ -68,6 +68,7 @@ #define PL_maxscream (vTHX->Tmaxscream) #define PL_modcount (vTHX->Tmodcount) #define PL_na (vTHX->Tna) +#define PL_nrs (vTHX->Tnrs) #define PL_ofs_sv (vTHX->Tofs_sv) #define PL_op (vTHX->Top) #define PL_opsave (vTHX->Topsave) @@ -161,7 +162,6 @@ #define PL_tmps_stack (vTHX->Ttmps_stack) #define PL_top_env (vTHX->Ttop_env) #define PL_toptarget (vTHX->Ttoptarget) -#define PL_unused_1 (vTHX->Tunused_1) #define PL_watchaddr (vTHX->Twatchaddr) #define PL_watchok (vTHX->Twatchok) @@ -1095,6 +1095,7 @@ #define PL_maxscream (aTHX->Tmaxscream) #define PL_modcount (aTHX->Tmodcount) #define PL_na (aTHX->Tna) +#define PL_nrs (aTHX->Tnrs) #define PL_ofs_sv (aTHX->Tofs_sv) #define PL_op (aTHX->Top) #define PL_opsave (aTHX->Topsave) @@ -1188,7 +1189,6 @@ #define PL_tmps_stack (aTHX->Ttmps_stack) #define PL_top_env (aTHX->Ttop_env) #define PL_toptarget (aTHX->Ttoptarget) -#define PL_unused_1 (aTHX->Tunused_1) #define PL_watchaddr (aTHX->Twatchaddr) #define PL_watchok (aTHX->Twatchok) @@ -1234,6 +1234,7 @@ #define PL_Tmaxscream PL_maxscream #define PL_Tmodcount PL_modcount #define PL_Tna PL_na +#define PL_Tnrs PL_nrs #define PL_Tofs_sv PL_ofs_sv #define PL_Top PL_op #define PL_Topsave PL_opsave @@ -1327,7 +1328,6 @@ #define PL_Ttmps_stack PL_tmps_stack #define PL_Ttop_env PL_top_env #define PL_Ttoptarget PL_toptarget -#define PL_Tunused_1 PL_unused_1 #define PL_Twatchaddr PL_watchaddr #define PL_Twatchok PL_watchok diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm index 10ae81b..4db23f1 100644 --- a/ext/B/B/Assembler.pm +++ b/ext/B/B/Assembler.pm @@ -160,9 +160,8 @@ sub uncstring { sub strip_comments { my $stmt = shift; # Comments only allowed in instructions which don't take string arguments + # Treat string as a single line so .* eats \n characters. $stmt =~ s{ - (?sx) # Snazzy extended regexp coming up. Also, treat - # string as a single line so .* eats \n characters. ^\s* # Ignore leading whitespace ( [^"]* # A double quote '"' indicates a string argument. If we @@ -170,7 +169,7 @@ sub strip_comments { ) \s*\# # Any amount of whitespace plus the comment marker... .*$ # ...which carries on to end-of-string. - }{$1}; # Keep only the instruction and optional argument. + }{$1}sx; # Keep only the instruction and optional argument. return $stmt; } diff --git a/lib/English.t b/lib/English.t index 745d42e..6e11dcc 100755 --- a/lib/English.t +++ b/lib/English.t @@ -85,7 +85,7 @@ is( $PERL_VERSION, $^V, '$PERL_VERSION' ); is( $DEBUGGING, $^D, '$DEBUGGING' ); is( $WARNING, 0, '$WARNING' ); -like( $EXECUTABLE_NAME, qr/perl/, '$EXECUTABLE_NAME' ); +like( $EXECUTABLE_NAME, qr/perl/i, '$EXECUTABLE_NAME' ); is( $OSNAME, $Config{osname}, '$OSNAME' ); # may be non-portable diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t index 24b6a17..1f23909 100644 --- a/lib/ExtUtils/t/Embed.t +++ b/lib/ExtUtils/t/Embed.t @@ -16,7 +16,9 @@ $| = 1; print "1..9\n"; my $cc = $Config{'cc'}; my $cl = ($^O eq 'MSWin32' && $cc eq 'cl'); -my $exe = 'embed_test' . $Config{'exe_ext'}; +my $skip_exe = $^O eq 'os2' && $Config{ldflags} =~ /(?updir; my $lib = File::Spec->updir; @@ -70,6 +72,8 @@ if ($^O eq 'VMS') { local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /No library found for -lperl/ }; + push(@cmd, '-Zlinker', '/PM:VIO') # Otherwise puts a warning to STDOUT! + if $^O eq 'os2' and $Config{ldflags} =~ /(?dev, $stat[0], "device number in position 0" ); # On OS/2 (fake) ino is not constant, it is incremented each time SKIP: { - skip(1, 'inode number is not constant on OS/2') if $^O eq 'os2'; + skip('inode number is not constant on OS/2', 1) if $^O eq 'os2'; is( $stat->ino, $stat[1], "inode number in position 1" ); } diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index d78a14f..c3673b1 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,6 +1,6 @@ package Net::Ping; -# $Id: Ping.pm,v 1.11 2001/12/04 02:41:51 rob Exp $ +# $Id: Ping.pm,v 1.13 2001/12/07 02:18:44 rob Exp $ require 5.002; require Exporter; @@ -15,7 +15,7 @@ use Carp; @ISA = qw(Exporter); @EXPORT = qw(pingecho); -$VERSION = 2.07; +$VERSION = 2.09; # Constants @@ -371,7 +371,7 @@ sub tcp_connect $child = waitpid($pid, &POSIX::WNOHANG); $! = $? >> 8; $@ = $!; - sleep 1; + select(undef, undef, undef, 0.1); } while time < $patience && $child != $pid; if ($child == $pid) { @@ -595,7 +595,7 @@ __END__ Net::Ping - check a remote host for reachability -$Id: Ping.pm,v 1.11 2001/12/04 02:41:51 rob Exp $ +$Id: Ping.pm,v 1.13 2001/12/07 02:18:44 rob Exp $ =head1 SYNOPSIS diff --git a/lib/Net/Ping/CHANGES b/lib/Net/Ping/CHANGES new file mode 100644 index 0000000..fb327f1 --- /dev/null +++ b/lib/Net/Ping/CHANGES @@ -0,0 +1,40 @@ +CHANGES +------- + +2.09 Dec 06 19:00 2001 + - Documental and test changes only. + - No functional changes. + +2.08 Dec 04 13:00 2001 + - Faster response for Win32 tcp_connect. + - Better explanations in test comments. + +2.07 Nov 28 13:00 2001 + - Compatibility changes + - Works with UNIX and Win32 OS + - Works with Perl 5.005 5.6.x 5.7.x 5.8.x + - Applied several patches from distro + - External protocol added thanks to + colinm@cpan.org (Colin McMillen) + - Stream protocol added thanks to + bronson@trestle.com (Scott Bronson) + +2.06 Nov 19 12:00 2001 + - Added Net-Ping.spec for RPM to easily + utilize using "rpm -ta Net-Ping*tar.gz" + - Moved Copyright section to perldoc + +2.05 Nov 18 20:00 2001 + - Added test suite + +2.04 Nov 16 16:00 2001 + - Added CHANGES and README to tarball. + - No functional changes. + +2.03 Nov 15 12:00 2001 + - Portability adjustments to ping_tcp() + made by Rob Brown to work with most + default systems. + +2.02 Sep 27 12:00 1996 + - Magic version by Russell Mosemann from CPAN diff --git a/lib/Net/Ping/README b/lib/Net/Ping/README new file mode 100644 index 0000000..53b4dab --- /dev/null +++ b/lib/Net/Ping/README @@ -0,0 +1,195 @@ +NAME + Net::Ping - check a remote host for reachability + + $Id: Ping.pm,v 1.13 2001/12/07 02:18:44 rob Exp $ + +SYNOPSIS + use Net::Ping; + + $p = Net::Ping->new(); + print "$host is alive.\n" if $p->ping($host); + $p->close(); + + $p = Net::Ping->new("icmp"); + foreach $host (@host_array) + { + print "$host is "; + print "NOT " unless $p->ping($host, 2); + print "reachable.\n"; + sleep(1); + } + $p->close(); + + $p = Net::Ping->new("tcp", 2); + # Try connecting to the www port instead of the echo port + $p->{port_num} = getservbyname("http", "tcp"); + while ($stop_time > time()) + { + print "$host not reachable ", scalar(localtime()), "\n" + unless $p->ping($host); + sleep(300); + } + undef($p); + + # For backward compatibility + print "$host is alive.\n" if pingecho($host); + +DESCRIPTION + This module contains methods to test the reachability of remote hosts on + a network. A ping object is first created with optional parameters, a + variable number of hosts may be pinged multiple times and then the + connection is closed. + + You may choose one of four different protocols to use for the ping. The + "udp" protocol is the default. Note that a live remote host may still + fail to be pingable by one or more of these protocols. For example, + www.microsoft.com is generally alive but not pingable. + + With the "tcp" protocol the ping() method attempts to establish a + connection to the remote host's echo port. If the connection is + successfully established, the remote host is considered reachable. No + data is actually echoed. This protocol does not require any special + privileges but has higher overhead than the other two protocols. + + Specifying the "udp" protocol causes the ping() method to send a udp + packet to the remote host's echo port. If the echoed packet is received + from the remote host and the received packet contains the same data as + the packet that was sent, the remote host is considered reachable. This + protocol does not require any special privileges. It should be borne in + mind that, for a udp ping, a host will be reported as unreachable if it + is not running the appropriate echo service. For Unix-like systems see + the inetd(8) manpage for more information. + + If the "icmp" protocol is specified, the ping() method sends an icmp + echo message to the remote host, which is what the UNIX ping program + does. If the echoed message is received from the remote host and the + echoed information is correct, the remote host is considered reachable. + Specifying the "icmp" protocol requires that the program be run as root + or that the program be setuid to root. + + If the "external" protocol is specified, the ping() method attempts to + use the `Net::Ping::External' module to ping the remote host. + `Net::Ping::External' interfaces with your system's default `ping' + utility to perform the ping, and generally produces relatively accurate + results. If `Net::Ping::External' if not installed on your system, + specifying the "external" protocol will result in an error. + + Functions + + Net::Ping->new([$proto [, $def_timeout [, $bytes]]]); + Create a new ping object. All of the parameters are optional. $proto + specifies the protocol to use when doing a ping. The current choices + are "tcp", "udp" or "icmp". The default is "udp". + + If a default timeout ($def_timeout) in seconds is provided, it is + used when a timeout is not given to the ping() method (below). The + timeout must be greater than 0 and the default, if not specified, is + 5 seconds. + + If the number of data bytes ($bytes) is given, that many data bytes + are included in the ping packet sent to the remote host. The number + of data bytes is ignored if the protocol is "tcp". The minimum (and + 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. + + $p->ping($host [, $timeout]); + Ping the remote host and wait for a response. $host can be either + the hostname or the IP number of the remote host. The optional + timeout must be greater than 0 seconds and defaults to whatever was + specified when the ping object was created. If the hostname cannot + be found or there is a problem with the IP number, undef is + returned. Otherwise, 1 is returned if the host is reachable and 0 if + it is not. For all practical purposes, undef and 0 and can be + treated as the same case. + + $p->open($host); + When you are using the stream protocol, this call pre-opens the tcp + socket. It's only necessary to do this if you want to provide a + different timeout when creating the connection, or remove the + overhead of establishing the connection from the first ping. If you + don't call `open()', the connection is automatically opened the + first time `ping()' is called. This call simply does nothing if you + are using any protocol other than stream. + + $p->open($host); + When you are using the stream protocol, this call pre-opens the tcp + socket. It's only necessary to do this if you want to provide a + different timeout when creating the connection, or remove the + overhead of establishing the connection from the first ping. If you + don't call `open()', the connection is automatically opened the + first time `ping()' is called. This call simply does nothing if you + are using any protocol other than stream. + + $p->close(); + Close the network connection for this ping object. The network + connection is also closed by "undef $p". The network connection is + automatically closed if the ping object goes out of scope (e.g. $p + is local to a subroutine and you leave the subroutine). + + pingecho($host [, $timeout]); + To provide backward compatibility with the previous version of + Net::Ping, a pingecho() subroutine is available with the same + functionality as before. pingecho() uses the tcp protocol. The + return values and parameters are the same as described for the + ping() method. This subroutine is obsolete and may be removed in a + future version of Net::Ping. + +WARNING + pingecho() or a ping object with the tcp protocol use alarm() to + implement the timeout. So, don't use alarm() in your program while you + are using pingecho() or a ping object with the tcp protocol. The udp and + icmp protocols do not use alarm() to implement the timeout. + +NOTES + There will be less network overhead (and some efficiency in your + program) if you specify either the udp or the icmp protocol. The tcp + protocol will generate 2.5 times or more traffic for each ping than + either udp or icmp. If many hosts are pinged frequently, you may wish to + implement a small wait (e.g. 25ms or more) between each ping to avoid + flooding your network with packets. + + The icmp protocol requires that the program be run as root or that it be + setuid to root. The other protocols do not require special privileges, + but not all network devices implement tcp or udp echo. + + Local hosts should normally respond to pings within milliseconds. + However, on a very congested network it may take up to 3 seconds or + longer to receive an echo packet from the remote host. If the timeout is + set too low under these conditions, it will appear that the remote host + is not reachable (which is almost the truth). + + Reachability doesn't necessarily mean that the remote host is actually + functioning beyond its ability to echo packets. tcp is slightly better + at indicating the health of a system than icmp because it uses more of + the networking stack to respond. + + Because of a lack of anything better, this module uses its own 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. + +AUTHOR(S) + Current maintainer Net::Ping base code: + colinm@cpan.org (Colin McMillen) + + Stream protocol: + bronson@trestle.com (Scott Bronson) + + Original pingecho(): + karrer@bernina.ethz.ch (Andreas Karrer) + pmarquess@bfsec.bt.co.uk (Paul Marquess) + + Original Net::Ping author: + mose@ns.ccsn.edu (Russell Mosemann) + + Compatibility porting: + bbb@cpan.org (Rob Brown) + +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 modify it + under the same terms as Perl itself. + diff --git a/lib/Net/Ping/t/100_load.t b/lib/Net/Ping/t/100_load.t new file mode 100644 index 0000000..d6a71e0 --- /dev/null +++ b/lib/Net/Ping/t/100_load.t @@ -0,0 +1,19 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.t' + +######################### We start with some black magic to print on failure. + +use Test; +BEGIN { plan tests => 1; $loaded = 0} +END { ok $loaded;} + +# Just make sure everything compiles +use Net::Ping; + +$loaded = 1; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): diff --git a/lib/Net/Ping/t/110_icmp_inst.t b/lib/Net/Ping/t/110_icmp_inst.t new file mode 100644 index 0000000..2e67a59 --- /dev/null +++ b/lib/Net/Ping/t/110_icmp_inst.t @@ -0,0 +1,12 @@ +# Test to make sure object can be instantiated for icmp protocol. +# Root access is required to actually perform icmp testing. + +use Test; +use Net::Ping; +plan tests => 2; + +# Everything loaded fine +ok 1; + +my $p = new Net::Ping "tcp"; +ok !!$p; diff --git a/lib/Net/Ping/t/120_udp_inst.t b/lib/Net/Ping/t/120_udp_inst.t new file mode 100644 index 0000000..ee53bd4 --- /dev/null +++ b/lib/Net/Ping/t/120_udp_inst.t @@ -0,0 +1,12 @@ +# Test to make sure object can be instantiated for udp protocol. +# I do not know of any servers that support udp echo anymore. + +use Test; +use Net::Ping; +plan tests => 2; + +# Everything loaded fine +ok 1; + +my $p = new Net::Ping "udp"; +ok !!$p; diff --git a/lib/Net/Ping/t/130_tcp_inst.t b/lib/Net/Ping/t/130_tcp_inst.t new file mode 100644 index 0000000..6a547e1 --- /dev/null +++ b/lib/Net/Ping/t/130_tcp_inst.t @@ -0,0 +1,11 @@ +# Test to make sure object can be instantiated for tcp protocol. + +use Test; +use Net::Ping; +plan tests => 2; + +# Everything loaded fine +ok 1; + +my $p = new Net::Ping "tcp"; +ok !!$p; diff --git a/lib/Net/Ping/t/140_stream_inst.t b/lib/Net/Ping/t/140_stream_inst.t new file mode 100644 index 0000000..142f6db --- /dev/null +++ b/lib/Net/Ping/t/140_stream_inst.t @@ -0,0 +1,11 @@ +# Test to make sure object can be instantiated for stream protocol. + +use Test; +use Net::Ping; +plan tests => 2; + +# Everything loaded fine +ok 1; + +my $p = new Net::Ping "stream"; +ok !!$p; diff --git a/lib/Net/Ping/t/200_ping_tcp.t b/lib/Net/Ping/t/200_ping_tcp.t new file mode 100644 index 0000000..7bdc8e7 --- /dev/null +++ b/lib/Net/Ping/t/200_ping_tcp.t @@ -0,0 +1,60 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + unless ($ENV{PERL_TEST_Net_Ping}) { + print "1..0 # Skip: network dependent test\n"; + exit; + } + chdir 't' if -d 't'; + @INC = qw(../lib); + } +} + +# Remote network test using tcp protocol. +# +# NOTE: +# Network connectivity will be required for all tests to pass. +# Firewalls may also cause some tests to fail, so test it +# on a clear network. If you know you do not have a direct +# connection to remote networks, but you still want the tests +# to pass, use the following: +# +# $ PERL_CORE=1 make test + +use Test; +use Net::Ping; +plan tests => 13; + +# Everything loaded fine +ok 1; + +my $p = new Net::Ping "tcp"; + +# new() worked? +ok !!$p; + +# Test on the default port +ok $p -> ping("localhost"); + +# Change to use the more common web port. +# This will pull from /etc/services on UNIX. +# (Make sure getservbyname works in scalar context.) +ok ($p -> {port_num} = (getservbyname("http", "tcp") || 80)); + +# Test localhost on the web port +ok $p -> ping("localhost"); + +# Hopefully this is not a routeable host +ok !$p -> ping("10.12.14.16"); + +# Test a few remote servers +# Hopefully they are up when the tests are run. + +ok $p -> ping("www.geocities.com"); +ok $p -> ping("ftp.geocities.com"); + +ok $p -> ping("www.freeservers.com"); +ok $p -> ping("ftp.freeservers.com"); + +ok $p -> ping("yahoo.com"); +ok $p -> ping("www.yahoo.com"); +ok $p -> ping("www.about.com"); diff --git a/lib/Net/Ping/t/300_ping_stream.t b/lib/Net/Ping/t/300_ping_stream.t new file mode 100644 index 0000000..4c32a64 --- /dev/null +++ b/lib/Net/Ping/t/300_ping_stream.t @@ -0,0 +1,55 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + unless ($ENV{PERL_TEST_Net_Ping}) { + print "1..0 # Skip: network dependent test\n"; + exit; + } + chdir 't' if -d 't'; + @INC = qw(../lib); + } +} + +# Test of stream protocol using loopback interface. +# +# NOTE: +# The echo service must be enabled on localhost +# to really test the stream protocol ping. + +use Test; +use Net::Ping; +plan tests => 12; + +my $p = new Net::Ping "stream"; + +# new() worked? +ok !!$p; + +# Attempt to connect to the echo port +if ($p -> ping("localhost")) { + ok 1; + # Try several pings while it is connected + for (1..10) { + ok $p -> ping("localhost"); + } +} else { + # Echo port is off, skip the tests + for (2..12) { skip "Local echo port is off", 1; } + exit; +} + +__END__ + +A simple xinetd configuration to enable the echo service can easily be made. +Just create the following file before restarting xinetd: + +/etc/xinetd.d/echo: + +# description: echo service +service echo +{ + socket_type = stream + wait = no + user = root + server = /bin/cat + disable = no +} diff --git a/lib/Shell.t b/lib/Shell.t index 837f6ac..b2d3d67 100644 --- a/lib/Shell.t +++ b/lib/Shell.t @@ -1,5 +1,10 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + use Test::More tests => 4; BEGIN { use_ok('Shell'); } @@ -19,7 +24,7 @@ while ( -f $tmpfile ) $tmpfile++; } -END { -f $tmpfile && unlink $tmpfile }; +END { -f $tmpfile && (open STDERR, '>&SAVERR' and unlink $tmpfile) }; @@ -28,7 +33,8 @@ open(STDERR, ">$tmpfile"); xXx(); # Ok someone could have a program called this :( -ok( !(-s $tmpfile) ,'$Shell::capture_stderr'); +# On os2 the warning is on by default... +ok( ($^O eq 'os2' xor !(-s $tmpfile)) ,'$Shell::capture_stderr'); $Shell::capture_stderr = 0; # diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 2f697ed..9c44823 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -57,8 +57,9 @@ AOUT_EXTRA_LIBS = $aout_extra_libs $spitshell >>Makefile <<'!NO!SUBS!' $(LIBPERL): perl.imp $(PERL_DLL) perl5.def libperl_override.lib emximp -o $(LIBPERL) perl.imp + cp $(LIBPERL) perl.lib -libperl_override.imp: os2/os2add.sym +libperl_override.imp: os2/os2add.sym miniperl ./miniperl -wnle 'print "$$_\t$(PERL_DLL_BASE)\t$$_\t?"' os2/os2add.sym > tmp.imp echo 'strdup $(PERL_DLL_BASE) Perl_strdup ?' >> tmp.imp echo 'putenv $(PERL_DLL_BASE) Perl_putenv ?' >> tmp.imp @@ -198,6 +199,7 @@ $(DYNALOADER_OBJ) : $(DYNALOADER) $(AOUT_LIBPERL) : $(aout_obj) perl$(AOUT_OBJ_EXT) rm -f $@ $(AOUT_AR) rcu $@ perl$(AOUT_OBJ_EXT) $(aout_obj) + cp $@ perl.a .c$(AOUT_OBJ_EXT): $(AOUT_CCCMD) $(PLDLFLAGS) -c $*.c @@ -219,7 +221,10 @@ miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) opmini$(AOUT_OBJ_EXT) # Forking statically loaded perl -perl_$(EXE_EXT) perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs +# Need a miniperl_ dependency, since $(AOUT_DYNALOADER) is build via implicit +# rules, thus would not rebuild miniperl_ via an explicit rule + +perl_$(EXE_EXT) perl_: $& miniperl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs $(CC) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(AOUT_LIBPERL) `cat ext.libs` $(libs) # Remove -Zcrtdll @@ -448,7 +453,7 @@ lib/auto/*/%.a : ext/%/Makefile.aout @cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..." cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS= -ext/%/Makefile.aout : miniperl_ \$(_preplibrary) \$(AOUT_EXTENSIONS_FORCE) +ext/%/Makefile.aout : miniperl_ $(_preplibrary) $(AOUT_EXTENSIONS_FORCE) cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL FIRST_MAKEFILE=Makefile.aout INSTALLDIRS=perl !NO!SUBS! diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL index fb91688..6756402 100644 --- a/os2/OS2/REXX/DLL/Makefile.PL +++ b/os2/OS2/REXX/DLL/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::DLL', - VERSION => '0.01', + VERSION_FROM => 'DLL.pm', MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, diff --git a/os2/os2.c b/os2/os2.c index 39463e6..655e613 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -618,14 +618,14 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) if (strEQ(PL_Argv[0],"/bin/sh")) PL_Argv[0] = PL_sh_path; - if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\' - && !(PL_Argv[0][0] && PL_Argv[0][1] == ':' - && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\')) - ) /* will spawnvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ /* We should check PERL_SH* and PERLLIB_* as well? */ if (!really || !*(tmps = SvPV(really, n_a))) tmps = PL_Argv[0]; + if (tmps[0] != '/' && tmps[0] != '\\' + && !(tmps[0] && tmps[1] == ':' + && (tmps[2] == '/' || tmps[2] != '\\')) + ) /* will spawnvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ reread: force_shell = 0; diff --git a/os2/perlrexx.c b/os2/perlrexx.c index 5706b18..fbeb493 100644 --- a/os2/perlrexx.c +++ b/os2/perlrexx.c @@ -320,234 +320,3 @@ PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PR retstr->strlength = 0; return 0; } -#define INCL_DOSPROCESS -#define INCL_DOSSEMAPHORES -#define INCL_DOSMODULEMGR -#define INCL_DOSMISC -#define INCL_DOSEXCEPTIONS -#define INCL_DOSERRORS -#define INCL_REXXSAA -#include - -/* - * "The Road goes ever on and on, down from the door where it began." - */ - -#ifdef OEMVS -#ifdef MYMALLOC -/* sbrk is limited to first heap segement so make it big */ -#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) -#else -#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) -#endif -#endif - - -#include "EXTERN.h" -#include "perl.h" - -static void xs_init (pTHX); -static PerlInterpreter *my_perl; - -#if defined (__MINT__) || defined (atarist) -/* The Atari operating system doesn't have a dynamic stack. The - stack size is determined from this value. */ -long _stksize = 64 * 1024; -#endif - -/* Register any extra external extensions */ - -/* Do not delete this line--writemain depends on it */ -EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); - -static void -xs_init(pTHX) -{ - char *file = __FILE__; - dXSUB_SYS; - newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); -} - -int perlos2_is_inited; - -static void -init_perlos2(void) -{ -/* static char *env[1] = {NULL}; */ - - Perl_OS2_init3(0, 0, 0); -} - -static int -init_perl(int doparse) -{ - int exitstatus; - char *argv[3] = {"perl_in_REXX", "-e", ""}; - - if (!perlos2_is_inited) { - perlos2_is_inited = 1; - init_perlos2(); - } - if (my_perl) - return 1; - if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - return 0; - perl_construct(my_perl); - PL_perl_destruct_level = 1; - } - if (!doparse) - return 1; - exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); - return !exitstatus; -} - -/* The REXX-callable entrypoints ... */ - -ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - int exitstatus; - char buf[256]; - char *argv[3] = {"perl_from_REXX", "-e", buf}; - ULONG ret; - - if (rargc != 1) { - sprintf(retstr->strptr, "one argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - if (rargv[0].strlength >= sizeof(buf)) { - sprintf(retstr->strptr, - "length of the argument %ld exceeds the maximum %ld", - rargv[0].strlength, (long)sizeof(buf) - 1); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - - if (!init_perl(0)) - return 1; - - memcpy(buf, rargv[0].strptr, rargv[0].strlength); - buf[rargv[0].strlength] = 0; - - exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); - if (!exitstatus) { - exitstatus = perl_run(my_perl); - } - - perl_destruct(my_perl); - perl_free(my_perl); - my_perl = 0; - - if (exitstatus) - ret = 1; - else { - ret = 0; - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - } - PERL_SYS_TERM1(0); - return ret; -} - -ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - if (rargc != 0) { - sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - PERL_SYS_TERM1(0); - return 0; -} - -ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - if (rargc != 0) { - sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - if (!my_perl) { - sprintf(retstr->strptr, "no perl interpreter present"); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - perl_destruct(my_perl); - perl_free(my_perl); - my_perl = 0; - - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - return 0; -} - - -ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - if (rargc != 0) { - sprintf(retstr->strptr, "no argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - if (!init_perl(1)) - return 1; - - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - return 0; -} - -ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - SV *res, *in; - STRLEN len; - char *str; - - if (rargc != 1) { - sprintf(retstr->strptr, "one argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - - if (!init_perl(1)) - return 1; - - { - dSP; - int ret; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); - eval_sv(in, G_SCALAR); - SPAGAIN; - res = POPs; - PUTBACK; - - ret = 0; - if (SvTRUE(ERRSV) || !SvOK(res)) - ret = 1; - str = SvPV(res, len); - if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, str, len); - retstr->strlength = len; - } else - ret = 1; - - FREETMPS; - LEAVE; - - return ret; - } -} diff --git a/patchlevel.h b/patchlevel.h index f079fdd..47177b6 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 - ,"DEVEL13745" + ,"DEVEL13810" ,NULL }; diff --git a/perlapi.h b/perlapi.h index 4eb2c4b..3d74ecd 100644 --- a/perlapi.h +++ b/perlapi.h @@ -733,6 +733,8 @@ END_EXTERN_C #define PL_modcount (*Perl_Tmodcount_ptr(aTHX)) #undef PL_na #define PL_na (*Perl_Tna_ptr(aTHX)) +#undef PL_nrs +#define PL_nrs (*Perl_Tnrs_ptr(aTHX)) #undef PL_ofs_sv #define PL_ofs_sv (*Perl_Tofs_sv_ptr(aTHX)) #undef PL_op @@ -919,8 +921,6 @@ END_EXTERN_C #define PL_top_env (*Perl_Ttop_env_ptr(aTHX)) #undef PL_toptarget #define PL_toptarget (*Perl_Ttoptarget_ptr(aTHX)) -#undef PL_unused_1 -#define PL_unused_1 (*Perl_Tunused_1_ptr(aTHX)) #undef PL_watchaddr #define PL_watchaddr (*Perl_Twatchaddr_ptr(aTHX)) #undef PL_watchok diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 047e7f6..e5f322c 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -386,14 +386,16 @@ value of $^F. See L. =item alarm Arranges to have a SIGALRM delivered to this process after the -specified number of seconds have elapsed. If SECONDS is not specified, -the value stored in C<$_> is used. (On some machines, -unfortunately, the elapsed time may be up to one second less than you -specified because of how seconds are counted.) Only one timer may be -counting at once. Each call disables the previous timer, and an -argument of C<0> may be supplied to cancel the previous timer without -starting a new one. The returned value is the amount of time remaining -on the previous timer. +specified number of wallclock seconds have elapsed. If SECONDS is not +specified, the value stored in C<$_> is used. (On some machines, +unfortunately, the elapsed time may be up to one second less or more +than you specified because of how seconds are counted, and process +scheduling may delay the delivery of the signal even further.) + +Only one timer may be counting at once. Each call disables the +previous timer, and an argument of C<0> may be supplied to cancel the +previous timer without starting a new one. The returned value is the +amount of time remaining on the previous timer. For delays of finer granularity than one second, you may use Perl's four-argument version of select() leaving the first three arguments diff --git a/pod/perlre.pod b/pod/perlre.pod index 900a01d..feafb0e 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -458,12 +458,14 @@ C<)> in the comment. =item C<(?imsx-imsx)> -One or more embedded pattern-match modifiers. This is particularly -useful for dynamic patterns, such as those read in from a configuration -file, read in as an argument, are specified in a table somewhere, -etc. Consider the case that some of which want to be case sensitive -and some do not. The case insensitive ones need to include merely -C<(?i)> at the front of the pattern. For example: +One or more embedded pattern-match modifiers, to be turned on (or +turned off, if preceded by C<->) for the remainder of the pattern or +the remainder of the enclosing pattern group (if any). This is +particularly useful for dynamic patterns, such as those read in from a +configuration file, read in as an argument, are specified in a table +somewhere, etc. Consider the case that some of which want to be case +sensitive and some do not. The case insensitive ones need to include +merely C<(?i)> at the front of the pattern. For example: $pattern = "foobar"; if ( /$pattern/i ) { } @@ -473,8 +475,7 @@ C<(?i)> at the front of the pattern. For example: $pattern = "(?i)foobar"; if ( /$pattern/ ) { } -Letters after a C<-> turn those modifiers off. These modifiers are -localized inside an enclosing group (if any). For example, +These modifiers are restored at the end of the enclosing group. For example, ( (?i) blah ) \s+ \1 diff --git a/pp.c b/pp.c index fddbfc2..0ddfefe 100644 --- a/pp.c +++ b/pp.c @@ -1123,8 +1123,8 @@ PP(pp_modulo) { UV left = 0; UV right = 0; - bool left_neg; - bool right_neg; + bool left_neg = FALSE; + bool right_neg = FALSE; bool use_double = FALSE; bool dright_valid = FALSE; NV dright = 0.0; diff --git a/proto.h b/proto.h index f9161bb..33e8b82 100644 --- a/proto.h +++ b/proto.h @@ -327,6 +327,9 @@ PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit); PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd); PERL_CALLCONV bool Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags); PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX); +PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c); +PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c); +PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ UV c); PERL_CALLCONV bool Perl_is_uni_alnumc(pTHX_ UV c); PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ UV c); diff --git a/t/op/alarm.t b/t/op/alarm.t index 12c8c26..907c385 100644 --- a/t/op/alarm.t +++ b/t/op/alarm.t @@ -29,7 +29,7 @@ my $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' ); -ok( $diff == 3 || $diff == 2, ' right time' ); +ok( abs($diff - 3) <= 1, " right time" ); my $start_time = time; @@ -44,4 +44,4 @@ $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' ); -ok( $diff == 3 || $diff == 2, ' right time' ); +ok( abs($diff - 3) <= 1, ' right time' ); diff --git a/thrdvar.h b/thrdvar.h index b35e735..e517c1e 100644 --- a/thrdvar.h +++ b/thrdvar.h @@ -81,7 +81,7 @@ PERLVAR(Ttimesbuf, struct tms) /* Fields used by magic variables such as $@, $/ and so on */ PERLVAR(Ttainted, bool) /* using variables controlled by $< */ PERLVAR(Tcurpm, PMOP *) /* what to do \ interps in REs from */ -PERLVAR(Tunused_1, SV *) /* placeholder: was Tnrs */ +PERLVAR(Tnrs, SV *) /* placeholder: unused since 5.8.0 (5.7.2 patch #12027 for bug ID 20010815.012) */ /* =for apidoc mn|SV*|PL_rs diff --git a/util.c b/util.c index 89c39fa..4736f11 100644 --- a/util.c +++ b/util.c @@ -2459,9 +2459,11 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto hard_way; # endif result = PerlProc_waitpid(pid,statusp,flags); + goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + goto finish; #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) hard_way: @@ -2476,6 +2478,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } } #endif + finish: if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); } diff --git a/wince/perldll.def b/wince/perldll.def index 01ed086..f7b7eb4 100644 --- a/wince/perldll.def +++ b/wince/perldll.def @@ -184,6 +184,7 @@ EXPORTS PL_no_usym PL_no_wrongref PL_nomemok + PL_nrs PL_ofmt PL_oldbufptr PL_oldname