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