X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F23_is_X_value.t;h=b06501ed8f5781e057e928ad3826fc526a9baeec;hb=843a94b5a440baaea0b5cd7d751f8995a1657421;hp=b919e0a72cecd131b66fd703def845995a410361;hpb=0da0fe34ca9d452d6775777f691b100a28d98907;p=dbsrgits%2FSQL-Abstract.git diff --git a/t/23_is_X_value.t b/t/23_is_X_value.t index b919e0a..b06501e 100644 --- a/t/23_is_X_value.t +++ b/t/23_is_X_value.t @@ -3,9 +3,33 @@ use strict; use Test::More; use Test::Exception; +use Scalar::Util 'refaddr'; +use Storable 'nfreeze'; + +BEGIN { $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} = 0 } use SQL::Abstract qw(is_plain_value is_literal_value); +# fallback setting is inheriting starting p5 50853fa9 (run up to 5.17.0) +use constant OVERLOAD_FALLBACK_INHERITS => ( ($] < 5.017) ? 0 : 1 ); +use constant STRINGIFIER_CAN_RETURN_IVS => ( ($] < 5.008) ? 0 : 1 ); + +{ + package # hideee + SQLATest::SillyBool; + + use overload + # *DELIBERATELY* unspecified + #fallback => 1, + bool => sub { ${$_[0]} }, + ; + + package # hideee + SQLATest::SillyBool::Subclass; + + our @ISA = 'SQLATest::SillyBool'; +} + { package # hideee SQLATest::SillyInt; @@ -41,33 +65,150 @@ 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'; +{ + package # hideee + SQLATest::AnalInt; + + use overload + fallback => 0, + '0+' => sub { ${$_[0]} }, + ; + + package # hideee + SQLATest::AnalInt::Subclass; + + use overload + '0+' => sub { ${$_[0]} }, + ; + + our @ISA = 'SQLATest::AnalInt'; +} + +{ + 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, + ; + + package # hideee + SQLATest::ReasonableInt::Subclass; + + our @ISA = 'SQLATest::ReasonableInt'; +} { - my $nummifiable_maybefallback_num = bless( \do { my $foo = 42 }, 'SQLATest::SillierInt::Subclass' ); - lives_ok { - ok( ( $nummifiable_maybefallback_num + 1) == 43 ) - }; - - my $can_str = !! eval { "$nummifiable_maybefallback_num" }; - - lives_ok { - is_deeply( - is_plain_value $nummifiable_maybefallback_num, - ( $can_str ? [ 42 ] : undef ), - 'parent-disabled-fallback stringification detected same as perl', - ); - }; + package # hidee + SQLATest::ReasonableString; + + # somewhat like DateTime + use overload + 'fallback' => 1, + '""' => sub { "${$_[0]}" }, + '-' => sub { ${$_[0]} - $_[1] }, + '+' => sub { ${$_[0]} + $_[1] }, + ; + + package # hideee + SQLATest::ReasonableString::Subclass; + + our @ISA = 'SQLATest::ReasonableString'; } +for my $case ( + { class => 'SQLATest::SillyBool', can_math => 0, should_str => 1 }, + { class => 'SQLATest::SillyBool::Subclass', can_math => 0, should_str => 1 }, + { 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',can_math => 1, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, + { class => 'SQLATest::AnalInt', can_math => 0, should_str => 0 }, + { class => 'SQLATest::AnalInt::Subclass', can_math => 0, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, + { class => 'SQLATest::ReasonableInt', can_math => 1, should_str => 1 }, + { class => 'SQLATest::ReasonableInt::Subclass', can_math => 1, should_str => 1 }, + { class => 'SQLATest::ReasonableString', can_math => 1, should_str => 1 }, + { class => 'SQLATest::ReasonableString::Subclass',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 (STRINGIFIER_CAN_RETURN_IVS and $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)} ), + 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 => [] }, - [ [] ], + \[], '-value recognized' ; @@ -82,7 +223,7 @@ for ([], {}, \'') { for (undef, { -value => undef }) { is_deeply is_plain_value $_, - [ undef ], + \undef, 'NULL -value recognized' ; }