In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/40c852dee6a247b996f2c759f997f7c7c89a47b3?hp=9bac1559a4f8ca714c2348d199ad2a13c4477b0b>
- Log ----------------------------------------------------------------- commit 40c852dee6a247b996f2c759f997f7c7c89a47b3 Author: David Mitchell <[email protected]> Date: Sat Jul 3 15:41:34 2010 +0100 avoid multiple FETCH/stringify on filetest ops some of the filetest operators could call mg_get and/or overload fallback stringify multiple times M lib/overload.t M pp_sys.c commit 0d7d409d8d92b77ed7de5b74ab047eced86edfc3 Author: David Mitchell <[email protected]> Date: Sat Jul 3 14:24:11 2010 +0100 add my_[l]stat_flags(); make my_[l]stat() mathoms my_stat() and my_lstat() call get magic on the stack arg, so create _flags() variants that allow us to control this. (I can't just change the signature or the mg_get() behaviour since my_[l]stat() are listed as being in the public API, even though they're undocumented.) M doio.c M embed.fnc M embed.h M global.sym M mathoms.c M perl.h M pp_sys.c M proto.h commit 79a8d5295c08d08001ca69256d5a990d05ee1556 Author: David Mitchell <[email protected]> Date: Sat Jul 3 13:36:59 2010 +0100 PL_amagic_generation doesn't show overload loaded PL_amagic_generation is non-zero even without the presence of 'use overload', so don't bother using it as a short-cut test of whether we can skip AMAGIC processing M pp_ctl.c M pp_sort.c commit 5a8697a75658d7d8584bbfa20c013c177b3dbac3 Author: David Mitchell <[email protected]> Date: Sat Jul 3 13:24:08 2010 +0100 fix bad indentation in pp_regcomp M pp_ctl.c commit f3ec07c74992f83551f19ac514b0c40fd1e93787 Author: David Mitchell <[email protected]> Date: Sat Jul 3 13:17:40 2010 +0100 avoid extra FETCHes on overloaded qr stringify /$tied/ called FETCH too many times if the FETCH returned an overloaded object with no qr method, but with stringify fallback M lib/overload.t M pp_ctl.c commit 3bc4ee4c5aa3ed1ba3b33fb9d35f9196144d5420 Author: David Mitchell <[email protected]> Date: Fri Jul 2 22:06:49 2010 +0100 overload.t: clarify concat #FETCH expected It turns out that the number of FETCHes for the fallback ($tied_ovld . foo) just needed explaining, not fixing. M lib/overload.t commit c5aa2872379824e696683293ee3de5762325de1e Author: David Mitchell <[email protected]> Date: Fri Jul 2 21:33:01 2010 +0100 remove double stringify-overload from $ovld .= foo There was a piece of code in pp_concat who's job it was to determine the UT8ness of the LHS, and it did it in a heavy-handed way to cope with the special case of a regexp (which is an RV pointing to REGEXP which might be UTF8) M lib/overload.t M pp_hot.c commit 895b760f672897cb301e8900c05743c32f282f42 Author: David Mitchell <[email protected]> Date: Thu Jun 24 00:02:39 2010 +0100 eval: handle taint of overloaded/tied arg string eval would check its arg for taint before processing magic, overload etc. If the magic or overload returned a tainted value, it wouldn't be detected. Fixes part of #75716. M lib/overload.t M pp_ctl.c commit 3e5c01898a8b319439f67ce035bfc80fb80b4f3b Author: David Mitchell <[email protected]> Date: Wed Jun 23 00:23:24 2010 +0100 eval $overloaded can crash Perl_lex_start() assumes that the SV passed to it is a well-behaved string that it can do PVX() stuff to. If it's actually a ref to an overloaded object, it can crash and burn. Fixed by creating a stringified copy of the SV if necessary. M t/op/eval.t M toke.c commit a02ec77af3235fc3d744725d93fbef7d9126695a Author: David Mitchell <[email protected]> Date: Tue Jun 22 17:03:12 2010 +0100 fix tainting and overload Sometimes when an overload method returned a tainted value, that taintedness got lost. This fixes #75716: overload removes tainting. It also considerably expands the tied series of tests in overload.t. It now taints the return value, and checks for correct taintedness. It also tests against two overload packages: the new one only has fallback methods, which affects the return path for the tainted value. It now also compares the expected (non-tied, non-overload) expression value against a overloaded version of that expression in addition to versions where a tied var returned an overloaded object; e.g. in these expressions: 1: 1 + $plain_value 2: 1 + $overloaded_var 3: 1 + $tied_scalar_that_returns_overloaded_value 4: 1 + $tied_array_whose element_0_holds_an_overloaded_value[0] then the value of expression 1 is compared against each of 2,3,4, whereas before it was only compared against 3,4. M lib/overload.t M sv.c commit 3340ac375f37f424a40787ccf00c582048903d8d Author: David Mitchell <[email protected]> Date: Fri Jun 18 22:45:45 2010 +0100 taint-enable lib/overload.t Stick a -T at the top of lib/overload.t in preparation for adding some taint tests later. This causes some of the current tests to fail, since the FETCH count has changed: so we fix those up too. They change because under taint, code like ${$x} is compiled as enter/gvsv/leave/rv2sv rather than gvsv/rv2sv (see Perl_scope), and the leave creates a mortal copy of the tied value, avoiding any further fetches. M lib/overload.t ----------------------------------------------------------------------- Summary of changes: doio.c | 8 +- embed.fnc | 6 +- embed.h | 16 +++- global.sym | 2 + lib/overload.t | 287 +++++++++++++++++++++++++++++++++++++++++++------------ mathoms.c | 14 +++ perl.h | 4 + pp_ctl.c | 45 ++++++--- pp_hot.c | 5 +- pp_sort.c | 2 +- pp_sys.c | 24 +++-- proto.h | 6 +- sv.c | 2 + t/op/eval.t | 9 ++- toke.c | 5 +- 15 files changed, 330 insertions(+), 105 deletions(-) diff --git a/doio.c b/doio.c index 06f2d3d..5f57b38 100644 --- a/doio.c +++ b/doio.c @@ -1258,7 +1258,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } I32 -Perl_my_stat(pTHX) +Perl_my_stat_flags(pTHX_ const U32 flags) { dVAR; dSP; @@ -1314,7 +1314,7 @@ Perl_my_stat(pTHX) goto do_fstat_have_io; } - s = SvPV_const(sv, len); + s = SvPV_flags_const(sv, len, flags); PL_statgv = NULL; sv_setpvn(PL_statname, s, len); s = SvPVX_const(PL_statname); /* s now NUL-terminated */ @@ -1328,7 +1328,7 @@ Perl_my_stat(pTHX) I32 -Perl_my_lstat(pTHX) +Perl_my_lstat_flags(pTHX_ const U32 flags) { dVAR; static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; @@ -1361,7 +1361,7 @@ Perl_my_lstat(pTHX) GvENAME((const GV *)SvRV(sv))); return (PL_laststatval = -1); } - file = SvPV_nolen_const(sv); + file = SvPV_flags_const_nolen(sv, flags); sv_setpv(PL_statname,file); PL_laststatval = PerlLIO_lstat(file,&PL_statcache); if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) diff --git a/embed.fnc b/embed.fnc index 81427fd..0992216 100644 --- a/embed.fnc +++ b/embed.fnc @@ -738,7 +738,8 @@ Ap |I32 |my_fflush_all Anp |Pid_t |my_fork Anp |void |atfork_lock Anp |void |atfork_unlock -Ap |I32 |my_lstat +Apmb |I32 |my_lstat +pX |I32 |my_lstat_flags |NULLOK const U32 flags #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) AnpP |I32 |my_memcmp |NN const char* s1|NN const char* s2|I32 len #endif @@ -749,7 +750,8 @@ Ap |I32 |my_pclose |NULLOK PerlIO* ptr Ap |PerlIO*|my_popen |NN const char* cmd|NN const char* mode Ap |PerlIO*|my_popen_list |NN const char* mode|int n|NN SV ** args Ap |void |my_setenv |NULLOK const char* nam|NULLOK const char* val -Ap |I32 |my_stat +Apmb |I32 |my_stat +pX |I32 |my_stat_flags |NULLOK const U32 flags Ap |char * |my_strftime |NN const char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst #if defined(MYSWAP) ApPa |short |my_swap |short s diff --git a/embed.h b/embed.h index 56ac2cf..82b83e2 100644 --- a/embed.h +++ b/embed.h @@ -561,7 +561,9 @@ #define my_fork Perl_my_fork #define atfork_lock Perl_atfork_lock #define atfork_unlock Perl_atfork_unlock -#define my_lstat Perl_my_lstat +#ifdef PERL_CORE +#define my_lstat_flags Perl_my_lstat_flags +#endif #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) #define my_memcmp Perl_my_memcmp #endif @@ -572,7 +574,9 @@ #define my_popen Perl_my_popen #define my_popen_list Perl_my_popen_list #define my_setenv Perl_my_setenv -#define my_stat Perl_my_stat +#ifdef PERL_CORE +#define my_stat_flags Perl_my_stat_flags +#endif #define my_strftime Perl_my_strftime #if defined(MYSWAP) #define my_swap Perl_my_swap @@ -2997,7 +3001,9 @@ #define my_fork Perl_my_fork #define atfork_lock Perl_atfork_lock #define atfork_unlock Perl_atfork_unlock -#define my_lstat() Perl_my_lstat(aTHX) +#ifdef PERL_CORE +#define my_lstat_flags(a) Perl_my_lstat_flags(aTHX_ a) +#endif #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) #define my_memcmp Perl_my_memcmp #endif @@ -3008,7 +3014,9 @@ #define my_popen(a,b) Perl_my_popen(aTHX_ a,b) #define my_popen_list(a,b,c) Perl_my_popen_list(aTHX_ a,b,c) #define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b) -#define my_stat() Perl_my_stat(aTHX) +#ifdef PERL_CORE +#define my_stat_flags(a) Perl_my_stat_flags(aTHX_ a) +#endif #define my_strftime(a,b,c,d,e,f,g,h,i,j) Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j) #if defined(MYSWAP) #define my_swap(a) Perl_my_swap(aTHX_ a) diff --git a/global.sym b/global.sym index 30d89f7..f7fb28d 100644 --- a/global.sym +++ b/global.sym @@ -314,6 +314,7 @@ Perl_my_fork Perl_atfork_lock Perl_atfork_unlock Perl_my_lstat +Perl_my_lstat_flags Perl_my_memcmp Perl_my_memset Perl_my_pclose @@ -321,6 +322,7 @@ Perl_my_popen Perl_my_popen_list Perl_my_setenv Perl_my_stat +Perl_my_stat_flags Perl_my_strftime Perl_my_swap Perl_my_htonl diff --git a/lib/overload.t b/lib/overload.t index ca58619..d116925 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -1,4 +1,4 @@ -#!./perl +#!./perl -T BEGIN { chdir 't' if -d 't'; @@ -47,8 +47,9 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead package main; $| = 1; -use Test::More tests => 1970; +use Test::More tests => 4880; +use Scalar::Util qw(tainted); $a = new Oscalar "087"; $b= "$a"; @@ -1632,10 +1633,45 @@ foreach my $op (qw(<=> == != < <= > >=)) { # We test here both a tied array and scalar, since the implementation of # tied arrays (and hashes) is such that in rvalue context, mg_get is # called prior to executing the op, while it isn't for a tied scalar. +# We also check that return values are correctly tainted. +# We try against two overload packages; one has all expected methods, the +# other uses only fallback methods. { - my @terms; + # @tests holds a list of test cases. Each elem is an array ref with + # the following entries: + # + # * the value that the overload method should return + # + # * the expression to be evaled. %s is replaced with the + # variable being tested ($ta[0], $ts, or $plain) + # + # * a string listing what functions we expect to be called. + # Each method appends its name in parentheses, so "(=)(+)" means + # we expect the copy constructor and then the add method to be + # called. + # + # * like above, but what should be called for the fallback-only test + # (in this case, nomethod() identifies itself as "(NM:*)" where * + # is the op). If this value is undef, fallback tests are skipped. + # + # * An array ref of expected counts of calls to FETCH/STORE. + # The first three values are: + # 1. the expected number of FETCHs for a tied array + # 2. the expected number of FETCHs for a tied scalar + # 3. the expected number of STOREs + # If there are a further three elements present, then + # these represent the expected counts for the fallback + # version of the tests. If absent, they are assumed to + # be the same as for the full method test + # + # * Under the taint version of the tests, whether we expect + # the result to be tainted (for example comparison ops + # like '==' don't return a tainted value, even if their + # args are. + my @tests; + my %subs; my $funcs; my $use_int; @@ -1658,69 +1694,115 @@ foreach my $op (qw(<=> == != < <= > >=)) { # multiple fetches between STOREs, which means that the tied # hash skips doing a FETCH during '='. - for (qw(+ - * / % ** << >> x . & | ^)) { - my $e = "%s $_= 3"; + for (qw(+ - * / % ** << >> & | ^)) { + my $op = $_; + $op = '%%' if $op eq '%'; + my $e = "%s $op= 3"; $subs{"$_="} = $e; # ARRAY FETCH: initial, sub+=, eval-return, # SCALAR FETCH: initial, sub=, sub+=, eval-return, # STORE: copy, mutator - push @terms, [ 18, $e, "$_=", '(=)', 3, 4, 2 ]; - $e = "%s $_ 3"; - $subs{$_} = $e; + push @tests, [ 18, $e, "(=)($_=)", "(=)(NM:$_=)", [ 3, 4, 2 ], 1 ]; + + $subs{$_} = + "do { my \$arg = %s; \$_[2] ? (3 $op \$arg) : (\$arg $op 3) }"; # ARRAY FETCH: initial # SCALAR FETCH: initial eval-return, - push @terms, [ 18, $e, $_, '', 1, 2, 0 ]; + push @tests, [ 18, "%s $op 3", "($_)", "(NM:$_)", [ 1, 2, 0 ], 1 ]; + push @tests, [ 18, "3 $op %s", "($_)", "(NM:$_)", [ 1, 2, 0 ], 1 ]; } + + # these use string fallback rather than nomethod + for (qw(x .)) { + my $op = $_; + my $e = "%s $op= 3"; + $subs{"$_="} = $e; + # For normal case: + # ARRAY FETCH: initial, sub+=, eval-return, + # SCALAR FETCH: initial, sub=, sub+=, eval-return, + # STORE: copy, mutator + # for fallback, we just stringify, so eval-return and copy skipped + + push @tests, [ 18, $e, "(=)($_=)", '("")', + [ 3, 4, 2, 2, 3, 1 ], 1 ]; + + $subs{$_} = + "do { my \$arg = %s; \$_[2] ? (3 $op \$arg) : (\$arg $op 3) }"; + # ARRAY FETCH: initial + # SCALAR FETCH: initial eval-return, + # with fallback, we just stringify, so eval-return skipped, + # but an extra FETCH happens in sub"", except for 'x', + # which passes a copy of the RV to sub"", avoiding the + # second FETCH + + push @tests, [ 18, "%s $op 3", "($_)", '("")', + [ 1, 2, 0, 1, ($_ eq '.' ? 2 : 1), 0 ], 1 ]; + next if $_ eq 'x'; # repeat only overloads on LHS + push @tests, [ 18, "3 $op %s", "($_)", '("")', + [ 1, 2, 0, 1, 2, 0 ], 1 ]; + } + for (qw(++ --)) { my $pre = "$_%s"; my $post = "%s$_"; $subs{$_} = $pre; - push @terms, + push @tests, # ARRAY FETCH: initial, sub+=, eval-return, # SCALAR FETCH: initial, sub=, sub+=, eval-return, # STORE: copy, mutator - [ 18, $pre, $_, '(=)("")', 3, 4, 2 ], + [ 18, $pre, "(=)($_)(\"\")", "(=)(NM:$_)(\"\")", [ 3, 4, 2 ], 1 ], # ARRAY FETCH: initial, sub+= # SCALAR FETCH: initial, sub=, sub+= # STORE: copy, mutator - [ 18, $post, $_, '(=)("")', 2, 3, 2 ]; + [ 18, $post, "(=)($_)(\"\")", "(=)(NM:$_)(\"\")", [ 2, 3, 2 ], 1 ]; } # For the non-mutator ops, we have a initial FETCH, # an extra FETCH within the sub itself for the scalar option, # and no STOREs - for (qw(< <= > >= == != lt le gt ge eq ne <=> cmp)) { + for (qw(< <= > >= == != lt le gt ge eq ne)) { + my $e = "%s $_ 3"; + $subs{$_} = $e; + push @tests, [ 3, $e, "($_)", "(NM:$_)", [ 1, 2, 0 ], 0 ]; + } + for (qw(<=> cmp)) { my $e = "%s $_ 3"; $subs{$_} = $e; - push @terms, [ 3, $e, $_, '', 1, 2, 0 ]; + push @tests, [ 3, $e, "($_)", "(NM:$_)", [ 1, 2, 0 ], 1 ]; } for (qw(atan2)) { my $e = "$_ %s, 3"; $subs{$_} = $e; - push @terms, [ 18, $e, $_, '', 1, 2, 0 ]; + push @tests, [ 18, $e, "($_)", "(NM:$_)", [ 1, 2, 0 ], 1 ]; + } + for (qw(cos sin exp abs log sqrt int ~)) { + my $e = "$_(%s)"; + $subs{$_} = $e; + push @tests, [ 1.23, $e, "($_)", + ($_ eq 'int' ? '(0+)' : "(NM:$_)") , [ 1, 2, 0 ], 1 ]; } - for (qw(cos sin exp abs log sqrt int ! ~)) { + for (qw(!)) { my $e = "$_(%s)"; $subs{$_} = $e; - push @terms, [ 1.23, $e, $_, '', 1, 2, 0 ]; + push @tests, [ 1.23, $e, "($_)", '(0+)', [ 1, 2, 0 ], 0 ]; } for (qw(-)) { my $e = "$_(%s)"; $subs{neg} = $e; - push @terms, [ 18, $e, 'neg', '', 1, 2, 0 ]; + push @tests, [ 18, $e, '(neg)', '(NM:neg)', [ 1, 2, 0 ], 1 ]; } my $e = '(%s) ? 1 : 0'; $subs{bool} = $e; - push @terms, [ 18, $e, 'bool', '', 1, 2, 0 ]; + push @tests, [ 18, $e, '(bool)', '(0+)', [ 1, 2, 0 ], 0 ]; # note: this is testing unary qr, not binary =~ - $subs{qr} = '(%s)'; - push @terms, [ qr/abc/, '"abc" =~ (%s)', 'qr', '', 1, 2, 0 ]; + $subs{qr} = '(qr/%s/)'; + push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ]; $e = '"abc" ~~ (%s)'; $subs{'~~'} = $e; - push @terms, [ "abc", $e, '~~', '', 1, 1, 0 ]; + push @tests, [ "abc", $e, '(~~)', '(NM:~~)', [ 1, 1, 0 ], 0 ]; $subs{'-X'} = 'do { my $f = (%s);' . '$_[1] eq "r" ? (-r ($f)) :' @@ -1733,37 +1815,43 @@ foreach my $op (qw(<=> == != < <= > >=)) { # long as the tied and untied versions return the same value. # The flags below are chosen to test all uses of tryAMAGICftest_MG for (qw(r e f l t T)) { - push @terms, [ 'TEST', "-$_ (%s)", '-X', '', 1, 2, 0 ]; + push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")', [ 1, 2, 0 ], 0 ]; } $subs{'${}'} = '%s'; - push @terms, [ do {my $s=99; \$s}, '${%s}', '${}', '', 1, 2, 0 ]; + push @tests, [ do {my $s=99; \$s}, '${%s}', '(${})', undef, [ 1, 1, 0 ], 0 ]; # we skip testing '@{}' here because too much of this test - # framework involves array deredfences! + # framework involves array dereferences! $subs{'%{}'} = '%s'; - push @terms, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}', '%{}', - '', 1, 2, 0 ]; + push @tests, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}', + '(%{})', undef, [ 1, 2, 0 ], 0 ]; $subs{'&{}'} = '%s'; - push @terms, [ sub {99}, 'do {&{%s} for 1,2}', '&{})(&{}', '', 2, 4, 0 ]; + push @tests, [ sub {99}, 'do {&{%s} for 1,2}', + '(&{})(&{})', undef, [ 2, 2, 0 ], 0 ]; our $RT57012A = 88; our $RT57012B; $subs{'*{}'} = '%s'; - push @terms, [ \*RT57012A, '*RT57012B = *{%s}; our $RT57012B', - '*{}', '', 1, 2, 0 ]; + push @tests, [ \*RT57012A, '*RT57012B = *{%s}; our $RT57012B', + '(*{})', undef, [ 1, 1, 0 ], 0 ]; # XXX TODO: '<>' + # eval should do tie, overload on its arg before checking taint */ + push @tests, [ '1;', 'eval q(eval %s); $@ =~ /Insecure/', + '("")', '("")', [ 1, 2, 0 ], 0 ]; + + for my $sub (keys %subs) { my $term = $subs{$sub}; my $t = sprintf $term, '$_[0][0]'; - $subs{$sub} = eval - "sub { \$funcs .= '($sub)'; my \$r; if (\$use_int) {" + my $e ="sub { \$funcs .= '($sub)'; my \$r; if (\$use_int) {" . "use integer; \$r = ($t) } else { \$r = ($t) } \$r }"; - die $@ if $@; + $subs{$sub} = eval $e; + die "Compiling sub gave error:\n<$e>\n<$@>\n" if $@; } } @@ -1772,18 +1860,49 @@ foreach my $op (qw(<=> == != < <= > >=)) { package RT57012_OV; - my $other; use overload %subs, - "=" => sub { $other .= '(=)'; bless [ $_[0][0] ] }, - '0+' => sub { $other .= '(0+)'; 0 + $_[0][0] }, - '""' => sub { $other .= '("")'; "$_[0][0]" }, + "=" => sub { $funcs .= '(=)'; bless [ $_[0][0] ] }, + '0+' => sub { $funcs .= '(0+)'; 0 + $_[0][0] }, + '""' => sub { $funcs .= '("")'; "$_[0][0]" }, + ; + + package RT57012_OV_FB; # only contains fallback conversion functions + + use overload + "=" => sub { $funcs .= '(=)'; bless [ $_[0][0] ] }, + '0+' => sub { $funcs .= '(0+)'; 0 + $_[0][0] }, + '""' => sub { $funcs .= '("")'; "$_[0][0]" }, + "nomethod" => sub { + $funcs .= "(NM:$_[3])"; + my $e = defined($_[1]) + ? $_[3] eq 'atan2' + ? $_[2] + ? "atan2(\$_[1],\$_[0][0])" + : "atan2(\$_[0][0],\$_[1])" + : $_[2] + ? "\$_[1] $_[3] \$_[0][0]" + : "\$_[0][0] $_[3] \$_[1]" + : $_[3] eq 'neg' + ? "-\$_[0][0]" + : "$_[3](\$_[0][0])"; + my $r; + if ($use_int) { + use integer; $r = eval $e; + } + else { + $r = eval $e; + } + ::diag("eval of nomethod <$e> gave <$@>") if $@; + $r; + } + ; package RT57012_TIE_S; my $tie_val; - sub TIESCALAR { bless [ bless [ $tie_val ], 'RT57012_OV' ] } + sub TIESCALAR { bless [ bless [ $tie_val ], $_[1] ] } sub FETCH { $fetches++; $_[0][0] } sub STORE { $stores++; $_[0][0] = $_[1] } @@ -1795,35 +1914,77 @@ foreach my $op (qw(<=> == != < <= > >=)) { package main; - for my $term (@terms) { - my ($val, $sub_term, $exp_funcs, $exp_side, - $exp_fetch_a, $exp_fetch_s, $exp_store) = @$term; + for my $test (@tests) { + my ($val, $sub_term, $exp_funcs, $exp_fb_funcs, + $exp_counts, $exp_taint) = @$test; + + my $tainted_val; + { + # create tainted version of $val (unless its a ref) + my $t = substr($^X,0,0); + my $t0 = $t."0"; + my $val1 = $val; # use a copy to avoid stringifying original + $tainted_val = ref($val1) ? $val : + ($val1 =~ /^[\d\.]+$/) ? $val+$t0 : $val.$t; + } + $tie_val = $tainted_val; - $tie_val = $val; for my $int ('', 'use integer; ') { $use_int = ($int ne ''); - for my $var ('$ta[0]', '$ts') { - my $exp_fetch = ($var eq '$ts') ? $exp_fetch_s : $exp_fetch_a; - tie my $ts, 'RT57012_TIE_S'; + my $plain = $tainted_val; + my $plain_term = $int . sprintf $sub_term, '$plain'; + my $exp = eval $plain_term; + diag("eval of plain_term <$plain_term> gave <$@>") if $@; + is(tainted($exp), $exp_taint, + "<$plain_term> taint of expected return"); + + for my $ov_pkg (qw(RT57012_OV RT57012_OV_FB)) { + # the deref ops don't support fallback + next if $ov_pkg eq 'RT57012_OV_FB' + and not defined $exp_fb_funcs; + my ($exp_fetch_a, $exp_fetch_s, $exp_store) = + ($ov_pkg eq 'RT57012_OV' || @$exp_counts < 4) + ? @$exp_counts[0,1,2] + : @$exp_counts[3,4,5]; + + tie my $ts, 'RT57012_TIE_S', $ov_pkg; tie my @ta, 'RT57012_TIE_A'; - $ta[0] = bless [ $val ], 'RT57012_OV'; - my $x = $val; - my $tied_term = $int . sprintf $sub_term, $var; - my $plain_term = $int . sprintf $sub_term, '$x'; - - $other = ''; $funcs = ''; - - $fetches = 0; - $stores = 0; - my $res = eval $tied_term; - $res = "$res"; - my $exp = eval $plain_term; - $exp = "$exp"; - is ($res, $exp, "tied '$tied_term' return value"); - is ($funcs, "($exp_funcs)", "tied '$tied_term' methods called"); - is ($other, $exp_side, "tied '$tied_term' side effects called"); - is ($fetches, $exp_fetch, "tied '$tied_term' FETCH count"); - is ($stores, $exp_store, "tied '$tied_term' STORE count"); + $ta[0] = bless [ $tainted_val ], $ov_pkg; + my $oload = bless [ $tainted_val ], $ov_pkg; + + for my $var ('$ta[0]', '$ts', '$oload') { + + $funcs = ''; + $fetches = 0; + $stores = 0; + + my $res_term = $int . sprintf $sub_term, $var; + my $desc = "<$res_term> $ov_pkg" ; + my $res = eval $res_term; + diag("eval of res_term $desc gave <$@>") if $@; + # uniquely, the inc/dec ops return tthe original + # ref rather than a copy, so stringify it to + # find out if its tainted + $res = "$res" if $res_term =~ /\+\+|--/; + is(tainted($res), $exp_taint, + "$desc taint of result return"); + is($res, $exp, "$desc return value"); + my $fns =($ov_pkg eq 'RT57012_OV_FB') + ? $exp_fb_funcs : $exp_funcs; + if ($var eq '$oload' && $res_term !~ /oload(\+\+|--)/) { + # non-tied overloading doesn't trigger a copy + # except for post inc/dec + $fns =~ s/^\(=\)//; + } + is($funcs, $fns, "$desc methods called"); + next if $var eq '$oload'; + my $exp_fetch = ($var eq '$ts') ? + $exp_fetch_s : $exp_fetch_a; + is($fetches, $exp_fetch, "$desc FETCH count"); + is($stores, $exp_store, "$desc STORE count"); + + } + } } } diff --git a/mathoms.c b/mathoms.c index 058d76d..1bb33d3 100644 --- a/mathoms.c +++ b/mathoms.c @@ -78,6 +78,8 @@ PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV AV * Perl_newAV(pTHX); PERL_CALLCONV HV * Perl_newHV(pTHX); PERL_CALLCONV IO * Perl_newIO(pTHX); +PERL_CALLCONV I32 Perl_my_stat(pTHX); +PERL_CALLCONV I32 Perl_my_lstat(pTHX); /* ref() is now a macro using Perl_doref; * this version provided for binary compatibility only. @@ -1519,6 +1521,18 @@ Perl_newIO(pTHX) return MUTABLE_IO(newSV_type(SVt_PVIO)); } +I32 +Perl_my_stat(pTHX) +{ + return my_stat_flags(SV_GMAGIC); +} + +I32 +Perl_my_lstat(pTHX) +{ + return my_lstat_flags(SV_GMAGIC); +} + #endif /* NO_MATHOMS */ /* diff --git a/perl.h b/perl.h index b551f4b..3d60a33 100644 --- a/perl.h +++ b/perl.h @@ -3425,6 +3425,10 @@ struct nexttoken { #include "warnings.h" #include "utf8.h" +/* these would be in doio.h if there was such a file */ +#define my_stat() my_stat_flags(SV_GMAGIC) +#define my_lstat() my_lstat_flags(SV_GMAGIC) + /* defined in sv.c, but also used in [ach]v.c */ #undef _XPV_HEAD #undef _XPVMG_HEAD diff --git a/pp_ctl.c b/pp_ctl.c index 7d041bd..ccda760 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -117,17 +117,15 @@ PP(pp_regcomp) sv_setpvs(tmpstr, ""); while (++MARK <= SP) { SV *msv = *MARK; - if (PL_amagic_generation) { - SV *sv; + SV *sv; - tryAMAGICregexp(msv); + tryAMAGICregexp(msv); - if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && - (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) - { - sv_setsv(tmpstr, sv); - continue; - } + if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && + (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) + { + sv_setsv(tmpstr, sv); + continue; } sv_catsv(tmpstr, msv); } @@ -176,8 +174,9 @@ PP(pp_regcomp) PM_SETRE(pm, re); } else { - STRLEN len; - const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; + STRLEN len = 0; + const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : ""; + re = PM_GETRE(pm); assert (re != (REGEXP*) &PL_sv_undef); @@ -215,10 +214,21 @@ PP(pp_regcomp) const char *const p = SvPV(tmpstr, len); tmpstr = newSVpvn_flags(p, len, SVs_TEMP); } + else if (SvAMAGIC(tmpstr)) { + /* make a copy to avoid extra stringifies */ + SV* copy = newSV_type(SVt_PV); + sv_setpvn(copy, t, len); + if (SvUTF8(tmpstr)) + SvUTF8_on(copy); + else + SvUTF8_off(copy); + sv_2mortal(copy); + tmpstr = copy; + } - if (eng) + if (eng) PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); - else + else PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed @@ -3763,6 +3773,15 @@ PP(pp_entereval) saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } sv = POPs; + if (!SvPOK(sv)) { + /* make sure we've got a plain PV (no overload etc) before testing + * for taint. Making a copy here is probably overkill, but better + * safe than sorry */ + SV* tmpsv = newSV_type(SVt_PV); + sv_copypv(tmpsv, sv); + sv_2mortal(tmpsv); + sv = tmpsv; + } TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); diff --git a/pp_hot.c b/pp_hot.c index 29928d7..0e52921 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -255,14 +255,13 @@ PP(pp_concat) SvUTF8_off(TARG); } else { /* TARG == left */ - STRLEN llen; if (!SvOK(TARG)) { if (left == right && ckWARN(WARN_UNINITIALIZED)) report_uninit(right); sv_setpvs(left, ""); } - (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */ - lbyte = !DO_UTF8(left); + lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP) + ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left); if (IN_BYTES) SvUTF8_off(TARG); } diff --git a/pp_sort.c b/pp_sort.c index ed9c809..f1ec82a 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1858,7 +1858,7 @@ S_sv_i_ncmp(pTHX_ SV *const a, SV *const b) } #define tryCALL_AMAGICbin(left,right,meth) \ - (PL_amagic_generation && (SvAMAGIC(left)||SvAMAGIC(right))) \ + (SvAMAGIC(left)||SvAMAGIC(right)) \ ? amagic_call(left, right, CAT2(meth,_amg), 0) \ : NULL; diff --git a/pp_sys.c b/pp_sys.c index d0b0423..fbac576 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -3133,7 +3133,7 @@ PP(pp_ftrread) #endif } - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3161,7 +3161,7 @@ PP(pp_ftis) STACKED_FTEST_CHECK; - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3233,7 +3233,7 @@ PP(pp_ftrowned) STACKED_FTEST_CHECK; - result = my_stat(); + result = my_stat_flags(0); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3303,7 +3303,7 @@ PP(pp_ftlink) I32 result; tryAMAGICftest_MG('l'); - result = my_lstat(); + result = my_lstat_flags(0); SPAGAIN; if (result < 0) @@ -3320,6 +3320,8 @@ PP(pp_fttty) int fd; GV *gv; SV *tmpsv = NULL; + char *name; + STRLEN namelen; tryAMAGICftest_MG('t'); @@ -3331,15 +3333,17 @@ PP(pp_fttty) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); - else - gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO); + else { + tmpsv = POPs; + name = SvPV_nomg(tmpsv, namelen); + gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); + } if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (tmpsv && SvOK(tmpsv)) { - const char *tmps = SvPV_nolen_const(tmpsv); - if (isDIGIT(*tmps)) - fd = atoi(tmps); + if (isDIGIT(*name)) + fd = atoi(name); else RETPUSHUNDEF; } @@ -3440,7 +3444,7 @@ PP(pp_fttext) really_filename: PL_statgv = NULL; PL_laststype = OP_STAT; - sv_setpv(PL_statname, SvPV_nolen_const(sv)); + sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) diff --git a/proto.h b/proto.h index 03148fa..b1239b8 100644 --- a/proto.h +++ b/proto.h @@ -2082,7 +2082,8 @@ PERL_CALLCONV I32 Perl_my_fflush_all(pTHX); PERL_CALLCONV Pid_t Perl_my_fork(void); PERL_CALLCONV void Perl_atfork_lock(void); PERL_CALLCONV void Perl_atfork_unlock(void); -PERL_CALLCONV I32 Perl_my_lstat(pTHX); +/* PERL_CALLCONV I32 Perl_my_lstat(pTHX); */ +PERL_CALLCONV I32 Perl_my_lstat_flags(pTHX_ const U32 flags); #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) PERL_CALLCONV I32 Perl_my_memcmp(const char* s1, const char* s2, I32 len) __attribute__pure__ @@ -2113,7 +2114,8 @@ PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ const char* mode, int n, SV ** ar assert(mode); assert(args) PERL_CALLCONV void Perl_my_setenv(pTHX_ const char* nam, const char* val); -PERL_CALLCONV I32 Perl_my_stat(pTHX); +/* PERL_CALLCONV I32 Perl_my_stat(pTHX); */ +PERL_CALLCONV I32 Perl_my_stat_flags(pTHX_ const U32 flags); PERL_CALLCONV char * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MY_STRFTIME \ diff --git a/sv.c b/sv.c index b06c14a..c38a318 100644 --- a/sv.c +++ b/sv.c @@ -2683,6 +2683,7 @@ Perl_sv_2num(pTHX_ register SV *const sv) return sv; if (SvAMAGIC(sv)) { SV * const tmpsv = AMG_CALLun(sv,numer); + TAINT_IF(tmpsv && SvTAINTED(tmpsv)); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) return sv_2num(tmpsv); } @@ -2804,6 +2805,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags if (flags & SV_SKIP_OVERLOAD) return NULL; tmpstr = AMG_CALLun(sv,string); + TAINT_IF(tmpstr && SvTAINTED(tmpstr)); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { /* Unwrap this: */ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); diff --git a/t/op/eval.t b/t/op/eval.t index ff5004e..0a5fadc 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -print "1..106\n"; +print "1..107\n"; eval 'print "ok 1\n";'; @@ -604,3 +604,10 @@ eval q{ eval { + } }; print "ok\n"; EOP +fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start'); +use overload '""' => sub { '1;' }; +my $ov = bless []; +eval $ov; +print "ok\n"; +EOP + diff --git a/toke.c b/toke.c index ac00450..5e2dc75 100644 --- a/toke.c +++ b/toke.c @@ -714,8 +714,9 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter) if (!len) { parser->linestr = newSVpvs("\n;"); - } else if (SvREADONLY(line) || s[len-1] != ';') { - parser->linestr = newSVsv(line); + } else if (SvREADONLY(line) || s[len-1] != ';' || !SvPOK(line)) { + parser->linestr = newSV_type(SVt_PV); + sv_copypv(parser->linestr, line); /* avoid tie/overload weirdness */ if (s[len-1] != ';') sv_catpvs(parser->linestr, "\n;"); } else { -- Perl5 Master Repository
