diff options
Diffstat (limited to 't/90sql_type_cast.t')
| -rw-r--r-- | t/90sql_type_cast.t | 148 |
1 files changed, 148 insertions, 0 deletions
diff --git a/t/90sql_type_cast.t b/t/90sql_type_cast.t new file mode 100644 index 0000000..45a91d4 --- /dev/null +++ b/t/90sql_type_cast.t @@ -0,0 +1,148 @@ +# $Id: 90sql_type_cast.t 13911 2010-04-22 10:41:37Z timbo $ +# 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; + +my $jx = 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"]}], + ); + +if (!$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); + is($json, $test->[5], "json $test->[0]"); + }; + } + + my ($pv, $iv, $nv, $rv, $hm); + ($pv, $iv, $nv, $rv, $hm) = Data::Peek::DDual($val) if $dp; + + if ($dp && ($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), "discard works, $test->[0]") if $dp; + }; + } + if (($test->[2] == SQL_DOUBLE) && ($dp)) { + #diag("D::P ", neat($pv), ",", neat($iv), ",", neat($nv), + # ",", neat($rv)); + if ($test->[4] == CAST_OK) { + ok(defined($nv), "nv defined $test->[0]"); + } else { + ok(!defined($nv) || !$nv, "nv not defined $test->[0]"); + } + } +} + +1; |