Author: timbo
Date: Sat Dec 5 06:27:00 2009
New Revision: 13645
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/90sql_type_cast.t
Log:
Added DBIstcf_STRICT and DBIstcf_DISCARD_STRING to DBI::PurePerl.
Added rough draft of sql_type_cast to DBI::PurePerl.
Fixed typo in Changes.
Removed DBI:: prefixes from t/90sql_type_cast.t
(Some tests still fail)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Sat Dec 5 06:27:00 2009
@@ -32,8 +32,8 @@
to an SQL type. e.g. SQL_INTEGER effectively does $value += 0;
Has other options plus an internal interface for drivers.
- Added specification of type casting behaviour for bind_column()
- based on DBI::sql_type_cast() and two new bind_column attributes
+ Added specification of type casting behaviour for bind_col()
+ based on DBI::sql_type_cast() and two new bind_col attributes
StrictlyTyped and DiscardString. Thanks to Martin Evans.
=head2 Changes in DBI 1.609 (svn r12816) 8th June 2009
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Sat Dec 5 06:27:00 2009
@@ -130,6 +130,9 @@
use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */
use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before
call */
+use constant DBIstcf_STRICT => 0x0001;
+use constant DBIstcf_DISCARD_STRING => 0x0002;
+
my %is_flag_attribute = map {$_ =>1 } qw(
Active
AutoCommit
@@ -674,6 +677,33 @@
return "$quote$v$quote";
}
+sub sql_type_cast {
+ my (undef, $sql_type, $flags) = @_;
+
+ return -1 unless defined $_[0];
+
+ my $cast_ok = 0;
+
+ if ($sql_type == SQL_INTEGER) {
+ my $dummy = $_[0] + 0;
+ }
+ elsif ($sql_type == SQL_DOUBLE) {
+ my $dummy = $_[0] + 0.0;
+ }
+ elsif ($sql_type == SQL_NUMERIC) {
+ my $dummy = $_[0] + 0.0;
+ }
+ else {
+ return -2;
+ }
+
+ # DBIstcf_DISCARD_STRING not supported for PurePerl currently
+
+ return 2 if $cast_ok;
+ return 0 if $flags & DBIstcf_STRICT;
+ return 1;
+}
+
sub dbi_time {
return time();
}
Modified: dbi/trunk/t/90sql_type_cast.t
==============================================================================
--- dbi/trunk/t/90sql_type_cast.t (original)
+++ dbi/trunk/t/90sql_type_cast.t Sat Dec 5 06:27:00 2009
@@ -3,7 +3,7 @@
use strict;
#use warnings; this script generate warnings deliberately as part of the test
use Test::More;
-use DBI qw(:sql_types);
+use DBI qw(:sql_types :utils);
use Config;
my $jx = eval {require JSON::XS;};
@@ -21,63 +21,63 @@
use constant CAST_OK => 2;
my @tests = (
- ['undef', undef, DBI::SQL_INTEGER, SV_IS_UNDEF, -1, q{[null]}],
+ ['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', DBI::SQL_INTEGER, 0, NO_CAST_NO_STRICT,
+ ['non numeric cast to int', 'aa', SQL_INTEGER, 0, NO_CAST_NO_STRICT,
q{["aa"]}],
- ['non numeric cast to int (strict)', 'aa', DBI::SQL_INTEGER,
- DBI::DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}],
- ['small int cast to int', "99", DBI::SQL_INTEGER, 0, CAST_OK, q{["99"]}],
- ['2 byte max signed int cast to int', "32767", DBI::SQL_INTEGER, 0,
+ ['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",
- DBI::SQL_INTEGER, 0, CAST_OK, q{["65535"]}],
+ SQL_INTEGER, 0, CAST_OK, q{["65535"]}],
['4 byte max signed int cast to int', "2147483647",
- DBI::SQL_INTEGER, 0, CAST_OK, q{["2147483647"]}],
+ SQL_INTEGER, 0, CAST_OK, q{["2147483647"]}],
['4 byte max unsigned int cast to int', "4294967295",
- DBI::SQL_INTEGER, 0, CAST_OK, q{["4294967295"]}],
+ SQL_INTEGER, 0, CAST_OK, q{["4294967295"]}],
['very large int cast to int',
- '99999999999999999999', DBI::SQL_INTEGER, 0, NO_CAST_NO_STRICT,
+ '99999999999999999999', SQL_INTEGER, 0, NO_CAST_NO_STRICT,
q{["99999999999999999999"]}],
['very large int cast to int (strict)',
- '99999999999999999999', DBI::SQL_INTEGER, DBI::DBIstcf_STRICT,
+ '99999999999999999999', SQL_INTEGER, DBIstcf_STRICT,
NO_CAST_STRICT, q{["99999999999999999999"]}],
['small int cast to int (discard)',
- '99', DBI::SQL_INTEGER, DBI::DBIstcf_DISCARD_STRING, CAST_OK, q{[99]}],
+ '99', SQL_INTEGER, DBIstcf_DISCARD_STRING, CAST_OK, q{[99]}],
- ['float cast to int', '99.99', DBI::SQL_INTEGER, 0,
+ ['float cast to int', '99.99', SQL_INTEGER, 0,
NO_CAST_NO_STRICT, q{["99.99"]}],
- ['float cast to int', '99.99', DBI::SQL_INTEGER, DBI::DBIstcf_STRICT,
+ ['float cast to int', '99.99', SQL_INTEGER, DBIstcf_STRICT,
NO_CAST_STRICT, q{["99.99"]}],
- ['float cast to double', '99.99', DBI::SQL_DOUBLE, 0, CAST_OK,
+ ['float cast to double', '99.99', SQL_DOUBLE, 0, CAST_OK,
q{["99.99"]}],
- ['non numeric cast to double', 'aabb', DBI::SQL_DOUBLE, 0,
+ ['non numeric cast to double', 'aabb', SQL_DOUBLE, 0,
NO_CAST_NO_STRICT, q{["aabb"]}],
- ['non numeric cast to double (strict)', 'aabb', DBI::SQL_DOUBLE,
- DBI::DBIstcf_STRICT, NO_CAST_STRICT, q{["aabb"]}],
+ ['non numeric cast to double (strict)', 'aabb', SQL_DOUBLE,
+ DBIstcf_STRICT, NO_CAST_STRICT, q{["aabb"]}],
- ['non numeric cast to numeric', 'aa', DBI::SQL_NUMERIC,
+ ['non numeric cast to numeric', 'aa', SQL_NUMERIC,
0, NO_CAST_NO_STRICT, q{["aa"]}],
- ['non numeric cast to numeric (strict)', 'aa', DBI::SQL_NUMERIC,
- DBI::DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}],
+ ['non numeric cast to numeric (strict)', 'aa', SQL_NUMERIC,
+ DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}],
);
if ($Config{ivsize} == 4) {
push @tests,
['4 byte max unsigned int cast to int (ivsize=4)', "4294967296",
- DBI::SQL_INTEGER, 0, NO_CAST_NO_STRICT, q{["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",
- DBI::SQL_INTEGER, 0, CAST_OK, q{["4294967296"]}];
+ SQL_INTEGER, 0, CAST_OK, q{["4294967296"]}];
}
my $tests = @tests;
$tests *= 2 if $jx;
$tests++; # for use_ok
foreach (@tests) {
- $tests++ if ($dp) && ($_->[3] & DBI::DBIstcf_DISCARD_STRING);
- $tests++ if ($dp) && ($_->[2] == DBI::SQL_DOUBLE);
+ $tests++ if ($dp) && ($_->[3] & DBIstcf_DISCARD_STRING);
+ $tests++ if ($dp) && ($_->[2] == SQL_DOUBLE);
}
plan tests => $tests;
@@ -88,30 +88,30 @@
foreach my $test(@tests) {
my $val = $test->[1];
- #diag(join(",", map {DBI::neat($_)} Data::Peek::DDual($val)));
+ #diag(join(",", map {neat($_)} Data::Peek::DDual($val)));
my $result;
{
no warnings;
- $result = DBI::sql_type_cast($val, $test->[2], $test->[3]);
+ $result = sql_type_cast($val, $test->[2], $test->[3]);
}
is($result, $test->[4], "result, $test->[0]");
if ($jx) {
my $json = JSON::XS->new->encode([$val]);
- #diag(DBI::neat($val), ",", $json);
+ #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] & DBI::DBIstcf_DISCARD_STRING)) {
- #diag("D::P ",DBI::neat($pv), ",", DBI::neat($iv), ",", DBI::neat($nv),
- # ",", DBI::neat($rv));
+ if ($dp && ($test->[3] & DBIstcf_DISCARD_STRING)) {
+ #diag("D::P ",neat($pv), ",", neat($iv), ",", neat($nv),
+ # ",", neat($rv));
ok(!defined($pv), "discard works, $test->[0]") if $dp;
}
- if (($test->[2] == DBI::SQL_DOUBLE) && ($dp)) {
- #diag("D::P ", DBI::neat($pv), ",", DBI::neat($iv), ",",
DBI::neat($nv),
- # ",", DBI::neat($rv));
+ 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 {
