# $Id$
# Test DBI::sql_type_cast
use strict;
#use warnings; this script generate warnings deliberately as part of the test
use Test::More;
use DBI qw(:sql_types :utils);
use Config;

# https://metacpan.org/release/MLEHMANN/Canary-Stability-2013/source/Stability.pm#L146
# 5.022 is the last supported perl for JSON::XS.
my $jx = $] >= 5.022000 ? 0 : eval {require JSON::XS;};
my $dp = eval {require Data::Peek;};
my $pp = $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning

# NOTE: would have liked to use DBI::neat to test the cast value is what
# we expect but unfortunately neat uses SvNIOK(sv) so anything that looks
# like a number is printed as a number without quotes even if it has
# a pv.

use constant INVALID_TYPE      => -2;
use constant SV_IS_UNDEF       => -1;
use constant NO_CAST_STRICT    =>  0;
use constant NO_CAST_NO_STRICT =>  1;
use constant CAST_OK           =>  2;

my @tests = (
    ['undef',
      undef,       SQL_INTEGER, SV_IS_UNDEF,     -1,                q{[null]}],
    ['invalid sql type',
     "99",         123456789,   0,               INVALID_TYPE,      q{["99"]}],
    ['non numeric cast to int',
     "aa",         SQL_INTEGER, 0,               NO_CAST_NO_STRICT, q{["aa"]}],
    ['non numeric cast to int (strict)',
     "aa",         SQL_INTEGER, DBIstcf_STRICT,  NO_CAST_STRICT,    q{["aa"]}],
    ['small int cast to int',
     "99",         SQL_INTEGER, 0,               CAST_OK,           q{["99"]}],
    ['2 byte max signed int cast to int',
     "32767",      SQL_INTEGER, 0,               CAST_OK,           q{["32767"]}],
    ['2 byte max unsigned int cast to int',
     "65535",      SQL_INTEGER, 0,               CAST_OK,           q{["65535"]}],
    ['4 byte max signed int cast to int',
     "2147483647", SQL_INTEGER, 0,               CAST_OK,           q{["2147483647"]}],
    ['4 byte max unsigned int cast to int',
     "4294967295", SQL_INTEGER, 0,               CAST_OK,           q{["4294967295"]}],
    ['small int cast to int (discard)',
     "99",         SQL_INTEGER, DBIstcf_DISCARD_STRING,
                                                 CAST_OK,           q{[99]}],
    ['non numeric cast to numeric',
     "aa",         SQL_NUMERIC, 0,               NO_CAST_NO_STRICT, q{["aa"]}],
    ['non numeric cast to numeric (strict)',
     "aa",         SQL_NUMERIC, DBIstcf_STRICT,  NO_CAST_STRICT,    q{["aa"]}],
   );

unless ($pp) {
    # some tests cannot be performed with PurePerl as numbers don't
    # overflow in the same way as XS.
    push @tests, (
        ['very large int cast to int',
         "99999999999999999999", SQL_INTEGER, 0,              NO_CAST_NO_STRICT, q{["99999999999999999999"]}],
        ['very large int cast to int (strict)',
         "99999999999999999999", SQL_INTEGER, DBIstcf_STRICT, NO_CAST_STRICT,    q{["99999999999999999999"]}],
        ['float cast to int',
         "99.99",                SQL_INTEGER, 0,              NO_CAST_NO_STRICT, q{["99.99"]}],
        ['float cast to int (strict)',
         "99.99",                SQL_INTEGER, DBIstcf_STRICT, NO_CAST_STRICT,    q{["99.99"]}],
        ['float cast to double',
         "99.99",                SQL_DOUBLE,  0,              CAST_OK,           q{["99.99"]}]
       );
    if ($Config{ivsize} == 4) {
        push @tests,
            ['4 byte max unsigned int cast to int (ivsize=4)',
             "4294967296",       SQL_INTEGER, 0,              NO_CAST_NO_STRICT, q{["4294967296"]}];
    } elsif ($Config{ivsize} >= 8) {
        push @tests,
            ['4 byte max unsigned int cast to int (ivsize>8)',
             "4294967296",       SQL_INTEGER, 0,              CAST_OK,           q{["4294967296"]}];
    }
}

if ($] >= 5.010001) {
   # Some numeric tests fail the return value test on Perls before 5.10.1
   # because sv_2nv leaves NOK set - changed in 5.10.1 probably via the
   # following change:
   # The public IV and NV flags are now not set if the string
   # value has trailing "garbage". This behaviour is consistent with not
   # setting the public IV or NV flags if the value is out of range for the
   # type.
   push @tests, (
    ['non numeric cast to double',
     "aabb",                     SQL_DOUBLE,  0,              NO_CAST_NO_STRICT, q{["aabb"]}],
    ['non numeric cast to double (strict)',
     "aabb",                     SQL_DOUBLE,  DBIstcf_STRICT, NO_CAST_STRICT,    q{["aabb"]}]
   );
}

my $tests = @tests;
$tests *= 2 if $jx;
foreach (@tests) {
    $tests++ if ($dp) && ($_->[3] & DBIstcf_DISCARD_STRING);
    $tests++ if ($dp) && ($_->[2] == SQL_DOUBLE);
}

plan tests => $tests;

foreach my $test(@tests) {
    my $val = $test->[1];
    #diag(join(",", map {neat($_)} Data::Peek::DDual($val)));
    my $result;
    {
        no warnings;   # lexical but also affects XS sub
        local $^W = 0; # needed for PurePerl tests
        $result = sql_type_cast($val, $test->[2], $test->[3]);
    }
    is($result, $test->[4], "result, $test->[0]");
    if ($jx) {

      SKIP: {
            skip 'DiscardString not supported in PurePerl', 1
                if $pp && ($test->[3] & DBIstcf_DISCARD_STRING);

            my $json = JSON::XS->new->encode([$val]);
            #diag(neat($val), ",", $json);
            # This test is about quotation of the value, not about the
            # style/formatting of JSON. Strip all leading/trailing
            # whitespace that is not part of the test, treating '[99]'
            # identical to ' [ 99 ] ' or '[99   ]'
            $json =~ s{^\s*\[\s*(.*?)\s*\]\s*$}{[$1]};
            is($json, $test->[5], "json $test->[0]");
        };
    }

    if ($dp) {
        my ($pv, $iv, $nv, $rv, $hm);
        ($pv, $iv, $nv, $rv, $hm) = Data::Peek::DDual($val);

        if ($test->[3] & DBIstcf_DISCARD_STRING) {
            #diag("D::P ",neat($pv), ",", neat($iv), ",", neat($nv),
            #     ",", neat($rv));
          SKIP: {
                skip 'DiscardString not supported in PurePerl', 1 if $pp;

                ok(!defined($pv), "dp: discard works, $test->[0]");
            };
        }
        if ($test->[2] == SQL_DOUBLE) {
            #diag("D::P ", neat($pv), ",", neat($iv), ",", neat($nv),
            #     ",", neat($rv));
            if ($test->[4] == CAST_OK) {
                ok(defined($nv), "dp: nv defined $test->[0]");
            } else {
                ok(!defined($nv) || !$nv, "dp: nv not defined $test->[0]");
            }
        }
    }
}

1;
