1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
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;
|
