From: Peter Rabbitson <ribasushi@cpan.org>
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 => [] },
   [ [] ],