diff options
| -rw-r--r-- | perlapi.c | 6 | ||||
| -rw-r--r-- | perlio.c | 3 | ||||
| -rw-r--r-- | pod/perldiag.pod | 2 | ||||
| -rw-r--r-- | sv.c | 15 | ||||
| -rwxr-xr-x | t/op/taint.t | 31 | ||||
| -rwxr-xr-x | t/pragma/locale.t | 40 | ||||
| -rw-r--r-- | toke.c | 17 |
7 files changed, 89 insertions, 25 deletions
@@ -2237,21 +2237,21 @@ Perl_init_i18nl14n(pTHXo_ int printwarn) #undef Perl_new_collate void -Perl_new_collate(pTHXo_ const char* newcoll) +Perl_new_collate(pTHXo_ char* newcoll) { ((CPerlObj*)pPerl)->Perl_new_collate(newcoll); } #undef Perl_new_ctype void -Perl_new_ctype(pTHXo_ const char* newctype) +Perl_new_ctype(pTHXo_ char* newctype) { ((CPerlObj*)pPerl)->Perl_new_ctype(newctype); } #undef Perl_new_numeric void -Perl_new_numeric(pTHXo_ const char* newcoll) +Perl_new_numeric(pTHXo_ char* newcoll) { ((CPerlObj*)pPerl)->Perl_new_numeric(newcoll); } @@ -1280,8 +1280,7 @@ PerlIO_funcs PerlIO_stdio = { #ifdef USE_STDIO_PTR PerlIOStdio_get_ptr, PerlIOStdio_get_cnt, -#if (defined(STDIO_PTR_LVALUE) && \ - (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) +#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) PerlIOStdio_set_ptrcnt #else /* STDIO_PTR_LVALUE */ NULL diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 452938cb7c..20a4a76db3 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1086,7 +1086,7 @@ on I<Mastering Regular Expressions>.) to check the return value of your socket() call? See L<perlfunc/connect>. -=item constant(%s): %s +=item Constant(%s)%s: %s (F) The parser found inconsistencies either while attempting to define an overloaded constant, or when trying to find the character name @@ -2570,7 +2570,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); if (SvIsUV(sstr)) SvIsUV_on(dstr); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } goto undef_sstr; @@ -2590,7 +2591,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) } SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } goto undef_sstr; @@ -2659,7 +2661,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); if (GvIMPORTED(dstr) != GVf_IMPORTED && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { @@ -2816,7 +2819,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvREFCNT_dec(dref); if (intro) SAVEFREESV(sref); - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); return; } if (SvPVX(dstr)) { @@ -2925,7 +2929,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else (void)SvOK_off(dstr); } - SvTAINT(dstr); + if (SvTAINTED(sstr)) + SvTAINT(dstr); } /* diff --git a/t/op/taint.t b/t/op/taint.t index fc3a595c4e..1e3d3964c2 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -99,7 +99,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..152\n"; +print "1..155\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -690,4 +690,33 @@ else { my $b = <IN>; print "not " unless tainted($a) && tainted($b) && !defined($b); print "ok 152\n"; + close IN; } + +{ + # bug id 20001004.007 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + my $a = <IN>; + + my $c = { a => 42, + b => $a }; + print "not " unless !tainted($c->{a}) && tainted($c->{b}); + print "ok 153\n"; + + my $d = { a => $a, + b => 42 }; + print "not " unless tainted($d->{a}) && !tainted($d->{b}); + print "ok 154\n"; + + my $e = { a => 42, + b => { c => $a, d => 42 } }; + print "not " unless !tainted($e->{a}) && + !tainted($e->{b}) && + tainted($e->{b}->{c}) && + !tainted($e->{b}->{d}); + print "ok 155\n"; + + close IN; +} + diff --git a/t/pragma/locale.t b/t/pragma/locale.t index 82fb684f4e..e354c0f815 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -34,7 +34,9 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -print "1..", ($have_setlocale ? 116 : 98), "\n"; +my $last = $have_setlocale ? 116 : 98; + +print "1..$last\n"; use vars qw(&LC_ALL); @@ -639,6 +641,9 @@ foreach $Locale (@Locale) { } debug "# testing 115 with locale '$Locale'\n"; + # Does taking lc separately differ from taking + # the lc "in-line"? (This was the bug 19990704.002, change #3568.) + # The bug was in the caching of the 'o'-magic. { use locale; @@ -662,6 +667,9 @@ foreach $Locale (@Locale) { } debug "# testing 116 with locale '$Locale'\n"; + # Does lc of an UPPER (if different from the UPPER) match + # case-insensitively the UPPER, and does the UPPER match + # case-insensitively the lc of the UPPER. And vice versa. { use locale; @@ -677,15 +685,16 @@ foreach $Locale (@Locale) { push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; } tryneoalpha($Locale, 116, @f == 0); - print "# testing 116 failed for locale '$Locale' for characters @f\n" - if @f; + if (@f) { + print "# failed 116 locale '$Locale' characters @f\n" + } } } # Recount the errors. -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { if ($_ == 102) { print "# The failure of test 102 is not necessarily fatal.\n"; @@ -701,7 +710,7 @@ foreach (99..116) { my $didwarn = 0; -foreach (99..116) { +foreach (99..$last) { if ($Problem{$_}) { my @f = sort keys %{ $Problem{$_} }; my $f = join(" ", @f); @@ -726,17 +735,18 @@ EOW } } -# Tell which locales were okay. +# Tell which locales were okay and which were not. if ($didwarn) { - my @s; + my (@s, @F); foreach my $l (@Locale) { my $p = 0; - foreach my $t (102..116) { + foreach my $t (102..$last) { $p++ if $Problem{$t}{$l}; } push @s, $l if $p == 0; + push @F, $l unless $p == 0; } if (@s) { @@ -748,7 +758,19 @@ if ($didwarn) { "#\t", $s, "\n#\n", "# tested okay.\n#\n", } else { - warn "# None of your locales was fully okay.\n"; + warn "# None of your locales were fully okay.\n"; + } + + if (@F) { + my $F = join(" ", @F); + $F =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $F, "\n#\n", + "# had problems.\n#\n", + } else { + warn "# None of your locales were broken.\n"; } } @@ -5749,14 +5749,23 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why1 = "%^H is not consistent"; why2 = strEQ(key,"charnames") - ? " (missing \"use charnames ...\"?)" + ? "(possibly a missing \"use charnames ...\")" : ""; - why3 = ""; + msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", + (type ? type: "undef"), why2); + + /* This is convoluted and evil ("goto considered harmful") + * but I do not understand the intricacies of all the different + * failure modes of %^H in here. The goal here is to make + * the most probable error message user-friendly. --jhi */ + + goto msgdone; + report: - msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", + msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); + msgdone: yyerror(SvPVX(msg)); SvREFCNT_dec(msg); return sv; |