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 BEGIN { $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} = 0 }
  10
  11 use SQL::Abstract qw(is_plain_value is_literal_value);
  12
  13 # fallback setting is inheriting starting p5 50853fa9 (run up to 5.17.0)
  14 use constant OVERLOAD_FALLBACK_INHERITS => ( ($] < 5.017) ? 0 : 1 );
  15 use constant STRINGIFIER_CAN_RETURN_IVS => ( ($] < 5.008) ? 0 : 1 );
  16
  17 {
  18   package # hideee
  19     SQLATest::SillyBool;
  20
  21   use overload
  22     # *DELIBERATELY* unspecified
  23     #fallback => 1,
  24     bool => sub { ${$_[0]} },
  25   ;
  26
  27   package # hideee
  28     SQLATest::SillyBool::Subclass;
  29
  30   our @ISA = 'SQLATest::SillyBool';
  31 }
  32
  33 {
  34   package # hideee
  35     SQLATest::SillyInt;
  36
  37   use overload
  38     # *DELIBERATELY* unspecified
  39     #fallback => 1,
  40     '0+' => sub { ${$_[0]} },
  41   ;
  42
  43   package # hideee
  44     SQLATest::SillyInt::Subclass;
  45
  46   our @ISA = 'SQLATest::SillyInt';
  47 }
  48
  49 {
  50   package # hideee
  51     SQLATest::SillierInt;
  52
  53   use overload
  54     fallback => 0,
  55   ;
  56
  57   package # hideee
  58     SQLATest::SillierInt::Subclass;
  59
  60   use overload
  61     '0+' => sub { ${$_[0]} },
  62     '+' => sub { ${$_[0]} + $_[1] },
  63   ;
  64
  65   our @ISA = 'SQLATest::SillierInt';
  66 }
  67
  68 {
  69   package # hideee
  70     SQLATest::AnalInt;
  71
  72   use overload
  73     fallback => 0,
  74     '0+' => sub { ${$_[0]} },
  75   ;
  76
  77   package # hideee
  78     SQLATest::AnalInt::Subclass;
  79
  80   use overload
  81     '0+' => sub { ${$_[0]} },
  82   ;
  83
  84   our @ISA = 'SQLATest::AnalInt';
  85 }
  86
  87 {
  88   package # hidee
  89     SQLATest::ReasonableInt;
  90
  91   # make it match JSON::PP::Boolean
  92   use overload
  93     '0+' => sub { ${$_[0]} },
  94     '++' => sub { $_[0] = ${$_[0]} + 1 },
  95     '--' => sub { $_[0] = ${$_[0]} - 1 },
  96     fallback => 1,
  97   ;
  98
  99   package # hideee
 100     SQLATest::ReasonableInt::Subclass;
 101
 102   our @ISA = 'SQLATest::ReasonableInt';
 103 }
 104
 105 {
 106   package # hidee
 107     SQLATest::ReasonableString;
 108
 109   # somewhat like DateTime
 110   use overload
 111     'fallback' => 1,
 112     '""'       => sub { "${$_[0]}" },
 113     '-'        => sub { ${$_[0]} - $_[1] },
 114     '+'        => sub { ${$_[0]} + $_[1] },
 115   ;
 116
 117   package # hideee
 118     SQLATest::ReasonableString::Subclass;
 119
 120   our @ISA = 'SQLATest::ReasonableString';
 121 }
 122
 123 for my $case (
 124   { class => 'SQLATest::SillyBool',           can_math => 0, should_str => 1 },
 125   { class => 'SQLATest::SillyBool::Subclass', can_math => 0, should_str => 1 },
 126   { class => 'SQLATest::SillyInt',            can_math => 0, should_str => 1 },
 127   { class => 'SQLATest::SillyInt::Subclass',  can_math => 0, should_str => 1 },
 128   { class => 'SQLATest::SillierInt',          can_math => 0, should_str => 0 },
 129   { class => 'SQLATest::SillierInt::Subclass',can_math => 1, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) },
 130   { class => 'SQLATest::AnalInt',             can_math => 0, should_str => 0 },
 131   { class => 'SQLATest::AnalInt::Subclass',   can_math => 0, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) },
 132   { class => 'SQLATest::ReasonableInt',             can_math => 1, should_str => 1 },
 133   { class => 'SQLATest::ReasonableInt::Subclass',   can_math => 1, should_str => 1 },
 134   { class => 'SQLATest::ReasonableString',          can_math => 1, should_str => 1 },
 135   { class => 'SQLATest::ReasonableString::Subclass',can_math => 1, should_str => 1 },
 136 ) {
 137
 138   my $num = bless( \do { my $foo = 42 }, $case->{class} );
 139
 140   my $can_str = eval { "$num" eq 42 } || 0;
 141
 142   ok (
 143     !($can_str xor $case->{should_str}),
 144     "should_str setting for $case->{class} matches perl behavior",
 145   ) || diag explain { %$case, can_str => $can_str };
 146
 147   my $can_math = eval { ($num + 1) == 43 } ? 1 : 0;
 148
 149   ok (
 150     !($can_math xor $case->{can_math}),
 151     "can_math setting for $case->{class} matches perl behavior",
 152   ) || diag explain { %$case, actual_can_math => $can_math };
 153
 154   my $can_cmp = eval { my $dum = ($num eq "nope"); 1 } || 0;
 155
 156   for (1,2) {
 157
 158     if ($can_str) {
 159
 160       ok $num, 'bool ctx works';
 161
 162       if (STRINGIFIER_CAN_RETURN_IVS and $can_cmp) {
 163         is_deeply(
 164           is_plain_value $num,
 165           \$num,
 166           "stringification detected on $case->{class}",
 167         ) || diag explain $case;
 168       }
 169       else {
 170         # is_deeply does not do nummify/stringify cmps properly
 171         # but we can always compare the ice
 172         ok(
 173           ( nfreeze( is_plain_value $num ) eq nfreeze( \$num ) ),
 174           "stringification without cmp capability detected on $case->{class}"
 175         ) || diag explain $case;
 176       }
 177
 178       is (
 179         refaddr( ${is_plain_value($num)} ),
 180         refaddr $num,
 181         "Same reference (blessed object) returned",
 182       );
 183     }
 184     else {
 185       is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" )
 186         || diag explain $case;
 187     }
 188
 189     if ($case->{can_math}) {
 190       is ($num+1, 43);
 191     }
 192   }
 193 }
 194
 195 lives_ok {
 196   my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' );
 197   cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly');
 198   cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly');
 199   is_deeply(
 200     is_plain_value $num,
 201     \23,
 202     'fallback stringification detected'
 203   );
 204   cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly');
 205   cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly');
 206 } 'overload testing lives';
 207
 208
 209 is_deeply
 210   is_plain_value {  -value => [] },
 211   \[],
 212   '-value recognized'
 213 ;
 214
 215 for ([], {}, \'') {
 216   is
 217     is_plain_value $_,
 218     undef,
 219     'nonvalues correctly recognized'
 220   ;
 221 }
 222
 223 for (undef, { -value => undef }) {
 224   is_deeply
 225     is_plain_value $_,
 226     \undef,
 227     'NULL -value recognized'
 228   ;
 229 }
 230
 231 is_deeply
 232   is_literal_value \'sql',
 233   [ 'sql' ],
 234   'literal correctly recognized and unpacked'
 235 ;
 236
 237 is_deeply
 238   is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ],
 239   [ 'sql', 'bind1', [ {} => 'bind2' ] ],
 240   'literal with binds correctly recognized and unpacked'
 241 ;
 242
 243
 244 for ([], {}, \'', undef) {
 245   is
 246     is_literal_value { -ident => $_ },
 247     undef,
 248     'illegal -ident does not trip up detection'
 249   ;
 250 }
 251
 252 done_testing;