diff options
64 files changed, 696 insertions, 494 deletions
@@ -700,6 +700,7 @@ ext/threads/t/end.t Test end functions ext/threads/t/join.t Testing the join function ext/threads/t/libc.t testing libc functions for threadsafety ext/threads/t/list.t Test threads->list() +ext/threads/t/problems.t Test various memory problems ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument. ext/threads/t/stress_re.t Test with multiple threads, string cv argument and regexes. ext/threads/t/stress_string.t Test with multiple threads, string cv argument. diff --git a/Porting/genlog b/Porting/genlog index 0c5fec6361..48126f4fb4 100755 --- a/Porting/genlog +++ b/Porting/genlog @@ -1,4 +1,4 @@ -#!/l/local/bin/perl -w +#!/usr/local/bin/perl -w # # Generate a nice changelist by querying perforce. # diff --git a/README.os400 b/README.os400 index 1eec8b20f6..cd78916695 100644 --- a/README.os400 +++ b/README.os400 @@ -36,6 +36,12 @@ Starting from OS/400 V5R2 the IBM Visual Age compiler is supported on OS/400 PASE, so it is possible to build Perl natively on OS/400. The easier way, however, is to compile in AIX, as just described. +If you don't want to install the compiled Perl in AIX into /QOpenSys +(for packaging it before copying it to PASE), you can use a Configure +parameter: -Dinstallprefix=/tmp/QOpenSys/perl. This will cause the +"make install" to install everything into that directory, while the +installed files still think they are (will be) in /QOpenSys/perl. + If building natively on PASE, please do the build under the /QOpenSys directory, since Perl is happier when built on a case sensitive filesystem. @@ -775,8 +775,8 @@ Perl_nextargv(pTHX_ register GV *gv) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s would not be unique", - SvPVX(sv)); + "Can't do inplace edit: %"SVf" would not be unique", + sv); do_close(gv,FALSE); continue; } @@ -786,8 +786,8 @@ Perl_nextargv(pTHX_ register GV *gv) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -802,8 +802,8 @@ Perl_nextargv(pTHX_ register GV *gv) if (link(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, sv, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -73,7 +73,7 @@ Perl_dump_sub(pTHX_ GV *gv) SV *sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv)); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %"SVf" = ", sv); if (CvXSUB(GvCV(gv))) Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", PTR2UV(CvXSUB(GvCV(gv))), @@ -90,7 +90,7 @@ Perl_dump_form(pTHX_ GV *gv) SV *sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX(sv)); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %"SVf" = ", sv); if (CvROOT(GvFORM(gv))) op_dump(CvROOT(GvFORM(gv))); else @@ -619,11 +619,10 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) #else if (cSVOPo->op_sv) { SV *tmpsv = NEWSV(0,0); - STRLEN n_a; ENTER; SAVEFREESV(tmpsv); gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch); - Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a)); + Perl_dump_indent(aTHX_ level, file, "GV = %"SVf"\n", tmpsv); LEAVE; } else @@ -719,10 +718,10 @@ Perl_gv_dump(pTHX_ GV *gv) sv = sv_newmortal(); PerlIO_printf(Perl_debug_log, "{\n"); gv_fullname3(sv, gv, Nullch); - Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv)); + Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %"SVf"", sv); if (gv != GvEGV(gv)) { gv_efullname3(sv, GvEGV(gv), Nullch); - Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX(sv)); + Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %"SVf"", sv); } PerlIO_putc(Perl_debug_log, '\n'); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); @@ -926,7 +925,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo char *s; U32 flags; U32 type; - STRLEN n_a; if (!sv) { Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); @@ -942,7 +940,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), (int)(PL_dumpindent*level), ""); - if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,"); + if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,"); if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); if (flags & SVs_PADMY) sv_catpv(d, "PADMY,"); if (flags & SVs_TEMP) sv_catpv(d, "TEMP,"); @@ -1273,7 +1271,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo break; case SVt_PVCV: if (SvPOK(sv)) - Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV(sv,n_a)); + Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%"SVf"\"\n", sv); /* FALL THROUGH */ case SVt_PVFM: do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); @@ -1405,7 +1403,6 @@ Perl_debop(pTHX_ OP *o) AV *padlist, *comppad; CV *cv; SV *sv; - STRLEN n_a; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -1420,7 +1417,7 @@ Perl_debop(pTHX_ OP *o) if (cGVOPo_gv) { sv = NEWSV(0,0); gv_fullname3(sv, cGVOPo_gv, Nullch); - PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); SvREFCNT_dec(sv); } else diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 63b0f79f86..6c9459e486 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -252,8 +252,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) - warn("WARNING(Freezer method call failed): %s", - SvPVX(ERRSV)); + warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); else if (i) val = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t index a1ed214d19..687dff042a 100644 --- a/ext/Devel/Peek/Peek.t +++ b/ext/Devel/Peek/Peek.t @@ -85,7 +85,7 @@ do_test( 5, $c = 456, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\) + FLAGS = \\(PADMY,IOK,pIOK\\) IV = 456'); # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers @@ -206,7 +206,7 @@ do_test(13, RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\) + FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\) IV = 0 NV = 0 PROTOTYPE = "" @@ -327,7 +327,7 @@ do_test(18, chr(256).chr(0).chr(512), 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\) + FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] CUR = 5 LEN = \\d+'); @@ -336,7 +336,7 @@ do_test(18, chr(256).chr(0).chr(512), 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\) + FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] CUR = 5 LEN = \\d+'); @@ -402,7 +402,7 @@ do_test(20, $x, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADBUSY,PADMY,SMG,POK,pPOK\\) + FLAGS = \\(PADMY,SMG,POK,pPOK\\) IV = 0 NV = 0 PV = $ADDR ""\\\0 @@ -433,8 +433,14 @@ do_test(21, MG_TYPE = PERL_MAGIC_envelem\\(e\\) (?: MG_FLAGS = 0x01 TAINTEDDIR -)? MG_LEN = 4 - MG_PTR = $ADDR "(?i:PATH)" +)? MG_LEN = -?\d+ + MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY + SV = PV\\($ADDR\\) at $ADDR + REFCNT = \d+ + FLAGS = \\(TEMP,POK,pPOK\\) + PV = $ADDR "(?i:PATH)"\\\0 + CUR = \d+ + LEN = \d+) MAGIC = $ADDR MG_VIRTUAL = &PL_vtbl_taint MG_TYPE = PERL_MAGIC_taint\\(t\\)'); diff --git a/ext/Filter/t/call.t b/ext/Filter/t/call.t index 0f9b452125..8dd0955941 100644 --- a/ext/Filter/t/call.t +++ b/ext/Filter/t/call.t @@ -806,10 +806,12 @@ EOM my $a = `$Perl "-I." $Inc -e "no ${module6}; print q{ok}"`; ok(29, ($? >>8) == 0); +chomp( $a ) if $^O eq 'VMS'; ok(30, $a eq 'ok'); $a = `$Perl "-I." $Inc $filename2`; ok(31, ($? >>8) == 0); +chomp( $a ) if $^O eq 'VMS'; ok(32, $a eq 'ok'); } diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index 2a08fb063b..c5a210f809 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -813,8 +813,9 @@ CODE: SHARED_CONTEXT; sv = av_pop((AV*)SHAREDSvPTR(shared)); CALLER_CONTEXT; - ST(0) = Nullsv; + ST(0) = sv_newmortal(); Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); + SvREFCNT_dec(sv); LEAVE_LOCK; XSRETURN(1); @@ -827,8 +828,9 @@ CODE: SHARED_CONTEXT; sv = av_shift((AV*)SHAREDSvPTR(shared)); CALLER_CONTEXT; - ST(0) = Nullsv; + ST(0) = sv_newmortal(); Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); + SvREFCNT_dec(sv); LEAVE_LOCK; XSRETURN(1); diff --git a/ext/threads/shared/t/hv_refs.t b/ext/threads/shared/t/hv_refs.t index 94bf822f8f..fb3c8de3f8 100644 --- a/ext/threads/shared/t/hv_refs.t +++ b/ext/threads/shared/t/hv_refs.t @@ -30,7 +30,7 @@ sub skip { use ExtUtils::testlib; use strict; -BEGIN { print "1..13\n" }; +BEGIN { print "1..14\n" }; use threads; use threads::shared; ok(1,1,"loaded"); @@ -75,3 +75,16 @@ ok(10, keys %foo == 0, "And make sure we realy have deleted the values"); ok(13, $hash1{hash}->{hash}->{thread} eq "yes", "Check hash created in another thread"); } +{ + my $h = {a=>14}; + my $r = \$h->{a}; + share($r); + lock($r); + lock($h->{a}); + ok(14, 1, "lock on helems now work, this was bug 10045"); + +} + + + + diff --git a/ext/threads/t/basic.t b/ext/threads/t/basic.t index fa9a6556d0..4236bf6b01 100755 --- a/ext/threads/t/basic.t +++ b/ext/threads/t/basic.t @@ -25,7 +25,7 @@ BEGIN { use ExtUtils::testlib; use strict; -BEGIN { $| = 1; print "1..15\n" }; +BEGIN { $| = 1; print "1..19\n" }; use threads; @@ -116,6 +116,23 @@ threads->create('test8')->join; ok(14, 0 == threads->self->tid(),"Check so that tid for threads work for main thread"); ok(15, 0 == threads->tid(),"Check so that tid for threads work for main thread"); +{ + local *CLONE = sub { ok(16, threads->tid() == 9, "Tid should be correct in the clone")}; + threads->create(sub { ok(17, threads->tid() == 9, "And tid be 9 here too") })->join(); +} + +{ + + sub Foo::DESTROY { + ok(19, threads->tid() == 10, "In destroy it should be correct too" ) + } + my $foo; + threads->create(sub { ok(18, threads->tid() == 10, "And tid be 10 here"); + $foo = bless {}, 'Foo'; + return undef; + })->join(); + +} 1; diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t index 230d70c545..255704cb34 100644 --- a/ext/threads/t/join.t +++ b/ext/threads/t/join.t @@ -93,17 +93,19 @@ ok(1,""); if ($^O eq 'linux') { # We parse ps output so this is OS-dependent. # First modify $0 in a subthread. - print "# 1a: \$0 = $0\n"; - join( threads->new( sub { - print "# 2a: \$0 = $0\n"; - $0 = "foobar"; - print "# 2b: \$0 = $0\n" } ) ); - print "# 1b: \$0 = $0\n"; - if (open PS, "ps -f |") { + print "# mainthread: \$0 = $0\n"; + threads->new( sub { + print "# subthread: \$0 = $0\n"; + $0 = "foobar"; + print "# subthread: \$0 = $0\n" } )->join; + print "# mainthread: \$0 = $0\n"; + print "# pid = $$\n"; + if (open PS, "ps -f |") { # Note: must work in (all) Linux(es). my $ok; while (<PS>) { - print "# $_"; - if (/^\S+\s+$$\s.+\sfoobar\s*$/) { + s/\s+$//; # there seems to be extra whitespace at the end by ps(1)? + print "# $_\n"; + if (/^\S+\s+$$\s.+\sfoobar$/) { $ok++; last; } diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t new file mode 100644 index 0000000000..a7b6c34787 --- /dev/null +++ b/ext/threads/t/problems.t @@ -0,0 +1,55 @@ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'useithreads'}) { + print "1..0 # Skip: no useithreads\n"; + exit 0; + } +} + +use ExtUtils::testlib; +use strict; +use threads; +use threads::shared; +use Test::More tests => 4; + + +# +# This tests for too much destruction +# which was caused by cloning stashes +# on join which led to double the dataspace +# +######################### + +$|++; +use Devel::Peek; + + +{ + + sub Foo::DESTROY { + my $self = shift; + my ($package, $file, $line) = caller; + is(threads->tid(),$self->{tid}, "In destroy it should be correct too" ) + } + my $foo; + $foo = bless {tid => 0}, 'Foo'; + my $bar = threads->create(sub { + is(threads->tid(),1, "And tid be 10 here"); + $foo->{tid} = 1; + return $foo; + })->join(); + $bar->{tid} = 0; + + +} +1; + + + + + + + diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 5bcf4e4e25..043f76202f 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -135,8 +135,13 @@ Perl_ithread_destruct (pTHX_ ithread* thread, const char *why) MUTEX_DESTROY(&thread->mutex); PerlMemShared_free(thread); if(destroyperl) { + ithread* current_thread; + PERL_THREAD_GETSPECIFIC(self_key,current_thread); + PERL_THREAD_SETSPECIFIC(self_key,thread); perl_destruct(destroyperl); perl_free(destroyperl); + PERL_THREAD_SETSPECIFIC(self_key,current_thread); + } PERL_SET_CONTEXT(aTHX); } @@ -277,12 +282,12 @@ Perl_ithread_run(void * arg) { } PUTBACK; len = call_sv(thread->init_function, thread->gimme|G_EVAL); + SPAGAIN; for (i=len-1; i >= 0; i--) { SV *sv = POPs; av_store(params, i, SvREFCNT_inc(sv)); } - PUTBACK; if (SvTRUE(ERRSV)) { Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV); } @@ -358,7 +363,8 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param { ithread* thread; CLONE_PARAMS clone_param; - + ithread* current_thread; + PERL_THREAD_GETSPECIFIC(self_key,current_thread); MUTEX_LOCK(&create_destruct_mutex); thread = PerlMemShared_malloc(sizeof(ithread)); Zero(thread,1,ithread); @@ -379,7 +385,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param */ PerlIO_flush((PerlIO*)NULL); - + PERL_THREAD_SETSPECIFIC(self_key,thread); #ifdef WIN32 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST); #else @@ -410,7 +416,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param PL_ptr_table = NULL; PL_exit_flags |= PERL_EXIT_DESTRUCT_END; } - + PERL_THREAD_SETSPECIFIC(self_key,current_thread); PERL_SET_CONTEXT(aTHX); /* Start the thread */ @@ -507,11 +513,35 @@ Perl_ithread_join(pTHX_ SV *obj) /* sv_dup over the args */ { + ithread* current_thread; AV* params = (AV*) SvRV(thread->params); CLONE_PARAMS clone_params; clone_params.stashes = newAV(); + clone_params.flags |= CLONEf_JOIN_IN; PL_ptr_table = ptr_table_new(); + PERL_THREAD_GETSPECIFIC(self_key,current_thread); + PERL_THREAD_SETSPECIFIC(self_key,thread); + +#if 0 + { + I32 len = av_len(params)+1; + I32 i; + for(i = 0; i < len; i++) { + sv_dump(SvRV(AvARRAY(params)[i])); + } + } +#endif retparam = (AV*) sv_dup((SV*)params, &clone_params); +#if 0 + { + I32 len = av_len(retparam)+1; + I32 i; + for(i = 0; i < len; i++) { + sv_dump(SvRV(AvARRAY(retparam)[i])); + } + } +#endif + PERL_THREAD_SETSPECIFIC(self_key,current_thread); SvREFCNT_dec(clone_params.stashes); SvREFCNT_inc(retparam); ptr_table_free(PL_ptr_table); @@ -254,8 +254,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %s for @%s::ISA", - SvPVX(sv), HvNAME(stash)); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", + sv, HvNAME(stash)); continue; } gv = gv_fetchmeth(basestash, name, len, @@ -1328,21 +1328,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* GvSV contains the name of the method. */ GV *ngv = Nullgv; - DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256"SVf"' for overloaded `%s' in package `%.256s'\n", + GvSV(gv), cp, HvNAME(stash)) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), FALSE))) { /* Can be an import stub (created by `can'). */ - if (GvCVGEN(gv)) { - Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", - (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), - cp, HvNAME(stash)); - } else - Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'", - (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), - cp, HvNAME(stash)); + SV *gvsv = GvSV(gv); + const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???"; + Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' in package `%.256s'", + (GvCVGEN(gv) ? "Stub found while resolving" + : "Can't resolve"), + name, cp, HvNAME(stash)); } cv = GvCV(gv = ngv); } diff --git a/hints/darwin.sh b/hints/darwin.sh index 777960e2b9..7565935274 100644 --- a/hints/darwin.sh +++ b/hints/darwin.sh @@ -147,7 +147,10 @@ firstmakefile=GNUmakefile; # case "$usethreads$useithreads" in *define*) - cat <<EOM >&4 + case "$osvers" in + [12345].*) cat <<EOM >&4 + + *** Warning, there might be problems with your libraries with *** regards to threading. The test ext/threads/t/libc.t is likely @@ -155,4 +158,7 @@ case "$usethreads$useithreads" in EOM ;; + *) usereentrant='define';; + esac + esac @@ -506,7 +506,15 @@ NULL if the operation failed or if the value did not need to be actually stored within the hash (as in the case of tied hashes). Otherwise it can be dereferenced to get the original C<SV*>. Note that the caller is responsible for suitably incrementing the reference count of C<val> before -the call, and decrementing it if the function returned NULL. +the call, and decrementing it if the function returned NULL. Effectively +a successful hv_store takes ownership of one reference to C<val>. This is +usually what you want; a newly created SV has a reference count of one, so +if all your code does is create SVs then store them in a hash, hv_store +will own the only reference to the new SV, and your code doesn't need to do +anything further to tidy up. hv_store is not implemented as a call to +hv_store_ent, and does not create a temporary SV for the key, so if your +key data is not already in SV form then use hv_store in preference to +hv_store_ent. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more information on how to use this function on tied hashes. @@ -681,7 +689,17 @@ stored within the hash (as in the case of tied hashes). Otherwise the contents of the return value can be accessed using the C<He?> macros described here. Note that the caller is responsible for suitably incrementing the reference count of C<val> before the call, and -decrementing it if the function returned NULL. +decrementing it if the function returned NULL. Effectively a successful +hv_store_ent takes ownership of one reference to C<val>. This is +usually what you want; a newly created SV has a reference count of one, so +if all your code does is create SVs then store them in a hash, hv_store +will own the only reference to the new SV, and your code doesn't need to do +anything further to tidy up. Note that hv_store_ent only reads the C<key>; +unlike C<val> it does not take ownership of it, so maintaining the correct +reference count on C<key> is entirely the caller's responsibility. hv_store +is not implemented as a call to hv_store_ent, and does not create a temporary +SV for the key, so if your key data is not already in SV form then use +hv_store in preference to hv_store_ent. See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more information on how to use this function on tied hashes. diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t index 5460a254bd..be12b8f44b 100644 --- a/lib/ExtUtils/t/Embed.t +++ b/lib/ExtUtils/t/Embed.t @@ -102,7 +102,7 @@ if ($^O eq 'VMS') { # Everyone needs libperl copied if it's not found by '-lperl'. $testlib = $Config{'libperl'}; my $srclib = $testlib; - $testlib =~ s/^[^.]+/libperl/; + $testlib =~ s/.+(?=\.[^.]*)/libperl/; $testlib = File::Spec::->catfile($lib, $testlib); $srclib = File::Spec::->catfile($lib, $srclib); if (-f $srclib) { diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index d2152ca460..5c5f0f3a37 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -269,13 +269,13 @@ File::Copy - Copy files or filehandles =head1 SYNOPSIS - use File::Copy; + use File::Copy; - copy("file1","file2"); - copy("Copy.pm",\*STDOUT);' + copy("file1","file2") or die "Copy failed: $!"; + copy("Copy.pm",\*STDOUT); move("/dev1/fileA","/dev2/fileB"); - use POSIX; + use POSIX; use File::Copy cp; $n = FileHandle->new("/a/file","r"); diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index d125b2f3c2..e8b40808ad 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -175,7 +175,7 @@ join is the same as catfile. =item splitpath Splits a path in to volume, directory, and filename portions. On systems -with no concept of volume, returns undef for volume. +with no concept of volume, returns '' for volume. ($volume,$directories,$file) = File::Spec->splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 000da91b1a..6067b3cd2b 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -442,7 +442,7 @@ sub path { ($volume,$directories,$file) = File::Spec->splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); -Splits a path in to volume, directory, and filename portions. +Splits a path into volume, directory, and filename portions. On Mac OS, assumes that the last part of the path is a filename unless $no_file is true or a trailing separator ":" is present. diff --git a/lib/File/Spec/OS2.pm b/lib/File/Spec/OS2.pm index b494e2cbf2..e65186ac48 100644 --- a/lib/File/Spec/OS2.pm +++ b/lib/File/Spec/OS2.pm @@ -76,10 +76,10 @@ sub canonpath { ($volume,$directories,$file) = File::Spec->splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); -Splits a path in to volume, directory, and filename portions. Assumes that +Splits a path into volume, directory, and filename portions. Assumes that the last file is a path unless the path ends in '/', '/.', '/..' or $no_file is true. On Win32 this means that $no_file true makes this return -( $volume, $path, undef ). +( $volume, $path, '' ). Separators accepted are \ and /. diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index d9615c06b4..fb8ee98d8e 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -213,6 +213,7 @@ Takes no argument, returns the environment variable PATH as an array. =cut sub path { + return () unless exists $ENV{PATH}; my @path = split(':', $ENV{PATH}); foreach (@path) { $_ = '.' if $_ eq '' } return @path; @@ -234,8 +235,8 @@ sub join { ($volume,$directories,$file) = File::Spec->splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); -Splits a path in to volume, directory, and filename portions. On systems -with no concept of volume, returns undef for volume. +Splits a path into volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. For systems with no syntax differentiating filenames from directories, assumes that the last file is a path unless $no_file is true or a diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index 7c2275811d..87a236b0d4 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -170,10 +170,10 @@ sub canonpath { ($volume,$directories,$file) = File::Spec->splitpath( $path ); ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); -Splits a path in to volume, directory, and filename portions. Assumes that +Splits a path into volume, directory, and filename portions. Assumes that the last file is a path unless the path ends in '\\', '\\.', '\\..' or $no_file is true. On Win32 this means that $no_file true makes this return -( $volume, $path, undef ). +( $volume, $path, '' ). Separators accepted are \ and /. diff --git a/lib/Math/Trig.pm b/lib/Math/Trig.pm index d1ac4f5500..9e653c892d 100644 --- a/lib/Math/Trig.pm +++ b/lib/Math/Trig.pm @@ -16,7 +16,7 @@ our($VERSION, $PACKAGE, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(Exporter); -$VERSION = 1.01; +$VERSION = 1.02; my @angcnv = qw(rad2deg rad2grad deg2rad deg2grad @@ -144,6 +144,9 @@ sub great_circle_direction { return rad2rad($direction); } +1; + +__END__ =pod =head1 NAME diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index d2dff0454c..ee374de954 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -1,7 +1,7 @@ # Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.34 2002/07/15 05:46:00 eagle Exp $ +# $Id: Man.pm,v 1.36 2003/01/05 06:32:55 eagle Exp $ # -# Copyright 1999, 2000, 2001, 2002 by Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery <rra@stanford.edu> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -38,7 +38,7 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); # Don't use the CVS revision as the version, since this module is also in Perl # core and too many things could munge CVS magic revision strings. This # number should ideally be the same as the CVS revision in podlators, however. -$VERSION = 1.34; +$VERSION = 1.36; ############################################################################## @@ -471,6 +471,7 @@ $_ $$self{INDEX} = []; # Index keys waiting to be printed. $$self{IN_NAME} = 0; # Whether processing the NAME section. $$self{ITEMS} = 0; # The number of consecutive =items. + $$self{ITEMTYPES} = []; # Stack of =item types, one per list. $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting. $$self{SHIFTS} = []; # Stack of .RS shifts. } @@ -537,9 +538,9 @@ sub textblock { $text =~ s/\n\s*$/\n/; # Output the paragraph. We also have to handle =over without =item. If - # there's an =over without =item, NEWINDENT will be set, and we need to - # handle creation of the indent here. Set WEIRDINDENT so that it will be - # cleaned up on =back. + # there's an =over without =item, SHIFTWAIT will be set, and we need to + # handle creation of the indent here. Add the shift to SHIFTS so that it + # will be cleaned up on =back. $self->makespace; if ($$self{SHIFTWAIT}) { $self->output (".RS $$self{INDENT}\n"); @@ -716,6 +717,7 @@ sub cmd_over { push (@{ $$self{SHIFTS} }, $$self{INDENT}); } push (@{ $$self{INDENTS} }, $$self{INDENT}); + push (@{ $$self{ITEMTYPES} }, 'unknown'); $$self{INDENT} = ($_ + 0); $$self{SHIFTWAIT} = 1; } @@ -726,7 +728,9 @@ sub cmd_over { sub cmd_back { my $self = shift; $$self{INDENT} = pop @{ $$self{INDENTS} }; - unless (defined $$self{INDENT}) { + if (defined $$self{INDENT}) { + pop @{ $$self{ITEMTYPES} }; + } else { my ($file, $line, $paragraph) = @_; ($file, $line) = $paragraph->file_line; warn "$file:$line: Unmatched =back\n"; @@ -759,8 +763,18 @@ sub cmd_item { $index = $_; $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//; } - $_ = '*' unless $_; - s/^\*(\s|\Z)/\\\(bu$1/; + $_ = '*' unless length ($_) > 0; + my $type = $$self{ITEMTYPES}[0]; + unless (defined $type) { + my ($file, $line, $paragraph) = @_; + ($file, $line) = $paragraph->file_line; + $type = 'unknown'; + } + if ($type eq 'unknown') { + $type = /^\*\s*\Z/ ? 'bullet' : 'text'; + $$self{ITEMTYPES}[0] = $type if $$self{ITEMTYPES}[0]; + } + s/^\*\s*\Z/\\\(bu/ if $type eq 'bullet'; if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) { $self->output (".RE\n"); pop @{ $$self{SHIFTS} }; @@ -1387,7 +1401,7 @@ B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>. =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2000, 2001, 2002 by Russ Allbery <rra@stanford.edu>. +Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery <rra@stanford.edu>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/Pod/t/man.t b/lib/Pod/t/man.t index 8bf7abdcba..f43f32a991 100644 --- a/lib/Pod/t/man.t +++ b/lib/Pod/t/man.t @@ -1,9 +1,9 @@ #!/usr/bin/perl -w -# $Id: man.t,v 1.2 2002/06/23 19:16:25 eagle Exp $ +# $Id: man.t,v 1.4 2003/01/05 06:31:52 eagle Exp $ # # man.t -- Additional specialized tests for Pod::Man. # -# Copyright 2002 by Russ Allbery <rra@stanford.edu> +# Copyright 2002, 2003 by Russ Allbery <rra@stanford.edu> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -17,7 +17,7 @@ BEGIN { } unshift (@INC, '../blib/lib'); $| = 1; - print "1..3\n"; + print "1..5\n"; } END { @@ -94,3 +94,46 @@ This C<.> should be quoted. .IX Header "PERIODS" This \f(CW\*(C`.\*(C'\fR should be quoted. ### + +### +=over 4 + +=item * + +A bullet. + +=item * + +Another bullet. + +=item * Not a bullet. + +=back +### +.IP "\(bu" 4 +A bullet. +.IP "\(bu" 4 +Another bullet. +.IP "* Not a bullet." 4 +.IX Item "Not a bullet." +### + +### +=over 4 + +=item foo + +Not a bullet. + +=item * + +Also not a bullet. + +=back +### +.IP "foo" 4 +.IX Item "foo" +Not a bullet. +.IP "*" 4 +Also not a bullet. +### diff --git a/lib/charnames.t b/lib/charnames.t index b2c1636789..97663a7d1e 100644 --- a/lib/charnames.t +++ b/lib/charnames.t @@ -6,6 +6,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } $SIG{__WARN__} = sub { push @WARN, @_ }; } @@ -292,11 +293,9 @@ for (@prgs) { print $ali $fil; close $ali or die "Could not close $alifile: $!"; } - my $res = - $^O eq "MSWin32" ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - $^O eq "NetWare" ? `perl -I../lib $switch $tmpfile 2>&1` : - $^O eq "MacOS" ? `$^X -I::lib -MMac::err=unix $switch $tmpfile` : - `./perl -I. -I../lib $switch $tmpfile 2>&1`; + my $res = runperl( switches => $switch, + progfile => $tmpfile, + stderr => 1 ); my $status = $?; $res =~ s/[\r\n]+$//; $res =~ s/tmp\d+/-/g; # fake $prog from STDIN @@ -658,7 +658,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(mg->mg_ptr, "\024AINT")) - sv_setiv(sv, PL_tainting); + sv_setiv(sv, PL_tainting + ? (PL_taint_warn || PL_unsafe ? -1 : 1) + : 0); break; case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ if (*(mg->mg_ptr+1) == '\0') @@ -152,8 +152,8 @@ STATIC void S_no_bareword_allowed(pTHX_ OP *o) { qerror(Perl_mess(aTHX_ - "Bareword \"%s\" not allowed while \"strict subs\" in use", - SvPV_nolen(cSVOPo_sv))); + "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", + cSVOPo_sv)); } /* "register" allocation */ @@ -3821,7 +3821,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv)); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv); sv_catpv(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); @@ -4136,7 +4136,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a)); + Perl_croak(aTHX_ "%"SVf, ERRSV); } } } @@ -5991,8 +5991,8 @@ Perl_ck_subr(pTHX_ OP *o) continue; default: oops: - Perl_croak(aTHX_ "Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, n_a)); + Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, + gv_ename(namegv), cv); } } else @@ -6197,8 +6197,8 @@ Perl_peep(pTHX_ register OP *o) SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), - "%s() called too early to check prototype", - SvPV_nolen(sv)); + "%"SVf"() called too early to check prototype", + sv); } } else if (o->op_next->op_type == OP_READLINE @@ -1824,7 +1824,7 @@ EXT U32 PL_opargs[] = { 0x00000014, /* egrent */ 0x0000000c, /* getlogin */ 0x0004281d, /* syscall */ - 0x00003604, /* lock */ + 0x0000f604, /* lock */ 0x00000044, /* threadsv */ 0x00001404, /* setstate */ 0x00000c40, /* method_named */ @@ -913,7 +913,7 @@ getlogin getlogin ck_null st0 syscall syscall ck_fun imst@ S L # For multi-threading -lock lock ck_rfun s% S +lock lock ck_rfun s% R threadsv per-thread value ck_null ds0 # Control (contd.) @@ -378,9 +378,7 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) if (PL_pad_reset_pending) pad_reset(); if (tmptype & SVs_PADMY) { - do { - sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); - } while (SvPADBUSY(sv)); /* need a fresh one */ + sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); retval = AvFILLp(PL_comppad); } else { @@ -916,7 +914,7 @@ Perl_pad_leavemy(pTHX) if ((sv = svp[off]) && sv != &PL_sv_undef && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "%s never introduced", SvPVX(sv)); + "%"SVf" never introduced", sv); } } /* "Deintroduce" my variables that are leaving with this scope. */ @@ -1175,21 +1173,21 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) if (namesv) { if (SvFAKE(namesv)) Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%"UVxf"<%lu> FAKE \"%s\"\n", + "%2d. 0x%"UVxf"<%lu> FAKE \"%"SVf"\"\n", (int) ix, PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - SvPVX(namesv) + namesv ); else Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n", + "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%"SVf"\"\n", (int) ix, PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), (unsigned long)I_32(SvNVX(namesv)), (unsigned long)SvIVX(namesv), - SvPVX(namesv) + namesv ); } else if (full) { @@ -1344,8 +1342,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) sv = (SV*)newHV(); else sv = NEWSV(0, 0); - if (!SvPADBUSY(sv)) - SvPADMY_on(sv); + SvPADMY_on(sv); PL_curpad[ix] = sv; } } @@ -3908,7 +3908,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) atsv = ERRSV; (void)SvPV(atsv, len); if (len) { - STRLEN n_a; PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); if (paramList == PL_beginav) @@ -3922,7 +3921,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); + Perl_croak(aTHX_ "%"SVf"", atsv); } break; case 1: diff --git a/pod/perl58delta.pod b/pod/perl58delta.pod index 3bef17ba1f..53aa21744f 100644 --- a/pod/perl58delta.pod +++ b/pod/perl58delta.pod @@ -3545,6 +3545,12 @@ be exact. (They produce something other than "1" and "-1" when formatting 0.6 and -0.6 using the printf format "%.0f"; most often, they produce "0" and "-0".) +=head2 SCO + +The socketpair tests are known to be unhappy in SCO 3.2v5.0.4: + + ext/Socket/socketpair.t...............FAILED tests 15-45 + =head2 Solaris 2.5 In case you are still using Solaris 2.5 (aka SunOS 5.5), you may diff --git a/pod/perlfaq.pod b/pod/perlfaq.pod index 419d973a5b..73f12e7712 100644 --- a/pod/perlfaq.pod +++ b/pod/perlfaq.pod @@ -1,11 +1,74 @@ =head1 NAME -perlfaq - frequently asked questions about Perl ($Date: 2002/11/13 06:23:50 $) +perlfaq - frequently asked questions about Perl ($Date: 2003/01/03 20:00:25 $) =head1 DESCRIPTION -The perlfaq is structured into the following documents: +The perlfaq is divided into several documents based on topics. A table +of contents is at the end of this document. +=head2 Where to get the perlfaq + +Extracts of the perlfaq are posted regularly to +comp.lang.perl.misc. It is available on many web sites: +http://www.perldoc.com/ and http://faq.perl.org/ + +=head2 How to contribute to the perlfaq + +You may mail corrections, additions, and suggestions to +perlfaq-workers@perl.org . This alias should not be used to +I<ask> FAQs. It's for fixing the current FAQ. Send +questions to the comp.lang.perl.misc newsgroup. You can +view the source tree at http://cvs.perl.org/cvsweb/perlfaq/ +(which is outside of the main Perl source tree). The CVS +repository notes all changes to the FAQ. + +=head2 What will happen if you mail your Perl programming problems to the authors + +Your questions will probably go unread, unless they're +suggestions of new questions to add to the FAQ, in which +case they should have gone to the perlfaq-workers@perl.org +instead. + +You should have read section 2 of this faq. There you would +have learned that comp.lang.perl.misc is the appropriate +place to go for free advice. If your question is really +important and you require a prompt and correct answer, you +should hire a consultant. + +=head1 Credits + +The original perlfaq was written by Tom Christiansen, then expanded +by collaboration between Tom and Nathan Torkington. The current +document is maintained by the perlfaq-workers (perlfaq-workers@perl.org). +Several people have contributed answers, corrections, and comments. + +=head1 Author and Copyright Information + +Copyright (c) 1997-2003 Tom Christiansen, Nathan Torkington, and +other contributors noted in the answers. + +All rights reserved. + +=head2 Bundled Distributions + +This documentation is free; you can redistribute it and/or modify it +under the same terms as Perl itself. + +Irrespective of its distribution, all code examples in these files +are hereby placed into the public domain. You are permitted and +encouraged to use this code in your own programs for fun +or for profit as you see fit. A simple comment in the code giving +credit would be courteous but is not required. + +=head2 Disclaimer + +This information is offered in good faith and in the hope that it may +be of use, but is not guaranteed to be correct, up to date, or suitable +for any particular purpose whatsoever. The authors accept no liability +in respect of this information or its use. + +=head1 Table of Contents =head2 perlfaq: Structural overview of the FAQ. @@ -1309,61 +1372,3 @@ How can I do RPC in Perl? =back -=head1 About the perlfaq documents - -=head2 Where to get the perlfaq - -This document is posted regularly to comp.lang.perl.announce and -several other related newsgroups. It is available on many -web sites: http://www.perldoc.com/ and http://perlfaq.cpan.org/ . - -=head2 How to contribute to the perlfaq - -You may mail corrections, additions, and suggestions to -perlfaq-workers@perl.org . This alias should not be -used to I<ask> FAQs. It's for fixing the current FAQ. -Send questions to the comp.lang.perl.misc newsgroup. - -=head2 What will happen if you mail your Perl programming problems to the authors - -Your questions will probably go unread, unless they're suggestions of -new questions to add to the FAQ, in which case they should have gone -to the perlfaq-workers@perl.org instead. - -You should have read section 2 of this faq. There you would have -learned that comp.lang.perl.misc is the appropriate place to go for -free advice. If your question is really important and you require a -prompt and correct answer, you should hire a consultant. - -=head1 Credits - -When I first began the Perl FAQ in the late 80s, I never realized it -would have grown to over a hundred pages, nor that Perl would ever become -so popular and widespread. This document could not have been written -without the tremendous help provided by Larry Wall and the rest of the -Perl Porters. - -=head1 Author and Copyright Information - -Copyright (c) 1997-2002 Tom Christiansen and Nathan Torkington. -All rights reserved. - -=head2 Bundled Distributions - -This documentation is free; you can redistribute it and/or modify it -under the same terms as Perl itself. - -Irrespective of its distribution, all code examples in these files -are hereby placed into the public domain. You are permitted and -encouraged to use this code in your own programs for fun -or for profit as you see fit. A simple comment in the code giving -credit would be courteous but is not required. - -=head2 Disclaimer - -This information is offered in good faith and in the hope that it may -be of use, but is not guaranteed to be correct, up to date, or suitable -for any particular purpose whatsoever. The authors accept no liability -in respect of this information or its use. - -=back diff --git a/pod/perlfaq1.pod b/pod/perlfaq1.pod index 69490de5e4..ea3a4c3676 100644 --- a/pod/perlfaq1.pod +++ b/pod/perlfaq1.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq1 - General Questions About Perl ($Revision: 1.10 $, $Date: 2002/08/29 03:34:00 $) +perlfaq1 - General Questions About Perl ($Revision: 1.11 $, $Date: 2002/12/06 07:40:11 $) =head1 DESCRIPTION @@ -83,7 +83,7 @@ The 5.0 release is, essentially, a ground-up rewrite of the original perl source code from releases 1 through 4. It has been modularized, object-oriented, tweaked, trimmed, and optimized until it almost doesn't look like the old code. However, the interface is mostly the same, and -compatibility with previous releases is very high. +compatibility with previous releases is very high. See L<perltrap/"Perl4 to Perl5 Traps">. To avoid the "what language is perl5?" confusion, some people prefer to @@ -94,14 +94,14 @@ See L<perlhist> for a history of Perl revisions. =head2 What is perl6? -At The Second O'Reilly Open Source Software Convention, Larry Wall +At The Second O'Reilly Open Source Software Convention, Larry Wall announced Perl6 development would begin in earnest. Perl6 was an oft used term for Chip Salzenberg's project to rewrite Perl in C++ named Topaz. However, Topaz provided valuable insights to the next version -of Perl and its implementation, but was ultimately abandoned. +of Perl and its implementation, but was ultimately abandoned. -If you want to learn more about Perl6, or have a desire to help in -the crusade to make Perl a better place then peruse the Perl6 developers +If you want to learn more about Perl6, or have a desire to help in +the crusade to make Perl a better place then peruse the Perl6 developers page at http://dev.perl.org/perl6/ and get involved. Perl6 is not scheduled for release yet, and Perl5 will still be supported diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index 46bdd40f03..22f7ad7ce0 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.17 $, $Date: 2002/11/16 23:33:08 $) +perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.18 $, $Date: 2002/12/06 07:40:11 $) =head1 DESCRIPTION @@ -204,7 +204,7 @@ see their FAQ ( http://www.faqs.org/faqs/alt-sources-intro/ ) for details. If you're just looking for software, first use Google ( http://www.google.com ), Google's usenet search interface -( http://groups.google.com ), and CPAN Search ( http://search.cpan.org ). +( http://groups.google.com ), and CPAN Search ( http://search.cpan.org ). This is faster and more productive than just posting a request. =head2 Perl Books @@ -419,7 +419,7 @@ A comprehensive list of Perl related mailing lists can be found at: =head2 Archives of comp.lang.perl.misc The Google search engine now carries archived and searchable newsgroup -content. +content. http://groups.google.com/groups?group=comp.lang.perl.misc diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 37be251412..7843dbff7d 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq3 - Programming Tools ($Revision: 1.29 $, $Date: 2002/11/13 06:23:50 $) +perlfaq3 - Programming Tools ($Revision: 1.31 $, $Date: 2003/01/03 20:10:11 $) =head1 DESCRIPTION @@ -68,7 +68,7 @@ shows up as "Perl" (although you can get those with Mod::CoreList). use ExtUtils::Installed; - + my $inst = ExtUtils::Installed->new(); my @modules = $inst->modules(); @@ -76,11 +76,11 @@ If you want a list of all of the Perl module filenames, you can use File::Find::Rule. use File::Find::Rule; - + my @files = File::Find::Rule->file()->name( '*.pm' )->in( @INC ); If you do not have that module, you can do the same thing -with File::Find which is part of the standard library. +with File::Find which is part of the standard library. use File::Find; my @files; @@ -89,10 +89,10 @@ with File::Find which is part of the standard library. @INC; print join "\n", @files; - + If you simply need to quickly check to see if a module is available, you can check for its documentation. If you can -read the documentation the module is most likely installed. +read the documentation the module is most likely installed. If you cannot read the documentation, the module might not have any (in rare cases). @@ -102,10 +102,10 @@ You can also try to include the module in a one-liner to see if perl finds it. perl -MModule::Name -e1 - + =head2 How do I debug my Perl programs? -Have you tried C<use warnings> or used C<-w>? They enable warnings +Have you tried C<use warnings> or used C<-w>? They enable warnings to detect dubious practices. Have you tried C<use strict>? It prevents you from using symbolic @@ -131,9 +131,9 @@ why what it's doing isn't what it should be doing. =head2 How do I profile my Perl programs? You should get the Devel::DProf module from the standard distribution -(or separately on CPAN) and also use Benchmark.pm from the standard -distribution. The Benchmark module lets you time specific portions of -your code, while Devel::DProf gives detailed breakdowns of where your +(or separately on CPAN) and also use Benchmark.pm from the standard +distribution. The Benchmark module lets you time specific portions of +your code, while Devel::DProf gives detailed breakdowns of where your code spends its time. Here's a sample use of Benchmark: @@ -167,7 +167,7 @@ of contrasting algorithms. =head2 How do I cross-reference my Perl programs? -The B::Xref module can be used to generate cross-reference reports +The B::Xref module can be used to generate cross-reference reports for Perl programs. perl -MO=Xref[,OPTIONS] scriptname.plx @@ -566,7 +566,7 @@ instead of this: When the files you're processing are small, it doesn't much matter which way you do it, but it makes a huge difference when they start getting -larger. +larger. =item * Use map and grep selectively @@ -641,7 +641,7 @@ everything works out right. return \@a; } - for $i ( 1 .. 10 ) { + for ( 1 .. 10 ) { push @many, makeone(); } @@ -919,7 +919,7 @@ L<perlboot>, L<perltoot>, L<perltooc>, and L<perlbot> for reference. try http://www.perldoc.com/ , but consider upgrading your perl.) A good book on OO on Perl is the "Object-Oriented Perl" -by Damian Conway from Manning Publications, +by Damian Conway from Manning Publications, http://www.manning.com/Conway/index.html =head2 Where can I learn about linking C with Perl? [h2xs, xsubpp] diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod index 7c616aca3d..f7215e2eef 100644 --- a/pod/perlfaq4.pod +++ b/pod/perlfaq4.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq4 - Data Manipulation ($Revision: 1.37 $, $Date: 2002/11/13 06:04:00 $) +perlfaq4 - Data Manipulation ($Revision: 1.39 $, $Date: 2003/01/03 20:06:21 $) =head1 DESCRIPTION @@ -22,12 +22,12 @@ representations and conversions. To limit the number of decimal places in your numbers, you can use the printf or sprintf function. See the -L<perlop|"Floating Point Arithmetic"> for more details. +L<"Floating Point Arithmetic"|perlop> for more details. printf "%.2f", 10/3; - + my $number = sprintf "%.2f", 10/3; - + =head2 Why isn't my octal data interpreted correctly? Perl only understands octal and hex numbers as such when they occur as @@ -43,13 +43,13 @@ The inverse mapping from decimal to octal can be done with either the "%o" or "%O" sprintf() formats. This problem shows up most often when people try using chmod(), mkdir(), -umask(), or sysopen(), which by widespread tradition typically take +umask(), or sysopen(), which by widespread tradition typically take permissions in octal. chmod(644, $file); # WRONG chmod(0644, $file); # right -Note the mistake in the first line was specifying the decimal literal +Note the mistake in the first line was specifying the decimal literal 644, rather than the intended octal literal 0644. The problem can be seen with: @@ -57,7 +57,7 @@ be seen with: Surely you had not intended C<chmod(01204, $file);> - did you? If you want to use numeric literals as arguments to chmod() et al. then please -try to express them as octal constants, that is with a leading zero and +try to express them as octal constants, that is with a leading zero and with the following digits restricted to the set 0..7. =head2 Does Perl have a round() function? What about ceil() and floor()? Trig functions? @@ -94,7 +94,7 @@ alternation: for ($i = 0; $i < 1.01; $i += 0.05) { printf "%.1f ",$i} - 0.0 0.1 0.1 0.2 0.2 0.2 0.3 0.3 0.4 0.4 0.5 0.5 0.6 0.7 0.7 + 0.0 0.1 0.1 0.2 0.2 0.2 0.3 0.3 0.4 0.4 0.5 0.5 0.6 0.7 0.7 0.8 0.8 0.9 0.9 1.0 1.0 Don't blame Perl. It's the same as in C. IEEE says we have to do this. @@ -364,18 +364,18 @@ L<perlfunc/"localtime">): Use the following simple functions: - sub get_century { + sub get_century { return int((((localtime(shift || time))[5] + 1999))/100); - } - sub get_millennium { + } + sub get_millennium { return 1+int((((localtime(shift || time))[5] + 1899))/1000); - } + } You can also use the POSIX strftime() function which may be a bit slower but is easier to read and maintain. use POSIX qw/strftime/; - + my $week_of_the_year = strftime "%W", localtime; my $day_of_the_year = strftime "%j", localtime; @@ -434,9 +434,9 @@ If you only need to find the date (and not the same time), you can use the Date::Calc module. use Date::Calc qw(Today Add_Delta_Days); - + my @date = Add_Delta_Days( Today(), -1 ); - + print "@date\n"; Most people try to use the time rather than the calendar to @@ -452,7 +452,7 @@ throws this off. Russ Allbery offers this solution. my $tdst = (localtime $then)[8] > 0; $then - ($tdst - $ndst) * 60 * 60; } - + Should give you "this time yesterday" in seconds since epoch relative to the first argument or the current time if no argument is given and suitable for passing to localtime or whatever else you need to do with @@ -576,7 +576,7 @@ pull out the smallest nesting parts one at a time: while (s/BEGIN((?:(?!BEGIN)(?!END).)*)END//gs) { # do something with $1 - } + } A more complicated and sneaky approach is to make Perl's regular expression engine do it for you. This is courtesy Dean Inada, and @@ -635,7 +635,7 @@ capabilities. You can access the first characters of a string with substr(). To get the first character, for example, start at position 0 -and grab the string of length 1. +and grab the string of length 1. $string = "Just another Perl Hacker"; @@ -645,11 +645,11 @@ To change part of a string, you can use the optional fourth argument which is the replacement string. substr( $string, 13, 4, "Perl 5.8.0" ); - + You can also use substr() as an lvalue. substr( $string, 13, 4 ) = "Perl 5.8.0"; - + =head2 How do I change the Nth occurrence of something? You have to keep track of N yourself. For example, let's say you want @@ -754,7 +754,7 @@ example, take a data line like this: SAR001,"","Cimetrix, Inc","Bob Smith","CAM",N,8,1,0,7,"Error, Core Dumped" Due to the restriction of the quotes, this is a fairly complex -problem. Thankfully, we have Jeffrey Friedl, author of +problem. Thankfully, we have Jeffrey Friedl, author of I<Mastering Regular Expressions>, to handle these for us. He suggests (assuming your string is contained in $text): @@ -799,10 +799,10 @@ Or more nicely written as: This idiom takes advantage of the C<foreach> loop's aliasing behavior to factor out common code. You can do this -on several strings at once, or arrays, or even the +on several strings at once, or arrays, or even the values of a hash if you use a slice: - # trim whitespace in the scalar, the array, + # trim whitespace in the scalar, the array, # and all the values in the hash foreach ($scalar, @array, @hash{keys %hash}) { s/^\s+//; @@ -812,7 +812,7 @@ values of a hash if you use a slice: =head2 How do I pad a string with blanks or pad a number with zeroes? (This answer contributed by Uri Guttman, with kibitzing from -Bart Lateur.) +Bart Lateur.) In the following examples, C<$pad_len> is the length to which you wish to pad the string, C<$text> or C<$num> contains the string to be padded, @@ -833,7 +833,7 @@ C<$pad_len>. # Right padding a string with blanks (no truncation): $padded = sprintf("%-${pad_len}s", $text); - # Left padding a number with 0 (no truncation): + # Left padding a number with 0 (no truncation): $padded = sprintf("%0${pad_len}d", $num); # Right padding a string with blanks using pack (will truncate): @@ -857,19 +857,19 @@ Left and right padding with any character, modifying C<$text> directly: =head2 How do I extract selected columns from a string? Use substr() or unpack(), both documented in L<perlfunc>. -If you prefer thinking in terms of columns instead of widths, +If you prefer thinking in terms of columns instead of widths, you can use this kind of thing: # determine the unpack format needed to split Linux ps output # arguments are cut columns my $fmt = cut2fmt(8, 14, 20, 26, 30, 34, 41, 47, 59, 63, 67, 72); - sub cut2fmt { + sub cut2fmt { my(@positions) = @_; my $template = ''; my $lastpos = 1; for my $place (@positions) { - $template .= "A" . ($place - $lastpos) . " "; + $template .= "A" . ($place - $lastpos) . " "; $lastpos = $place; } $template .= "A*"; @@ -907,7 +907,7 @@ be, you'd have to do this: It's probably better in the general case to treat those variables as entries in some special hash. For example: - %user_defs = ( + %user_defs = ( foo => 23, bar => 19, ); @@ -921,7 +921,7 @@ of the FAQ. The problem is that those double-quotes force stringification-- coercing numbers and references into strings--even when you don't want them to be strings. Think of it this way: double-quote -expansion is used to produce new strings. If you already +expansion is used to produce new strings. If you already have a string, why do you need more? If you get used to writing odd things like these: @@ -952,7 +952,7 @@ that actually do care about the difference between a string and a number, such as the magical C<++> autoincrement operator or the syscall() function. -Stringification also destroys arrays. +Stringification also destroys arrays. @lines = `command`; print "@lines"; # WRONG - extra blanks @@ -964,15 +964,15 @@ Check for these three things: =over 4 -=item 1. There must be no space after the << part. +=item There must be no space after the << part. -=item 2. There (probably) should be a semicolon at the end. +=item There (probably) should be a semicolon at the end. -=item 3. You can't (easily) have any space in front of the tag. +=item You can't (easily) have any space in front of the tag. =back -If you want to indent the text in the here document, you +If you want to indent the text in the here document, you can do this: # all in one @@ -982,7 +982,7 @@ can do this: HERE_TARGET But the HERE_TARGET must still be flush against the margin. -If you want that indented also, you'll have to quote +If you want that indented also, you'll have to quote in the indentation. ($quote = <<' FINIS') =~ s/^\s+//gm; @@ -1077,7 +1077,7 @@ with @bad[0] = `same program that outputs several lines`; -The C<use warnings> pragma and the B<-w> flag will warn you about these +The C<use warnings> pragma and the B<-w> flag will warn you about these matters. =head2 How can I remove duplicate elements from a list or array? @@ -1233,8 +1233,8 @@ like this one. It uses the CPAN module FreezeThaw: @a = @b = ( "this", "that", [ "more", "stuff" ] ); printf "a and b contain %s arrays\n", - cmpStr(\@a, \@b) == 0 - ? "the same" + cmpStr(\@a, \@b) == 0 + ? "the same" : "different"; This approach also works for comparing hashes. Here @@ -1244,7 +1244,7 @@ we'll demonstrate two different answers: %a = %b = ( "this" => "that", "extra" => [ "more", "stuff" ] ); $a{EXTRA} = \%b; - $b{EXTRA} = \%a; + $b{EXTRA} = \%a; printf "a and b contain %s hashes\n", cmpStr(\%a, \%b) == 0 ? "the same" : "different"; @@ -1264,9 +1264,9 @@ use the first() function in the List::Util module, which comes with Perl 5.8. This example finds the first element that contains "Perl". use List::Util qw(first); - + my $element = first { /Perl/ } @array; - + If you cannot use List::Util, you can make your own loop to do the same thing. Once you find the element, you stop the loop with last. @@ -1280,13 +1280,13 @@ If you want the array index, you can iterate through the indices and check the array element at each index until you find one that satisfies the condition. - my( $found, $i ) = ( undef, -1 ); - for( $i = 0; $i < @array; $i++ ) + my( $found, $index ) = ( undef, -1 ); + for( $i = 0; $i < @array; $i++ ) { - if( $array[$i] =~ /Perl/ ) - { + if( $array[$i] =~ /Perl/ ) + { $found = $array[$i]; - $index = $i; + $index = $i; last; } } @@ -1408,7 +1408,7 @@ Here's another; let's compute spherical volumes: $_ **= 3; $_ *= (4/3) * 3.14159; # this will be constant folded } - + which can also be done with map() which is made to transform one list into another: @@ -1420,7 +1420,7 @@ the values are not copied, so if you modify $orbit (in this case), you modify the value. for $orbit ( values %orbits ) { - ($orbit **= 3) *= (4/3) * 3.14159; + ($orbit **= 3) *= (4/3) * 3.14159; } Prior to perl 5.6 C<values> returned copies of the values, @@ -1440,7 +1440,7 @@ Use the rand() function (see L<perlfunc/rand>): $element = $array[$index]; Make sure you I<only call srand once per program, if then>. -If you are calling it more than once (such as before each +If you are calling it more than once (such as before each call to rand), you're almost certainly doing something wrong. =head2 How do I permute N elements of a list? @@ -1456,6 +1456,14 @@ on CPAN). It's written in XS code and is very efficient. print "next permutation: (@perm)\n"; } +For even faster execution, you could do: + + use Algorithm::Permute; + my @array = 'a'..'d'; + Algorithm::Permute::permute { + print "next permutation: (@array)\n"; + } @array; + Here's a little program that generates all permutations of all the words on each line of input. The algorithm embodied in the permute() function is discussed in Volume 4 (still @@ -1585,13 +1593,13 @@ Or use the CPAN module Bit::Vector: @ints = $vector->Index_List_Read(); Bit::Vector provides efficient methods for bit vector, sets of small integers -and "big int" math. +and "big int" math. Here's a more extensive illustration using vec(): # vec demo $vector = "\xff\x0f\xef\xfe"; - print "Ilya's string \\xff\\x0f\\xef\\xfe represents the number ", + print "Ilya's string \\xff\\x0f\\xef\\xfe represents the number ", unpack("N", $vector), "\n"; $is_set = vec($vector, 23, 1); print "Its 23rd bit is ", $is_set ? "set" : "clear", ".\n"; @@ -1611,7 +1619,7 @@ Here's a more extensive illustration using vec(): set_vec(0,32,17); set_vec(1,32,17); - sub set_vec { + sub set_vec { my ($offset, $width, $value) = @_; my $vector = ''; vec($vector, $offset, $width) = $value; @@ -1628,7 +1636,7 @@ Here's a more extensive illustration using vec(): print "vector length in bytes: ", length($vector), "\n"; @bytes = unpack("A8" x length($vector), $bits); print "bits are: @bytes\n\n"; - } + } =head2 Why does defined() return true on empty arrays and hashes? @@ -1695,8 +1703,8 @@ use the keys() function in a scalar context: $num_keys = keys %hash; -The keys() function also resets the iterator, which means that you may -see strange results if you use this between uses of other hash operators +The keys() function also resets the iterator, which means that you may +see strange results if you use this between uses of other hash operators such as each(). =head2 How do I sort a hash (optionally by value instead of key)? @@ -1967,10 +1975,10 @@ if you just want to say, ``Is this a float?'' return undef; } else { return $num; - } - } + } + } - sub is_numeric { defined getnum($_[0]) } + sub is_numeric { defined getnum($_[0]) } Or you could check out the L<String::Scanf|String::Scanf> module on the CPAN instead. The POSIX module (part of the standard Perl distribution) provides @@ -1985,10 +1993,10 @@ or Storable modules from CPAN. Starting from Perl 5.8 Storable is part of the standard distribution. Here's one example using Storable's C<store> and C<retrieve> functions: - use Storable; + use Storable; store(\%hash, "filename"); - # later on... + # later on... $href = retrieve("filename"); # by ref %hash = %{ retrieve("filename") }; # direct to hash @@ -1998,7 +2006,7 @@ The Data::Dumper module on CPAN (or the 5.005 release of Perl) is great for printing out data structures. The Storable module, found on CPAN, provides a function called C<dclone> that recursively copies its argument. - use Storable qw(dclone); + use Storable qw(dclone); $r2 = dclone($r1); Where $r1 can be a reference to any kind of data structure you'd like. diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index ca2fb7e87c..c04f3c6872 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq5 - Files and Formats ($Revision: 1.26 $, $Date: 2002/09/21 21:04:17 $) +perlfaq5 - Files and Formats ($Revision: 1.27 $, $Date: 2002/12/06 07:40:11 $) =head1 DESCRIPTION @@ -30,7 +30,7 @@ value, Perl will flush the handle's buffer after each print() or write(). Setting $| affects buffering only for the currently selected default file handle. You choose this handle with the one argument select() call (see -L<perlvar/$|> and L<perlfunc/select>). +L<perlvar/$E<verbar>> and L<perlfunc/select>). Use select() to choose the desired handle, then set its per-filehandle variables. @@ -110,7 +110,7 @@ C<.c.orig> file. Use the File::Temp module, see L<File::Temp> for more information. - use File::Temp qw/ tempfile tempdir /; + use File::Temp qw/ tempfile tempdir /; $dir = tempdir( CLEANUP => 1 ); ($fh, $filename) = tempfile( DIR => $dir ); @@ -164,7 +164,7 @@ Berkeley-style ps: # 15158 p5 T 0:00 perl /home/tchrist/scripts/now-what $PS_T = 'A6 A4 A7 A5 A*'; open(PS, "ps|"); - print scalar <PS>; + print scalar <PS>; while (<PS>) { ($pid, $tt, $stat, $time, $command) = unpack($PS_T, $_); for $var (qw!pid tt stat time command!) { @@ -282,9 +282,9 @@ an expression where you would place the filehandle: That block is a proper block like any other, so you can put more complicated code there. This sends the message out to one of two places: - $ok = -x "/bin/cat"; + $ok = -x "/bin/cat"; print { $ok ? $fd[1] : $fd[2] } "cat stat $ok\n"; - print { $fd[ 1+ ($ok || 0) ] } "cat stat $ok\n"; + print { $fd[ 1+ ($ok || 0) ] } "cat stat $ok\n"; This approach of treating C<print> and C<printf> like object methods calls doesn't work for the diamond operator. That's because it's a @@ -369,7 +369,7 @@ I<then> gives you read-write access: open(FH, "+> /path/name"); # WRONG (almost always) Whoops. You should instead use this, which will fail if the file -doesn't exist. +doesn't exist. open(FH, "+< /path/name"); # open for update @@ -458,11 +458,11 @@ best therefore to use glob() only in list context. Normally perl ignores trailing blanks in filenames, and interprets certain leading characters (or a trailing "|") to mean something -special. +special. The three argument form of open() lets you specify the mode separately from the filename. The open() function treats -special mode characters and whitespace in the filename as +special mode characters and whitespace in the filename as literals open FILE, "<", " file "; # filename is " file " @@ -532,7 +532,7 @@ for your own system's idiosyncrasies (sometimes called "features"). Slavish adherence to portability concerns shouldn't get in the way of your getting your job done.) -For more information on file locking, see also +For more information on file locking, see also L<perlopentut/"File Locking"> if you have it (new for 5.6). =back @@ -699,7 +699,7 @@ to each filehandle. You can use the File::Slurp module to do it in one step. use File::Slurp; - + $all_of_it = read_file($filename); # entire file in scalar @all_lines = read_file($filename); # one line perl element @@ -710,7 +710,7 @@ do so one line at a time: while (<INPUT>) { chomp; # do something with $_ - } + } close(INPUT) || die "can't close $file: $!"; This is tremendously more efficient than reading the entire file into @@ -735,7 +735,7 @@ You can read the entire filehandle contents into a scalar. $var = <INPUT>; } -That temporarily undefs your record separator, and will automatically +That temporarily undefs your record separator, and will automatically close the file at block exit. If the file is already open, just use this: $var = do { local $/; <INPUT> }; @@ -754,7 +754,7 @@ set it to C<""> to eliminate empty paragraphs (C<"abc\n\n\n\ndef">, 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 +Note that a blank line must have no blanks in it. Thus 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? @@ -931,7 +931,7 @@ Or even with a literal numeric descriptor: Note that "<&STDIN" makes a copy, but "<&=STDIN" make an alias. That means if you close an aliased handle, all -aliases become inaccessible. This is not true with +aliases become inaccessible. This is not true with a copied one. Error checking, as always, has been left as an exercise for the reader. @@ -949,8 +949,8 @@ to, you may be able to do this: Or, just use the fdopen(3S) feature of open(): - { - local *F; + { + local *F; open F, "<&=$fd" or die "Cannot reopen fd=$fd: $!"; close F; } diff --git a/pod/perlfaq6.pod b/pod/perlfaq6.pod index cf3a8fb7ca..9bbf80a018 100644 --- a/pod/perlfaq6.pod +++ b/pod/perlfaq6.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq6 - Regular Expressions ($Revision: 1.18 $, $Date: 2002/10/30 18:44:21 $) +perlfaq6 - Regular Expressions ($Revision: 1.20 $, $Date: 2003/01/03 20:05:28 $) =head1 DESCRIPTION @@ -8,7 +8,7 @@ This section is surprisingly small because the rest of the FAQ is littered with answers involving regular expressions. For example, decoding a URL and checking whether something is a number are handled with regular expressions, but those answers are found elsewhere in -this document (in L<perlfaq9>: ``How do I decode or create those %-encodings +this document (in L<perlfaq9>: ``How do I decode or create those %-encodings on the web'' and L<perlfaq4>: ``How do I determine whether a scalar is a number/whole/integer/float'', to be precise). @@ -143,16 +143,16 @@ Here's another example of using C<..>: # now choose between them } continue { reset if eof(); # fix $. - } + } =head2 I put a regular expression into $/ but it didn't work. What's wrong? -As of Perl 5.8.0, $/ has to be a string. This may change in 5.10, +Up to Perl 5.8.0, $/ has to be a string. This may change in 5.10, but don't get your hopes up. Until then, you can use these examples if you really need to do this. -Use the four argument form of sysread to continually add to -a buffer. After you add to the buffer, you check if you have a +Use the four argument form of sysread to continually add to +a buffer. After you add to the buffer, you check if you have a complete line (using your regular expression). local $_ = ""; @@ -162,11 +162,11 @@ complete line (using your regular expression). # do stuff here. } } - + You can do the same thing with foreach and a match using the c flag and the \G anchor, if you do not mind your entire file being in memory at the end. - + local $_ = ""; while( sysread FH, $_, 8192, length ) { foreach my $record ( m/\G((?s).*?)your_pattern/gc ) { @@ -201,7 +201,7 @@ And here it is as a subroutine, modeled after the above: my $mask = uc $old ^ $old; uc $new | $mask . - substr($mask, -1) x (length($new) - length($old)) + substr($mask, -1) x (length($new) - length($old)) } $a = "this is a TEsT case"; @@ -280,8 +280,8 @@ documented in L<perlre>. No matter which locale you are in, the alphabetic characters are the characters in \w without the digits and the underscore. As a regex, that looks like C</[^\W\d_]/>. Its complement, -the non-alphabetics, is then everything in \W along with -the digits and the underscore, or C</[\W\d_]/>. +the non-alphabetics, is then everything in \W along with +the digits and the underscore, or C</[\W\d_]/>. =head2 How can I quote a variable to use in a regex? @@ -442,9 +442,9 @@ playing hot potato. Use the split function: while (<>) { - foreach $word ( split ) { + foreach $word ( split ) { # do something with $word here - } + } } Note that this isn't really a word in the English sense; it's just @@ -478,7 +478,7 @@ in the previous question: If you wanted to do the same thing for lines, you wouldn't need a regular expression: - while (<>) { + while (<>) { $seen{$_}++; } while ( ($line, $count) = each %seen ) { @@ -500,12 +500,12 @@ The following is extremely inefficient: @popstates = qw(CO ON MI WI MN); while (defined($line = <>)) { for $state (@popstates) { - if ($line =~ /\b$state\b/i) { + if ($line =~ /\b$state\b/i) { print $line; last; } } - } + } That's because Perl has to recompile all those patterns for each of the lines of the file. As of the 5.005 release, there's a much better @@ -602,7 +602,7 @@ still need the C<g> flag. { print "Found $1\n"; } - + After the match fails at the letter C<a>, perl resets pos() and the next match on the same string starts at the beginning. @@ -648,7 +648,7 @@ which works in 5.004 or later. For each line, the PARSER loop first tries to match a series of digits followed by a word boundary. This match has to start at the place the last match left off (or the beginning -of the string on the first match). Since C<m/ \G( \d+\b +of the string on the first match). Since C<m/ \G( \d+\b )/gcx> uses the C<c> flag, if the string does not match that regular expression, perl does not reset pos() and the next match starts at the same position to try a different @@ -737,7 +737,7 @@ Goldberg: (?:[A-Z][A-Z])*? GX /x; - + This succeeds if the "martian" character GX is in the string, and fails otherwise. If you don't like using (?!<), you can replace (?!<[A-Z]) with (?:^|[^A-Z]). diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod index 23a1f556a8..6eb2a6b4bf 100644 --- a/pod/perlfaq7.pod +++ b/pod/perlfaq7.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq7 - General Perl Language Issues ($Revision: 1.11 $, $Date: 2002/11/10 17:35:47 $) +perlfaq7 - General Perl Language Issues ($Revision: 1.12 $, $Date: 2002/12/06 07:40:11 $) =head1 DESCRIPTION @@ -38,7 +38,7 @@ really type specifiers: Note that <FILE> is I<neither> the type specifier for files nor the name of the handle. It is the C<< <> >> operator applied to the handle FILE. It reads one line (well, record--see -L<perlvar/$/>) from the handle FILE in scalar context, or I<all> lines +L<perlvar/$E<sol>>) from the handle FILE in scalar context, or I<all> lines in list context. When performing open, close, or any other operation besides C<< <> >> on files, or even when talking about the handle, do I<not> use the brackets. These are correct: C<eof(FH)>, C<seek(FH, 0, @@ -81,7 +81,7 @@ One way is to treat the return values as a list and index into it: Another way is to use undef as an element on the left-hand-side: ($dev, $ino, undef, undef, $uid, $gid) = stat($file); - + You can also use a list slice to select only the elements that you need: @@ -308,13 +308,13 @@ which you treat as any other scalar. open my $fh, $filename or die "Cannot open $filename! $!"; func( $fh ); - + sub func { my $passed_fh = shift; - + my $line = <$fh>; } - + Before Perl 5.6, you had to use the C<*FH> or C<\*FH> notations. These are "typeglobs"--see L<perldata/"Typeglobs and Filehandles"> and especially L<perlsub/"Pass by Reference"> for more information. @@ -475,7 +475,7 @@ In summary, local() doesn't make what you think of as private, local variables. It gives a global variable a temporary value. my() is what you're looking for if you want private variables. -See L<perlsub/"Private Variables via my()"> and +See L<perlsub/"Private Variables via my()"> and L<perlsub/"Temporary Values via local()"> for excruciating details. =head2 How can I access a dynamic variable while a similarly named lexical is in scope? @@ -603,7 +603,7 @@ construct like this: elsif (/pat2/) { } # do something else elsif (/pat3/) { } # do something else else { } # default - } + } Here's a simple example of a switch based on pattern matching, this time lined up in a way to make it look more like a switch statement. @@ -640,7 +640,7 @@ in $whatchamacallit: } -See C<perlsyn/"Basic BLOCKs and Switch Statements"> for many other +See C<perlsyn/"Basic BLOCKs and Switch Statements"> for many other examples in this style. Sometimes you should change the positions of the constant and the variable. @@ -658,7 +658,7 @@ C<"STOP"> here: elsif ("LIST" =~ /^\Q$answer/i) { print "Action is list\n" } elsif ("EDIT" =~ /^\Q$answer/i) { print "Action is edit\n" } -A totally different approach is to create a hash of function references. +A totally different approach is to create a hash of function references. my %commands = ( "happy" => \&joy, @@ -673,7 +673,7 @@ A totally different approach is to create a hash of function references. $commands{$string}->(); } else { print "No such command: $string\n"; - } + } =head2 How can I catch accesses to undefined variables, functions, or methods? @@ -761,7 +761,7 @@ Use this code, provided by Mark-Jason Dominus: sub scrub_package { no strict 'refs'; my $pack = shift; - die "Shouldn't delete main package" + die "Shouldn't delete main package" if $pack eq "" || $pack eq "main"; my $stash = *{$pack . '::'}{HASH}; my $name; @@ -776,7 +776,7 @@ Use this code, provided by Mark-Jason Dominus: } } -Or, if you're using a recent release of Perl, you can +Or, if you're using a recent release of Perl, you can just use the Symbol::delete_package() function instead. =head2 How can I use a variable as a variable name? @@ -844,7 +844,7 @@ wanted to use another scalar variable to refer to those by name. $name = "fred"; $$name{WIFE} = "wilma"; # set %fred - $name = "barney"; + $name = "barney"; $$name{WIFE} = "betty"; # set %barney This is still a symbolic reference, and is still saddled with the @@ -868,7 +868,7 @@ can play around with the symbol table. For example: for my $name (@colors) { no strict 'refs'; # renege for the block *$name = sub { "<FONT COLOR='$name'>@_</FONT>" }; - } + } All those functions (red(), blue(), green(), etc.) appear to be separate, but the real code in the closure actually was compiled only once. diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod index e00d007912..31af4bd7df 100644 --- a/pod/perlfaq8.pod +++ b/pod/perlfaq8.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq8 - System Interaction ($Revision: 1.14 $, $Date: 2002/11/10 17:35:47 $) +perlfaq8 - System Interaction ($Revision: 1.16 $, $Date: 2003/01/03 20:03:57 $) =head1 DESCRIPTION @@ -77,7 +77,7 @@ Or like this: Controlling input buffering is a remarkably system-dependent matter. On many systems, you can just use the B<stty> command as shown in L<perlfunc/getc>, but as you see, that's already getting you into -portability snags. +portability snags. open(TTY, "+</dev/tty") or die "no tty: $!"; system "stty cbreak </dev/tty >/dev/tty 2>&1"; @@ -188,14 +188,14 @@ positions, etc, you might wish to use Term::Cap module: =head2 How do I get the screen size? -If you have Term::ReadKey module installed from CPAN, +If you have Term::ReadKey module installed from CPAN, you can use it to fetch the width and height in characters and in pixels: use Term::ReadKey; ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize(); -This is more portable than the raw C<ioctl>, but not as +This is more portable than the raw C<ioctl>, but not as illustrative: require 'sys/ioctl.ph'; @@ -275,7 +275,7 @@ next. If you expect characters to get to your device when you print() them, you'll want to autoflush that filehandle. You can use select() -and the C<$|> variable to control autoflushing (see L<perlvar/$|> +and the C<$|> variable to control autoflushing (see L<perlvar/$E<verbar>> and L<perlfunc/select>, or L<perlfaq5>, ``How do I flush/unbuffer an output filehandle? Why must I do this?''): @@ -383,11 +383,11 @@ not an issue with C<system("cmd&")>. You have to be prepared to "reap" the child process when it finishes. $SIG{CHLD} = sub { wait }; - + $SIG{CHLD} = 'IGNORE'; - -You can also use a double fork. You immediately wait() for your -first child, and the init daemon will wait() for your grandchild once + +You can also use a double fork. You immediately wait() for your +first child, and the init daemon will wait() for your grandchild once it exits. unless ($pid = fork) { @@ -445,8 +445,8 @@ If perl was installed correctly and your shadow library was written properly, the getpw*() functions described in L<perlfunc> should in theory provide (read-only) access to entries in the shadow password file. To change the file, make a new shadow password file (the format -varies from system to system--see L<passwd(5)> for specifics) and use -pwd_mkdb(8) to install it (see L<pwd_mkdb(8)> for more details). +varies from system to system--see L<passwd> for specifics) and use +pwd_mkdb(8) to install it (see L<pwd_mkdb> for more details). =head2 How do I set the time and date? @@ -511,14 +511,14 @@ something like this: Release 5 of Perl added the END block, which can be used to simulate atexit(). Each package's END block is called when the program or -thread ends (see L<perlmod> manpage for more details). +thread ends (see L<perlmod> manpage for more details). For example, you can use this to make sure your filter program managed to finish its output without filling up the disk: END { close(STDOUT) || die "stdout close failed: $!"; - } + } The END block isn't called when untrapped signals kill the program, though, so if you use END blocks you should also use @@ -556,7 +556,10 @@ syscall(), you can use the syscall function (documented in L<perlfunc>). Remember to check the modules that came with your distribution, and -CPAN as well--someone may already have written a module to do it. +CPAN as well---someone may already have written a module to do it. On +Windows, try Win32::API. On Macs, try Mac::Carbon. If no module +has an interface to the C function, you can inline a bit of C in your +Perl source with Inline::C. =head2 Where do I get the include files to do ioctl() or syscall()? @@ -594,8 +597,8 @@ scripts inherently insecure. Perl gives you a number of options The IPC::Open2 module (part of the standard perl distribution) is an easy-to-use approach that internally uses pipe(), fork(), and exec() to do the job. Make sure you read the deadlock warnings in its documentation, -though (see L<IPC::Open2>). See -L<perlipc/"Bidirectional Communication with Another Process"> and +though (see L<IPC::Open2>). See +L<perlipc/"Bidirectional Communication with Another Process"> and L<perlipc/"Bidirectional Communication with Yourself"> You may also use the IPC::Open3 module (part of the standard perl @@ -783,7 +786,7 @@ Strictly speaking, nothing. Stylistically speaking, it's not a good way to write maintainable code. Perl has several operators for running external commands. Backticks are one; they collect the output from the command for use in your program. The C<system> function is -another; it doesn't do this. +another; it doesn't do this. Writing backticks in your program sends a clear message to the readers of your code that you wanted to collect the output of the command. @@ -944,7 +947,7 @@ different process from the shell it was started from. Changes to a process are not reflected in its parent--only in any children created after the change. There is shell magic that may allow you to fake it by eval()ing the script's output in your shell; check out the -comp.unix.questions FAQ for details. +comp.unix.questions FAQ for details. =back @@ -965,7 +968,7 @@ module for other solutions. =item * -Open /dev/tty and use the TIOCNOTTY ioctl on it. See L<tty(4)> +Open /dev/tty and use the TIOCNOTTY ioctl on it. See L<tty> for details. Or better yet, you can just use the POSIX::setsid() function, so you don't have to worry about process groups. @@ -1044,7 +1047,7 @@ sample code) and then have a signal handler for the INT signal that passes the signal on to the subprocess. Or you can check for it: $rc = system($cmd); - if ($rc & 127) { die "signal death" } + if ($rc & 127) { die "signal death" } =head2 How do I open a file without blocking? @@ -1060,16 +1063,16 @@ sysopen(): =head2 How do I install a module from CPAN? The easiest way is to have a module also named CPAN do it for you. -This module comes with perl version 5.004 and later. +This module comes with perl version 5.004 and later. $ perl -MCPAN -e shell cpan shell -- CPAN exploration and modules installation (v1.59_54) ReadLine support enabled - cpan> install Some::Module + cpan> install Some::Module -To manually install the CPAN module, or any well-behaved CPAN module +To manually install the CPAN module, or any well-behaved CPAN module for that matter, follow these steps: =over 4 @@ -1176,7 +1179,7 @@ but other times it is not. Modern programs C<use Socket;> instead. =head1 AUTHOR AND COPYRIGHT -Copyright (c) 1997-2002 Tom Christiansen and Nathan Torkington. +Copyright (c) 1997-2003 Tom Christiansen and Nathan Torkington. All rights reserved. This documentation is free; you can redistribute it and/or modify it diff --git a/pod/perlfaq9.pod b/pod/perlfaq9.pod index e4206bba15..ec0a4f5b74 100644 --- a/pod/perlfaq9.pod +++ b/pod/perlfaq9.pod @@ -1,6 +1,6 @@ =head1 NAME -perlfaq9 - Networking ($Revision: 1.13 $, $Date: 2002/11/13 06:07:58 $) +perlfaq9 - Networking ($Revision: 1.14 $, $Date: 2002/12/06 07:40:11 $) =head1 DESCRIPTION @@ -11,10 +11,10 @@ and a few on the web. (Alan Flavell <flavell+www@a5.ph.gla.ac.uk> answers...) -The Common Gateway Interface (CGI) specifies a software interface between -a program ("CGI script") and a web server (HTTPD). It is not specific -to Perl, and has its own FAQs and tutorials, and usenet group, -comp.infosystems.www.authoring.cgi +The Common Gateway Interface (CGI) specifies a software interface between +a program ("CGI script") and a web server (HTTPD). It is not specific +to Perl, and has its own FAQs and tutorials, and usenet group, +comp.infosystems.www.authoring.cgi The original CGI specification is at: http://hoohoo.ncsa.uiuc.edu/cgi/ @@ -22,9 +22,9 @@ Current best-practice RFC draft at: http://CGI-Spec.Golux.Com/ Other relevant documentation listed in: http://www.perl.org/CGI_MetaFAQ.html -These Perl FAQs very selectively cover some CGI issues. However, Perl +These Perl FAQs very selectively cover some CGI issues. However, Perl programmers are strongly advised to use the CGI.pm module, to take care -of the details for them. +of the details for them. The similarity between CGI response headers (defined in the CGI specification) and HTTP response headers (defined in the HTTP @@ -53,7 +53,7 @@ Perl CGI scripts" guide at http://www.perl.org/troubleshooting_CGI.html -If, after that, you can demonstrate that you've read the FAQs and that +If, after that, you can demonstrate that you've read the FAQs and that your problem isn't something simple that can be easily answered, you'll probably receive a courteous and useful reply to your question if you post it on comp.infosystems.www.authoring.cgi (if it's something to do @@ -61,7 +61,7 @@ with HTTP or the CGI protocols). Questions that appear to be Perl questions but are really CGI ones that are posted to comp.lang.perl.misc are not so well received. -The useful FAQs, related documents, and troubleshooting guides are +The useful FAQs, related documents, and troubleshooting guides are listed in the CGI Meta FAQ: http://www.perl.org/CGI_MetaFAQ.html @@ -150,19 +150,19 @@ on text like this: You can easily extract all sorts of URLs from HTML with C<HTML::SimpleLinkExtor> which handles anchors, images, objects, -frames, and many other tags that can contain a URL. If you need -anything more complex, you can create your own subclass of -C<HTML::LinkExtor> or C<HTML::Parser>. You might even use +frames, and many other tags that can contain a URL. If you need +anything more complex, you can create your own subclass of +C<HTML::LinkExtor> or C<HTML::Parser>. You might even use C<HTML::SimpleLinkExtor> as an example for something specifically suited to your needs. You can use URI::Find to extract URLs from an arbitrary text document. -Less complete solutions involving regular expressions can save +Less complete solutions involving regular expressions can save you a lot of processing time if you know that the input is simple. One solution from Tom Christiansen runs 100 times faster than most module based approaches but only extracts URLs from anchors where the first -attribute is HREF and there are no other attributes. +attribute is HREF and there are no other attributes. #!/usr/bin/perl -n00 # qxurl - tchrist@perl.com @@ -297,9 +297,9 @@ redirection is handled by the local web server. print redirect($url); -But if coded directly, it could be as follows (the final "\n" is +But if coded directly, it could be as follows (the final "\n" is shown separately, for clarity), using either a complete URL or -an absolute URLpath. +an absolute URLpath. print "Location: $url\n"; # CGI response header print "\n"; # end of headers @@ -551,7 +551,7 @@ MIME::Lite also includes a method for sending these things. $msg->send; -This defaults to using L<sendmail(1)> but can be customized to use +This defaults to using L<sendmail> but can be customized to use SMTP via L<Net::SMTP>. =head2 How do I read mail? diff --git a/pod/perlre.pod b/pod/perlre.pod index 85ce658791..17a94252cf 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -6,7 +6,7 @@ perlre - Perl regular expressions This page describes the syntax of regular expressions in Perl. -if you haven't used regular expressions before, a quick-start +If you haven't used regular expressions before, a quick-start introduction is available in L<perlrequick>, and a longer tutorial introduction is available in L<perlretut>. @@ -564,7 +564,7 @@ only for fixed-width look-behind. B<WARNING>: This extended regular expression feature is considered highly experimental, and may be changed or deleted without notice. -This zero-width assertion evaluate any embedded Perl code. It +This zero-width assertion evaluates any embedded Perl code. It always succeeds, and its C<code> is not interpolated. Currently, the rules to determine where the C<code> ends are somewhat convoluted. @@ -627,7 +627,7 @@ although it could raise an exception from an illegal pattern. If you turn on the C<use re 'eval'>, though, it is no longer secure, so you should only do so if you are also using taint checking. Better yet, use the carefully constrained evaluation within a Safe -module. See L<perlsec> for details about both these mechanisms. +compartment. See L<perlsec> for details about both these mechanisms. =item C<(??{ code })> diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 1a71142fea..08235c2cb4 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1105,8 +1105,9 @@ and B<-C> filetests are based on this value. =item ${^TAINT} -Reflects if taint mode is on or off (i.e. if the program was run with -B<-T> or not). True for on, false for off. +Reflects if taint mode is on or off. 1 for on (the program was run with +B<-T>), 0 for off, -1 when only taint warnings are enabled (i.e. with +B<-t> or B<-TU>). This variable is read-only. =item $PERL_VERSION @@ -1015,6 +1015,16 @@ PP(pp_flop) /* Control. */ +static char *context_name[] = { + "pseudo-block", + "subroutine", + "eval", + "loop", + "substitution", + "block", + "format" +}; + STATIC I32 S_dopoptolabel(pTHX_ char *label) { @@ -1025,30 +1035,16 @@ S_dopoptolabel(pTHX_ char *label) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s", - OP_NAME(PL_op)); - break; case CXt_SUB: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s", - OP_NAME(PL_op)); - break; case CXt_FORMAT: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s", - OP_NAME(PL_op)); - break; case CXt_EVAL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s", - OP_NAME(PL_op)); - break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s", - OP_NAME(PL_op)); - return -1; + Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if (CxTYPE(cx) == CXt_NULL) + return -1; + break; case CXt_LOOP: if (!cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { @@ -1160,30 +1156,16 @@ S_dopoptoloop(pTHX_ I32 startingblock) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s", - OP_NAME(PL_op)); - break; case CXt_SUB: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s", - OP_NAME(PL_op)); - break; case CXt_FORMAT: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s", - OP_NAME(PL_op)); - break; case CXt_EVAL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s", - OP_NAME(PL_op)); - break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s", - OP_NAME(PL_op)); - return -1; + Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if ((CxTYPE(cx)) == CXt_NULL) + return -1; + break; case CXt_LOOP: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; @@ -1820,7 +1802,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV *nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%s did not return a true value", SvPVX(nsv)); + DIE(aTHX_ "%"SVf" did not return a true value", nsv); } break; case CXt_FORMAT: @@ -2048,11 +2030,15 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) continue; - if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && - (ops == opstack || - (ops[-1]->op_type != OP_NEXTSTATE && - ops[-1]->op_type != OP_DBSTATE))) - *ops++ = kid; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + if (ops == opstack) + *ops++ = kid; + else if (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE) + ops[-1] = kid; + else + *ops++ = kid; + } if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } @@ -2108,7 +2094,7 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr)); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -3363,7 +3349,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV *nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv)); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); /* die_where() did LEAVE, or we won't be here */ } else { @@ -2696,7 +2696,7 @@ try_autoload: else { sub_name = sv_newmortal(); gv_efullname3(sub_name, gv, Nullch); - DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name)); + DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name); } } if (!cv) @@ -2713,8 +2713,8 @@ Perl_sub_crush_depth(pTHX_ CV *cv) else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"", - SvPVX(tmpstr)); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", + tmpstr); } } @@ -2730,7 +2730,7 @@ PP(pp_aelem) SV *sv; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv); if (elem > 0) elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) @@ -1455,8 +1455,8 @@ PP(pp_sort) else if (gv) { SV *tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - DIE(aTHX_ "Undefined sort subroutine \"%s\" called", - SvPVX(tmpstr)); + DIE(aTHX_ "Undefined sort subroutine \"%"SVf"\" called", + tmpstr); } else { DIE(aTHX_ "Undefined subroutine in sort"); @@ -762,7 +762,6 @@ PP(pp_tie) char *methname; int how = PERL_MAGIC_tied; U32 items; - STRLEN n_a; varsv = *++MARK; switch(SvTYPE(varsv)) { @@ -809,8 +808,8 @@ PP(pp_tie) */ stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { - DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,n_a)); + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", + methname, *MARK); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -1364,21 +1363,8 @@ PP(pp_leavewrite) fp = IoOFP(io); if (!fp) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) { - /* integrate with 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_ packWARN(WARN_IO), - "Filehandle %s opened only for input", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for input"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } @@ -1451,20 +1437,8 @@ PP(pp_prtf) } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - /* integrate with report_evil_fh()? */ - if (IoIFP(io)) { - char *name = NULL; - if (isGV(gv)) { - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for input", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for input"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } @@ -1691,21 +1665,7 @@ PP(pp_sysread) } if (count < 0) { if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) - { - /* integrate with 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_ packWARN(WARN_IO), - "Filehandle %s opened only for output", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for output"); - } + report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); goto say_undef; } SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv))); @@ -548,6 +548,7 @@ Perl_save_clearsv(pTHX_ SV **svp) SSCHECK(2); SSPUSHLONG((long)(svp-PL_curpad)); SSPUSHINT(SAVEt_CLEARSV); + SvPADSTALE_off(*svp); /* mark lexical as active */ } void @@ -918,16 +919,19 @@ Perl_leave_scope(pTHX_ I32 base) (void)SvOOK_off(sv); break; } + SvPADSTALE_on(sv); /* mark as no longer live */ } else { /* Someone has a claim on this, so abandon it. */ - U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP); + U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP); switch (SvTYPE(sv)) { /* Console ourselves with a new value */ case SVt_PVAV: *(SV**)ptr = (SV*)newAV(); break; case SVt_PVHV: *(SV**)ptr = (SV*)newHV(); break; default: *(SV**)ptr = NEWSV(0,0); break; } SvREFCNT_dec(sv); /* Cast current value to the winds. */ - SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */ + /* preserve pad nature, but also mark as not live + * for any closure capturing */ + SvFLAGS(*(SV**)ptr) |= padflags & SVs_PADSTALE; } break; case SAVEt_DELETE: @@ -3762,7 +3762,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) switch (SvTYPE(sref)) { case SVt_PVAV: if (intro) - SAVESPTR(GvAV(dstr)); + SAVEGENERICSV(GvAV(dstr)); else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; @@ -3774,7 +3774,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; case SVt_PVHV: if (intro) - SAVESPTR(GvHV(dstr)); + SAVEGENERICSV(GvHV(dstr)); else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; @@ -3792,7 +3792,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvCVGEN(dstr) = 0; /* Switch off cacheness. */ PL_sub_generation++; } - SAVESPTR(GvCV(dstr)); + SAVEGENERICSV(GvCV(dstr)); } else dref = (SV*)GvCV(dstr); @@ -3842,21 +3842,21 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; case SVt_PVIO: if (intro) - SAVESPTR(GvIOp(dstr)); + SAVEGENERICSV(GvIOp(dstr)); else dref = (SV*)GvIOp(dstr); GvIOp(dstr) = (IO*)sref; break; case SVt_PVFM: if (intro) - SAVESPTR(GvFORM(dstr)); + SAVEGENERICSV(GvFORM(dstr)); else dref = (SV*)GvFORM(dstr); GvFORM(dstr) = (CV*)sref; break; default: if (intro) - SAVESPTR(GvSV(dstr)); + SAVEGENERICSV(GvSV(dstr)); else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; @@ -3869,8 +3869,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (dref) SvREFCNT_dec(dref); - if (intro) - SAVEFREESV(sref); if (SvTAINTED(sstr)) SvTAINT(dstr); return; @@ -6913,7 +6911,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv); break; } return io; @@ -6994,7 +6992,8 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", + sv); } return GvCVu(gv); } @@ -8720,8 +8719,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!args && ckWARN(WARN_PRINTF) && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); - Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", - (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", + (PL_op->op_type == OP_PRTF) ? "" : "s"); if (c) { if (isPRINT(c)) Perl_sv_catpvf(aTHX_ msg, @@ -9348,6 +9347,18 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if (dstr) return dstr; + if(param->flags & CLONEf_JOIN_IN) { + /** We are joining here so we don't want do clone + something that is bad **/ + + if(SvTYPE(sstr) == SVt_PVHV && + HvNAME(sstr)) { + /** don't clone stashes if they already exist **/ + HV* old_stash = gv_stashpv(HvNAME(sstr),0); + return (SV*) old_stash; + } + } + /* create anew and remember what it is */ new_SV(dstr); ptr_table_store(PL_ptr_table, sstr, dstr); @@ -148,7 +148,7 @@ perform the upgrade if necessary. See C<svtype>. #define SvUPGRADE(sv, mt) (SvTYPE(sv) >= mt || sv_upgrade(sv, mt)) -#define SVs_PADBUSY 0x00000100 /* reserved for tmp or my already */ +#define SVs_PADSTALE 0x00000100 /* lexical has gone out of scope */ #define SVs_PADTMP 0x00000200 /* in use as tmp */ #define SVs_PADMY 0x00000400 /* in use a "my" variable */ #define SVs_TEMP 0x00000800 /* string is stealable? */ @@ -637,14 +637,16 @@ and leaves the UTF8 status as it was. #define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST) -#define SvPADBUSY(sv) (SvFLAGS(sv) & SVs_PADBUSY) +#define SvPADSTALE(sv) (SvFLAGS(sv) & SVs_PADSTALE) +#define SvPADSTALE_on(sv) (SvFLAGS(sv) |= SVs_PADSTALE) +#define SvPADSTALE_off(sv) (SvFLAGS(sv) &= ~SVs_PADSTALE) #define SvPADTMP(sv) (SvFLAGS(sv) & SVs_PADTMP) -#define SvPADTMP_on(sv) (SvFLAGS(sv) |= SVs_PADTMP|SVs_PADBUSY) +#define SvPADTMP_on(sv) (SvFLAGS(sv) |= SVs_PADTMP) #define SvPADTMP_off(sv) (SvFLAGS(sv) &= ~SVs_PADTMP) #define SvPADMY(sv) (SvFLAGS(sv) & SVs_PADMY) -#define SvPADMY_on(sv) (SvFLAGS(sv) |= SVs_PADMY|SVs_PADBUSY) +#define SvPADMY_on(sv) (SvFLAGS(sv) |= SVs_PADMY) #define SvTEMP(sv) (SvFLAGS(sv) & SVs_TEMP) #define SvTEMP_on(sv) (SvFLAGS(sv) |= SVs_TEMP) @@ -1184,6 +1186,7 @@ Returns a pointer to the character buffer. #define CLONEf_COPY_STACKS 1 #define CLONEf_KEEP_PTR_TABLE 2 #define CLONEf_CLONE_HOST 4 +#define CLONEf_JOIN_IN 8 struct clone_params { AV* stashes; diff --git a/t/op/taint.t b/t/op/taint.t index 4b8039cf6c..686354ed2f 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -904,7 +904,7 @@ else { } -ok( ${^TAINT}, '$^TAINT is on' ); +ok( ${^TAINT} == 1, '$^TAINT is on' ); eval { ${^TAINT} = 0 }; ok( ${^TAINT}, '$^TAINT is not assignable' ); diff --git a/t/run/runenv.t b/t/run/runenv.t index 9acad00edf..df4a778b4d 100644 --- a/t/run/runenv.t +++ b/t/run/runenv.t @@ -150,7 +150,7 @@ try({PERL5OPT => '-w -w'}, try({PERL5OPT => '-t'}, ['-e', 'print ${^TAINT}'], - '1', + '-1', ''); try({PERLLIB => "foobar$Config{path_sep}42"}, diff --git a/t/run/switchI.t b/t/run/switchI.t index fa74b9435e..fcd2dc00f2 100644 --- a/t/run/switchI.t +++ b/t/run/switchI.t @@ -11,9 +11,15 @@ BEGIN { } ok(grep { $_ eq 'Bla' } @INC); -ok(grep { $_ eq 'Foo::Bar' } @INC); +SKIP: { + skip 'Double colons not allowed in dir spec', 1 if $^O eq 'VMS'; + ok(grep { $_ eq 'Foo::Bar' } @INC); +} fresh_perl_is('print grep { $_ eq "Bla2" } @INC', 'Bla2', { switches => ['-IBla2'] }, '-I'); -fresh_perl_is('print grep { $_ eq "Foo::Bar2" } @INC', 'Foo::Bar2', - { switches => ['-IFoo::Bar2'] }, '-I with colons'); +SKIP: { + skip 'Double colons not allowed in dir spec', 1 if $^O eq 'VMS'; + fresh_perl_is('print grep { $_ eq "Foo::Bar2" } @INC', 'Foo::Bar2', + { switches => ['-IFoo::Bar2'] }, '-I with colons'); +} diff --git a/t/run/switcht.t b/t/run/switcht.t index 869605ff95..f48124e70d 100644 --- a/t/run/switcht.t +++ b/t/run/switcht.t @@ -14,7 +14,7 @@ my $warning; local $SIG{__WARN__} = sub { $warning = join "\n", @_; }; my $Tmsg = 'while running with -t switch'; -ok( ${^TAINT}, '${^TAINT} defined' ); +is( ${^TAINT}, -1, '${^TAINT} == -1' ); my $out = `$Perl -le "print q(Hello)"`; is( $out, "Hello\n", '`` worked' ); @@ -5037,8 +5037,8 @@ Perl_yylex(pTHX) d[tmp] = '\0'; if (bad_proto && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Illegal character in prototype for %s : %s", - SvPVX(PL_subname), d); + "Illegal character in prototype for %"SVf" : %s", + PL_subname, d); SvCUR(PL_lex_stuff) = tmp; have_proto = TRUE; diff --git a/universal.c b/universal.c index 9764ee4c73..7999757f28 100644 --- a/universal.c +++ b/universal.c @@ -94,8 +94,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %s for @%s::ISA", - SvPVX(sv), HvNAME(stash)); + "Can't locate package %"SVf" for @%s::ISA", + sv, HvNAME(stash)); continue; } if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, @@ -1564,8 +1564,8 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none) } if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) { if (SvPOK(retval)) - Perl_croak(aTHX_ "Can't find Unicode property definition \"%s\"", - SvPV_nolen(retval)); + Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"", + retval); Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref"); } return retval; diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 19b368abab..4bfcbee7d3 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -1174,9 +1174,9 @@ regen_headers : # VMS uses modified perly.[ch] with tags for globaldefs if using DEC compiler perly.c : [.vms]perly_c.vms - Copy/NoConfirm/Log $(MMS$SOURCE) [] + Copy/NoConfirm/Log $(MMS$SOURCE) $(MMS$TARGET) perly.h : [.vms]perly_h.vms - Copy/NoConfirm/Log $(MMS$SOURCE) [] + Copy/NoConfirm/Log $(MMS$SOURCE) $(MMS$TARGET) .ifdef LINK_ONLY .else diff --git a/win32/makefile.mk b/win32/makefile.mk index 723d5b2815..952894d871 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -820,8 +820,8 @@ CFG_VARS = \ useithreads=$(USE_ITHREADS) ~ \ usemultiplicity=$(USE_MULTI) ~ \ useperlio=$(USE_PERLIO) ~ \ - uselargefiles=$(USE_LARGE_FILES) ~ \ - LINK_FLAGS=$(LINK_FLAGS:s/\/\\/) ~ \ + uselargefiles=$(USE_LARGE_FILES) ~ \ + LINK_FLAGS=$(LINK_FLAGS:s/\/\\/) ~ \ optimize=$(OPTIMIZE) # diff --git a/win32/win32.c b/win32/win32.c index c03c3be789..070ee9c132 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1912,6 +1912,8 @@ win32_async_check(pTHX) return ours; } +/* This function will not return until the timeout has elapsed, or until + * one of the handles is ready. */ DllExport DWORD win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp) { @@ -1936,10 +1938,7 @@ win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD result } if (result == WAIT_OBJECT_0 + count) { /* Message has arrived - check it */ - if (win32_async_check(aTHX)) { - /* was one of ours */ - break; - } + (void)win32_async_check(aTHX); } else { /* Not timeout or message - one of handles is ready */ |