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 # make sure we recognize overloaded stuff properly
  47 lives_ok {
  48   my $num = bless( \do { my $foo = 69 }, 'SQLATest::SillyInt::Subclass' );
  49   ok( is_plain_value $num, 'parent-fallback-provided stringification detected' );
  50   is("$num", 69, 'test overloaded object stringifies, without specified fallback');
  51 } 'overload testing lives';
  52
  53 {
  54   my $nummifiable_maybefallback_num = bless( \do { my $foo = 42 }, 'SQLATest::SillierInt::Subclass' );
  55   lives_ok {
  56     ok( ( $nummifiable_maybefallback_num + 1) == 43 )
  57   };
  58
  59   my $is_pv_res = is_plain_value $nummifiable_maybefallback_num;
  60
  61   # this perl can recognize inherited fallback
  62   if ( !! eval { "$nummifiable_maybefallback_num" } ) {
  63     # we may *not* be able to compare, due to ""-derived-eq fallbacks missing,
  64     # but we can always compare the ice
  65     ok (
  66       ( nfreeze( $is_pv_res ) eq nfreeze( [ $nummifiable_maybefallback_num ] ) ),
  67       'parent-disabled-fallback stringification matches that of perl'
  68     );
  69
  70     is (
  71       refaddr($is_pv_res->[0]),
  72       refaddr $nummifiable_maybefallback_num,
  73       "Same reference (blessed object) returned",
  74     );
  75   }
  76   else {
  77     is $is_pv_res, undef, 'parent-disabled-fallback stringification matches that of perl';
  78   }
  79 }
  80
  81 is_deeply
  82   is_plain_value {  -value => [] },
  83   [ [] ],
  84   '-value recognized'
  85 ;
  86
  87 for ([], {}, \'') {
  88   is
  89     is_plain_value $_,
  90     undef,
  91     'nonvalues correctly recognized'
  92   ;
  93 }
  94
  95 for (undef, { -value => undef }) {
  96   is_deeply
  97     is_plain_value $_,
  98     [ undef ],
  99     'NULL -value recognized'
 100   ;
 101 }
 102
 103 is_deeply
 104   is_literal_value { -ident => 'foo' },
 105   [ 'foo' ],
 106   '-ident recognized as literal'
 107 ;
 108
 109 is_deeply
 110   is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ],
 111   [ 'sql', 'bind1', [ {} => 'bind2' ] ],
 112   'literal correctly unpacked'
 113 ;
 114
 115
 116 for ([], {}, \'', undef) {
 117   is
 118     is_literal_value { -ident => $_ },
 119     undef,
 120     'illegal -ident does not trip up detection'
 121   ;
 122 }
 123
 124 done_testing;