t/23_is_X_value.t

   1 use warnings;
   2 use strict;
   3
   4 use Test::More;
   5 use Test::Exception;
   6 use Scalar::Util 'refaddr';
   7 use Storable 'nfreeze';
   8
   9 use SQL::Abstract qw(is_plain_value is_literal_value);
  10
  11 {
  12   package # hideee
  13     SQLATest::SillyInt;
  14
  15   use overload
  16     # *DELIBERATELY* unspecified
  17     #fallback => 1,
  18     '0+' => sub { ${$_[0]} },
  19   ;
  20
  21   package # hideee
  22     SQLATest::SillyInt::Subclass;
  23
  24   our @ISA = 'SQLATest::SillyInt';
  25 }
  26
  27 {
  28   package # hideee
  29     SQLATest::SillierInt;
  30
  31   use overload
  32     fallback => 0,
  33   ;
  34
  35   package # hideee
  36     SQLATest::SillierInt::Subclass;
  37
  38   use overload
  39     '0+' => sub { ${$_[0]} },
  40     '+' => sub { ${$_[0]} + $_[1] },
  41   ;
  42
  43   our @ISA = 'SQLATest::SillierInt';
  44 }
  45
  46 {
  47   package # hidee
  48     SQLATest::ReasonableInt;
  49
  50   # make it match JSON::PP::Boolean
  51   use overload
  52     '0+' => sub { ${$_[0]} },
  53     '++' => sub { $_[0] = ${$_[0]} + 1 },
  54     '--' => sub { $_[0] = ${$_[0]} - 1 },
  55     fallback => 1,
  56   ;
  57 }
  58
  59 for my $case (
  60   { class => 'SQLATest::SillyInt',            can_math => 0, should_str => 1 },
  61   { class => 'SQLATest::SillyInt::Subclass',  can_math => 0, should_str => 1 },
  62   { class => 'SQLATest::SillierInt',          can_math => 0, should_str => 0 },
  63   { class => 'SQLATest::SillierInt::Subclass',
  64     ($] < 5.017)  # fallback is inheriting starting p5 50853fa9 (run up to 5.17.0)
  65     ? ( can_math => 1, should_str => 1 )
  66     : ( can_math => 1, should_str => 0 )
  67   },
  68   { class => 'SQLATest::ReasonableInt',       can_math => 1, should_str => 1 },
  69 ) {
  70
  71   my $num = bless( \do { my $foo = 42 }, $case->{class} );
  72
  73   my $can_str = eval { "$num" eq 42 } || 0;
  74
  75   ok (
  76     !($can_str xor $case->{should_str}),
  77     "should_str setting for $case->{class} matches perl behavior",
  78   ) || diag explain { %$case, can_str => $can_str };
  79
  80   my $can_math = eval { ($num + 1) == 43 } ? 1 : 0;
  81
  82   ok (
  83     !($can_math xor $case->{can_math}),
  84     "can_math setting for $case->{class} matches perl behavior",
  85   ) || diag explain { %$case, actual_can_math => $can_math };
  86
  87   my $can_cmp = eval { my $dum = $num eq "nope"; 1 } || 0;
  88
  89   for (1,2) {
  90
  91     if ($can_str) {
  92
  93       ok $num, 'bool ctx works';
  94
  95       if ($can_cmp) {
  96         is_deeply(
  97           is_plain_value $num,
  98           [ $num ],
  99           "stringification detected on $case->{class}",
 100         ) || diag explain $case;
 101       }
 102       else {
 103         # is_deeply does not do nummify/stringify cmps properly
 104         # but we can always compare the ice
 105         ok(
 106           ( nfreeze( is_plain_value $num ) eq nfreeze( [ $num ] ) ),
 107           "stringification without cmp capability detected on $case->{class}"
 108         ) || diag explain $case;
 109       }
 110
 111       is (
 112         refaddr(is_plain_value($num)->[0]),
 113         refaddr $num,
 114         "Same reference (blessed object) returned",
 115       );
 116     }
 117     else {
 118       is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" )
 119         || diag explain $case;
 120     }
 121
 122     if ($case->{can_math}) {
 123       is ($num+1, 43);
 124     }
 125   }
 126 }
 127
 128 lives_ok {
 129   my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' );
 130   cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly');
 131   cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly');
 132   is_deeply(
 133     is_plain_value $num,
 134     [ 23 ],
 135     'fallback stringification detected'
 136   );
 137   cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly');
 138   cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly');
 139 } 'overload testing lives';
 140
 141
 142 is_deeply
 143   is_plain_value {  -value => [] },
 144   [ [] ],
 145   '-value recognized'
 146 ;
 147
 148 for ([], {}, \'') {
 149   is
 150     is_plain_value $_,
 151     undef,
 152     'nonvalues correctly recognized'
 153   ;
 154 }
 155
 156 for (undef, { -value => undef }) {
 157   is_deeply
 158     is_plain_value $_,
 159     [ undef ],
 160     'NULL -value recognized'
 161   ;
 162 }
 163
 164 is_deeply
 165   is_literal_value { -ident => 'foo' },
 166   [ 'foo' ],
 167   '-ident recognized as literal'
 168 ;
 169
 170 is_deeply
 171   is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ],
 172   [ 'sql', 'bind1', [ {} => 'bind2' ] ],
 173   'literal correctly unpacked'
 174 ;
 175
 176
 177 for ([], {}, \'', undef) {
 178   is
 179     is_literal_value { -ident => $_ },
 180     undef,
 181     'illegal -ident does not trip up detection'
 182   ;
 183 }
 184
 185 done_testing;