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