Even more versatile is_plain_value testing - feeble attempts to trip up perl

[scpubgit/Q-Branch.git] / t / 23_is_X_value.t

use warnings;
use strict;

use Test::More;
use Test::Exception;
use Scalar::Util 'refaddr';
use Storable 'nfreeze';

use SQL::Abstract qw(is_plain_value is_literal_value);

{
  package # hideee
    SQLATest::SillyInt;

  use overload
    # *DELIBERATELY* unspecified
    #fallback => 1,
    '0+' => sub { ${$_[0]} },
  ;

  package # hideee
    SQLATest::SillyInt::Subclass;

  our @ISA = 'SQLATest::SillyInt';
}

{
  package # hideee
    SQLATest::SillierInt;

  use overload
    fallback => 0,
  ;

  package # hideee
    SQLATest::SillierInt::Subclass;

  use overload
    '0+' => sub { ${$_[0]} },
    '+' => sub { ${$_[0]} + $_[1] },
  ;

  our @ISA = 'SQLATest::SillierInt';
}

{
  package # hidee
    SQLATest::ReasonableInt;

  # make it match JSON::PP::Boolean
  use overload
    '0+' => sub { ${$_[0]} },
    '++' => sub { $_[0] = ${$_[0]} + 1 },
    '--' => sub { $_[0] = ${$_[0]} - 1 },
    fallback => 1,
  ;
}

for my $case (
  { class => 'SQLATest::SillyInt',            can_math => 0, should_str => 1 },
  { class => 'SQLATest::SillyInt::Subclass',  can_math => 0, should_str => 1 },
  { class => 'SQLATest::SillierInt',          can_math => 0, should_str => 0 },
  { class => 'SQLATest::SillierInt::Subclass',
    ($] < 5.017)  # fallback is inheriting starting p5 50853fa9 (run up to 5.17.0)
    ? ( can_math => 1, should_str => 1 )
    : ( can_math => 1, should_str => 0 )
  },
  { class => 'SQLATest::ReasonableInt',       can_math => 1, should_str => 1 },
) {

  my $num = bless( \do { my $foo = 42 }, $case->{class} );

  my $can_str = eval { "$num" eq 42 } || 0;

  ok (
    !($can_str xor $case->{should_str}),
    "should_str setting for $case->{class} matches perl behavior",
  ) || diag explain { %$case, can_str => $can_str };

  my $can_math = eval { ($num + 1) == 43 } ? 1 : 0;

  ok (
    !($can_math xor $case->{can_math}),
    "can_math setting for $case->{class} matches perl behavior",
  ) || diag explain { %$case, actual_can_math => $can_math };

  my $can_cmp = eval { my $dum = $num eq "nope"; 1 } || 0;

  for (1,2) {

    if ($can_str) {

      ok $num, 'bool ctx works';

      if ($can_cmp) {
        is_deeply(
          is_plain_value $num,
          [ $num ],
          "stringification detected on $case->{class}",
        ) || diag explain $case;
      }
      else {
        # is_deeply does not do nummify/stringify cmps properly
        # but we can always compare the ice
        ok(
          ( nfreeze( is_plain_value $num ) eq nfreeze( [ $num ] ) ),
          "stringification without cmp capability detected on $case->{class}"
        ) || diag explain $case;
      }

      is (
        refaddr(is_plain_value($num)->[0]),
        refaddr $num,
        "Same reference (blessed object) returned",
      );
    }
    else {
      is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" )
        || diag explain $case;
    }

    if ($case->{can_math}) {
      is ($num+1, 43);
    }
  }
}

lives_ok {
  my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' );
  cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly');
  cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly');
  is_deeply(
    is_plain_value $num,
    [ 23 ],
    'fallback stringification detected'
  );
  cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly');
  cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly');
} 'overload testing lives';


is_deeply
  is_plain_value {  -value => [] },
  [ [] ],
  '-value recognized'
;

for ([], {}, \'') {
  is
    is_plain_value $_,
    undef,
    'nonvalues correctly recognized'
  ;
}

for (undef, { -value => undef }) {
  is_deeply
    is_plain_value $_,
    [ undef ],
    'NULL -value recognized'
  ;
}

is_deeply
  is_literal_value { -ident => 'foo' },
  [ 'foo' ],
  '-ident recognized as literal'
;

is_deeply
  is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ],
  [ 'sql', 'bind1', [ {} => 'bind2' ] ],
  'literal correctly unpacked'
;


for ([], {}, \'', undef) {
  is
    is_literal_value { -ident => $_ },
    undef,
    'illegal -ident does not trip up detection'
  ;
}

done_testing;