diff options
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | ext/Thread/Thread.pm | 17 | ||||
| -rwxr-xr-x | installperl | 1 | ||||
| -rw-r--r-- | lib/Dumpvalue.pm | 3 | ||||
| -rw-r--r-- | lib/charnames.pm | 1 | ||||
| -rw-r--r-- | lib/dumpvar.pl | 4 | ||||
| -rw-r--r-- | lib/perl5db.pl | 83 | ||||
| -rw-r--r-- | op.c | 28 | ||||
| -rw-r--r-- | op.h | 3 | ||||
| -rw-r--r-- | opcode.h | 2 | ||||
| -rwxr-xr-x | opcode.pl | 2 | ||||
| -rw-r--r-- | perl.h | 2 | ||||
| -rw-r--r--[-rwxr-xr-x] | perlapi.c | 0 | ||||
| -rw-r--r--[-rwxr-xr-x] | perlapi.h | 0 | ||||
| -rw-r--r-- | pod/perldebug.pod | 33 | ||||
| -rw-r--r-- | pod/perldelta.pod | 85 | ||||
| -rw-r--r-- | pod/perldiag.pod | 23 | ||||
| -rw-r--r-- | pod/perlop.pod | 15 | ||||
| -rw-r--r-- | pod/perlthrtut.pod | 8 | ||||
| -rw-r--r-- | pp.sym | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 4 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/op/filetest.t | 0 | ||||
| -rwxr-xr-x | t/op/sort.t | 9 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/op/subst_amp.t | 0 | ||||
| -rw-r--r-- | t/pragma/warn/op | 51 | ||||
| -rw-r--r-- | toke.c | 22 | ||||
| -rw-r--r-- | vms/ext/vmsish.pm | 33 | ||||
| -rw-r--r-- | vms/ext/vmsish.t | 49 | ||||
| -rw-r--r-- | vms/vmsish.h | 6 |
30 files changed, 344 insertions, 143 deletions
@@ -870,6 +870,7 @@ print CAPIH <<'EOT'; #endif /* __perlapi_h__ */ EOT +close CAPIH; print CAPI <<'EOT'; /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index 3e50a99cd4..00cba8af67 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -36,16 +36,15 @@ Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) =head1 DESCRIPTION -The C<Thread> module provides multithreading support for perl. - -WARNING: Threading is an experimental feature. Both the interface -and implementation are subject to change drastically. + WARNING: Threading is an experimental feature. Both the interface + and implementation are subject to change drastically. In fact, this + documentation describes the flavor of threads that was in version + 5.005. Perl 5.6.0 and later have the beginnings of support for + interpreter threads, which (when finished) is expected to be + significantly different from what is described here. The information + contained here may therefore soon be obsolete. Use at your own risk! -In fact, this documentation describes the flavor of threads that was in -version 5.005. Perl v5.6 has the beginnings of support for interpreter -threads, which (when finished) is expected to be significantly different -from what is described here. The information contained here may therefore -soon be obsolete. Use at your own risk! +The C<Thread> module provides multithreading support for perl. =head1 FUNCTIONS diff --git a/installperl b/installperl index cd3e0a3743..b2ddc84c24 100755 --- a/installperl +++ b/installperl @@ -377,7 +377,6 @@ if (! $versiononly) { safe_unlink("$installscript/pstruct$scr_ext"); if ($^O eq 'dos' or $Is_VMS or $^O eq 'transit') { copy("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext"); - chmod(0755, "$installscript/pstruct$scr_ext"); } else { link("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext"); } diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 94b6aa6e78..5d3a9dafc2 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -404,7 +404,8 @@ sub dumpvars { next if @vars && !grep( matchvar($key, $_), @vars ); if ($self->{usageOnly}) { $self->globUsage(\$val, $key) - unless $package eq 'Dumpvalue' and $key eq 'stab'; + if ($package ne 'Dumpvalue' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; } else { $self->dumpglob($package, 0,$key, $val); } diff --git a/lib/charnames.pm b/lib/charnames.pm index 21b4dd61bc..7c2209b9f0 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -2,7 +2,6 @@ package charnames; use bytes (); # for $bytes::hint_bits $charnames::hint_bits = 0x20000; -my $fname = 'unicode/UnicodeData-Latest.txt'; my $txt; # This is not optimized in any way yet diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index c72781801b..4a3041a02b 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -361,7 +361,9 @@ sub main::dumpvar { return if $DB::signal; next if @vars && !grep( matchvar($key, $_), @vars ); if ($usageOnly) { - globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab'; + globUsage(\$val, $key) + if ($package ne 'dumpvar' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; } else { dumpglob(0,$key, $val); } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 50844d28f8..132e08e0bd 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -273,13 +273,13 @@ $inhibit_exit = $option{PrintRet} = 1; ); # These guys may be defined in $ENV{PERL5DB} : -$rl = 1 unless defined $rl; -$warnLevel = 1 unless defined $warnLevel; -$dieLevel = 1 unless defined $dieLevel; -$signalLevel = 1 unless defined $signalLevel; -$pre = [] unless defined $pre; -$post = [] unless defined $post; -$pretype = [] unless defined $pretype; +$rl = 1 unless defined $rl; +$warnLevel = 0 unless defined $warnLevel; +$dieLevel = 0 unless defined $dieLevel; +$signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); @@ -604,16 +604,19 @@ EOP $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { + $cmd =~ s/^\s+//s; # trim annoying leading whitespace + $cmd =~ s/\s+$//s; # trim annoying trailing whitespace ($i) = split(/\s+/,$cmd); - #eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; if ($alias{$i}) { - print STDERR "ALIAS $cmd INTO "; + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval "\$cmd =~ $alias{$i}"; - print "$cmd\n"; - print $OUT $@; + if ($@) { + print $OUT "Couldn't evaluate `$i' alias: $@"; + next CMD; + } } - $cmd =~ s/^\s+//s; # trim annoying leading whitespace - $cmd =~ s/\s+$//s; # trim annoying trailing whitespace $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { print_help($help); @@ -1211,6 +1214,9 @@ EOP $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print $OUT "$@"; @@ -1240,9 +1246,12 @@ EOP $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { - print $OUT "$@"; + print $OUT $@; next CMD; } $pat = $inpat; @@ -1308,19 +1317,39 @@ EOP next CMD; }; $cmd =~ s/^p$/print {\$DB::OUT} \$_/; $cmd =~ s/^p\b/print {\$DB::OUT} /; - $cmd =~ /^=/ && do { - if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { - $alias{$k}="s~$k~$v~"; - print $OUT "$k = $v\n"; - } elsif ($cmd =~ /^=\s*$/) { - foreach $k (sort keys(%alias)) { - if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { - print $OUT "$k = $v\n"; - } else { + $cmd =~ s/^=\s*// && do { + my @keys; + if (length $cmd == 0) { + @keys = sort keys %alias; + } + elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) { + # can't use $_ or kill //g state + for my $x ($k, $v) { $x =~ s/\a/\\a/g } + $alias{$k} = "s\a$k\a$v\a"; + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; + unless (eval "sub { s\a$k\a$v\a }; 1") { + print $OUT "Can't alias $k to $v: $@\n"; + delete $alias{$k}; + next CMD; + } + @keys = ($k); + } + else { + @keys = ($cmd); + } + for my $k (@keys) { + if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) { + print $OUT "$k\t= $1\n"; + } + elsif (defined $alias{$k}) { print $OUT "$k\t$alias{$k}\n"; - }; - }; - }; + } + else { + print "No alias for $k\n"; + } + } next CMD; }; $cmd =~ /^\|\|?\s*[^|]/ && do { if ($pager =~ /^\|/) { @@ -1716,7 +1745,7 @@ sub setterm { $| = 1; select($sel); } else { - eval "require Term::Rendezvous;" or die $@; + eval "require Term::Rendezvous;" or die; my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$"; my $term_rv = new Term::Rendezvous $rv; $IN = $term_rv->IN; @@ -4656,6 +4656,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_checkav) PL_checkav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; @@ -4664,6 +4666,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_initav) PL_initav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -4804,6 +4808,8 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (strEQ(s, "CHECK")) { if (!PL_checkav) PL_checkav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; @@ -4811,6 +4817,8 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -5156,6 +5164,20 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_exit(pTHX_ OP *o) +{ +#ifdef VMS + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + if (svp && *svp && SvTRUE(*svp)) + o->op_private |= OPpEXIT_VMSISH; + } +#endif + return ck_fun(o); +} + +OP * Perl_ck_exec(pTHX_ OP *o) { OP *kid; @@ -5992,6 +6014,12 @@ Perl_ck_sort(pTHX_ OP *o) for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; + /* don't descend into loops */ + else if (k->op_type == OP_ENTERLOOP + || k->op_type == OP_ENTERITER) + { + k = cLOOPx(k)->op_lastop; + } } } else @@ -203,6 +203,9 @@ Deprecated. Use C<GIMME_V> instead. #define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */ #define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */ +/* Private for OP_EXIT */ +#define OPpEXIT_VMSISH 128 /* exit(0) vs. exit(1) vmsish mode*/ + struct op { BASEOP }; @@ -1284,7 +1284,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_null), /* redo */ MEMBER_TO_FPTR(Perl_ck_null), /* dump */ MEMBER_TO_FPTR(Perl_ck_null), /* goto */ - MEMBER_TO_FPTR(Perl_ck_fun), /* exit */ + MEMBER_TO_FPTR(Perl_ck_exit), /* exit */ MEMBER_TO_FPTR(Perl_ck_open), /* open */ MEMBER_TO_FPTR(Perl_ck_fun), /* close */ MEMBER_TO_FPTR(Perl_ck_fun), /* pipe_op */ @@ -597,7 +597,7 @@ next next ck_null ds} redo redo ck_null ds} dump dump ck_null ds} goto goto ck_null ds} -exit exit ck_fun ds% S? +exit exit ck_exit ds% S? # continued below #nswitch numeric switch ck_null d @@ -1652,7 +1652,7 @@ typedef pthread_key_t perl_key; #ifdef VMS # define STATUS_NATIVE PL_statusvalue_vms # define STATUS_NATIVE_EXPORT \ - ((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) + (((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) | (VMSISH_HUSHED ? 0x10000000 : 0)) # define STATUS_NATIVE_SET(n) \ STMT_START { \ PL_statusvalue_vms = (n); \ diff --git a/perlapi.c b/perlapi.c index 787c2f220c..787c2f220c 100755..100644 --- a/perlapi.c +++ b/perlapi.c diff --git a/perlapi.h b/perlapi.h index 5e5ac2825b..5e5ac2825b 100755..100644 --- a/perlapi.h +++ b/perlapi.h diff --git a/pod/perldebug.pod b/pod/perldebug.pod index ead5414ccf..1750f1a5c0 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -488,16 +488,23 @@ Run Tk while prompting (with ReadLine). =item C<signalLevel>, C<warnLevel>, C<dieLevel> -Level of verbosity. By default, the debugger prints backtraces -upon receiving any kind of warning (this is often annoying) and -fatal exceptions (this is often valuable). It will attempt to print -a message when uncaught INT, BUS, or SEGV signals arrive. - -To disable this behaviour, set these values to 0. If C<dieLevel> -is 2, the debugger usurps your own exception handler and prints out -a trace of these, replacing your exceptions with its own. This may -be useful for some tracing purposes, but tends to hopelessly destroy -any program that takes its exception handling seriously. +Level of verbosity. By default, the debugger leaves your exceptions +and warnings alone, because altering them can break correctly running +programs. It will attempt to print a message when uncaught INT, BUS, or +SEGV signals arrive. (But see the mention of signals in L<BUGS> below.) + +To disable this default safe mode, set these values to something higher +than 0. At a level of 1, you get backtraces upon receiving any kind +of warning (this is often annoying) or exception (this is +often valuable). Unfortunately, the debugger cannot discern fatal +exceptions from non-fatal ones. If C<dieLevel> is even 1, then your +non-fatal exceptions are also traced and unceremoniously altered if they +came from C<eval'd> strings or from any kind of C<eval> within modules +you're attempting to load. If C<dieLevel> is 2, the debugger doesn't +care where they came from: It usurps your exception handler and prints +out a trace, then modifies all exceptions with its own embellishments. +This may perhaps be useful for some tracing purposes, but tends to hopelessly +destroy any program that takes its exception handling seriously. =item C<AutoTrace> @@ -929,3 +936,9 @@ that were not compiled by Perl, such as those from C or C++ extensions. If you alter your @_ arguments in a subroutine (such as with B<shift> or B<pop>, the stack backtrace will not show the original values. + +If you're in a slow syscall (like C<wait>ing, C<accept>ing, or C<read>ing +from your keyboard or a socket) and haven't set up your own C<$SIG{INT}> +handler, then you won't be able to CTRL-C your way back to the debugger, +because the debugger's own C<$SIG{INT}> handler doesn't understand that +it needs to raise an exception to longjmp(3) out of slow syscalls. diff --git a/pod/perldelta.pod b/pod/perldelta.pod index d4d82f3c2d..147bbc1edb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1972,7 +1972,7 @@ An introduction to Unicode support features in Perl. =item "%s" variable %s masks earlier declaration in same %s -(W) A "my" or "our" variable has been redeclared in the current scope or statement, +(W misc) A "my" or "our" variable has been redeclared in the current scope or statement, effectively eliminating all access to the previous instance. This is almost always a typographical error. Note that the earlier variable will still exist until the end of the scope or until all closure referents to it are @@ -1985,7 +1985,7 @@ yet. =item "our" variable %s redeclared -(W) You seem to have already declared the same global once before in the +(W misc) You seem to have already declared the same global once before in the current lexical scope. =item '!' allowed only after types %s @@ -2020,25 +2020,25 @@ See L<perlfunc/pack>. =item /%s/: Unrecognized escape \\%c passed through -(W) You used a backslash-character combination which is not recognized +(W regexp) You used a backslash-character combination which is not recognized by Perl. This combination appears in an interpolated variable or a C<'>-delimited regular expression. The character was understood literally. =item /%s/: Unrecognized escape \\%c in character class passed through -(W) You used a backslash-character combination which is not recognized +(W regexp) You used a backslash-character combination which is not recognized by Perl inside character classes. The character was understood literally. =item /%s/ should probably be written as "%s" -(W) You have used a pattern where Perl expected to find a string, +(W syntax) You have used a pattern where Perl expected to find a string, as in the first argument to C<join>. Perl will treat the true or false result of matching the pattern against $_ as the string, which is probably not what you had in mind. =item %s() called too early to check prototype -(W) You've called a function that has a prototype before the parser saw a +(W prototype) You've called a function that has a prototype before the parser saw a definition or declaration for it, and Perl could not check that the call conforms to the prototype. You need to either add an early prototype declaration for the subroutine in question, or move the subroutine @@ -2072,14 +2072,14 @@ name, and not a subroutine call. C<exists &sub()> will generate this error. =item %s package attribute may clash with future reserved word: %s -(W) A lowercase attribute name was used that had a package-specific handler. +(W reserved) A lowercase attribute name was used that had a package-specific handler. That name might have a meaning to Perl itself some day, even though it doesn't yet. Perhaps you should use a mixed-case attribute name, instead. See L<attributes>. =item (in cleanup) %s -(W) This prefix usually indicates that a DESTROY() method raised +(W misc) This prefix usually indicates that a DESTROY() method raised the indicated exception. Since destructors are usually called by the system at arbitrary points during execution, and often a vast number of times, the warning is issued only once for any number @@ -2114,7 +2114,7 @@ setting environment variable C<PERL_BADFREE> to 1. =item Bareword found in conditional -(W) The compiler found a bareword where it expected a conditional, +(W bareword) The compiler found a bareword where it expected a conditional, which often indicates that an || or && was parsed as part of the last argument of the previous construct, for example: @@ -2130,17 +2130,17 @@ The C<strict> pragma is useful in avoiding such errors. =item Binary number > 0b11111111111111111111111111111111 non-portable -(W) The binary number you specified is larger than 2**32-1 +(W portable) The binary number you specified is larger than 2**32-1 (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. =item Bit vector size > 32 non-portable -(W) Using bit vector sizes larger than 32 is non-portable. +(W portable) Using bit vector sizes larger than 32 is non-portable. =item Buffer overflow in prime_env_iter: %s -(W) A warning peculiar to VMS. While Perl was preparing to iterate over +(W internal) A warning peculiar to VMS. While Perl was preparing to iterate over %ENV, it encountered a logical name or symbol definition which was too long, so it was truncated to the string shown. @@ -2161,7 +2161,7 @@ for other types of variables in future. =item Can't ignore signal CHLD, forcing to default -(W) Perl has detected that it is being run with the SIGCHLD signal +(W signal) Perl has detected that it is being run with the SIGCHLD signal (sometimes known as SIGCLD) disabled. Since disabling this signal will interfere with proper determination of exit status of child processes, Perl has reset the signal to its default value. @@ -2204,7 +2204,7 @@ See L<perlre>. =item Character class syntax [%s] belongs inside character classes -(W) The character class constructs [: :], [= =], and [. .] go +(W unsafe) The character class constructs [: :], [= =], and [. .] go I<inside> character classes, the [] are part of the construct, for example: /[012[:alpha:]345]/. Note that [= =] and [. .] are not currently implemented; they are simply placeholders for @@ -2218,15 +2218,12 @@ message indicates the type of reference that was expected. This usually indicates a syntax error in dereferencing the constant value. See L<perlsub/"Constant Functions"> and L<constant>. -=item constant(%s): %%^H is not localized - -(F) When setting compile-time-lexicalized hash %^H one should set the -corresponding bit of $^H as well. - =item constant(%s): %s -(F) Compile-time-substitutions (such as overloaded constants and -character names) were not correctly set up. +(F) The parser found inconsistencies either while attempting to define an +overloaded constant, or when trying to find the character name specified +in the C<\N{...}> escape. Perhaps you forgot to load the corresponding +C<overload> or C<charnames> pragma? See L<charnames> and L<overload>. =item CORE::%s is not a keyword @@ -2250,7 +2247,7 @@ See Server error. =item Did you mean "local" instead of "our"? -(W) Remember that "our" does not localize the declared global variable. +(W misc) Remember that "our" does not localize the declared global variable. You have declared it again in the same lexical scope, which seems superfluous. =item Document contains no data @@ -2264,14 +2261,14 @@ effective uids or gids failed. =item false [] range "%s" in regexp -(W) A character class range must start and end at a literal character, not +(W regexp) A character class range must start and end at a literal character, not another character class like C<\d> or C<[:alpha:]>. The "-" in your false range is interpreted as a literal "-". Consider quoting the "-", "\-". See L<perlre>. =item Filehandle %s opened only for output -(W) You tried to read from a filehandle opened only for writing. If you +(W io) You tried to read from a filehandle opened only for writing. If you intended it to be a read/write filehandle, you needed to open it with "+<" or "+>" or "+>>" instead of with "<" or nothing. If you intended only to read from the file, use "<". See @@ -2279,7 +2276,7 @@ L<perlfunc/open>. =item flock() on closed filehandle %s -(W) The filehandle you're attempting to flock() got itself closed some +(W closed) The filehandle you're attempting to flock() got itself closed some time before now. Check your logic flow. flock() operates on filehandles. Are you attempting to call flock() on a dirhandle by the same name? @@ -2292,19 +2289,19 @@ is in (using "::"). =item Hexadecimal number > 0xffffffff non-portable -(W) The hexadecimal number you specified is larger than 2**32-1 +(W portable) The hexadecimal number you specified is larger than 2**32-1 (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. =item Ill-formed CRTL environ value "%s" -(W) A warning peculiar to VMS. Perl tried to read the CRTL's internal +(W internal) A warning peculiar to VMS. Perl tried to read the CRTL's internal environ array, and encountered an element without the C<=> delimiter used to spearate keys from values. The element is ignored. =item Ill-formed message in prime_env_iter: |%s| -(W) A warning peculiar to VMS. Perl tried to read a logical name +(W internal) A warning peculiar to VMS. Perl tried to read a logical name or CLI symbol definition when preparing to iterate over %ENV, and didn't see the expected delimiter between key and value, so the line was ignored. @@ -2315,7 +2312,7 @@ line was ignored. =item Illegal binary digit %s ignored -(W) You may have tried to use a digit other than 0 or 1 in a binary number. +(W digit) You may have tried to use a digit other than 0 or 1 in a binary number. Interpretation of the binary number stopped before the offending digit. =item Illegal number of bits in vec @@ -2325,7 +2322,7 @@ two from 1 to 32 (or 64, if your platform supports that). =item Integer overflow in %s number -(W) The hexadecimal, octal or binary number you have specified either +(W overflow) The hexadecimal, octal or binary number you have specified either as a literal or as an argument to hex() or oct() is too big for your architecture, and has been converted to a floating point number. On a 32-bit architecture the largest hexadecimal, octal or binary number @@ -2385,7 +2382,7 @@ double-quotish context. =item Missing command in piped open -(W) You used the C<open(FH, "| command")> or C<open(FH, "command |")> +(W pipe) You used the C<open(FH, "| command")> or C<open(FH, "command |")> construction, but the command was missing or blank. =item Missing name in "my sub" @@ -2419,7 +2416,7 @@ get local time. =item Octal number > 037777777777 non-portable -(W) The octal number you specified is larger than 2**32-1 (4294967295) +(W portable) The octal number you specified is larger than 2**32-1 (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. @@ -2441,7 +2438,7 @@ references to an object. =item Parentheses missing around "%s" list -(W) You said something like +(W parenthesis) You said something like my $foo, $bar = @_; @@ -2453,12 +2450,12 @@ Remember that "my", "our", and "local" bind tighter than comma. =item Possible Y2K bug: %s -(W) You are concatenating the number 19 with another number, which +(W y2k) You are concatenating the number 19 with another number, which could be a potential Year 2000 problem. =item pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead -(W) You have written somehing like this: +(W deprecated) You have written somehing like this: sub doit { @@ -2496,7 +2493,7 @@ been freed. =item Reference is already weak -(W) You have attempted to weaken a reference that is already weak. +(W misc) You have attempted to weaken a reference that is already weak. Doing so has no effect. =item setpgrp can't take arguments @@ -2506,7 +2503,7 @@ unlike POSIX setpgid(), which takes a process ID and process group ID. =item Strange *+?{} on zero-length expression -(W) You applied a regular expression quantifier in a place where it +(W regexp) You applied a regular expression quantifier in a place where it makes no sense, such as on a zero-width assertion. Try putting the quantifier inside the assertion instead. For example, the way to match "abc" provided that it is followed by three @@ -2521,13 +2518,21 @@ real and effective uids or gids. =item This Perl can't set CRTL environ elements (%s=%s) -(W) Warnings peculiar to VMS. You tried to change or delete an element +(W internal) Warnings peculiar to VMS. You tried to change or delete an element of the CRTL's internal environ array, but your copy of Perl wasn't built with a CRTL that contained the setenv() function. You'll need to rebuild Perl with a CRTL that does, or redefine F<PERL_ENV_TABLES> (see L<perlvms>) so that the environ array isn't the target of the change to %ENV which produced the warning. +=item Too late to run %s block + +(W void) A CHECK or INIT block is being defined during run time proper, +when the opportunity to run them has already passed. Perhaps you are +loading a file with C<require> or C<do> when you should be using +C<use> instead. Or perhaps you should put the C<require> or C<do> +inside a BEGIN block. + =item Unknown open() mode '%s' (F) The second argument of 3-argument open() is not among the list @@ -2543,7 +2548,7 @@ subvert Perl's population of %ENV for nefarious purposes. =item Unrecognized escape \\%c passed through -(W) You used a backslash-character combination which is not recognized +(W misc) You used a backslash-character combination which is not recognized by Perl. The character was understood literally. =item Unterminated attribute parameter in attribute list @@ -2576,7 +2581,7 @@ too soon. =item Value of CLI symbol "%s" too long -(W) A warning peculiar to VMS. Perl tried to read the value of an %ENV +(W misc) A warning peculiar to VMS. Perl tried to read the value of an %ENV element from a CLI symbol table, and found a resultant string longer than 1024 characters. The return value has been truncated to 1024 characters. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d57e7e57a3..a988124b5b 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -161,14 +161,14 @@ an ampersand before the name to avoid the warning. See L<perlsub>. (F) The argument to exists() must be a hash or array element, such as: $foo{$bar} - $ref->[12]->["susie"] + $ref->{"susie"}[12] =item %s argument is not a HASH or ARRAY element or slice (F) The argument to delete() must be either a hash or array element, such as: $foo{$bar} - $ref->[12]->["susie"] + $ref->{"susie"}[12] or a hash or array slice, such as: @@ -1255,15 +1255,12 @@ workarounds. inlining. See L<perlsub/"Constant Functions"> for commentary and workarounds. -=item constant(%s): %%^H is not localized - -(F) When setting compile-time-lexicalized hash %^H one should set the -corresponding bit of $^H as well. - =item constant(%s): %s -(F) Compile-time-substitutions (such as overloaded constants and -character names) were not correctly set up. +(F) The parser found inconsistencies either while attempting to define an +overloaded constant, or when trying to find the character name specified +in the C<\N{...}> escape. Perhaps you forgot to load the corresponding +C<overload> or C<charnames> pragma? See L<charnames> and L<overload>. =item Copy method did not return a reference @@ -3053,6 +3050,14 @@ B<-T> option must appear on the command line: C<perl -T scriptname>. B<-M> or B<-m> option. This is an error because B<-M> and B<-m> options are not intended for use inside scripts. Use the C<use> pragma instead. +=item Too late to run %s block + +(W void) A CHECK or INIT block is being defined during run time proper, +when the opportunity to run them has already passed. Perhaps you are +loading a file with C<require> or C<do> when you should be using +C<use> instead. Or perhaps you should put the C<require> or C<do> +inside a BEGIN block. + =item Too many ('s =item Too many )'s diff --git a/pod/perlop.pod b/pod/perlop.pod index db0563ce91..ce6fb66bc9 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1140,9 +1140,10 @@ text is not evaluated as a command. If the PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own pair of quotes, which may or may not be bracketing quotes, e.g., C<s(foo)(bar)> or C<< s<foo>/bar/ >>. A C</e> will cause the -replacement portion to be interpreted as a full-fledged Perl expression -and eval()ed right then and there. It is, however, syntax checked at -compile-time. +replacement portion to be treated as a full-fledged Perl expression +and evaluated right then and there. It is, however, syntax checked at +compile-time. A second C<e> modifier will cause the replacement portion +to be C<eval>ed before being run as a Perl expression. Examples: @@ -1169,8 +1170,12 @@ Examples: # symbolic dereferencing s/\$(\w+)/${$1}/g; - # /e's can even nest; this will expand - # any embedded scalar variable (including lexicals) in $_ + # Add one to the value of any numbers in the string + s/(\d+)/1 + $1/eg; + + # This will expand any embedded scalar variable + # (including lexicals) in $_ : First $1 is interpolated + # to the variable name, and then evaluated s/(\$\w+)/$1/eeg; # Delete (most) C comments. diff --git a/pod/perlthrtut.pod b/pod/perlthrtut.pod index 88849dd662..0314d9da6c 100644 --- a/pod/perlthrtut.pod +++ b/pod/perlthrtut.pod @@ -4,6 +4,14 @@ perlthrtut - tutorial on threads in Perl =head1 DESCRIPTION + WARNING: Threading is an experimental feature. Both the interface + and implementation are subject to change drastically. In fact, this + documentation describes the flavor of threads that was in version + 5.005. Perl 5.6.0 and later have the beginnings of support for + interpreter threads, which (when finished) is expected to be + significantly different from what is described here. The information + contained here may therefore soon be obsolete. Use at your own risk! + One of the most prominent new features of Perl 5.005 is the inclusion of threads. Threads make a number of things a lot easier, and are a very useful addition to your bag of programming tricks. @@ -13,6 +13,7 @@ Perl_ck_eof Perl_ck_eval Perl_ck_exec Perl_ck_exists +Perl_ck_exit Perl_ck_ftst Perl_ck_fun Perl_ck_fun_locale @@ -2463,8 +2463,8 @@ PP(pp_exit) anum = 0; else { anum = SvIVx(POPs); -#ifdef VMSISH_EXIT - if (anum == 1 && VMSISH_EXIT) +#ifdef VMS + if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; #endif } diff --git a/pp_proto.h b/pp_proto.h index 7f2d80b0b1..4ce9d74594 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -12,6 +12,7 @@ PERL_CKDEF(Perl_ck_eof) PERL_CKDEF(Perl_ck_eval) PERL_CKDEF(Perl_ck_exec) PERL_CKDEF(Perl_ck_exists) +PERL_CKDEF(Perl_ck_exit) PERL_CKDEF(Perl_ck_ftst) PERL_CKDEF(Perl_ck_fun) PERL_CKDEF(Perl_ck_fun_locale) diff --git a/t/op/filetest.t b/t/op/filetest.t index e00d5fb7b0..e00d5fb7b0 100644..100755 --- a/t/op/filetest.t +++ b/t/op/filetest.t diff --git a/t/op/sort.t b/t/op/sort.t index 794b1f2a6c..ba0a4c2a2d 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -13,6 +13,15 @@ print "1..49\n"; $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } +# these shouldn't hang +{ + no warnings; + sort { for ($_ = 0;; $_++) {} } @a; + sort { while(1) {} } @a; + sort { while(1) { last; } } @a; + sort { while(0) { last; } } @a; +} + sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } diff --git a/t/op/subst_amp.t b/t/op/subst_amp.t index e2e7c0e542..e2e7c0e542 100644..100755 --- a/t/op/subst_amp.t +++ b/t/op/subst_amp.t diff --git a/t/pragma/warn/op b/t/pragma/warn/op index d70a333bbc..461f3f618b 100644 --- a/t/pragma/warn/op +++ b/t/pragma/warn/op @@ -808,3 +808,54 @@ joe() ; sub joe ($$) {} EXPECT main::fred() called too early to check prototype at - line 3. +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +use warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +use abc; +delete $INC{"abc.pm"}; +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in check +in init +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in end +in end +in end +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +no warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in begin +in mainline +in end +in end @@ -5648,30 +5648,28 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV *res; SV **cvp; SV *cv, *typesv; - const char *why, *why1, *why2; + const char *why1, *why2, *why3; - if (!(PL_hints & HINT_LOCALIZE_HH)) { + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why = "%^H is not localized"; - report_short: - why1 = why2 = ""; + why1 = "%^H is not consistent"; + why2 = strEQ(key,"charnames") + ? " (missing \"use charnames ...\"?)" + : ""; + why3 = ""; report: msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", - (type ? type: "undef"), why1, why2, why); + (type ? type: "undef"), why1, why2, why3); yyerror(SvPVX(msg)); SvREFCNT_dec(msg); return sv; } - if (!table) { - why = "%^H is not defined"; - goto report_short; - } cvp = hv_fetch(table, key, strlen(key), FALSE); if (!cvp || !SvOK(*cvp)) { - why = "} is not defined"; why1 = "$^H{"; why2 = key; + why3 = "} is not defined"; goto report; } sv_2mortal(sv); /* Parent created it permanently */ @@ -5719,9 +5717,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, POPSTACK; if (!SvOK(res)) { - why = "}} did not return a defined value"; why1 = "Call to &{$^H{"; why2 = key; + why3 = "}} did not return a defined value"; sv = res; goto report; } diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index dfb565b326..2fc48530c0 100644 --- a/vms/ext/vmsish.pm +++ b/vms/ext/vmsish.pm @@ -11,6 +11,7 @@ vmsish - Perl pragma to control VMS-specific language features use vmsish 'status'; # or '$?' use vmsish 'exit'; use vmsish 'time'; + use vmsish 'hushed'; use vmsish; no vmsish 'time'; @@ -18,8 +19,8 @@ vmsish - Perl pragma to control VMS-specific language features =head1 DESCRIPTION If no import list is supplied, all possible VMS-specific features are -assumed. Currently, there are three VMS-specific features available: -'status' (a.k.a '$?'), 'exit', and 'time'. +assumed. Currently, there are four VMS-specific features available: +'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'. =over 6 @@ -41,6 +42,16 @@ used directly as Perl's exit status. This makes all times relative to the local time zone, instead of the default of Universal Time (a.k.a Greenwich Mean Time, or GMT). +=item C<vmsish hushed> + +This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR +if Perl terminates with an error status. This primarily effects error +exits from things like compiler errors or "standard Perl" runtime errors, +where text error messages are also generated by Perl. + +The error exits from inside VMS.C are generally more serious, and are +not supressed. + =back See L<perlmod/Pragmatic Modules>. @@ -56,8 +67,8 @@ sub bits { my $bits = 0; my $sememe; foreach $sememe (@_) { - $bits |= 0x20000000, next if $sememe eq 'status' || $sememe eq '$?'; - $bits |= 0x40000000, next if $sememe eq 'exit'; + $bits |= 0x20000000, next if $sememe eq 'hushed'; + $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; $bits |= 0x80000000, next if $sememe eq 'time'; } $bits; @@ -65,12 +76,22 @@ sub bits { sub import { shift; - $^H |= bits(@_ ? @_ : qw(status exit time)); + $^H |= bits(@_ ? @_ : qw(status time hushed)); + my $sememe; + + foreach $sememe (@_ ? @_ : qw(exit)) { + $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; + } } sub unimport { shift; - $^H &= ~ bits(@_ ? @_ : qw(status exit time)); + $^H &= ~ bits(@_ ? @_ : qw(status time hushed)); + my $sememe; + + foreach $sememe (@_ ? @_ : qw(exit)) { + $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; + } } 1; diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index 24a9f437ef..2a5b580bda 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -3,7 +3,7 @@ BEGIN { unshift @INC, '[-.lib]'; } my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); -print "1..16\n"; +print "1..17\n"; #========== vmsish status ========== `$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. @@ -30,10 +30,11 @@ else { print "ok 5\n"; } else { print "ok 6\n"; } } -#========== vmsish exit ========== +#========== vmsish exit, messages ========== { use vmsish qw(status); - my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`; + + $msg = do_a_perl('-e "exit 1"'); if ($msg !~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line print "not ok 7 # subprocess output: |$msg|\n"; @@ -42,7 +43,7 @@ else { print "ok 5\n"; } if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; } else { print "ok 8\n"; } - $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`; + $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); if (length $msg) { $msg =~ s/\n/\\n/g; # keep output on one line print "not ok 9 # subprocess output: |$msg|\n"; @@ -51,7 +52,7 @@ else { print "ok 5\n"; } if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; } else { print "ok 10\n"; } - $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`; + $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); if ($msg !~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line print "not ok 11 # subprocess output: |$msg|\n"; @@ -59,6 +60,14 @@ else { print "ok 5\n"; } else { print "ok 11\n"; } if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; } else { print "ok 12\n"; } + + $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"'); + if ($msg =~ /ABORT/) { + $msg =~ s/\n/\\n/g; # keep output on one line + print "not ok 13 # subprocess output: |$msg|\n"; + } + else { print "ok 13\n"; } + } @@ -93,30 +102,44 @@ else { print "ok 5\n"; } # an amount, and it renders the test resistant to delays from # things like stat() on a file mounted over a slow network link. if ($utctime - $vmstime + $offset > 10) { - print "not ok 13 # (time) UTC: $utctime VMS: $vmstime\n"; + print "not ok 14 # (time) UTC: $utctime VMS: $vmstime\n"; } - else { print "ok 13\n"; } + else { print "ok 14\n"; } $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; if ($vmsval - $utcval + $offset > 10) { - print "not ok 14 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; + print "not ok 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; } - else { print "ok 14\n"; } + else { print "ok 15\n"; } $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; if ($vmsval - $utcval + $offset > 10) { - print "not ok 15 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; + print "not ok 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; } - else { print "ok 15\n"; } + else { print "ok 16\n"; } if ($vmsmtime - $utcmtime + $offset > 10) { - print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; + print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; } - else { print "ok 16\n"; } + else { print "ok 17\n"; } +} + +#====== need this to make sure error messages come out, even if +# they were turned off in invoking procedure +sub do_a_perl { + local *P; + open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); + print P "\$ set message/facil/sever/ident/text\n"; + print P "\$ $Invoke_Perl @_\n"; + close P; + my $x = `\@vmsish_test.com`; + unlink 'vmsish_test.com'; + return $x; } + diff --git a/vms/vmsish.h b/vms/vmsish.h index 12b13696ce..e53c604d16 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -223,14 +223,14 @@ #define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */ #define HINT_V_VMSISH 24 -#define HINT_M_VMSISH_STATUS 0x20000000 /* system, $? return VMS status */ -#define HINT_M_VMSISH_EXIT 0x40000000 /* exit(1) ==> SS$_NORMAL */ +#define HINT_M_VMSISH_HUSHED 0x20000000 /* stifle error msgs on exit */ +#define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */ #define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */ #define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */ #define TEST_VMSISH(h) (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)) +#define VMSISH_HUSHED TEST_VMSISH(HINT_M_VMSISH_HUSHED) #define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS) -#define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT) #define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME) /* Flags for vmstrnenv() */ |