From: Peter Rabbitson Date: Fri, 5 Sep 2014 06:16:57 +0000 (+0200) Subject: Even more versatile is_plain_value testing - feeble attempts to trip up perl X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ad5ca8e9ef6c42feca9531d682d15cfa177c9c1d;p=scpubgit%2FQ-Branch.git Even more versatile is_plain_value testing - feeble attempts to trip up perl This is an attempt to simulate the behavior of JSON::PP::Boolean, and to replicate the error autarch was seeing - clearly there is more to it than just simple value juggling. Oh well, commit already written tests anyway. See further commits for the actual code changes --- diff --git a/t/23_is_X_value.t b/t/23_is_X_value.t index 79c003e..d52d228 100644 --- a/t/23_is_X_value.t +++ b/t/23_is_X_value.t @@ -43,41 +43,102 @@ use SQL::Abstract qw(is_plain_value is_literal_value); our @ISA = 'SQLATest::SillierInt'; } -# make sure we recognize overloaded stuff properly -lives_ok { - my $num = bless( \do { my $foo = 69 }, 'SQLATest::SillyInt::Subclass' ); - ok( is_plain_value $num, 'parent-fallback-provided stringification detected' ); - is("$num", 69, 'test overloaded object stringifies, without specified fallback'); -} 'overload testing lives'; - { - my $nummifiable_maybefallback_num = bless( \do { my $foo = 42 }, 'SQLATest::SillierInt::Subclass' ); - lives_ok { - ok( ( $nummifiable_maybefallback_num + 1) == 43 ) - }; - - my $is_pv_res = is_plain_value $nummifiable_maybefallback_num; - - # this perl can recognize inherited fallback - if ( !! eval { "$nummifiable_maybefallback_num" } ) { - # we may *not* be able to compare, due to ""-derived-eq fallbacks missing, - # but we can always compare the ice - ok ( - ( nfreeze( $is_pv_res ) eq nfreeze( [ $nummifiable_maybefallback_num ] ) ), - 'parent-disabled-fallback stringification matches that of perl' - ); - - is ( - refaddr($is_pv_res->[0]), - refaddr $nummifiable_maybefallback_num, - "Same reference (blessed object) returned", - ); - } - else { - is $is_pv_res, undef, 'parent-disabled-fallback stringification matches that of perl'; + package # hidee + SQLATest::ReasonableInt; + + # make it match JSON::PP::Boolean + use overload + '0+' => sub { ${$_[0]} }, + '++' => sub { $_[0] = ${$_[0]} + 1 }, + '--' => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, + ; +} + +for my $case ( + { class => 'SQLATest::SillyInt', can_math => 0, should_str => 1 }, + { class => 'SQLATest::SillyInt::Subclass', can_math => 0, should_str => 1 }, + { class => 'SQLATest::SillierInt', can_math => 0, should_str => 0 }, + { class => 'SQLATest::SillierInt::Subclass', + ($] < 5.017) # fallback is inheriting starting p5 50853fa9 (run up to 5.17.0) + ? ( can_math => 1, should_str => 1 ) + : ( can_math => 1, should_str => 0 ) + }, + { class => 'SQLATest::ReasonableInt', can_math => 1, should_str => 1 }, +) { + + my $num = bless( \do { my $foo = 42 }, $case->{class} ); + + my $can_str = eval { "$num" eq 42 } || 0; + + ok ( + !($can_str xor $case->{should_str}), + "should_str setting for $case->{class} matches perl behavior", + ) || diag explain { %$case, can_str => $can_str }; + + my $can_math = eval { ($num + 1) == 43 } ? 1 : 0; + + ok ( + !($can_math xor $case->{can_math}), + "can_math setting for $case->{class} matches perl behavior", + ) || diag explain { %$case, actual_can_math => $can_math }; + + my $can_cmp = eval { my $dum = $num eq "nope"; 1 } || 0; + + for (1,2) { + + if ($can_str) { + + ok $num, 'bool ctx works'; + + if ($can_cmp) { + is_deeply( + is_plain_value $num, + [ $num ], + "stringification detected on $case->{class}", + ) || diag explain $case; + } + else { + # is_deeply does not do nummify/stringify cmps properly + # but we can always compare the ice + ok( + ( nfreeze( is_plain_value $num ) eq nfreeze( [ $num ] ) ), + "stringification without cmp capability detected on $case->{class}" + ) || diag explain $case; + } + + is ( + refaddr(is_plain_value($num)->[0]), + refaddr $num, + "Same reference (blessed object) returned", + ); + } + else { + is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" ) + || diag explain $case; + } + + if ($case->{can_math}) { + is ($num+1, 43); + } } } +lives_ok { + my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' ); + cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly'); + cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly'); + is_deeply( + is_plain_value $num, + [ 23 ], + 'fallback stringification detected' + ); + cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly'); + cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly'); +} 'overload testing lives'; + + is_deeply is_plain_value { -value => [] }, [ [] ],