Even more versatile is_plain_value testing - feeble attempts to trip up perl

[scpubgit/Q-Branch.git] / t / 23_is_X_value.t

diff --git a/t/23_is_X_value.t b/t/23_is_X_value.t
index b919e0a..d52d228 100644 (file)
--- a/t/23_is_X_value.t
+++ b/t/23_is_X_value.t
@@ -3,6 +3,8 @@ use strict;
 
 use Test::More;
 use Test::Exception;
+use Scalar::Util 'refaddr';
+use Storable 'nfreeze';
 
 use SQL::Abstract qw(is_plain_value is_literal_value);
 
@@ -41,29 +43,101 @@ use SQL::Abstract qw(is_plain_value is_literal_value);
   our @ISA = 'SQLATest::SillierInt';
 }
 
-# make sure we recognize overloaded stuff properly
+{
+  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 = 69 }, 'SQLATest::SillyInt::Subclass' );
-  ok( is_plain_value $num, 'parent-fallback-provided stringification detected' );
-  is("$num", 69, 'test overloaded object stringifies, without specified fallback');
+  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';
 
-{
-  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',
-    );
-  };
-}
 
 is_deeply
   is_plain_value {  -value => [] },