In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a53bfdae91fb2d719e69761f2d2f84c5d8a47753?hp=7aa8cb0dec173dcfca4157e60634c74b97429a05>
- Log ----------------------------------------------------------------- commit a53bfdae91fb2d719e69761f2d2f84c5d8a47753 Author: Hugo van der Sanden <[email protected]> Date: Sun Feb 8 13:53:00 2015 +0000 [perl #123759] always count on OPpTRANS_IDENTICAL If we detect that an in-place transliteration will not result in any changes to the string, we set OPpTRANS_IDENTICAL and skip the normal checks for readonlyness; but if we do that, we must make sure to use the same logic to decide which transliteration strategy to use, or we may end up trying to write to the readonly string anyway. This resulted in several ways to hit assert failures, found by AFL (<http://lcamtuf.coredump.cx/afl>). ----------------------------------------------------------------------- Summary of changes: doop.c | 40 ++++++++++++++-------------------------- t/op/tr.t | 15 ++++++++++++++- 2 files changed, 28 insertions(+), 27 deletions(-) diff --git a/doop.c b/doop.c index 2bd4e13..47fea28 100644 --- a/doop.c +++ b/doop.c @@ -619,18 +619,18 @@ I32 Perl_do_trans(pTHX_ SV *sv) { STRLEN len; - const I32 hasutf = (PL_op->op_private & - (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); + const I32 flags = PL_op->op_private; + const I32 hasutf = flags & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF); PERL_ARGS_ASSERT_DO_TRANS; - if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) { - Perl_croak_no_modify(); + if (SvREADONLY(sv) && !(flags & OPpTRANS_IDENTICAL)) { + Perl_croak_no_modify(); } (void)SvPV_const(sv, len); if (!len) return 0; - if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) { + if (!(flags & OPpTRANS_IDENTICAL)) { if (!SvPOKp(sv) || SvTHINKFIRST(sv)) (void)SvPV_force_nomg(sv, len); (void)SvPOK_only_UTF8(sv); @@ -638,27 +638,15 @@ Perl_do_trans(pTHX_ SV *sv) DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); - switch (PL_op->op_private & ~hasutf & ( - OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL| - OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) { - case 0: - if (hasutf) - return do_trans_simple_utf8(sv); - else - return do_trans_simple(sv); - - case OPpTRANS_IDENTICAL: - case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT: - if (hasutf) - return do_trans_count_utf8(sv); - else - return do_trans_count(sv); - - default: - if (hasutf) - return do_trans_complex_utf8(sv); - else - return do_trans_complex(sv); + /* If we use only OPpTRANS_IDENTICAL to bypass the READONLY check, + * we must also rely on it to choose the readonly strategy. + */ + if (flags & OPpTRANS_IDENTICAL) { + return hasutf ? do_trans_count_utf8(sv) : do_trans_count(sv); + } else if (flags & (OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) { + return hasutf ? do_trans_complex_utf8(sv) : do_trans_complex(sv); + } else { + return hasutf ? do_trans_simple_utf8(sv) : do_trans_simple(sv); } } diff --git a/t/op/tr.t b/t/op/tr.t index c45971a..6c38893 100644 --- a/t/op/tr.t +++ b/t/op/tr.t @@ -8,7 +8,7 @@ BEGIN { set_up_inc('../lib'); } -plan tests => 134; +plan tests => 138; # Test this first before we extend the stack with other operations. # This caused an asan failure due to a bad write past the end of the stack. @@ -538,4 +538,17 @@ for ("", nullrocow) { 'tr/a/b/ fails on zero-length ro string'; } +# Whether they're permitted or not, non-modifying tr/// should not write +# to read-only values, even with funky flags. +{ # [perl #123759] + eval q{ ('a' =~ /./) =~ tr///d }; + ok(1, "tr///d on PL_Yes does not assert"); + eval q{ ('a' =~ /./) =~ tr/a-z/a-z/d }; + ok(1, "tr/a-z/a-z/d on PL_Yes does not assert"); + eval q{ ('a' =~ /./) =~ tr///s }; + ok(1, "tr///s on PL_Yes does not assert"); + eval q{ *x =~ tr///d }; + ok(1, "tr///d on glob does not assert"); +} + 1; -- Perl5 Master Repository
