From 5c3354f132f3587d2ec587e190a9ebb20d390b38 Mon Sep 17 00:00:00 2001 From: Ed J Date: Tue, 19 Nov 2024 10:16:40 +0000 Subject: [PATCH] no force boolean context for defined-or ops --- Cover.xs | 53 +++-- test_output/cover/cond_or.5.012000 | 40 ++-- test_output/cover/cond_or.5.020000 | 283 +++++++++++++++++++++++ test_output/cover/overload_bool.5.012000 | 17 +- tests/overload_bool | 9 +- 5 files changed, 360 insertions(+), 42 deletions(-) create mode 100644 test_output/cover/cond_or.5.020000 diff --git a/Cover.xs b/Cover.xs index 4f144355..382557f8 100644 --- a/Cover.xs +++ b/Cover.xs @@ -535,7 +535,13 @@ static void set_conditional(pTHX_ OP *op, int cond, int value) { static void add_conditional(pTHX_ OP *op, int cond) { SV **count = av_fetch(get_conditional_array(aTHX_ op), cond, 1); - int c = SvTRUE(*count) ? SvIV(*count) + 1 : 1; +#if PERL_VERSION > 8 + bool true_ish = (op->op_type == OP_DOR || op->op_type == OP_DORASSIGN) + ? SvOK(*count) : SvTRUE(*count); +#else + bool true_ish = SvTRUE(*count); +#endif + int c = true_ish ? SvIV(*count) + 1 : 1; sv_setiv(*count, c); NDEB(D(L, "Adding %d conditional making %d at %p\n", cond, c, op)); } @@ -594,14 +600,20 @@ static void add_condition(pTHX_ SV *cond_ref, int value) { for (; i <= av_len(conds); i++) { OP *op = INT2PTR(OP *, SvIV(*av_fetch(conds, i, 0))); SV **count = av_fetch(get_conditional_array(aTHX_ op), 0, 1); - int type = SvTRUE(*count) ? SvIV(*count) : 0; +#if PERL_VERSION > 8 + bool true_ish = (op->op_type == OP_DOR || op->op_type == OP_DORASSIGN) + ? SvOK(*count) : SvTRUE(*count); +#else + bool true_ish = SvTRUE(*count); +#endif + int type = true_ish ? SvIV(*count) : 0; sv_setiv(*count, 0); /* Check if we have come from an xor with a true first op */ if (final) value = 1; if (type == 1) value += 2; - NDEB(D(L, "Found %p: %d, %d\n", op, type, value)); + NDEB(D(L, "Found %p (trueish=%d): %d, %d\n", op, true_ish?1:0, type, value)); add_conditional(aTHX_ op, value); } @@ -718,7 +730,15 @@ static OP *get_condition(pTHX) { PL_op, (void *)PL_op->op_targ, pc, hex_key(get_key(PL_op)))); /* dump_conditions(aTHX); */ NDEB(svdump(Pending_conditionals)); - add_condition(aTHX_ *pc, SvTRUE(TOPs) ? 2 : 1); + bool true_ish; +#if PERL_VERSION > 8 + true_ish = (PL_op->op_type == OP_DOR || PL_op->op_type == OP_DORASSIGN) + ? SvOK(TOPs) : SvTRUE(TOPs); +#else + true_ish = SvTRUE(TOPs); +#endif + NDEB(D(L, " get_condition true_ish=%d\n", true_ish?1:0)); + add_condition(aTHX_ *pc, true_ish ? 2 : 1); } else { PDEB(D(L, "All is lost, I know not where to go from %p, %p: %p (%s)\n", PL_op, (void *)PL_op->op_targ, pc, hex_key(get_key(PL_op)))); @@ -810,9 +830,12 @@ static void cover_logop(pTHX) { } else { dSP; - int left_val = SvTRUE(TOPs); + int leftval_true_ish; #if PERL_VERSION > 8 - int left_val_def = SvOK(TOPs); + leftval_true_ish = (PL_op->op_type == OP_DOR || PL_op->op_type == OP_DORASSIGN) + ? SvOK(TOPs) : SvTRUE(TOPs); +#else + leftval_true_ish = SvTRUE(TOPs); #endif /* We don't count X= as void context because we care about the value * of the RHS */ @@ -822,19 +845,19 @@ static void cover_logop(pTHX) { #endif PL_op->op_type != OP_ANDASSIGN && PL_op->op_type != OP_ORASSIGN; - NDEB(D(L, "left_val: %d, void_context: %d at %p\n", - left_val, void_context, PL_op)); + NDEB(D(L, "leftval_true_ish: %d, void_context: %d at %p\n", + leftval_true_ish, void_context, PL_op)); NDEB(op_dump(PL_op)); set_conditional(aTHX_ PL_op, 5, void_context); - if ((PL_op->op_type == OP_AND && left_val) || - (PL_op->op_type == OP_ANDASSIGN && left_val) || - (PL_op->op_type == OP_OR && !left_val) || - (PL_op->op_type == OP_ORASSIGN && !left_val) || + if ((PL_op->op_type == OP_AND && leftval_true_ish) || + (PL_op->op_type == OP_ANDASSIGN && leftval_true_ish) || + (PL_op->op_type == OP_OR && !leftval_true_ish) || + (PL_op->op_type == OP_ORASSIGN && !leftval_true_ish) || #if PERL_VERSION > 8 - (PL_op->op_type == OP_DOR && !left_val_def) || - (PL_op->op_type == OP_DORASSIGN && !left_val_def) || + (PL_op->op_type == OP_DOR && !leftval_true_ish) || + (PL_op->op_type == OP_DORASSIGN && !leftval_true_ish) || #endif (PL_op->op_type == OP_XOR)) { /* no short circuit */ @@ -866,7 +889,7 @@ static void cover_logop(pTHX) { *cond; OP *next; - if (PL_op->op_type == OP_XOR && left_val) { + if (PL_op->op_type == OP_XOR && leftval_true_ish) { /* * This is an xor. It does not short circuit. We * have just executed the first op. When we get to diff --git a/test_output/cover/cond_or.5.012000 b/test_output/cover/cond_or.5.012000 index 98c3fe93..239c0403 100644 --- a/test_output/cover/cond_or.5.012000 +++ b/test_output/cover/cond_or.5.012000 @@ -249,26 +249,26 @@ or 2 conditions line err % l !l expr ----- --- ------ ------ ------ ---- -16 *** 50 11 0 $$x[18] //= undef -17 *** 50 11 0 $$x[18] //= 0 -18 *** 50 11 0 $$x[18] //= 0 -19 *** 50 11 0 $$x[18] //= 1 -20 *** 50 11 0 $$x[18] //= 1 -22 100 10 1 $$x[19] //= 1 -23 *** 50 11 0 $$x[19] //= 1 -24 *** 50 11 0 $$x[19] //= 0 -25 *** 50 11 0 $$x[19] //= undef -26 *** 50 11 0 $$x[19] //= 1 -28 *** 50 0 11 $$x[21] // undef -29 *** 50 0 11 $$x[21] // 0 -30 *** 50 0 11 $$x[21] // 0 -31 *** 50 0 11 $$x[21] // 1 -32 *** 50 0 11 $$x[21] // 1 -34 100 10 1 $$x[22] // undef -35 100 10 1 $$x[22] // 0 -36 *** 50 11 0 $$x[22] // 0 -37 *** 50 11 0 $$x[22] // 1 -38 *** 50 11 0 $$x[22] // 1 +16 *** 50 1 0 $$x[18] //= undef +17 *** 50 1 0 $$x[18] //= 0 +18 *** 50 1 0 $$x[18] //= 0 +19 *** 50 1 0 $$x[18] //= 1 +20 *** 50 1 0 $$x[18] //= 1 +22 100 1 1 $$x[19] //= 1 +23 *** 50 1 0 $$x[19] //= 1 +24 *** 50 1 0 $$x[19] //= 0 +25 *** 50 1 0 $$x[19] //= undef +26 *** 50 1 0 $$x[19] //= 1 +28 *** 50 0 1 $$x[21] // undef +29 *** 50 0 1 $$x[21] // 0 +30 *** 50 0 1 $$x[21] // 0 +31 *** 50 0 1 $$x[21] // 1 +32 *** 50 0 1 $$x[21] // 1 +34 100 1 1 $$x[22] // undef +35 100 1 1 $$x[22] // 0 +36 *** 50 1 0 $$x[22] // 0 +37 *** 50 1 0 $$x[22] // 1 +38 *** 50 1 0 $$x[22] // 1 Covered Subroutines diff --git a/test_output/cover/cond_or.5.020000 b/test_output/cover/cond_or.5.020000 new file mode 100644 index 00000000..98c3fe93 --- /dev/null +++ b/test_output/cover/cond_or.5.020000 @@ -0,0 +1,283 @@ +Reading database from ... + + +---------------- ------ ------ ------ ------ ------ +File stmt bran cond sub total +---------------- ------ ------ ------ ------ ------ +tests/cond_or 89.6 35.0 64.4 60.0 70.4 +tests/cond_or.pl 100.0 n/a 57.5 100.0 75.7 +Total 92.9 35.0 61.6 75.0 72.1 +---------------- ------ ------ ------ ------ ------ + + +Run: ... +Perl version: ... +OS: ... +Start: ... +Finish: ... + +tests/cond_or + +line err stmt bran cond sub code +1 #!/usr/bin/perl +2 +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) +4 +5 # This software is free. It is licensed under the same terms as Perl itself. +6 +7 # The latest version of this software should be available from my homepage: +8 # http://www.pjcj.net +9 +10 # __COVER__ skip_test $] < 5.008 || $^O eq "cygwin" +11 # __COVER__ skip_reason Busted on 5.6 and cygwin +12 +13 1 1 use strict; + 1 + 1 +14 1 1 use warnings; + 1 + 1 +15 +16 1 my @x; +17 +18 1 my $y = 1; +19 1 my $z = 0; +20 1 $::foo = 17; +21 +22 *** 1 * 50 if ($] >= 5.009) { +23 1 $ENV{PATH} = "/bin"; +24 1 system "pwd"; +25 1 1 use lib "tests"; + 1 + 1 +26 1 my $file = "cond_or.pl"; +27 *** 1 * 50 unless (my $return = do $file) { +28 *** *0 * 0 die "couldn't parse $file: $@" if $@; +29 *** *0 * 0 die "couldn't do $file: $!" unless defined $return; +30 *** *0 * 0 die "couldn't run $file" unless $return; +31 } +32 } +33 +34 1 for my $i (0 .. 10) { +35 *** 11 * 50 $y || +36 $x[1]++; +37 +38 *** 11 * 50 * 33 $y || +39 $x[0]++ || +40 $x[1]++; +41 +42 *** 11 * 50 $x[2]++ +43 unless $z; +44 +45 11 for (0 .. 2) { +46 33 $x[3]++; +47 } +48 +49 *** 11 * 50 if ($z) { +50 *** *0 $x[4]++; +51 } else { +52 11 $x[5]++; +53 } +54 +55 *** 11 * 33 my $p = $y || $z; +56 *** 11 * 33 my $q = $z || $y; +57 11 100 my $r = $i || "qqq"; +58 11 100 my $s = $i || []; +59 11 my $t = $y | $z; +60 *** 11 * 50 my $u = $y || 0; +61 *** 11 * 50 my $v = $y || undef; +62 *** 11 * 50 my $w = $z || 0; +63 +64 *** 11 * 33 $p ||= $y; +65 *** 11 * 33 $p ||= $z; +66 *** 11 * 66 $x[ 6] ||= $y; +67 *** 11 * 33 $x[ 7] ||= $z; +68 11 100 $x[ 8] ||= 1; +69 11 100 $x[ 9] ||= {}; +70 11 100 $x[10] ||= \"foo"; +71 11 100 $x[11] ||= \$y; +72 11 100 $x[12] ||= \*STDIO; +73 *** 11 100 *0 $x[13] ||= sub { 1 }; + *** *0 +74 11 100 $x[14] ||= *::foo{SCALAR}; +75 *** 11 * 50 $x[15] ||= *STDIO{IO}; +76 11 100 $x[16] ||= bless {}, "XXX"; +77 11 100 $x[17] ||= $i == 1; +78 *** 11 * 33 $w ||= ref($i) eq "SCALAR"; +79 11 100 $x[18] ||= <<"EOD"; +80 blah +81 EOD +82 *** 11 * 50 cond_dor(\@x) if exists &cond_dor; +83 *** 11 * 0 *0 sub { $x[19] ||= 1 }; + *** *0 +84 } +85 +86 # print join(", ", @x), "\n"; + + +Branches +-------- + +line err % true false branch +----- --- ------ ------ ------ ------ +22 *** 50 1 0 if ($] >= "5.009") +27 *** 50 0 1 unless (my $return = do $file) +28 *** 0 0 0 if $@ +29 *** 0 0 0 unless defined $return +30 *** 0 0 0 unless $return +35 *** 50 0 11 unless $y +38 *** 50 0 11 unless $y or $x[0]++ +42 *** 50 11 0 unless $z +49 *** 50 0 11 if ($z) { } +82 *** 50 11 0 if exists &cond_dor + + +Conditions +---------- + +or 2 conditions + +line err % l !l expr +----- --- ------ ------ ------ ---- +57 100 10 1 $i || 'qqq' +58 100 10 1 $i || [] +60 *** 50 11 0 $y || 0 +61 *** 50 11 0 $y || undef +62 *** 50 0 11 $z || 0 +68 100 10 1 $x[8] ||= 1 +69 100 10 1 $x[9] ||= {} +70 100 10 1 $x[10] ||= \"foo" +71 100 10 1 $x[11] ||= \$y +72 100 10 1 $x[12] ||= \*STDIO +73 100 10 1 $x[13] ||= sub { + 1; +} + +74 100 10 1 $x[14] ||= *foo{"SCALAR"} +75 *** 50 0 11 $x[15] ||= *STDIO{"IO"} +76 100 10 1 $x[16] ||= bless({}, "XXX") +79 100 10 1 $x[18] ||= "blah\n" +83 *** 0 0 0 $x[19] ||= 1 + +or 3 conditions + +line err % l !l&&r !l&&!r expr +----- --- ------ ------ ------ ------ ---- +38 *** 33 11 0 0 $y or $x[0]++ +55 *** 33 11 0 0 $y || $z +56 *** 33 0 11 0 $z || $y +64 *** 33 11 0 0 $p ||= $y +65 *** 33 11 0 0 $p ||= $z +66 *** 66 10 1 0 $x[6] ||= $y +67 *** 33 0 0 11 $x[7] ||= $z +77 100 9 1 1 $x[17] ||= $i == 1 +78 *** 33 0 0 11 $w ||= ref $i eq "SCALAR" + + +Covered Subroutines +------------------- + +Subroutine Count Location +---------- ----- ---------------- +BEGIN 1 tests/cond_or:13 +BEGIN 1 tests/cond_or:14 +BEGIN 1 tests/cond_or:25 + +Uncovered Subroutines +--------------------- + +Subroutine Count Location +---------- ----- ---------------- +__ANON__ 0 tests/cond_or:73 +__ANON__ 0 tests/cond_or:83 + + +tests/cond_or.pl + +line err stmt bran cond sub code +1 #!/usr/bin/perl +2 +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) +4 +5 # This software is free. It is licensed under the same terms as Perl itself. +6 +7 # The latest version of this software should be available from my homepage: +8 # http://www.pjcj.net +9 +10 1 1 use strict; + 1 + 1 +11 1 1 use warnings; + 1 + 1 +12 +13 sub cond_dor { +14 11 11 my ($x) = @_; +15 +16 *** 11 * 50 $x->[18] //= undef; +17 *** 11 * 50 $x->[18] //= 0; +18 *** 11 * 50 $x->[18] //= 0; +19 *** 11 * 50 $x->[18] //= 1; +20 *** 11 * 50 $x->[18] //= 1; +21 +22 11 100 $x->[19] //= 1; +23 *** 11 * 50 $x->[19] //= 1; +24 *** 11 * 50 $x->[19] //= 0; +25 *** 11 * 50 $x->[19] //= undef; +26 *** 11 * 50 $x->[19] //= 1; +27 +28 *** 11 * 50 $x->[20] = $x->[21] // undef; +29 *** 11 * 50 $x->[20] = $x->[21] // 0; +30 *** 11 * 50 $x->[20] = $x->[21] // 0; +31 *** 11 * 50 $x->[20] = $x->[21] // 1; +32 *** 11 * 50 $x->[20] = $x->[21] // 1; +33 +34 11 100 $x->[22] = $x->[22] // undef; +35 11 100 $x->[22] = $x->[22] // 0; +36 *** 11 * 50 $x->[22] = $x->[22] // 0; +37 *** 11 * 50 $x->[22] = $x->[22] // 1; +38 *** 11 * 50 $x->[22] = $x->[22] // 1; +39 } +40 +41 1; + + +Conditions +---------- + +or 2 conditions + +line err % l !l expr +----- --- ------ ------ ------ ---- +16 *** 50 11 0 $$x[18] //= undef +17 *** 50 11 0 $$x[18] //= 0 +18 *** 50 11 0 $$x[18] //= 0 +19 *** 50 11 0 $$x[18] //= 1 +20 *** 50 11 0 $$x[18] //= 1 +22 100 10 1 $$x[19] //= 1 +23 *** 50 11 0 $$x[19] //= 1 +24 *** 50 11 0 $$x[19] //= 0 +25 *** 50 11 0 $$x[19] //= undef +26 *** 50 11 0 $$x[19] //= 1 +28 *** 50 0 11 $$x[21] // undef +29 *** 50 0 11 $$x[21] // 0 +30 *** 50 0 11 $$x[21] // 0 +31 *** 50 0 11 $$x[21] // 1 +32 *** 50 0 11 $$x[21] // 1 +34 100 10 1 $$x[22] // undef +35 100 10 1 $$x[22] // 0 +36 *** 50 11 0 $$x[22] // 0 +37 *** 50 11 0 $$x[22] // 1 +38 *** 50 11 0 $$x[22] // 1 + + +Covered Subroutines +------------------- + +Subroutine Count Location +---------- ----- ------------------- +BEGIN 1 tests/cond_or.pl:10 +BEGIN 1 tests/cond_or.pl:11 +cond_dor 11 tests/cond_or.pl:14 + + diff --git a/test_output/cover/overload_bool.5.012000 b/test_output/cover/overload_bool.5.012000 index 24a4a14e..8b0d64d2 100644 --- a/test_output/cover/overload_bool.5.012000 +++ b/test_output/cover/overload_bool.5.012000 @@ -4,8 +4,8 @@ Reading database from ... ------------------- ------ ------ ------ ------ ------ File stmt bran cond sub total ------------------- ------ ------ ------ ------ ------ -tests/overload_bool 55.5 50.0 n/a 25.0 46.6 -Total 55.5 50.0 n/a 25.0 46.6 +tests/overload_bool 66.6 50.0 n/a 25.0 54.5 +Total 66.6 50.0 n/a 25.0 54.5 ------------------- ------ ------ ------ ------ ------ @@ -30,7 +30,7 @@ line err stmt bran cond sub code 10 package Foo; 11 use overload 12 *** *0 *0 '""' => sub { shift->render}, -13 1 1 bool => sub { die; 1 }; +13 1 1 bool => sub { die "I was used as a bool and shouldn't be\n"; 1 }; *** 1 *0 1 *** *0 @@ -41,9 +41,14 @@ line err stmt bran cond sub code 17 } 18 19 1 my $foo = 1; -20 *** 1 * 50 bless {}, 'Foo' if $foo; +20 *** 1 * 50 my $boolobj = bless {}, 'Foo' if $foo; 21 -22 1; +22 *** 1 * 50 if ($] >= 5.010) { +23 1 eval '$boolobj //= 5;'; +24 *** 1 * 50 die if $@; +25 } +26 +27 1; Branches @@ -52,6 +57,8 @@ Branches line err % true false branch ----- --- ------ ------ ------ ------ 20 *** 50 1 0 if $foo +22 *** 50 1 0 if ($] >= "5.01") +24 *** 50 0 1 if $@ Covered Subroutines diff --git a/tests/overload_bool b/tests/overload_bool index fb0d08ac..26ca965e 100644 --- a/tests/overload_bool +++ b/tests/overload_bool @@ -10,13 +10,18 @@ package Foo; use overload '""' => sub { shift->render}, - bool => sub { die; 1 }; + bool => sub { die "I was used as a bool and shouldn't be\n"; 1 }; sub render { "foo"; } my $foo = 1; -bless {}, 'Foo' if $foo; +my $boolobj = bless {}, 'Foo' if $foo; + +if ($] >= 5.010) { + eval '$boolobj //= 5;'; + die if $@; +} 1;