summaryrefslogtreecommitdiff
path: root/t
diff options
context:
space:
mode:
Diffstat (limited to 't')
-rwxr-xr-xt/01basics.t336
-rwxr-xr-xt/02dbidrv.t254
-rw-r--r--t/03handle.t410
-rw-r--r--t/04mods.t59
-rw-r--r--t/05concathash.t190
-rw-r--r--t/06attrs.t311
-rw-r--r--t/07kids.t102
-rw-r--r--t/08keeperr.t291
-rw-r--r--t/09trace.t137
-rw-r--r--t/10examp.t579
-rw-r--r--t/11fetch.t124
-rw-r--r--t/12quote.t48
-rw-r--r--t/13taint.t133
-rw-r--r--t/14utf8.t76
-rw-r--r--t/15array.t254
-rw-r--r--t/16destroy.t147
-rw-r--r--t/19fhtrace.t306
-rw-r--r--t/20meta.t32
-rw-r--r--t/30subclass.t182
-rw-r--r--t/31methcache.t153
-rw-r--r--t/35thrclone.t81
-rw-r--r--t/40profile.t485
-rw-r--r--t/41prof_dump.t105
-rw-r--r--t/42prof_data.t150
-rw-r--r--t/43prof_env.t52
-rw-r--r--t/48dbi_dbd_sqlengine.t81
-rw-r--r--t/49dbd_file.t174
-rwxr-xr-xt/50dbm_simple.t264
-rw-r--r--t/51dbm_file.t130
-rw-r--r--t/52dbm_complex.t359
-rwxr-xr-xt/60preparse.t148
-rw-r--r--t/65transact.t35
-rw-r--r--t/70callbacks.t207
-rw-r--r--t/72childhandles.t149
-rw-r--r--t/80proxy.t473
-rw-r--r--t/85gofer.t264
-rw-r--r--t/86gofer_fail.t168
-rw-r--r--t/87gofer_cache.t108
-rw-r--r--t/90sql_type_cast.t148
-rw-r--r--t/lib.pl33
-rw-r--r--t/pod-coverage.t8
-rw-r--r--t/pod.t8
42 files changed, 7754 insertions, 0 deletions
diff --git a/t/01basics.t b/t/01basics.t
new file mode 100755
index 0000000..2c11f3c
--- /dev/null
+++ b/t/01basics.t
@@ -0,0 +1,336 @@
+#!perl -w
+
+use strict;
+
+use Test::More tests => 130;
+use File::Spec;
+
+$|=1;
+
+## ----------------------------------------------------------------------------
+## 01basic.t - test of some basic DBI functions
+## ----------------------------------------------------------------------------
+# Mostly this script takes care of testing the items exported by the 3
+# tags below (in this order):
+# - :sql_types
+# - :squl_cursor_types
+# - :util
+# It also then handles some other class methods and functions of DBI, such
+# as the following:
+# - $DBI::dbi_debug & its relation to DBI->trace
+# - DBI->internal
+# and then tests on that return value:
+# - $i->debug
+# - $i->{DebugDispatch}
+# - $i->{Warn}
+# - $i->{Attribution}
+# - $i->{Version}
+# - $i->{private_test1}
+# - $i->{cachedKids}
+# - $i->{Kids}
+# - $i->{ActiveKids}
+# - $i->{Active}
+# - and finally that it will not autovivify
+# - DBI->available_drivers
+# - DBI->installed_versions (only for developers)
+## ----------------------------------------------------------------------------
+
+## load DBI and export some symbols
+BEGIN {
+ use_ok('DBI', qw(
+ :sql_types
+ :sql_cursor_types
+ :utils
+ ));
+}
+
+## ----------------------------------------------------------------------------
+## testing the :sql_types exports
+
+cmp_ok(SQL_GUID , '==', -11, '... testing sql_type');
+cmp_ok(SQL_WLONGVARCHAR , '==', -10, '... testing sql_type');
+cmp_ok(SQL_WVARCHAR , '==', -9, '... testing sql_type');
+cmp_ok(SQL_WCHAR , '==', -8, '... testing sql_type');
+cmp_ok(SQL_BIT , '==', -7, '... testing sql_type');
+cmp_ok(SQL_TINYINT , '==', -6, '... testing sql_type');
+cmp_ok(SQL_BIGINT , '==', -5, '... testing sql_type');
+cmp_ok(SQL_LONGVARBINARY , '==', -4, '... testing sql_type');
+cmp_ok(SQL_VARBINARY , '==', -3, '... testing sql_type');
+cmp_ok(SQL_BINARY , '==', -2, '... testing sql_type');
+cmp_ok(SQL_LONGVARCHAR , '==', -1, '... testing sql_type');
+cmp_ok(SQL_UNKNOWN_TYPE , '==', 0, '... testing sql_type');
+cmp_ok(SQL_ALL_TYPES , '==', 0, '... testing sql_type');
+cmp_ok(SQL_CHAR , '==', 1, '... testing sql_type');
+cmp_ok(SQL_NUMERIC , '==', 2, '... testing sql_type');
+cmp_ok(SQL_DECIMAL , '==', 3, '... testing sql_type');
+cmp_ok(SQL_INTEGER , '==', 4, '... testing sql_type');
+cmp_ok(SQL_SMALLINT , '==', 5, '... testing sql_type');
+cmp_ok(SQL_FLOAT , '==', 6, '... testing sql_type');
+cmp_ok(SQL_REAL , '==', 7, '... testing sql_type');
+cmp_ok(SQL_DOUBLE , '==', 8, '... testing sql_type');
+cmp_ok(SQL_DATETIME , '==', 9, '... testing sql_type');
+cmp_ok(SQL_DATE , '==', 9, '... testing sql_type');
+cmp_ok(SQL_INTERVAL , '==', 10, '... testing sql_type');
+cmp_ok(SQL_TIME , '==', 10, '... testing sql_type');
+cmp_ok(SQL_TIMESTAMP , '==', 11, '... testing sql_type');
+cmp_ok(SQL_VARCHAR , '==', 12, '... testing sql_type');
+cmp_ok(SQL_BOOLEAN , '==', 16, '... testing sql_type');
+cmp_ok(SQL_UDT , '==', 17, '... testing sql_type');
+cmp_ok(SQL_UDT_LOCATOR , '==', 18, '... testing sql_type');
+cmp_ok(SQL_ROW , '==', 19, '... testing sql_type');
+cmp_ok(SQL_REF , '==', 20, '... testing sql_type');
+cmp_ok(SQL_BLOB , '==', 30, '... testing sql_type');
+cmp_ok(SQL_BLOB_LOCATOR , '==', 31, '... testing sql_type');
+cmp_ok(SQL_CLOB , '==', 40, '... testing sql_type');
+cmp_ok(SQL_CLOB_LOCATOR , '==', 41, '... testing sql_type');
+cmp_ok(SQL_ARRAY , '==', 50, '... testing sql_type');
+cmp_ok(SQL_ARRAY_LOCATOR , '==', 51, '... testing sql_type');
+cmp_ok(SQL_MULTISET , '==', 55, '... testing sql_type');
+cmp_ok(SQL_MULTISET_LOCATOR , '==', 56, '... testing sql_type');
+cmp_ok(SQL_TYPE_DATE , '==', 91, '... testing sql_type');
+cmp_ok(SQL_TYPE_TIME , '==', 92, '... testing sql_type');
+cmp_ok(SQL_TYPE_TIMESTAMP , '==', 93, '... testing sql_type');
+cmp_ok(SQL_TYPE_TIME_WITH_TIMEZONE , '==', 94, '... testing sql_type');
+cmp_ok(SQL_TYPE_TIMESTAMP_WITH_TIMEZONE , '==', 95, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_YEAR , '==', 101, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_MONTH , '==', 102, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_DAY , '==', 103, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_HOUR , '==', 104, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_MINUTE , '==', 105, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_SECOND , '==', 106, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_YEAR_TO_MONTH , '==', 107, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_DAY_TO_HOUR , '==', 108, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_DAY_TO_MINUTE , '==', 109, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_DAY_TO_SECOND , '==', 110, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_HOUR_TO_MINUTE , '==', 111, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_HOUR_TO_SECOND , '==', 112, '... testing sql_type');
+cmp_ok(SQL_INTERVAL_MINUTE_TO_SECOND , '==', 113, '... testing sql_type');
+
+## ----------------------------------------------------------------------------
+## testing the :sql_cursor_types exports
+
+cmp_ok(SQL_CURSOR_FORWARD_ONLY, '==', 0, '... testing sql_cursor_types');
+cmp_ok(SQL_CURSOR_KEYSET_DRIVEN, '==', 1, '... testing sql_cursor_types');
+cmp_ok(SQL_CURSOR_DYNAMIC, '==', 2, '... testing sql_cursor_types');
+cmp_ok(SQL_CURSOR_STATIC, '==', 3, '... testing sql_cursor_types');
+cmp_ok(SQL_CURSOR_TYPE_DEFAULT, '==', 0, '... testing sql_cursor_types');
+
+## ----------------------------------------------------------------------------
+## test the :util exports
+
+## testing looks_like_number
+
+my @is_num = looks_like_number(undef, "", "foo", 1, ".", 2, "2");
+
+ok(!defined $is_num[0], '... looks_like_number : undef -> undef');
+ok(!defined $is_num[1], '... looks_like_number : "" -> undef (eg "don\'t know")');
+ok( defined $is_num[2], '... looks_like_number : "foo" -> defined false');
+ok( !$is_num[2], '... looks_like_number : "foo" -> defined false');
+ok( $is_num[3], '... looks_like_number : 1 -> true');
+ok( !$is_num[4], '... looks_like_number : "." -> false');
+ok( $is_num[5], '... looks_like_number : 1 -> true');
+ok( $is_num[6], '... looks_like_number : 1 -> true');
+
+## testing neat
+
+cmp_ok($DBI::neat_maxlen, '==', 1000, "... $DBI::neat_maxlen initial state is 400");
+
+is(neat(1 + 1), "2", '... neat : 1 + 1 -> "2"');
+is(neat("2"), "'2'", '... neat : 2 -> "\'2\'"');
+is(neat(undef), "undef", '... neat : undef -> "undef"');
+
+## testing neat_list
+
+is(neat_list([ 1 + 1, "2", undef, "foobarbaz"], 8, "|"), "2|'2'|undef|'foo...'", '... test array argument w/seperator and maxlen');
+is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out seperator or maxlen');
+
+
+## ----------------------------------------------------------------------------
+## testing DBI functions
+
+## test DBI->internal
+
+my $switch = DBI->internal;
+
+isa_ok($switch, 'DBI::dr');
+
+## checking attributes of $switch
+
+# NOTE:
+# check too see if this covers all the attributes or not
+
+# TO DO:
+# these three can be improved
+$switch->debug(0);
+pass('... test debug');
+$switch->{DebugDispatch} = 0; # handled by Switch
+pass('... test DebugDispatch');
+$switch->{Warn} = 1; # handled by DBI core
+pass('... test Warn');
+
+like($switch->{'Attribution'}, qr/DBI.*? by Tim Bunce/, '... this should say Tim Bunce');
+
+# is this being presumptious?
+is($switch->{'Version'}, $DBI::VERSION, '... the version should match DBI version');
+
+cmp_ok(($switch->{private_test1} = 1), '==', 1, '... this should work and return 1');
+cmp_ok($switch->{private_test1}, '==', 1, '... this should equal 1');
+
+is($switch->{CachedKids}, undef, '... CachedKids should be undef initially');
+my $cache = {};
+$switch->{CachedKids} = $cache;
+is($switch->{CachedKids}, $cache, '... CachedKids should be our ref');
+
+cmp_ok($switch->{Kids}, '==', 0, '... this should be zero');
+cmp_ok($switch->{ActiveKids}, '==', 0, '... this should be zero');
+
+ok($switch->{Active}, '... Active flag is true');
+
+# test attribute warnings
+{
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= "@_" };
+ $switch->{FooBarUnknown} = 1;
+ like($warn, qr/Can't set.*FooBarUnknown/, '... we should get a warning here');
+
+ $warn = "";
+ $_ = $switch->{BarFooUnknown};
+ like($warn, qr/Can't get.*BarFooUnknown/, '... we should get a warning here');
+
+ $warn = "";
+ my $dummy = $switch->{$_} for qw(private_foo dbd_foo dbi_foo); # special cases
+ cmp_ok($warn, 'eq', "", '... we should get no warnings here');
+}
+
+# is this here for a reason? Are we testing anything?
+
+$switch->trace_msg("Test \$h->trace_msg text.\n", 1);
+DBI->trace_msg("Test DBI->trace_msg text.\n", 1);
+
+## testing DBI->available_drivers
+
+my @drivers = DBI->available_drivers();
+cmp_ok(scalar(@drivers), '>', 0, '... we at least have one driver installed');
+
+# NOTE:
+# we lowercase the interpolated @drivers array
+# so that our reg-exp will match on VMS & Win32
+
+like(lc("@drivers"), qr/examplep/, '... we should at least have ExampleP installed');
+
+# call available_drivers in scalar context
+
+my $num_drivers = DBI->available_drivers;
+cmp_ok($num_drivers, '>', 0, '... we should at least have one driver');
+
+## testing DBI::hash
+
+cmp_ok(DBI::hash("foo1" ), '==', -1077531989, '... should be -1077531989');
+cmp_ok(DBI::hash("foo1",0), '==', -1077531989, '... should be -1077531989');
+cmp_ok(DBI::hash("foo2",0), '==', -1077531990, '... should be -1077531990');
+SKIP: {
+ skip("Math::BigInt < 1.56",2)
+ if $DBI::PurePerl && !eval { require Math::BigInt; require_version Math::BigInt 1.56 };
+ skip("Math::BigInt $Math::BigInt::VERSION broken",2)
+ if $DBI::PurePerl && $Math::BigInt::VERSION =~ /^1\.8[45]/;
+ my $bigint_vers = $Math::BigInt::VERSION || "";
+ if (!$DBI::PurePerl) {
+ cmp_ok(DBI::hash("foo1",1), '==', -1263462440);
+ cmp_ok(DBI::hash("foo2",1), '==', -1263462437);
+ }
+ else {
+ # for PurePerl we use Math::BigInt but that's often caused test failures that
+ # aren't DBI's fault. So we just warn (via a skip) if it's not working right.
+ skip("Seems like your Math::BigInt $Math::BigInt::VERSION has a bug",2)
+ unless (DBI::hash("foo1X",1) == -1263462440) && (DBI::hash("foo2",1) == -1263462437);
+ ok(1, "Math::BigInt $Math::BigInt::VERSION worked okay");
+ ok(1);
+ }
+}
+
+is(data_string_desc(""), "UTF8 off, ASCII, 0 characters 0 bytes");
+is(data_string_desc(42), "UTF8 off, ASCII, 2 characters 2 bytes");
+is(data_string_desc("foo"), "UTF8 off, ASCII, 3 characters 3 bytes");
+is(data_string_desc(undef), "UTF8 off, undef");
+is(data_string_desc("bar\x{263a}"), "UTF8 on, non-ASCII, 4 characters 6 bytes");
+is(data_string_desc("\xEA"), "UTF8 off, non-ASCII, 1 characters 1 bytes");
+
+is(data_string_diff( "", ""), "");
+is(data_string_diff( "",undef), "String b is undef, string a has 0 characters");
+is(data_string_diff(undef,undef), "");
+is(data_string_diff("aaa","aaa"), "");
+
+is(data_string_diff("aaa","aba"), "Strings differ at index 1: a[1]=a, b[1]=b");
+is(data_string_diff("aba","aaa"), "Strings differ at index 1: a[1]=b, b[1]=a");
+is(data_string_diff("aa" ,"aaa"), "String a truncated after 2 characters");
+is(data_string_diff("aaa","aa" ), "String b truncated after 2 characters");
+
+is(data_diff( "", ""), "");
+is(data_diff(undef,undef), "");
+is(data_diff("aaa","aaa"), "");
+
+is(data_diff( "",undef),
+ join "","a: UTF8 off, ASCII, 0 characters 0 bytes\n",
+ "b: UTF8 off, undef\n",
+ "String b is undef, string a has 0 characters\n");
+is(data_diff("aaa","aba"),
+ join "","a: UTF8 off, ASCII, 3 characters 3 bytes\n",
+ "b: UTF8 off, ASCII, 3 characters 3 bytes\n",
+ "Strings differ at index 1: a[1]=a, b[1]=b\n");
+is(data_diff(pack("C",0xEA), pack("U",0xEA)),
+ join "", "a: UTF8 off, non-ASCII, 1 characters 1 bytes\n",
+ "b: UTF8 on, non-ASCII, 1 characters 2 bytes\n",
+ "Strings contain the same sequence of characters\n");
+is(data_diff(pack("C",0xEA), pack("U",0xEA), 1), ""); # no logical difference
+
+
+## ----------------------------------------------------------------------------
+# restrict this test to just developers
+
+SKIP: {
+ skip 'developer tests', 4 unless -d ".svn" || -d ".git";
+
+ if ($^O eq "MSWin32" && eval { require Win32API::File }) {
+ Win32API::File::SetErrorMode(Win32API::File::SEM_FAILCRITICALERRORS());
+ }
+
+ print "Test DBI->installed_versions (for @drivers)\n";
+ print "(If one of those drivers, or the configuration for it, is bad\n";
+ print "then these tests can kill or freeze the process here. That's not the DBI's fault.)\n";
+ $SIG{ALRM} = sub {
+ die "Test aborted because a driver (one of: @drivers) hung while loading"
+ ." (almost certainly NOT a DBI problem)";
+ };
+ alarm(20);
+
+ ## ----------------------------------------------------------------------------
+ ## test installed_versions
+
+ # scalar context
+ my $installed_versions = DBI->installed_versions;
+
+ is(ref($installed_versions), 'HASH', '... we got a hash of installed versions');
+ cmp_ok(scalar(keys(%{$installed_versions})), '>=', 1, '... make sure we have at least one');
+
+ # list context
+ my @installed_drivers = DBI->installed_versions;
+
+ cmp_ok(scalar(@installed_drivers), '>=', 1, '... make sure we got at least one');
+ like("@installed_drivers", qr/Sponge/, '... make sure at least one of them is DBD::Sponge');
+}
+
+## testing dbi_debug
+
+cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug's initial state is 0");
+
+SKIP: {
+ my $null = File::Spec->devnull();
+ skip "cannot find : $null", 2 unless ($^O eq "MSWin32" || -e $null);
+
+ DBI->trace(15,$null);
+ cmp_ok($DBI::dbi_debug, '==', 15, "... DBI::dbi_debug is 15");
+ DBI->trace(0, undef);
+ cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug is 0");
+}
+
+1;
diff --git a/t/02dbidrv.t b/t/02dbidrv.t
new file mode 100755
index 0000000..7a80ffe
--- /dev/null
+++ b/t/02dbidrv.t
@@ -0,0 +1,254 @@
+#!perl -w
+# vim:sw=4:ts=8:et
+$|=1;
+
+use strict;
+
+use Test::More tests => 53;
+
+## ----------------------------------------------------------------------------
+## 02dbidrv.t - ...
+## ----------------------------------------------------------------------------
+# This test creates a Test Driver (DBD::Test) and then exercises it.
+# NOTE:
+# There are a number of tests as well that are embedded within the actual
+# driver code as well
+## ----------------------------------------------------------------------------
+
+## load DBI
+
+BEGIN {
+ use_ok('DBI');
+}
+
+## ----------------------------------------------------------------------------
+## create a Test Driver (DBD::Test)
+
+## main Test Driver Package
+{
+ package DBD::Test;
+
+ use strict;
+ use warnings;
+
+ my $drh = undef;
+
+ sub driver {
+ return $drh if $drh;
+
+ Test::More::pass('... DBD::Test->driver called to getnew Driver handle');
+
+ my($class, $attr) = @_;
+ $class = "${class}::dr";
+ ($drh) = DBI::_new_drh($class, {
+ Name => 'Test',
+ Version => '$Revision: 11.11 $',
+ },
+ 77 # 'implementors data'
+ );
+
+ Test::More::ok($drh, "... new Driver handle ($drh) created successfully");
+ Test::More::isa_ok($drh, 'DBI::dr');
+
+ return $drh;
+ }
+}
+
+## Test Driver
+{
+ package DBD::Test::dr;
+
+ use strict;
+ use warnings;
+
+ $DBD::Test::dr::imp_data_size = 0;
+
+ Test::More::cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo');
+
+ sub DESTROY { undef }
+
+ sub data_sources {
+ my ($h) = @_;
+
+ Test::More::ok($h, '... Driver object passed to data_sources');
+ Test::More::isa_ok($h, 'DBI::dr');
+ Test::More::ok(!tied $h, '... Driver object is not tied');
+
+ return ("dbi:Test:foo", "dbi:Test:bar");
+ }
+}
+
+## Test db package
+{
+ package DBD::Test::db;
+
+ use strict;
+
+ $DBD::Test::db::imp_data_size = 0;
+
+ Test::More::cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo');
+
+ sub do {
+ my $h = shift;
+
+ Test::More::ok($h, '... Database object passed to do');
+ Test::More::isa_ok($h, 'DBI::db');
+ Test::More::ok(!tied $h, '... Database object is not tied');
+
+ my $drh_i = $h->{Driver};
+
+ Test::More::ok($drh_i, '... got Driver object from Database object with Driver attribute');
+ Test::More::isa_ok($drh_i, "DBI::dr");
+ Test::More::ok(!tied %{$drh_i}, '... Driver object is not tied');
+
+ my $drh_o = $h->FETCH('Driver');
+
+ Test::More::ok($drh_o, '... got Driver object from Database object by FETCH-ing Driver attribute');
+ Test::More::isa_ok($drh_o, "DBI::dr");
+ SKIP: {
+ Test::More::skip "running DBI::PurePerl", 1 if $DBI::PurePerl;
+ Test::More::ok(tied %{$drh_o}, '... Driver object is not tied');
+ }
+
+ # return this to make our test pass
+ return 1;
+ }
+
+ sub data_sources {
+ my ($dbh, $attr) = @_;
+ my @ds = $dbh->SUPER::data_sources($attr);
+
+ Test::More::is_deeply((
+ \@ds,
+ [ 'dbi:Test:foo', 'dbi:Test:bar' ]
+ ),
+ '... checking fetched datasources from Driver'
+ );
+
+ push @ds, "dbi:Test:baz";
+ return @ds;
+ }
+
+ sub disconnect {
+ shift->STORE(Active => 0);
+ }
+}
+
+## ----------------------------------------------------------------------------
+## test the Driver (DBD::Test)
+
+$INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver()
+
+# Note that install_driver should *not* normally be called directly.
+# This test does so only because it's a test of install_driver!
+
+my $drh = DBI->install_driver('Test');
+
+ok($drh, '... got a Test Driver object back from DBI->install_driver');
+isa_ok($drh, 'DBI::dr');
+
+cmp_ok(DBI::_get_imp_data($drh), '==', 77, '... checking the DBI::_get_imp_data function');
+
+my @ds1 = DBI->data_sources("Test");
+is_deeply((
+ [ @ds1 ],
+ [ 'dbi:Test:foo', 'dbi:Test:bar' ]
+ ), '... got correct datasources from DBI->data_sources("Test")'
+);
+
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids');
+}
+
+# create scope to test $dbh DESTROY behaviour
+do {
+
+ my $dbh = $drh->connect;
+
+ ok($dbh, '... got a database handle from calling $drh->connect');
+ isa_ok($dbh, 'DBI::db');
+
+ SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 1, '... this Driver does not yet have any Kids');
+ }
+
+ my @ds2 = $dbh->data_sources();
+ is_deeply((
+ [ @ds2 ],
+ [ 'dbi:Test:foo', 'dbi:Test:bar', 'dbi:Test:baz' ]
+ ), '... got correct datasources from $dbh->data_sources()'
+ );
+
+ ok($dbh->do('dummy'), '... this will trigger more driver internal tests above in DBD::Test::db');
+
+ $dbh->disconnect;
+
+ $drh->set_err("41", "foo 41 drh");
+ cmp_ok($drh->err, '==', 41, '... checking Driver handle err set with set_err method');
+ $dbh->set_err("42", "foo 42 dbh");
+ cmp_ok($dbh->err, '==', 42, '... checking Database handle err set with set_err method');
+ cmp_ok($drh->err, '==', 41, '... checking Database handle err set with Driver handle set_err method');
+
+};
+
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids')
+ or $drh->dump_handle("bad Kids",3);
+}
+
+# copied up to drh from dbh when dbh was DESTROYd
+cmp_ok($drh->err, '==', 42, '... $dbh->DESTROY should set $drh->err to 42');
+
+$drh->set_err("99", "foo");
+cmp_ok($DBI::err, '==', 99, '... checking $DBI::err set with Driver handle set_err method');
+is($DBI::errstr, "foo 42 dbh [err was 42 now 99]\nfoo", '... checking $DBI::errstr');
+
+$drh->default_user("",""); # just to reset err etc
+$drh->set_err(1, "errmsg", "00000");
+is($DBI::state, "", '... checking $DBI::state');
+
+$drh->set_err(1, "test error 1");
+is($DBI::state, 'S1000', '... checking $DBI::state');
+
+$drh->set_err(2, "test error 2", "IM999");
+is($DBI::state, 'IM999', '... checking $DBI::state');
+
+SKIP: {
+ skip "using DBI::PurePerl", 1 if $DBI::PurePerl;
+ eval {
+ $DBI::rows = 1
+ };
+ like($@, qr/Can't modify/, '... trying to assign to $DBI::rows should throw an excpetion'); #'
+}
+
+is($drh->{FetchHashKeyName}, 'NAME', '... FetchHashKeyName is NAME');
+$drh->{FetchHashKeyName} = 'NAME_lc';
+is($drh->{FetchHashKeyName}, 'NAME_lc', '... FetchHashKeyName is now changed to NAME_lc');
+
+ok(!$drh->disconnect_all, '... calling $drh->disconnect_all (not implemented but will fail silently)');
+
+ok defined $drh->dbixs_revision, 'has dbixs_revision';
+ok($drh->dbixs_revision =~ m/^\d+$/, 'has integer dbixs_revision');
+
+SKIP: {
+ skip "using DBI::PurePerl", 5 if $DBI::PurePerl;
+ my $can = $drh->can('FETCH');
+
+ ok($can, '... $drh can FETCH');
+ is(ref($can), "CODE", '... and it returned a proper CODE ref');
+
+ my $name = $can->($drh, "Name");
+
+ ok($name, '... used FETCH returned from can to fetch the Name attribute');
+ is($name, "Test", '... the Name attribute is equal to Test');
+
+ ok(!$drh->can('disconnect_all'), '... ');
+}
+
+1;
diff --git a/t/03handle.t b/t/03handle.t
new file mode 100644
index 0000000..7440ad0
--- /dev/null
+++ b/t/03handle.t
@@ -0,0 +1,410 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use Test::More tests => 137;
+
+## ----------------------------------------------------------------------------
+## 03handle.t - tests handles
+## ----------------------------------------------------------------------------
+# This set of tests exercises the different handles; Driver, Database and
+# Statement in various ways, in particular in their interactions with one
+# another
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok( 'DBI' );
+}
+
+# installed drivers should start empty
+my %drivers = DBI->installed_drivers();
+is(scalar keys %drivers, 0);
+
+## ----------------------------------------------------------------------------
+# get the Driver handle
+
+my $driver = "ExampleP";
+
+my $drh = DBI->install_driver($driver);
+isa_ok( $drh, 'DBI::dr' );
+
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids');
+}
+
+# now the driver should be registered
+%drivers = DBI->installed_drivers();
+is(scalar keys %drivers, 1);
+ok(exists $drivers{ExampleP});
+ok($drivers{ExampleP}->isa('DBI::dr'));
+
+my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
+
+## ----------------------------------------------------------------------------
+# do database handle tests inside do BLOCK to capture scope
+
+do {
+ my $dbh = DBI->connect("dbi:$driver:", '', '');
+ isa_ok($dbh, 'DBI::db');
+
+ my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer
+
+ SKIP: {
+ skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 1, '... our Driver has one Kid');
+ cmp_ok($drh->{ActiveKids}, '==', 1, '... our Driver has one ActiveKid');
+ }
+
+ my $sql = "select name from ?";
+
+ my $sth1 = $dbh->prepare_cached($sql);
+ isa_ok($sth1, 'DBI::st');
+ ok($sth1->execute("."), '... execute ran successfully');
+
+ my $ck = $dbh->{CachedKids};
+ is(ref($ck), "HASH", '... we got the CachedKids hash');
+
+ cmp_ok(scalar(keys(%{$ck})), '==', 1, '... there is one CachedKid');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth1 ]
+ ),
+ '... our statment handle should be in the CachedKids');
+
+ ok($sth1->{Active}, '... our first statment is Active');
+
+ {
+ my $warn = 0; # use this to check that we are warned
+ local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /still active/i };
+
+ my $sth2 = $dbh->prepare_cached($sql);
+ isa_ok($sth2, 'DBI::st');
+
+ is($sth1, $sth2, '... prepare_cached returned the same statement handle');
+ cmp_ok($warn,'==', 1, '... we got warned about our first statement handle being still active');
+
+ ok(!$sth1->{Active}, '... our first statment is no longer Active since we re-prepared it');
+
+ my $sth3 = $dbh->prepare_cached($sql, { foo => 1 });
+ isa_ok($sth3, 'DBI::st');
+
+ isnt($sth1, $sth3, '... prepare_cached returned a different statement handle now');
+ cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth1, $sth3 ]
+ ),
+ '... both statment handles should be in the CachedKids');
+
+ ok($sth1->execute("."), '... executing first statement handle again');
+ ok($sth1->{Active}, '... first statement handle is now active again');
+
+ my $sth4 = $dbh->prepare_cached($sql, undef, 3);
+ isa_ok($sth4, 'DBI::st');
+
+ isnt($sth1, $sth4, '... our fourth statement handle is not the same as our first');
+ ok($sth1->{Active}, '... first statement handle is still active');
+
+ cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth2, $sth4 ]
+ ),
+ '... second and fourth statment handles should be in the CachedKids');
+
+ $sth1->finish;
+ ok(!$sth1->{Active}, '... first statement handle is no longer active');
+
+ ok($sth4->execute("."), '... fourth statement handle executed properly');
+ ok($sth4->{Active}, '... fourth statement handle is Active');
+
+ my $sth5 = $dbh->prepare_cached($sql, undef, 1);
+ isa_ok($sth5, 'DBI::st');
+
+ cmp_ok($warn, '==', 1, '... we still only got one warning');
+
+ is($sth4, $sth5, '... fourth statement handle and fifth one match');
+ ok(!$sth4->{Active}, '... fourth statement handle is not Active');
+ ok(!$sth5->{Active}, '... fifth statement handle is not Active (shouldnt be its the same as fifth)');
+
+ cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
+ ok(eq_set(
+ [ values %{$ck} ],
+ [ $sth2, $sth5 ]
+ ),
+ '... second and fourth/fifth statment handles should be in the CachedKids');
+ }
+
+ SKIP: {
+ skip "swap_inner_handle() not supported under DBI::PurePerl", 23 if $DBI::PurePerl;
+
+ my $sth6 = $dbh->prepare($sql);
+ $sth6->execute(".");
+ my $sth1_driver_name = $sth1->{Database}{Driver}{Name};
+
+ ok( $sth6->{Active}, '... sixth statement handle is active');
+ ok(!$sth1->{Active}, '... first statement handle is not active');
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth');
+ ok(!$sth6->{Active}, '... sixth statement handle is now not active');
+ ok( $sth1->{Active}, '... first statement handle is now active again');
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth');
+ ok( $sth6->{Active}, '... sixth statement handle is active');
+ ok(!$sth1->{Active}, '... first statement handle is not active');
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth');
+ ok(!$sth6->{Active}, '... sixth statement handle is now not active');
+ ok( $sth1->{Active}, '... first statement handle is now active again');
+
+ $sth1->{PrintError} = 0;
+ ok(!$sth1->swap_inner_handle($dbh), '... can not swap a sth with a dbh');
+ cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle between sth and dbh");
+
+ ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth');
+ ok( $sth6->{Active}, '... sixth statement handle is active');
+ ok(!$sth1->{Active}, '... first statement handle is not active');
+
+ $sth6->finish;
+
+ ok(my $dbh_nullp = DBI->connect("dbi:NullP:", undef, undef, { go_bypass => 1 }));
+ ok(my $sth7 = $dbh_nullp->prepare(""));
+
+ $sth1->{PrintError} = 0;
+ ok(!$sth1->swap_inner_handle($sth7), "... can't swap_inner_handle with handle from different parent");
+ cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle with handle from different parent");
+
+ cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', $sth1_driver_name );
+ ok( $sth1->swap_inner_handle($sth7,1), "... can swap to different parent if forced");
+ cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', "NullP" );
+
+ $dbh_nullp->disconnect;
+ }
+
+ ok( $dbh->ping, 'ping should be true before disconnect');
+ $dbh->disconnect;
+ $dbh->{PrintError} = 0; # silence 'not connected' warning
+ ok( !$dbh->ping, 'ping should be false after disconnect');
+
+ SKIP: {
+ skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 1, '... our Driver has one Kid after disconnect');
+ cmp_ok($drh->{ActiveKids}, '==', 0, '... our Driver has no ActiveKids after disconnect');
+ }
+
+};
+
+if ($using_dbd_gofer) {
+ $drh->{CachedKids} = {};
+}
+
+# make sure our driver has no more kids after this test
+# NOTE:
+# this also assures us that the next test has an empty slate as well
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 0, "... our $drh->{Name} driver should have 0 Kids after dbh was destoryed");
+}
+
+## ----------------------------------------------------------------------------
+# handle reference leak tests
+
+# NOTE:
+# this test checks for reference leaks by testing the Kids attribute
+# which is not supported by DBI::PurePerl, so we just do not run this
+# for DBI::PurePerl all together. Even though some of the tests would
+# pass, it does not make sense becuase in the end, what is actually
+# being tested for will give a false positive
+
+sub work {
+ my (%args) = @_;
+ my $dbh = DBI->connect("dbi:$driver:", '', '');
+ isa_ok( $dbh, 'DBI::db' );
+
+ cmp_ok($drh->{Kids}, '==', 1, '... the Driver should have 1 Kid(s) now');
+
+ if ( $args{Driver} ) {
+ isa_ok( $dbh->{Driver}, 'DBI::dr' );
+ } else {
+ pass( "not testing Driver here" );
+ }
+
+ my $sth = $dbh->prepare_cached("select name from ?");
+ isa_ok( $sth, 'DBI::st' );
+
+ if ( $args{Database} ) {
+ isa_ok( $sth->{Database}, 'DBI::db' );
+ } else {
+ pass( "not testing Database here" );
+ }
+
+ $dbh->disconnect;
+ # both handles should be freed here
+}
+
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 25 if $DBI::PurePerl;
+ skip "drh Kids not testable under DBD::Gofer", 25 if $using_dbd_gofer;
+
+ foreach my $args (
+ {},
+ { Driver => 1 },
+ { Database => 1 },
+ { Driver => 1, Database => 1 },
+ ) {
+ work( %{$args} );
+ cmp_ok($drh->{Kids}, '==', 0, '... the Driver should have no Kids');
+ }
+
+ # make sure we have no kids when we end this
+ cmp_ok($drh->{Kids}, '==', 0, '... the Driver should have no Kids at the end of this test');
+}
+
+## ----------------------------------------------------------------------------
+# handle take_imp_data test
+
+SKIP: {
+ skip "take_imp_data test not supported under DBD::Gofer", 19 if $using_dbd_gofer;
+
+ my $dbh = DBI->connect("dbi:$driver:", '', '');
+ isa_ok($dbh, "DBI::db");
+ my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer
+
+ cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here')
+ unless $DBI::PurePerl && pass();
+
+ $dbh->prepare("select name from ?"); # destroyed at once
+ my $sth2 = $dbh->prepare("select name from ?"); # inactive
+ my $sth3 = $dbh->prepare("select name from ?"); # active:
+ $sth3->execute(".");
+ is $sth3->{Active}, 1;
+ is $dbh->{ActiveKids}, 1
+ unless $DBI::PurePerl && pass();
+
+ my $ChildHandles = $dbh->{ChildHandles};
+
+ skip "take_imp_data test needs weakrefs", 15 if not $ChildHandles;
+
+ ok $ChildHandles, 'we need weakrefs for take_imp_data to work safely with child handles';
+ is @$ChildHandles, 3, 'should have 3 entries (implementation detail)';
+ is grep({ defined } @$ChildHandles), 2, 'should have 2 defined handles';
+
+ my $imp_data = $dbh->take_imp_data;
+ ok($imp_data, '... we got some imp_data to test');
+ # generally length($imp_data) = 112 for 32bit, 116 for 64 bit
+ # (as of DBI 1.37) but it can differ on some platforms
+ # depending on structure packing by the compiler
+ # so we just test that it's something reasonable:
+ cmp_ok(length($imp_data), '>=', 80, '... test that our imp_data is greater than or equal to 80, this is reasonable');
+
+ cmp_ok($drh->{Kids}, '==', 0, '... our Driver should have 0 Kid(s) after calling take_imp_data');
+
+ is ref $sth3, 'DBI::zombie', 'sth should be reblessed';
+ eval { $sth3->finish };
+ like $@, qr/Can't locate object method/;
+
+ {
+ my @warn;
+ local $SIG{__WARN__} = sub { push @warn, $_[0] if $_[0] =~ /after take_imp_data/; print "warn: @_\n"; };
+
+ my $drh = $dbh->{Driver};
+ ok(!defined $drh, '... our Driver should be undefined');
+
+ my $trace_level = $dbh->{TraceLevel};
+ ok(!defined $trace_level, '... our TraceLevel should be undefined');
+
+ ok(!defined $dbh->disconnect, '... disconnect should return undef');
+
+ ok(!defined $dbh->quote(42), '... quote should return undefined');
+
+ cmp_ok(scalar @warn, '==', 4, '... we should have gotten 4 warnings');
+ }
+
+ my $dbh2 = DBI->connect("dbi:$driver:", '', '', { dbi_imp_data => $imp_data });
+ isa_ok($dbh2, "DBI::db");
+ # need a way to test dbi_imp_data has been used
+
+ cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) again')
+ unless $DBI::PurePerl && pass();
+
+}
+
+# we need this SKIP block on its own since we are testing the
+# destruction of objects within the scope of the above SKIP
+# block
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh->{Kids}, '==', 0, '... our Driver has no Kids after this test');
+}
+
+## ----------------------------------------------------------------------------
+# NullP statement handle attributes without execute
+
+my $driver2 = "NullP";
+
+my $drh2 = DBI->install_driver($driver);
+isa_ok( $drh2, 'DBI::dr' );
+
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh2->{Kids}, '==', 0, '... our Driver (2) has no Kids before this test');
+}
+
+do {
+ my $dbh = DBI->connect("dbi:$driver2:", '', '');
+ isa_ok($dbh, "DBI::db");
+
+ my $sth = $dbh->prepare("foo bar");
+ isa_ok($sth, "DBI::st");
+
+ cmp_ok($sth->{NUM_OF_PARAMS}, '==', 0, '... NUM_OF_PARAMS is 0');
+ is($sth->{NUM_OF_FIELDS}, undef, '... NUM_OF_FIELDS should be undef');
+ is($sth->{Statement}, "foo bar", '... Statement is "foo bar"');
+
+ ok(!defined $sth->{NAME}, '... NAME is undefined');
+ ok(!defined $sth->{TYPE}, '... TYPE is undefined');
+ ok(!defined $sth->{SCALE}, '... SCALE is undefined');
+ ok(!defined $sth->{PRECISION}, '... PRECISION is undefined');
+ ok(!defined $sth->{NULLABLE}, '... NULLABLE is undefined');
+ ok(!defined $sth->{RowsInCache}, '... RowsInCache is undefined');
+ ok(!defined $sth->{ParamValues}, '... ParamValues is undefined');
+ # derived NAME attributes
+ ok(!defined $sth->{NAME_uc}, '... NAME_uc is undefined');
+ ok(!defined $sth->{NAME_lc}, '... NAME_lc is undefined');
+ ok(!defined $sth->{NAME_hash}, '... NAME_hash is undefined');
+ ok(!defined $sth->{NAME_uc_hash}, '... NAME_uc_hash is undefined');
+ ok(!defined $sth->{NAME_lc_hash}, '... NAME_lc_hash is undefined');
+
+ my $dbh_ref = ref($dbh);
+ my $sth_ref = ref($sth);
+
+ ok($dbh_ref->can("prepare"), '... $dbh can call "prepare"');
+ ok(!$dbh_ref->can("nonesuch"), '... $dbh cannot call "nonesuch"');
+ ok($sth_ref->can("execute"), '... $sth can call "execute"');
+
+ # what is this test for??
+
+ # I don't know why this warning has the "(perhaps ...)" suffix, it shouldn't:
+ # Can't locate object method "nonesuch" via package "DBI::db" (perhaps you forgot to load "DBI::db"?)
+ eval { ref($dbh)->nonesuch; };
+
+ $dbh->disconnect;
+};
+
+SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($drh2->{Kids}, '==', 0, '... our Driver (2) has no Kids after this test');
+}
+
+## ----------------------------------------------------------------------------
+
+1;
diff --git a/t/04mods.t b/t/04mods.t
new file mode 100644
index 0000000..97638d0
--- /dev/null
+++ b/t/04mods.t
@@ -0,0 +1,59 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use Test::More tests => 12;
+
+## ----------------------------------------------------------------------------
+## 04mods.t - ...
+## ----------------------------------------------------------------------------
+# Note:
+# the modules tested here are all marked as new and not guaranteed, so this if
+# they change, these will fail.
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok( 'DBI' );
+
+ # load these first, since the other two load them
+ # and we want to catch the error first
+ use_ok( 'DBI::Const::GetInfo::ANSI' );
+ use_ok( 'DBI::Const::GetInfo::ODBC' );
+
+ use_ok( 'DBI::Const::GetInfoType', qw(%GetInfoType) );
+ use_ok( 'DBI::Const::GetInfoReturn', qw(%GetInfoReturnTypes %GetInfoReturnValues) );
+}
+
+## test GetInfoType
+
+cmp_ok(scalar(keys(%GetInfoType)), '>', 1, '... we have at least one key in the GetInfoType hash');
+
+is_deeply(
+ \%GetInfoType,
+ { %DBI::Const::GetInfo::ANSI::InfoTypes, %DBI::Const::GetInfo::ODBC::InfoTypes },
+ '... the GetInfoType hash is constructed from the ANSI and ODBC hashes'
+ );
+
+## test GetInfoReturnTypes
+
+cmp_ok(scalar(keys(%GetInfoReturnTypes)), '>', 1, '... we have at least one key in the GetInfoReturnType hash');
+
+is_deeply(
+ \%GetInfoReturnTypes,
+ { %DBI::Const::GetInfo::ANSI::ReturnTypes, %DBI::Const::GetInfo::ODBC::ReturnTypes },
+ '... the GetInfoReturnType hash is constructed from the ANSI and ODBC hashes'
+ );
+
+## test GetInfoReturnValues
+
+cmp_ok(scalar(keys(%GetInfoReturnValues)), '>', 1, '... we have at least one key in the GetInfoReturnValues hash');
+
+# ... testing GetInfoReturnValues any further would be difficult
+
+## test the two methods found in DBI::Const::GetInfoReturn
+
+can_ok('DBI::Const::GetInfoReturn', 'Format');
+can_ok('DBI::Const::GetInfoReturn', 'Explain');
+
+1;
diff --git a/t/05concathash.t b/t/05concathash.t
new file mode 100644
index 0000000..554fc34
--- /dev/null
+++ b/t/05concathash.t
@@ -0,0 +1,190 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl CatHash.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use strict;
+use Benchmark qw(:all);
+use Scalar::Util qw(looks_like_number);
+no warnings 'uninitialized';
+
+use Test::More tests => 41;
+
+BEGIN { use_ok('DBI') };
+
+# null and undefs -- segfaults?;
+is (DBI::_concat_hash_sorted(undef, "=", ":", 0, undef), undef);
+is (DBI::_concat_hash_sorted({ }, "=", ":", 0, undef), "");
+eval { DBI::_concat_hash_sorted([], "=", ":", 0, undef) };
+like ($@ || "", qr/is not a hash reference/);
+is (DBI::_concat_hash_sorted({ }, undef, ":", 0, undef), "");
+is (DBI::_concat_hash_sorted({ }, "=", undef, 0, undef), "");
+is (DBI::_concat_hash_sorted({ }, "=", ":", undef, undef),"");
+
+# simple cases
+is (DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=", ", ", undef, undef), "1='a', 2='b'");
+# nul byte in key sep and pair sep
+# (nul byte in hash not supported)
+is DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=\000=", ":\000:", undef, undef),
+ "1=\000='a':\000:2=\000='b'", 'should work with nul bytes in kv_sep and pair_sep';
+is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 1, undef),
+ "1='a.a':2='b'", 'should work with nul bytes in hash value (neat)';
+is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 0, undef),
+ "1='a\000a':2='b'", 'should work with nul bytes in hash value (not neat)';
+
+# Simple stress tests
+# limit stress when performing automated testing
+# eg http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4374116.html
+my $stress = $ENV{AUTOMATED_TESTING} ? 1_000 : 10_000;
+ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "="x$stress, ":", 1, undef));
+ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "=", ":"x$stress, 1, undef));
+ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "="x$stress, ":", 1, undef));
+ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "=", ":"x$stress, 1, undef), 'test');
+ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..100)}, "="x$stress, ":"x$stress, 1, undef), 'test');
+
+my $simple_hash = {
+ bob=>"there",
+ jack=>12,
+ fred=>"there",
+ norman=>"there",
+ # sam =>undef
+};
+
+my $simple_numeric = {
+ 1=>"there",
+ 2=>"there",
+ 16 => 'yo',
+ 07 => "buddy",
+ 49 => undef,
+};
+
+my $simple_mixed = {
+ bob=>"there",
+ jack=>12,
+ fred=>"there",
+ sam =>undef,
+ 1=>"there",
+ 32=>"there",
+ 16 => 'yo',
+ 07 => "buddy",
+ 49 => undef,
+};
+
+my $simple_float = {
+ 1.12 =>"there",
+ 3.1415926 =>"there",
+ 32=>"there",
+ 1.6 => 'yo',
+ 0.78 => "buddy",
+ 49 => undef,
+};
+
+#eval {
+# DBI::_concat_hash_sorted($simple_hash, "=",,":",1,12);
+#};
+ok(1," Unknown sort order");
+#like ($@, qr/Unknown sort order/, "Unknown sort order");
+
+
+
+## Loopify and Add Neat
+
+
+my %neats = (
+ "Neat"=>0,
+ "Not Neat"=> 1
+);
+my %sort_types = (
+ guess=>undef,
+ numeric => 1,
+ lexical=> 0
+);
+my %hashes = (
+ Numeric=>$simple_numeric,
+ "Simple Hash" => $simple_hash,
+ "Mixed Hash" => $simple_mixed,
+ "Float Hash" => $simple_float
+);
+
+for my $sort_type (keys %sort_types){
+ for my $neat (keys %neats) {
+ for my $hash (keys %hashes) {
+ test_concat_hash($hash, $neat, $sort_type);
+ }
+ }
+}
+
+sub test_concat_hash {
+ my ($hash, $neat, $sort_type) = @_;
+ my @args = ($hashes{$hash}, "=", ":",$neats{$neat}, $sort_types{$sort_type});
+ is (
+ DBI::_concat_hash_sorted(@args),
+ _concat_hash_sorted(@args),
+ "$hash - $neat $sort_type"
+ );
+}
+
+if (0) {
+ eval {
+ cmpthese(200_000, {
+ Perl => sub {_concat_hash_sorted($simple_hash, "=", ":",0,undef); },
+ C=> sub {DBI::_concat_hash_sorted($simple_hash, "=", ":",0,1);}
+ });
+
+ print "\n";
+ cmpthese(200_000, {
+ NotNeat => sub {DBI::_concat_hash_sorted(
+ $simple_hash, "=", ":",1,undef);
+ },
+ Neat => sub {DBI::_concat_hash_sorted(
+ $simple_hash, "=", ":",0,undef);
+ }
+ });
+ };
+}
+#CatHash::_concat_hash_values({ }, ":-",,"::",1,1);
+
+
+sub _concat_hash_sorted {
+ my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_;
+ # $num_sort: 0=lexical, 1=numeric, undef=try to guess
+
+ return undef unless defined $hash_ref;
+ die "hash is not a hash reference" unless ref $hash_ref eq 'HASH';
+ my $keys = _get_sorted_hash_keys($hash_ref, $num_sort);
+ my $string = '';
+ for my $key (@$keys) {
+ $string .= $pair_separator if length $string > 0;
+ my $value = $hash_ref->{$key};
+ if ($use_neat) {
+ $value = DBI::neat($value, 0);
+ }
+ else {
+ $value = (defined $value) ? "'$value'" : 'undef';
+ }
+ $string .= $key . $kv_separator . $value;
+ }
+ return $string;
+}
+
+sub _get_sorted_hash_keys {
+ my ($hash_ref, $sort_type) = @_;
+ if (not defined $sort_type) {
+ my $sort_guess = 1;
+ $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess
+ for keys %$hash_ref;
+ $sort_type = $sort_guess;
+ }
+
+ my @keys = keys %$hash_ref;
+ no warnings 'numeric';
+ my @sorted = ($sort_type)
+ ? sort { $a <=> $b or $a cmp $b } @keys
+ : sort @keys;
+ #warn "$sort_type = @sorted\n";
+ return \@sorted;
+}
+
+1;
diff --git a/t/06attrs.t b/t/06attrs.t
new file mode 100644
index 0000000..89ba7c1
--- /dev/null
+++ b/t/06attrs.t
@@ -0,0 +1,311 @@
+#!perl -w
+
+use strict;
+
+use Test::More tests => 148;
+
+## ----------------------------------------------------------------------------
+## 06attrs.t - ...
+## ----------------------------------------------------------------------------
+# This test checks the parameters and the values associated with them for
+# the three different handles (Driver, Database, Statement)
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok( 'DBI' )
+}
+
+$|=1;
+
+my $using_autoproxy = ($ENV{DBI_AUTOPROXY});
+my $dsn = 'dbi:ExampleP:dummy';
+
+# Connect to the example driver.
+my $dbh = DBI->connect($dsn, '', '', {
+ PrintError => 0, RaiseError => 1,
+});
+
+isa_ok( $dbh, 'DBI::db' );
+
+# Clean up when we're done.
+END { $dbh->disconnect if $dbh };
+
+## ----------------------------------------------------------------------------
+# Check the database handle attributes.
+
+# bit flag attr
+ok( $dbh->{Warn}, '... checking Warn attribute for dbh');
+ok( $dbh->{Active}, '... checking Active attribute for dbh');
+ok( $dbh->{AutoCommit}, '... checking AutoCommit attribute for dbh');
+ok(!$dbh->{CompatMode}, '... checking CompatMode attribute for dbh');
+ok(!$dbh->{InactiveDestroy}, '... checking InactiveDestory attribute for dbh');
+ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for dbh');
+ok(!$dbh->{PrintError}, '... checking PrintError attribute for dbh');
+ok( $dbh->{PrintWarn}, '... checking PrintWarn attribute for dbh'); # true because of perl -w above
+ok( $dbh->{RaiseError}, '... checking RaiseError attribute for dbh');
+ok(!$dbh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for dbh');
+ok(!$dbh->{ChopBlanks}, '... checking ChopBlanks attribute for dbh');
+ok(!$dbh->{LongTruncOk}, '... checking LongTrunkOk attribute for dbh');
+ok(!$dbh->{TaintIn}, '... checking TaintIn attribute for dbh');
+ok(!$dbh->{TaintOut}, '... checking TaintOut attribute for dbh');
+ok(!$dbh->{Taint}, '... checking Taint attribute for dbh');
+ok(!$dbh->{Executed}, '... checking Executed attribute for dbh');
+
+# other attr
+cmp_ok($dbh->{ErrCount}, '==', 0, '... checking ErrCount attribute for dbh');
+
+SKIP: {
+ skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
+
+ cmp_ok($dbh->{Kids}, '==', 0, '... checking Kids attribute for dbh');;
+ cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for dbh');;
+}
+
+is($dbh->{CachedKids}, undef, '... checking CachedKids attribute for dbh');
+ok(!defined $dbh->{HandleError}, '... checking HandleError attribute for dbh');
+ok(!defined $dbh->{Profile}, '... checking Profile attribute for dbh');
+ok(!defined $dbh->{Statement}, '... checking Statement attribute for dbh');
+ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for dbh');
+ok(!defined $dbh->{ReadOnly}, '... checking ReadOnly attribute for dbh');
+
+is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for dbh');
+is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh') # fails for Multiplex
+ unless $using_autoproxy && ok(1);
+
+cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for dbh');
+cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for dbh');
+
+is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen ErrCount)) ],
+ [ undef, qw(NAME 80 0) ], 'should be able to FETCH_many';
+
+is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh attribute value';
+
+# Raise an error.
+eval {
+ $dbh->do('select foo from foo')
+};
+like($@, qr/^DBD::\w+::db do failed: Unknown field names: foo/ , '... catching exception');
+
+ok(defined $dbh->err, '... $dbh->err is undefined');
+like($dbh->errstr, qr/^Unknown field names: foo\b/, '... checking $dbh->errstr');
+
+is($dbh->state, 'S1000', '... checking $dbh->state');
+
+ok($dbh->{Executed}, '... checking Executed attribute for dbh'); # even though it failed
+$dbh->{Executed} = 0; # reset(able)
+cmp_ok($dbh->{Executed}, '==', 0, '... checking Executed attribute for dbh (after reset)');
+
+cmp_ok($dbh->{ErrCount}, '==', 1, '... checking ErrCount attribute for dbh (after error was generated)');
+
+## ----------------------------------------------------------------------------
+# Test the driver handle attributes.
+
+my $drh = $dbh->{Driver};
+isa_ok( $drh, 'DBI::dr' );
+
+ok($dbh->err, '... checking $dbh->err');
+
+cmp_ok($drh->{ErrCount}, '==', 0, '... checking ErrCount attribute for drh');
+
+ok( $drh->{Warn}, '... checking Warn attribute for drh');
+ok( $drh->{Active}, '... checking Active attribute for drh');
+ok( $drh->{AutoCommit}, '... checking AutoCommit attribute for drh');
+ok(!$drh->{CompatMode}, '... checking CompatMode attribute for drh');
+ok(!$drh->{InactiveDestroy}, '... checking InactiveDestory attribute for drh');
+ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for drh');
+ok(!$drh->{PrintError}, '... checking PrintError attribute for drh');
+ok( $drh->{PrintWarn}, '... checking PrintWarn attribute for drh'); # true because of perl -w above
+ok(!$drh->{RaiseError}, '... checking RaiseError attribute for drh');
+ok(!$drh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for drh');
+ok(!$drh->{ChopBlanks}, '... checking ChopBlanks attribute for drh');
+ok(!$drh->{LongTruncOk}, '... checking LongTrunkOk attribute for drh');
+ok(!$drh->{TaintIn}, '... checking TaintIn attribute for drh');
+ok(!$drh->{TaintOut}, '... checking TaintOut attribute for drh');
+ok(!$drh->{Taint}, '... checking Taint attribute for drh');
+
+SKIP: {
+ skip "Executed attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ ok($drh->{Executed}, '... checking Executed attribute for drh') # due to the do() above
+}
+
+SKIP: {
+ skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if ($DBI::PurePerl or $dbh->{mx_handle_list});
+ cmp_ok($drh->{Kids}, '==', 1, '... checking Kids attribute for drh');
+ cmp_ok($drh->{ActiveKids}, '==', 1, '... checking ActiveKids attribute for drh');
+}
+
+is($drh->{CachedKids}, undef, '... checking CachedKids attribute for drh');
+ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
+ok(!defined $drh->{Profile}, '... checking Profile attribute for drh');
+ok(!defined $drh->{ReadOnly}, '... checking ReadOnly attribute for drh');
+
+cmp_ok($drh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for drh');
+cmp_ok($drh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for drh');
+
+is($drh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for drh');
+is($drh->{Name}, 'ExampleP', '... checking Name attribute for drh')
+ unless $using_autoproxy && ok(1);
+
+## ----------------------------------------------------------------------------
+# Test the statement handle attributes.
+
+# Create a statement handle.
+my $sth = $dbh->prepare("select ctime, name from ?");
+isa_ok($sth, "DBI::st");
+
+ok(!$sth->{Executed}, '... checking Executed attribute for sth');
+ok(!$dbh->{Executed}, '... checking Executed attribute for dbh');
+cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth');
+
+# Trigger an exception.
+eval {
+ $sth->execute("foo")
+};
+# we don't check actual opendir error msg because of locale differences
+like($@, qr/^DBD::\w+::st execute failed: .*opendir\(foo\): /msi, '... checking exception');
+
+# Test all of the statement handle attributes.
+like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr');
+is($sth->state, 'S1000', '... checking $sth->state');
+ok($sth->{Executed}, '... checking Executed attribute for sth'); # even though it failed
+ok($dbh->{Executed}, '... checking Exceuted attribute for dbh'); # due to $sth->prepare, even though it failed
+
+cmp_ok($sth->{ErrCount}, '==', 1, '... checking ErrCount attribute for sth');
+eval {
+ $sth->{ErrCount} = 42
+};
+like($@, qr/STORE failed:/, '... checking exception');
+
+cmp_ok($sth->{ErrCount}, '==', 42 , '... checking ErrCount attribute for sth (after assignment)');
+
+$sth->{ErrCount} = 0;
+cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth (after reset)');
+
+# booleans
+ok( $sth->{Warn}, '... checking Warn attribute for sth');
+ok(!$sth->{Active}, '... checking Active attribute for sth');
+ok(!$sth->{CompatMode}, '... checking CompatMode attribute for sth');
+ok(!$sth->{InactiveDestroy}, '... checking InactiveDestroy attribute for sth');
+ok(!$sth->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for sth');
+ok(!$sth->{PrintError}, '... checking PrintError attribute for sth');
+ok( $sth->{PrintWarn}, '... checking PrintWarn attribute for sth');
+ok( $sth->{RaiseError}, '... checking RaiseError attribute for sth');
+ok(!$sth->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for sth');
+ok(!$sth->{ChopBlanks}, '... checking ChopBlanks attribute for sth');
+ok(!$sth->{LongTruncOk}, '... checking LongTrunkOk attribute for sth');
+ok(!$sth->{TaintIn}, '... checking TaintIn attribute for sth');
+ok(!$sth->{TaintOut}, '... checking TaintOut attribute for sth');
+ok(!$sth->{Taint}, '... checking Taint attribute for sth');
+
+# common attr
+SKIP: {
+ skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
+ cmp_ok($sth->{Kids}, '==', 0, '... checking Kids attribute for sth');
+ cmp_ok($sth->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for sth');
+}
+
+ok(!defined $sth->{CachedKids}, '... checking CachedKids attribute for sth');
+ok(!defined $sth->{HandleError}, '... checking HandleError attribute for sth');
+ok(!defined $sth->{Profile}, '... checking Profile attribute for sth');
+ok(!defined $sth->{ReadOnly}, '... checking ReadOnly attribute for sth');
+
+cmp_ok($sth->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for sth');
+cmp_ok($sth->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for sth');
+
+is($sth->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for sth');
+
+# sth specific attr
+ok(!defined $sth->{CursorName}, '... checking CursorName attribute for sth');
+
+cmp_ok($sth->{NUM_OF_FIELDS}, '==', 2, '... checking NUM_OF_FIELDS attribute for sth');
+cmp_ok($sth->{NUM_OF_PARAMS}, '==', 1, '... checking NUM_OF_PARAMS attribute for sth');
+
+my $name = $sth->{NAME};
+is(ref($name), 'ARRAY', '... checking type of NAME attribute for sth');
+cmp_ok(scalar(@{$name}), '==', 2, '... checking number of elements returned');
+is_deeply($name, ['ctime', 'name' ], '... checking values returned');
+
+my $name_lc = $sth->{NAME_lc};
+is(ref($name_lc), 'ARRAY', '... checking type of NAME_lc attribute for sth');
+cmp_ok(scalar(@{$name_lc}), '==', 2, '... checking number of elements returned');
+is_deeply($name_lc, ['ctime', 'name' ], '... checking values returned');
+
+my $name_uc = $sth->{NAME_uc};
+is(ref($name_uc), 'ARRAY', '... checking type of NAME_uc attribute for sth');
+cmp_ok(scalar(@{$name_uc}), '==', 2, '... checking number of elements returned');
+is_deeply($name_uc, ['CTIME', 'NAME' ], '... checking values returned');
+
+my $nhash = $sth->{NAME_hash};
+is(ref($nhash), 'HASH', '... checking type of NAME_hash attribute for sth');
+cmp_ok(scalar(keys(%{$nhash})), '==', 2, '... checking number of keys returned');
+cmp_ok($nhash->{ctime}, '==', 0, '... checking values returned');
+cmp_ok($nhash->{name}, '==', 1, '... checking values returned');
+
+my $nhash_lc = $sth->{NAME_lc_hash};
+is(ref($nhash_lc), 'HASH', '... checking type of NAME_lc_hash attribute for sth');
+cmp_ok(scalar(keys(%{$nhash_lc})), '==', 2, '... checking number of keys returned');
+cmp_ok($nhash_lc->{ctime}, '==', 0, '... checking values returned');
+cmp_ok($nhash_lc->{name}, '==', 1, '... checking values returned');
+
+my $nhash_uc = $sth->{NAME_uc_hash};
+is(ref($nhash_uc), 'HASH', '... checking type of NAME_uc_hash attribute for sth');
+cmp_ok(scalar(keys(%{$nhash_uc})), '==', 2, '... checking number of keys returned');
+cmp_ok($nhash_uc->{CTIME}, '==', 0, '... checking values returned');
+cmp_ok($nhash_uc->{NAME}, '==', 1, '... checking values returned');
+
+my $type = $sth->{TYPE};
+is(ref($type), 'ARRAY', '... checking type of TYPE attribute for sth');
+cmp_ok(scalar(@{$type}), '==', 2, '... checking number of elements returned');
+is_deeply($type, [ 4, 12 ], '... checking values returned');
+
+my $null = $sth->{NULLABLE};
+is(ref($null), 'ARRAY', '... checking type of NULLABLE attribute for sth');
+cmp_ok(scalar(@{$null}), '==', 2, '... checking number of elements returned');
+is_deeply($null, [ 0, 0 ], '... checking values returned');
+
+# Should these work? They don't.
+my $prec = $sth->{PRECISION};
+is(ref($prec), 'ARRAY', '... checking type of PRECISION attribute for sth');
+cmp_ok(scalar(@{$prec}), '==', 2, '... checking number of elements returned');
+is_deeply($prec, [ 10, 1024 ], '... checking values returned');
+
+my $scale = $sth->{SCALE};
+is(ref($scale), 'ARRAY', '... checking type of SCALE attribute for sth');
+cmp_ok(scalar(@{$scale}), '==', 2, '... checking number of elements returned');
+is_deeply($scale, [ 0, 0 ], '... checking values returned');
+
+my $params = $sth->{ParamValues};
+is(ref($params), 'HASH', '... checking type of ParamValues attribute for sth');
+is($params->{1}, 'foo', '... checking values returned');
+
+is($sth->{Statement}, "select ctime, name from ?", '... checking Statement attribute for sth');
+ok(!defined $sth->{RowsInCache}, '... checking type of RowsInCache attribute for sth');
+
+is $sth->{examplep_private_sth_attrib}, 24, 'should see driver-private sth attribute value';
+
+# $h->{TraceLevel} tests are in t/09trace.t
+
+note "Checking inheritance\n";
+
+SKIP: {
+ skip "drh->dbh->sth inheritance test skipped with DBI_AUTOPROXY", 2 if $ENV{DBI_AUTOPROXY};
+
+sub check_inherited {
+ my ($drh, $attr, $value, $skip_sth) = @_;
+ local $drh->{$attr} = $value;
+ local $drh->{PrintError} = 1;
+ my $dbh = $drh->connect("dummy");
+ is $dbh->{$attr}, $drh->{$attr}, "dbh $attr value should be inherited from drh";
+ unless ($skip_sth) {
+ my $sth = $dbh->prepare("select name from .");
+ is $sth->{$attr}, $dbh->{$attr}, "sth $attr value should be inherited from dbh";
+ }
+}
+
+check_inherited($drh, "ReadOnly", 1, 0);
+
+}
+
+1;
+# end
diff --git a/t/07kids.t b/t/07kids.t
new file mode 100644
index 0000000..8364ad2
--- /dev/null
+++ b/t/07kids.t
@@ -0,0 +1,102 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use Test::More;
+
+use DBI 1.50; # also tests Exporter::require_version
+
+BEGIN {
+ plan skip_all => '$h->{Kids} attribute not supported for DBI::PurePerl'
+ if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning
+ plan tests => 20;
+}
+
+## ----------------------------------------------------------------------------
+## 07kids.t
+## ----------------------------------------------------------------------------
+# This test check the Kids and the ActiveKids attributes and how they act
+# in various situations.
+#
+# Check the database handle's kids:
+# - upon creation of handle
+# - upon creation of statement handle
+# - after execute of statement handle
+# - after finish of statement handle
+# - after destruction of statement handle
+# Check the driver handle's kids:
+# - after creation of database handle
+# - after disconnection of database handle
+# - after destruction of database handle
+## ----------------------------------------------------------------------------
+
+
+# Connect to the example driver and create a database handle
+my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
+ {
+ PrintError => 1,
+ RaiseError => 0
+ });
+
+# check our database handle to make sure its good
+isa_ok($dbh, 'DBI::db');
+
+# check that it has no Kids or ActiveKids yet
+cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) at start');
+cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) at start');
+
+# create a scope for our $sth to live and die in
+do {
+
+ # create a statement handle
+ my $sth = $dbh->prepare('select uid from ./');
+
+ # verify that it is a correct statement handle
+ isa_ok($sth, "DBI::st");
+
+ # check our Kids and ActiveKids after prepare
+ cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $dbh->prepare');
+ cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $dbh->prepare');
+
+ $sth->execute();
+
+ # check our Kids and ActiveKids after execute
+ cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $sth->execute');
+ cmp_ok($dbh->{ActiveKids}, '==', 1, '... database handle has 1 ActiveKid(s) after $sth->execute');
+
+ $sth->finish();
+
+ # check our Kids and Activekids after finish
+ cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $sth->finish');
+ cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $sth->finish');
+
+};
+
+# now check it after the statement handle has been destroyed
+cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) after $sth is destroyed');
+cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $sth is destroyed');
+
+# get the database handles driver Driver
+my $drh = $dbh->{Driver};
+
+# check that is it a correct driver handle
+isa_ok($drh, "DBI::dr");
+
+# check the driver's Kids and ActiveKids
+cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s)');
+cmp_ok( $drh->{ActiveKids}, '==', 1, '... driver handle has 1 ActiveKid(s)');
+
+$dbh->disconnect;
+
+# check the driver's Kids and ActiveKids after $dbh->disconnect
+cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s) after $dbh->disconnect');
+cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after $dbh->disconnect');
+
+undef $dbh;
+ok(!defined($dbh), '... lets be sure that $dbh is not undefined');
+
+# check the driver's Kids and ActiveKids after undef $dbh
+cmp_ok( $drh->{Kids}, '==', 0, '... driver handle has 0 Kid(s) after undef $dbh');
+cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after undef $dbh');
+
diff --git a/t/08keeperr.t b/t/08keeperr.t
new file mode 100644
index 0000000..617a81d
--- /dev/null
+++ b/t/08keeperr.t
@@ -0,0 +1,291 @@
+#!perl -w
+
+use strict;
+
+use Test::More tests => 79;
+
+## ----------------------------------------------------------------------------
+## 08keeperr.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok('DBI');
+}
+
+$|=1;
+$^W=1;
+
+## ----------------------------------------------------------------------------
+# subclass DBI
+
+# DBI subclass
+package My::DBI;
+use base 'DBI';
+
+# Database handle subclass
+package My::DBI::db;
+use base 'DBI::db';
+
+# Statement handle subclass
+package My::DBI::st;
+use base 'DBI::st';
+
+sub execute {
+ my $sth = shift;
+ # we localize an attribute here to check that the correpoding STORE
+ # at scope exit doesn't clear any recorded error
+ local $sth->{Warn} = 0;
+ my $rv = $sth->SUPER::execute(@_);
+ return $rv;
+}
+
+
+## ----------------------------------------------------------------------------
+# subclass the subclass of DBI
+
+package Test;
+
+use strict;
+use base 'My::DBI';
+
+use DBI;
+
+my @con_info = ('dbi:ExampleP:.', undef, undef, { PrintError => 0, RaiseError => 1 });
+
+sub test_select {
+ my $dbh = shift;
+ eval { $dbh->selectrow_arrayref('select * from foo') };
+ $dbh->disconnect;
+ return $@;
+}
+
+my $err1 = test_select( My::DBI->connect(@con_info) );
+Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error');
+
+my $err2 = test_select( DBI->connect(@con_info) );
+Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error');
+
+package main;
+
+# test ping does not destroy the errstr
+sub ping_keeps_err {
+ my $dbh = DBI->connect('DBI:ExampleP:', undef, undef, { PrintError => 0 });
+
+ $dbh->set_err(42, "ERROR 42");
+ is $dbh->err, 42;
+ is $dbh->errstr, "ERROR 42";
+ ok $dbh->ping, "ping returns true";
+ is $dbh->err, 42, "err unchanged after ping";
+ is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
+
+ $dbh->disconnect;
+
+ $dbh->set_err(42, "ERROR 42");
+ is $dbh->err, 42, "err unchanged after ping";
+ is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
+ ok !$dbh->ping, "ping returns false";
+ # it's reasonable for ping() to set err/errstr if it fails
+ # so here we just test that there is an error
+ ok $dbh->err, "err true after failed ping";
+ ok $dbh->errstr, "errstr true after failed ping";
+}
+
+## ----------------------------------------------------------------------------
+print "Test HandleSetErr\n";
+
+my $dbh = DBI->connect(@con_info);
+isa_ok($dbh, "DBI::db");
+
+$dbh->{RaiseError} = 1;
+$dbh->{PrintError} = 1;
+$dbh->{PrintWarn} = 1;
+
+# warning handler
+my %warn = ( failed => 0, warning => 0 );
+my @handlewarn = (0,0,0);
+$SIG{__WARN__} = sub {
+ my $msg = shift;
+ if ($msg =~ /^DBD::\w+::\S+\s+(\S+)\s+(\w+)/) {
+ ++$warn{$2};
+ $msg =~ s/\n/\\n/g;
+ print "warn: '$msg'\n";
+ return;
+ }
+ warn $msg;
+};
+
+# HandleSetErr handler
+$dbh->{HandleSetErr} = sub {
+ my ($h, $err, $errstr, $state) = @_;
+ return 0
+ unless defined $err;
+ ++$handlewarn[ $err ? 2 : length($err) ]; # count [info, warn, err] calls
+ return 1
+ if $state && $state eq "return"; # for tests
+ ($_[1], $_[2], $_[3]) = (99, "errstr99", "OV123")
+ if $state && $state eq "override"; # for tests
+ return 0
+ if $err; # be transparent for errors
+ local $^W;
+ print "HandleSetErr called: h=$h, err=$err, errstr=$errstr, state=$state\n";
+ return 0;
+};
+
+# start our tests
+
+ok(!defined $DBI::err, '... $DBI::err is not defined');
+
+# ----
+
+$dbh->set_err("", "(got info)");
+
+ok(defined $DBI::err, '... $DBI::err is defined'); # true
+is($DBI::err, "", '... $DBI::err is an empty string');
+is($DBI::errstr, "(got info)", '... $DBI::errstr is as we expected');
+is($dbh->errstr, "(got info)", '... $dbh->errstr matches $DBI::errstr');
+cmp_ok($warn{failed}, '==', 0, '... $warn{failed} is 0');
+cmp_ok($warn{warning}, '==', 0, '... $warn{warning} is 0');
+is_deeply(\@handlewarn, [ 1, 0, 0 ], '... the @handlewarn array is (1, 0, 0)');
+
+# ----
+
+$dbh->set_err(0, "(got warn)", "AA001"); # triggers PrintWarn
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+is($DBI::err, "0", '... $DBI::err is "0"');
+is($DBI::errstr, "(got info)\n(got warn)",
+ '... $DBI::errstr is as we expected');
+is($dbh->errstr, "(got info)\n(got warn)",
+ '... $dbh->errstr matches $DBI::errstr');
+is($DBI::state, "AA001", '... $DBI::state is AA001');
+cmp_ok($warn{warning}, '==', 1, '... $warn{warning} is 1');
+is_deeply(\@handlewarn, [ 1, 1, 0 ], '... the @handlewarn array is (1, 1, 0)');
+
+
+# ----
+
+$dbh->set_err("", "(got more info)"); # triggers PrintWarn
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+is($DBI::err, "0", '... $DBI::err is "0"'); # not "", ie it's still a warn
+is($dbh->err, "0", '... $dbh->err is "0"');
+is($DBI::state, "AA001", '... $DBI::state is AA001');
+is($DBI::errstr, "(got info)\n(got warn)\n(got more info)",
+ '... $DBI::errstr is as we expected');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info)",
+ '... $dbh->errstr matches $DBI::errstr');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is_deeply(\@handlewarn, [ 2, 1, 0 ], '... the @handlewarn array is (2, 1, 0)');
+
+
+# ----
+
+$dbh->{RaiseError} = 0;
+$dbh->{PrintError} = 1;
+
+# ----
+
+$dbh->set_err("42", "(got error)", "AA002");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)",
+ '... $dbh->errstr is as we expected');
+is($DBI::state, "AA002", '... $DBI::state is AA002');
+is_deeply(\@handlewarn, [ 2, 1, 1 ], '... the @handlewarn array is (2, 1, 1)');
+
+# ----
+
+$dbh->set_err("", "(got info)");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)",
+ '... $dbh->errstr is as we expected');
+is_deeply(\@handlewarn, [ 3, 1, 1 ], '... the @handlewarn array is (3, 1, 1)');
+
+# ----
+
+$dbh->set_err("0", "(got warn)"); # no PrintWarn because it's already an err
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn)",
+ '... $dbh->errstr is as we expected');
+is_deeply(\@handlewarn, [ 3, 2, 1 ], '... the @handlewarn array is (3, 2, 1)');
+
+# ----
+
+$dbh->set_err("4200", "(got new error)", "AA003");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 4200, '... $DBI::err is 4200');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now AA003]\n(got new error)",
+ '... $dbh->errstr is as we expected');
+is_deeply(\@handlewarn, [ 3, 2, 2 ], '... the @handlewarn array is (3, 2, 2)');
+
+# ----
+
+$dbh->set_err(undef, "foo", "bar"); # clear error
+
+ok(!defined $dbh->errstr, '... $dbh->errstr is defined');
+ok(!defined $dbh->err, '... $dbh->err is defined');
+is($dbh->state, "", '... $dbh->state is an empty string');
+
+# ----
+
+%warn = ( failed => 0, warning => 0 );
+@handlewarn = (0,0,0);
+
+# ----
+
+my @ret;
+@ret = $dbh->set_err(1, "foo"); # PrintError
+
+cmp_ok(scalar(@ret), '==', 1, '... only returned one value');
+ok(!defined $ret[0], '... the first value is undefined');
+ok(!defined $dbh->set_err(2, "bar"), '... $dbh->set_err returned undefiend'); # PrintError
+ok(!defined $dbh->set_err(3, "baz"), '... $dbh->set_err returned undefiend'); # PrintError
+ok(!defined $dbh->set_err(0, "warn"), '... $dbh->set_err returned undefiend'); # PrintError
+is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn",
+ '... $dbh->errstr is as we expected');
+is($warn{failed}, 4, '... $warn{failed} is 4');
+is_deeply(\@handlewarn, [ 0, 1, 3 ], '... the @handlewarn array is (0, 1, 3)');
+
+# ----
+
+$dbh->set_err(undef, undef, undef); # clear error
+
+@ret = $dbh->set_err(1, "foo", "AA123", "method");
+cmp_ok(scalar @ret, '==', 1, '... only returned one value');
+ok(!defined $ret[0], '... the first value is undefined');
+
+@ret = $dbh->set_err(1, "foo", "AA123", "method", "42");
+cmp_ok(scalar @ret, '==', 1, '... only returned one value');
+is($ret[0], "42", '... the first value is "42"');
+
+@ret = $dbh->set_err(1, "foo", "return");
+cmp_ok(scalar @ret, '==', 0, '... returned no values');
+
+# ----
+
+$dbh->set_err(undef, undef, undef); # clear error
+
+@ret = $dbh->set_err("", "info", "override");
+cmp_ok(scalar @ret, '==', 1, '... only returned one value');
+ok(!defined $ret[0], '... the first value is undefined');
+cmp_ok($dbh->err, '==', 99, '... $dbh->err is 99');
+is($dbh->errstr, "errstr99", '... $dbh->errstr is as we expected');
+is($dbh->state, "OV123", '... $dbh->state is as we expected');
+$dbh->disconnect;
+
+ping_keeps_err();
+
+1;
+# end
diff --git a/t/09trace.t b/t/09trace.t
new file mode 100644
index 0000000..021bc5c
--- /dev/null
+++ b/t/09trace.t
@@ -0,0 +1,137 @@
+#!perl -w
+# vim:sw=4:ts=8
+
+use strict;
+
+use Test::More tests => 99;
+
+## ----------------------------------------------------------------------------
+## 09trace.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ $ENV{DBI_TRACE} = 0; # for PurePerl - ensure DBI_TRACE is in the env
+ use_ok( 'DBI' );
+}
+
+$|=1;
+
+
+my $trace_file = "dbitrace$$.log";
+
+1 while unlink $trace_file;
+warn "Can't unlink existing $trace_file: $!" if -e $trace_file;
+
+my $orig_trace_level = DBI->trace;
+DBI->trace(3, $trace_file); # enable trace before first driver load
+
+my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
+die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
+
+isa_ok($dbh, 'DBI::db');
+
+$dbh->dump_handle("dump_handle test, write to log file", 2);
+
+DBI->trace(0, undef); # turn off and restore to STDERR
+
+SKIP: {
+ skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i);
+ ok( -s $trace_file, "trace file size = " . -s $trace_file);
+}
+
+DBI->trace($orig_trace_level); # no way to restore previous outfile XXX
+
+
+# Clean up when we're done.
+END { $dbh->disconnect if $dbh;
+ 1 while unlink $trace_file; };
+
+## ----------------------------------------------------------------------------
+# Check the database handle attributes.
+
+cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute');
+
+1 while unlink $trace_file;
+
+$dbh->trace(0, $trace_file);
+ok( -f $trace_file, '... trace file successfully created');
+
+my @names = qw(
+ SQL
+ CON
+ ENC
+ DBD
+ TXN
+ foo bar baz boo bop
+);
+my %flag;
+my $all_flags = 0;
+
+foreach my $name (@names) {
+ print "parse_trace_flag $name\n";
+ ok( my $flag1 = $dbh->parse_trace_flag($name) );
+ ok( my $flag2 = $dbh->parse_trace_flags($name) );
+ is( $flag1, $flag2 );
+
+ $dbh->{TraceLevel} = $flag1;
+ is( $dbh->{TraceLevel}, $flag1 );
+
+ $dbh->{TraceLevel} = 0;
+ is( $dbh->{TraceLevel}, 0 );
+
+ $dbh->trace($flag1);
+ is $dbh->trace, $flag1;
+ is $dbh->{TraceLevel}, $flag1;
+
+ $dbh->{TraceLevel} = $name; # set by name
+ $dbh->{TraceLevel} = undef; # check no change on undef
+ is( $dbh->{TraceLevel}, $flag1 );
+
+ $flag{$name} = $flag1;
+ $all_flags |= $flag1
+ if defined $flag1; # reduce noise if there's a bug
+}
+
+print "parse_trace_flag @names\n";
+ok(eq_set([ keys %flag ], [ @names ]), '...');
+$dbh->{TraceLevel} = 0;
+$dbh->{TraceLevel} = join "|", @names;
+is($dbh->{TraceLevel}, $all_flags, '...');
+
+{
+ print "inherit\n";
+ my $sth = $dbh->prepare("select ctime, name from foo");
+ isa_ok( $sth, 'DBI::st' );
+ is( $sth->{TraceLevel}, $all_flags );
+}
+
+$dbh->{TraceLevel} = 0;
+ok !$dbh->{TraceLevel};
+$dbh->{TraceLevel} = 'ALL';
+ok $dbh->{TraceLevel};
+
+{
+ print "test unknown parse_trace_flag\n";
+ my $warn = 0;
+ local $SIG{__WARN__} = sub {
+ if ($_[0] =~ /unknown/i) { ++$warn; print "caught warn: ",@_ }else{ warn @_ }
+ };
+ is $dbh->parse_trace_flag("nonesuch"), undef;
+ is $warn, 0;
+ is $dbh->parse_trace_flags("nonesuch"), 0;
+ is $warn, 1;
+ is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"), $dbh->parse_trace_flag("SQL");
+ is $warn, 2;
+}
+
+$dbh->dump_handle("dump_handle test, write to log file", 2);
+
+$dbh->trace(0);
+ok !$dbh->{TraceLevel};
+$dbh->trace(undef, "STDERR"); # close $trace_file
+ok( -s $trace_file );
+
+1;
+# end
diff --git a/t/10examp.t b/t/10examp.t
new file mode 100644
index 0000000..b7f063a
--- /dev/null
+++ b/t/10examp.t
@@ -0,0 +1,579 @@
+#!perl -w
+
+use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
+use DBI qw(:sql_types);
+use Config;
+use Cwd;
+use strict;
+use Data::Dumper;
+
+$^W = 1;
+$| = 1;
+
+require File::Basename;
+require File::Spec;
+require VMS::Filespec if $^O eq 'VMS';
+
+use Test::More tests => 229;
+
+do {
+ # provide some protection against growth in size of '.' during the test
+ # which was probable cause of this failure
+ # http://www.nntp.perl.org/group/perl.cpan.testers/2009/09/msg5297317.html
+ my $tmpfile = "deleteme_$$";
+ open my $fh, ">$tmpfile";
+ close $fh;
+ unlink $tmpfile;
+};
+
+# "globals"
+my ($r, $dbh);
+
+ok !eval {
+ $dbh = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1, AutoCommit => 1 });
+}, 'connect should fail';
+like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an exception here');
+ok(!$dbh, '... $dbh2 should not be defined');
+
+$dbh = DBI->connect('dbi:ExampleP:', '', '');
+
+sub check_connect_cached {
+ # connect_cached
+ # ------------------------------------------
+ # This test checks that connect_cached works
+ # and how it then relates to the CachedKids
+ # attribute for the driver.
+
+ ok my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 });
+
+ ok my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 });
+
+ is($dbh_cached_1, $dbh_cached_2, '... these 2 handles are cached, so they are the same');
+
+ ok my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', { examplep_foo => 1 });
+
+ isnt($dbh_cached_3, $dbh_cached_2, '... this handle was created with different parameters, so it is not the same');
+
+ # check that cached_connect applies attributes to handles returned from the cache
+ # (The specific case of Executed is relevant to DBD::Gofer retry-on-error logic)
+ ok $dbh_cached_1->do("select * from ."); # set Executed flag
+ ok $dbh_cached_1->{Executed}, 'Executed should be true';
+ ok my $dbh_cached_4 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 });
+ is $dbh_cached_4, $dbh_cached_1, 'should return same handle';
+ ok !$dbh_cached_4->{Executed}, 'Executed should be false because reset by connect attributes';
+
+ my $drh = $dbh->{Driver};
+ isa_ok($drh, "DBI::dr");
+
+ my @cached_kids = values %{$drh->{CachedKids}};
+ ok(eq_set(\@cached_kids, [ $dbh_cached_1, $dbh_cached_3 ]), '... these are our cached kids');
+
+ $drh->{CachedKids} = {};
+ cmp_ok(scalar(keys %{$drh->{CachedKids}}), '==', 0, '... we have emptied out cache');
+}
+
+check_connect_cached();
+
+$dbh->{AutoCommit} = 1;
+$dbh->{PrintError} = 0;
+
+ok($dbh->{AutoCommit} == 1);
+cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError should be 0');
+
+is($dbh->{FetchHashKeyName}, 'NAME', '... FetchHashKey is NAME');
+
+# test access to driver-private attributes
+like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the example driver_path');
+
+print "others\n";
+eval { $dbh->commit('dummy') };
+ok($@ =~ m/DBI commit: invalid number of arguments:/, $@)
+ unless $DBI::PurePerl && ok(1);
+
+ok($dbh->ping, "ping should return true");
+
+# --- errors
+my $cursor_e = $dbh->prepare("select unknown_field_name from ?");
+is($cursor_e, undef, "prepare should fail");
+ok($dbh->err, "sth->err should be true");
+ok($DBI::err, "DBI::err should be true");
+cmp_ok($DBI::err, 'eq', $dbh->err , "\$DBI::err should match \$dbh->err");
+like($DBI::errstr, qr/Unknown field names: unknown_field_name/, "\$DBI::errstr should contain error string");
+cmp_ok($DBI::errstr, 'eq', $dbh->errstr, "\$DBI::errstr should match \$dbh->errstr");
+
+# --- func
+ok($dbh->errstr eq $dbh->func('errstr'));
+
+my $std_sql = "select mode,size,name from ?";
+my $csr_a = $dbh->prepare($std_sql);
+ok(ref $csr_a);
+ok($csr_a->{NUM_OF_FIELDS} == 3);
+
+SKIP: {
+ skip "inner/outer handles not fully supported for DBI::PurePerl", 3 if $DBI::PurePerl;
+ ok(tied %{ $csr_a->{Database} }); # ie is 'outer' handle
+ ok($csr_a->{Database} eq $dbh, "$csr_a->{Database} ne $dbh")
+ unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex tests
+ ok(tied %{ $csr_a->{Database}->{Driver} }); # ie is 'outer' handle
+}
+
+my $driver_name = $csr_a->{Database}->{Driver}->{Name};
+ok($driver_name eq 'ExampleP')
+ unless $ENV{DBI_AUTOPROXY} && ok(1);
+
+# --- FetchHashKeyName
+$dbh->{FetchHashKeyName} = 'NAME_uc';
+my $csr_b = $dbh->prepare($std_sql);
+$csr_b->execute('.');
+ok(ref $csr_b);
+
+ok($csr_a != $csr_b);
+
+ok("@{$csr_b->{NAME_lc}}" eq "mode size name"); # before NAME
+ok("@{$csr_b->{NAME_uc}}" eq "MODE SIZE NAME");
+ok("@{$csr_b->{NAME}}" eq "mode size name");
+ok("@{$csr_b->{ $csr_b->{FetchHashKeyName} }}" eq "MODE SIZE NAME");
+
+ok("@{[sort keys %{$csr_b->{NAME_lc_hash}}]}" eq "mode name size");
+ok("@{[sort values %{$csr_b->{NAME_lc_hash}}]}" eq "0 1 2");
+ok("@{[sort keys %{$csr_b->{NAME_uc_hash}}]}" eq "MODE NAME SIZE");
+ok("@{[sort values %{$csr_b->{NAME_uc_hash}}]}" eq "0 1 2");
+
+do "t/lib.pl";
+
+# get a dir always readable on all platforms
+#my $dir = getcwd() || cwd();
+#$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
+# untaint $dir
+#$dir =~ m/(.*)/; $dir = $1 || die;
+my $dir = test_dir ();
+
+# ---
+
+my($col0, $col1, $col2, $col3, $rows);
+my(@row_a, @row_b);
+
+ok($csr_a->bind_columns(undef, \($col0, $col1, $col2)) );
+ok($csr_a->execute( $dir ), $DBI::errstr);
+
+@row_a = $csr_a->fetchrow_array;
+ok(@row_a);
+
+# check bind_columns
+is($row_a[0], $col0);
+is($row_a[1], $col1);
+is($row_a[2], $col2);
+
+ok( ! $csr_a->bind_columns(undef, \($col0, $col1)) );
+like $csr_a->errstr, '/bind_columns called with 2 values but 3 are needed/', 'errstr should contain error message';
+ok( ! $csr_a->bind_columns(undef, \($col0, $col1, $col2, $col3)) );
+like $csr_a->errstr, '/bind_columns called with 4 values but 3 are needed/', 'errstr should contain error message';
+
+ok( $csr_a->bind_col(2, undef, { foo => 42 }) );
+ok ! eval { $csr_a->bind_col(0, undef) };
+like $@, '/bind_col: column 0 is not a valid column \(1..3\)/', 'errstr should contain error message';
+ok ! eval { $csr_a->bind_col(4, undef) };
+like $@, '/bind_col: column 4 is not a valid column \(1..3\)/', 'errstr should contain error message';
+
+ok($csr_b->bind_param(1, $dir));
+ok($csr_b->execute());
+@row_b = @{ $csr_b->fetchrow_arrayref };
+ok(@row_b);
+
+ok("@row_a" eq "@row_b");
+@row_b = $csr_b->fetchrow_array;
+ok("@row_a" ne "@row_b");
+
+ok($csr_a->finish);
+ok($csr_b->finish);
+
+$csr_a = undef; # force destruction of this cursor now
+ok(1);
+
+print "fetchrow_hashref('NAME_uc')\n";
+ok($csr_b->execute());
+my $row_b = $csr_b->fetchrow_hashref('NAME_uc');
+ok($row_b);
+ok($row_b->{MODE} == $row_a[0]);
+ok($row_b->{SIZE} == $row_a[1]);
+ok($row_b->{NAME} eq $row_a[2]);
+
+print "fetchrow_hashref('ParamValues')\n";
+ok($csr_b->execute());
+ok(!defined eval { $csr_b->fetchrow_hashref('ParamValues') } ); # PurePerl croaks
+
+print "FetchHashKeyName\n";
+ok($csr_b->execute());
+$row_b = $csr_b->fetchrow_hashref();
+ok($row_b);
+ok(keys(%$row_b) == 3);
+ok($row_b->{MODE} == $row_a[0]);
+ok($row_b->{SIZE} == $row_a[1]);
+ok($row_b->{NAME} eq $row_a[2]);
+
+print "fetchall_arrayref\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref;
+ok($r);
+ok(@$r);
+ok($r->[0]->[0] == $row_a[0]);
+ok($r->[0]->[1] == $row_a[1]);
+ok($r->[0]->[2] eq $row_a[2]);
+
+print "fetchall_arrayref array slice\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref([2,1]);
+ok($r && @$r);
+ok($r->[0]->[1] == $row_a[1]);
+ok($r->[0]->[0] eq $row_a[2]);
+
+print "fetchall_arrayref hash slice\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref({ SizE=>1, nAMe=>1});
+ok($r && @$r);
+ok($r->[0]->{SizE} == $row_a[1]);
+ok($r->[0]->{nAMe} eq $row_a[2]);
+
+ok ! $csr_b->fetchall_arrayref({ NoneSuch=>1 });
+like $DBI::errstr, qr/Invalid column name/;
+
+print "fetchall_arrayref renaming hash slice\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref(\{ 1 => "Koko", 2 => "Nimi"});
+ok($r && @$r);
+ok($r->[0]->{Koko} == $row_a[1]);
+ok($r->[0]->{Nimi} eq $row_a[2]);
+
+ok ! eval { $csr_b->fetchall_arrayref(\{ 9999 => "Koko" }) };
+like $@, qr/\Qis not a valid column/;
+
+print "fetchall_arrayref empty renaming hash slice\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref(\{});
+ok($r && @$r);
+ok(keys %{$r->[0]} == 0);
+
+ok($csr_b->execute());
+ok(!$csr_b->fetchall_arrayref(\[]));
+like $DBI::errstr, qr/\Qfetchall_arrayref(REF) invalid/;
+
+print "fetchall_arrayref hash\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref({});
+ok($r);
+ok(keys %{$r->[0]} == 3);
+ok("@{$r->[0]}{qw(MODE SIZE NAME)}" eq "@row_a", "'@{$r->[0]}{qw(MODE SIZE NAME)}' ne '@row_a'");
+
+print "rows()\n"; # assumes previous fetch fetched all rows
+$rows = $csr_b->rows;
+ok($rows > 0, "row count $rows");
+ok($rows == @$r, "$rows vs ".@$r);
+ok($rows == $DBI::rows, "$rows vs $DBI::rows");
+
+print "fetchall_arrayref array slice and max rows\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref([0], 1);
+ok($r);
+is_deeply($r, [[$row_a[0]]]);
+
+$r = $csr_b->fetchall_arrayref([], 1);
+is @$r, 1, 'should fetch one row';
+
+$r = $csr_b->fetchall_arrayref([], 99999);
+ok @$r, 'should fetch all the remaining rows';
+
+$r = $csr_b->fetchall_arrayref([], 99999);
+is $r, undef, 'should return undef as there are no more rows';
+
+# ---
+
+print "selectrow_array\n";
+@row_b = $dbh->selectrow_array($std_sql, undef, $dir);
+ok(@row_b == 3);
+ok("@row_b" eq "@row_a");
+
+print "selectrow_hashref\n";
+$r = $dbh->selectrow_hashref($std_sql, undef, $dir);
+ok(keys %$r == 3);
+ok($r->{MODE} eq $row_a[0]);
+ok($r->{SIZE} eq $row_a[1]);
+ok($r->{NAME} eq $row_a[2]);
+
+print "selectall_arrayref\n";
+$r = $dbh->selectall_arrayref($std_sql, undef, $dir);
+ok($r);
+ok(@{$r->[0]} == 3);
+ok("@{$r->[0]}" eq "@row_a");
+ok(@$r == $rows);
+
+print "selectall_arrayref Slice array slice\n";
+$r = $dbh->selectall_arrayref($std_sql, { Slice => [ 2, 0 ] }, $dir);
+ok($r);
+ok(@{$r->[0]} == 2);
+ok("@{$r->[0]}" eq "$row_a[2] $row_a[0]", qq{"@{$r->[0]}" eq "$row_a[2] $row_a[0]"});
+ok(@$r == $rows);
+
+print "selectall_arrayref Columns array slice\n";
+$r = $dbh->selectall_arrayref($std_sql, { Columns => [ 3, 1 ] }, $dir);
+ok($r);
+ok(@{$r->[0]} == 2);
+ok("@{$r->[0]}" eq "$row_a[2] $row_a[0]", qq{"@{$r->[0]}" eq "$row_a[2] $row_a[0]"});
+ok(@$r == $rows);
+
+print "selectall_arrayref hash slice\n";
+$r = $dbh->selectall_arrayref($std_sql, { Columns => { MoDe=>1, NamE=>1 } }, $dir);
+ok($r);
+ok(keys %{$r->[0]} == 2);
+ok(exists $r->[0]{MoDe});
+ok(exists $r->[0]{NamE});
+ok($r->[0]{MoDe} eq $row_a[0]);
+ok($r->[0]{NamE} eq $row_a[2]);
+ok(@$r == $rows);
+
+print "selectall_hashref\n";
+$r = $dbh->selectall_hashref($std_sql, 'NAME', undef, $dir);
+ok($r, "selectall_hashref result");
+is(ref $r, 'HASH', "selectall_hashref HASH: ".ref $r);
+is(scalar keys %$r, $rows);
+is($r->{ $row_a[2] }{SIZE}, $row_a[1], qq{$r->{ $row_a[2] }{SIZE} eq $row_a[1]});
+
+print "selectall_hashref by column number\n";
+$r = $dbh->selectall_hashref($std_sql, 3, undef, $dir);
+ok($r);
+ok($r->{ $row_a[2] }{SIZE} eq $row_a[1], qq{$r->{ $row_a[2] }{SIZE} eq $row_a[1]});
+
+print "selectcol_arrayref\n";
+$r = $dbh->selectcol_arrayref($std_sql, undef, $dir);
+ok($r);
+ok(@$r == $rows);
+ok($r->[0] eq $row_b[0]);
+
+print "selectcol_arrayref column slice\n";
+$r = $dbh->selectcol_arrayref($std_sql, { Columns => [3,2] }, $dir);
+ok($r);
+# warn Dumper([\@row_b, $r]);
+ok(@$r == $rows * 2);
+ok($r->[0] eq $row_b[2]);
+ok($r->[1] eq $row_b[1]);
+
+# ---
+
+print "others...\n";
+my $csr_c;
+$csr_c = $dbh->prepare("select unknown_field_name1 from ?");
+ok(!defined $csr_c);
+ok($DBI::errstr =~ m/Unknown field names: unknown_field_name1/);
+
+print "RaiseError & PrintError & ShowErrorStatement\n";
+$dbh->{RaiseError} = 1;
+ok($dbh->{RaiseError});
+$dbh->{ShowErrorStatement} = 1;
+ok($dbh->{ShowErrorStatement});
+
+my $error_sql = "select unknown_field_name2 from ?";
+
+ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; });
+#print "$@\n";
+like $@, qr/\Q$error_sql/; # ShowErrorStatement
+like $@, qr/Unknown field names: unknown_field_name2/;
+
+# check attributes are inherited
+my $se_sth1 = $dbh->prepare("select mode from ?");
+ok($se_sth1->{RaiseError});
+ok($se_sth1->{ShowErrorStatement});
+
+# check ShowErrorStatement ParamValues are included and sorted
+$se_sth1->bind_param($_, "val$_") for (1..11);
+ok( !eval { $se_sth1->execute } );
+like $@, qr/\[for Statement "select mode from \?" with ParamValues: 1='val1', 2='val2', 3='val3', 4='val4', 5='val5', 6='val6', 7='val7', 8='val8', 9='val9', 10='val10', 11='val11'\]/;
+
+# this test relies on the fact that ShowErrorStatement is set above
+TODO: {
+ local $TODO = "rt66127 not fixed yet";
+ eval {
+ local $se_sth1->{PrintError} = 0;
+ $se_sth1->execute(1,2);
+ };
+ unlike($@, qr/ParamValues:/, 'error string does not contain ParamValues');
+ is($se_sth1->{ParamValues}, undef, 'ParamValues is empty')
+ or diag(Dumper($se_sth1->{ParamValues}));
+};
+# check that $dbh->{Statement} tracks last _executed_ sth
+$se_sth1 = $dbh->prepare("select mode from ?");
+ok($se_sth1->{Statement} eq "select mode from ?");
+ok($dbh->{Statement} eq "select mode from ?") or print "got: $dbh->{Statement}\n";
+my $se_sth2 = $dbh->prepare("select name from ?");
+ok($se_sth2->{Statement} eq "select name from ?");
+ok($dbh->{Statement} eq "select name from ?");
+$se_sth1->execute('.');
+ok($dbh->{Statement} eq "select mode from ?");
+
+# show error param values
+ok(! eval { $se_sth1->execute('first','second') }); # too many params
+ok($@ =~ /\b1='first'/, $@);
+ok($@ =~ /\b2='second'/, $@);
+
+$se_sth1->finish;
+$se_sth2->finish;
+
+$dbh->{RaiseError} = 0;
+ok(!$dbh->{RaiseError});
+$dbh->{ShowErrorStatement} = 0;
+ok(!$dbh->{ShowErrorStatement});
+
+{
+ my @warn;
+ local($SIG{__WARN__}) = sub { push @warn, @_ };
+ $dbh->{PrintError} = 1;
+ ok($dbh->{PrintError});
+ ok(! $dbh->selectall_arrayref("select unknown_field_name3 from ?"));
+ ok("@warn" =~ m/Unknown field names: unknown_field_name3/);
+ $dbh->{PrintError} = 0;
+ ok(!$dbh->{PrintError});
+}
+
+
+print "HandleError\n";
+my $HandleErrorReturn;
+my $HandleError = sub {
+ my $msg = sprintf "HandleError: %s [h=%s, rv=%s, #=%d]",
+ $_[0],$_[1],(defined($_[2])?$_[2]:'undef'),scalar(@_);
+ die $msg if $HandleErrorReturn < 0;
+ print "$msg\n";
+ $_[2] = 42 if $HandleErrorReturn == 2;
+ return $HandleErrorReturn;
+};
+
+$dbh->{HandleError} = $HandleError;
+ok($dbh->{HandleError});
+ok($dbh->{HandleError} == $HandleError);
+
+$dbh->{RaiseError} = 1;
+$dbh->{PrintError} = 0;
+$error_sql = "select unknown_field_name2 from ?";
+
+print "HandleError -> die\n";
+$HandleErrorReturn = -1;
+ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; });
+ok($@ =~ m/^HandleError:/, $@);
+
+print "HandleError -> 0 -> RaiseError\n";
+$HandleErrorReturn = 0;
+ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; });
+ok($@ =~ m/^DBD::(ExampleP|Multiplex|Gofer)::db prepare failed:/, $@);
+
+print "HandleError -> 1 -> return (original)undef\n";
+$HandleErrorReturn = 1;
+$r = eval { $csr_c = $dbh->prepare($error_sql); };
+ok(!$@, $@);
+ok(!defined($r), $r);
+
+print "HandleError -> 2 -> return (modified)42\n";
+$HandleErrorReturn = 2;
+$r = eval { $csr_c = $dbh->prepare($error_sql); };
+ok(!$@, $@);
+ok($r==42) unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex
+
+$dbh->{HandleError} = undef;
+ok(!$dbh->{HandleError});
+
+{
+ # dump_results;
+ my $sth = $dbh->prepare($std_sql);
+
+ isa_ok($sth, "DBI::st");
+
+ if (length(File::Spec->updir)) {
+ ok($sth->execute(File::Spec->updir));
+ } else {
+ ok($sth->execute('../'));
+ }
+
+ my $dump_file = 'dumpcsr.tst';
+ SKIP: {
+ skip "# dump_results test skipped: unable to open $dump_file: $!\n", 4
+ unless open(DUMP_RESULTS, ">$dump_file");
+ ok($sth->dump_results("10", "\n", ",\t", \*DUMP_RESULTS));
+ close(DUMP_RESULTS) or warn "close $dump_file: $!";
+ ok(-s $dump_file > 0);
+ is( unlink( $dump_file ), 1, "Remove $dump_file" );
+ ok( !-e $dump_file, "Actually gone" );
+ }
+
+}
+
+note "table_info\n";
+# First generate a list of all subdirectories
+$dir = File::Basename::dirname( $INC{"DBI.pm"} );
+my $dh;
+ok(opendir($dh, $dir));
+my(%dirs, %unexpected, %missing);
+while (defined(my $file = readdir($dh))) {
+ $dirs{$file} = 1 if -d File::Spec->catdir($dir,$file);
+}
+note( "Local $dir subdirs: @{[ keys %dirs ]}" );
+closedir($dh);
+my $sth = $dbh->table_info($dir, undef, "%", "TABLE");
+ok($sth);
+%unexpected = %dirs;
+%missing = ();
+while (my $ref = $sth->fetchrow_hashref()) {
+ if (exists($unexpected{$ref->{'TABLE_NAME'}})) {
+ delete $unexpected{$ref->{'TABLE_NAME'}};
+ } else {
+ $missing{$ref->{'TABLE_NAME'}} = 1;
+ }
+}
+ok(keys %unexpected == 0)
+ or diag "Unexpected directories: ", join(",", keys %unexpected), "\n";
+ok(keys %missing == 0)
+ or diag "Missing directories: ", join(",", keys %missing), "\n";
+
+note "tables\n";
+my @tables_expected = (
+ q{"schema"."table"},
+ q{"sch-ema"."table"},
+ q{"schema"."ta-ble"},
+ q{"sch ema"."table"},
+ q{"schema"."ta ble"},
+);
+my @tables = $dbh->tables(undef, undef, "%", "VIEW");
+ok(@tables == @tables_expected, "Table count mismatch".@tables_expected." vs ".@tables);
+ok($tables[$_] eq $tables_expected[$_], "$tables[$_] ne $tables_expected[$_]")
+ foreach (0..$#tables_expected);
+
+for (my $i = 0; $i < 300; $i += 100) {
+ note "Testing the fake directories ($i).\n";
+ ok($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i"));
+ ok($csr_a->execute(), $DBI::errstr);
+ my $ary = $csr_a->fetchall_arrayref;
+ ok(@$ary == $i, @$ary." rows instead of $i");
+ if ($i) {
+ my @n1 = map { $_->[0] } @$ary;
+ my @n2 = reverse map { "file$_" } 1..$i;
+ ok("@n1" eq "@n2", "'@n1' ne '@n2'");
+ }
+ else {
+ ok(1);
+ }
+}
+
+
+SKIP: {
+ skip "test not tested with Multiplex", 1
+ if $dbh->{mx_handle_list};
+ note "Testing \$dbh->func().\n";
+ my %tables;
+ %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables();
+ my @func_tables = $dbh->func('lib', 'examplep_tables');
+ foreach my $t (@func_tables) {
+ defined(delete $tables{$t}) or print "Unexpected table: $t\n";
+ }
+ is(keys(%tables), 0);
+}
+
+$dbh->disconnect;
+ok(!$dbh->{Active});
+ok(!$dbh->ping, "ping should return false after disconnect");
+
+1;
diff --git a/t/11fetch.t b/t/11fetch.t
new file mode 100644
index 0000000..5f2fedc
--- /dev/null
+++ b/t/11fetch.t
@@ -0,0 +1,124 @@
+#!perl -w
+# vim:ts=8:sw=4
+$|=1;
+
+use strict;
+
+use Test::More;
+use DBI;
+use Storable qw(dclone);
+use Data::Dumper;
+
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Sortkeys = 1;
+$Data::Dumper::Quotekeys = 0;
+
+plan tests => 24;
+
+my $dbh = DBI->connect("dbi:Sponge:foo","","", {
+ PrintError => 0,
+ RaiseError => 1,
+});
+
+my $source_rows = [ # data for DBD::Sponge to return via fetch
+ [ 41, "AAA", 9 ],
+ [ 41, "BBB", 9 ],
+ [ 42, "BBB", undef ],
+ [ 43, "ccc", 7 ],
+ [ 44, "DDD", 6 ],
+];
+
+sub go {
+ my $source = shift || $source_rows;
+ my $sth = $dbh->prepare("foo", {
+ rows => dclone($source),
+ NAME => [ qw(C1 C2 C3) ],
+ });
+ ok($sth->execute(), $DBI::errstr);
+ return $sth;
+}
+
+my($sth, $col0, $col1, $col2, $rows);
+
+# --- fetchrow_arrayref
+# --- fetchrow_array
+# etc etc
+
+# --- fetchall_hashref
+my @fetchall_hashref_results = ( # single keys
+ C1 => {
+ 41 => { C1 => 41, C2 => 'BBB', C3 => 9 },
+ 42 => { C1 => 42, C2 => 'BBB', C3 => undef },
+ 43 => { C1 => 43, C2 => 'ccc', C3 => 7 },
+ 44 => { C1 => 44, C2 => 'DDD', C3 => 6 }
+ },
+ C2 => {
+ AAA => { C1 => 41, C2 => 'AAA', C3 => 9 },
+ BBB => { C1 => 42, C2 => 'BBB', C3 => undef },
+ DDD => { C1 => 44, C2 => 'DDD', C3 => 6 },
+ ccc => { C1 => 43, C2 => 'ccc', C3 => 7 }
+ },
+ [ 'C2' ] => { # single key within arrayref
+ AAA => { C1 => 41, C2 => 'AAA', C3 => 9 },
+ BBB => { C1 => 42, C2 => 'BBB', C3 => undef },
+ DDD => { C1 => 44, C2 => 'DDD', C3 => 6 },
+ ccc => { C1 => 43, C2 => 'ccc', C3 => 7 }
+ },
+);
+push @fetchall_hashref_results, ( # multiple keys
+ [ 'C1', 'C2' ] => {
+ '41' => {
+ AAA => { C1 => '41', C2 => 'AAA', C3 => 9 },
+ BBB => { C1 => '41', C2 => 'BBB', C3 => 9 }
+ },
+ '42' => {
+ BBB => { C1 => '42', C2 => 'BBB', C3 => undef }
+ },
+ '43' => {
+ ccc => { C1 => '43', C2 => 'ccc', C3 => 7 }
+ },
+ '44' => {
+ DDD => { C1 => '44', C2 => 'DDD', C3 => 6 }
+ }
+ },
+);
+
+my %dump;
+
+while (my $keyfield = shift @fetchall_hashref_results) {
+ my $expected = shift @fetchall_hashref_results;
+ my $k = (ref $keyfield) ? "[@$keyfield]" : $keyfield;
+ print "# fetchall_hashref($k)\n";
+ ok($sth = go());
+ my $result = $sth->fetchall_hashref($keyfield);
+ ok($result);
+ is_deeply($result, $expected);
+ # $dump{$k} = dclone $result; # just for adding tests
+}
+
+warn Dumper \%dump if %dump;
+
+# test assignment to NUM_OF_FIELDS automatically alters the row buffer
+$sth = go();
+my $row = $sth->fetchrow_arrayref;
+is scalar @$row, 3;
+is $sth->{NUM_OF_FIELDS}, 3;
+is scalar @{ $sth->_get_fbav }, 3;
+$sth->{NUM_OF_FIELDS} = 4;
+is $sth->{NUM_OF_FIELDS}, 4;
+is scalar @{ $sth->_get_fbav }, 4;
+$sth->{NUM_OF_FIELDS} = 2;
+is $sth->{NUM_OF_FIELDS}, 2;
+is scalar @{ $sth->_get_fbav }, 2;
+
+$sth->finish;
+
+
+if (0) {
+ my @perf = map { [ int($_/100), $_, $_ ] } 0..10000;
+ require Benchmark;
+ Benchmark::timethis(10, sub { go(\@perf)->fetchall_hashref([ 'C1','C2','C3' ]) });
+}
+
+
+1; # end
diff --git a/t/12quote.t b/t/12quote.t
new file mode 100644
index 0000000..c7dc948
--- /dev/null
+++ b/t/12quote.t
@@ -0,0 +1,48 @@
+#!perl -w
+
+use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
+use strict;
+
+use Test::More tests => 10;
+
+use DBI qw(:sql_types);
+use Config;
+use Cwd;
+
+$^W = 1;
+$| = 1;
+
+my $dbh = DBI->connect('dbi:ExampleP:', '', '');
+
+sub check_quote {
+ # checking quote
+ is($dbh->quote("quote's"), "'quote''s'", '... quoting strings with embedded single quotes');
+ is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as SQL_VARCHAR');
+ is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as SQL_INTEGER');
+ is($dbh->quote(undef), "NULL", '... quoting undef as NULL');
+}
+
+check_quote();
+
+sub check_quote_identifier {
+
+ is($dbh->quote_identifier('foo'), '"foo"', '... properly quotes foo as "foo"');
+ is($dbh->quote_identifier('f"o'), '"f""o"', '... properly quotes f"o as "f""o"');
+ is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '... properly quotes foo, bar as "foo"."bar"');
+ is($dbh->quote_identifier(undef,undef,'bar'), '"bar"', '... properly quotes undef, undef, bar as "bar"');
+
+ is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '... properly quotes foo, undef, bar as "foo"."bar"');
+
+ SKIP: {
+ skip "Can't test alternate quote_identifier logic with DBI_AUTOPROXY", 1
+ if $ENV{DBI_AUTOPROXY};
+ my $qi = $dbh->{dbi_quote_identifier_cache} || die "test out of date with dbi internals?";
+ $qi->[1] = '@'; # SQL_CATALOG_NAME_SEPARATOR
+ $qi->[2] = 2; # SQL_CATALOG_LOCATION
+ is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now quotes it as "bar"@"foo" after flushing cache');
+ }
+}
+
+check_quote_identifier();
+
+1;
diff --git a/t/13taint.t b/t/13taint.t
new file mode 100644
index 0000000..4fd1076
--- /dev/null
+++ b/t/13taint.t
@@ -0,0 +1,133 @@
+#!perl -wT
+
+use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
+use DBI qw(:sql_types);
+use Config;
+use Cwd;
+use strict;
+
+
+$^W = 1;
+$| = 1;
+
+require VMS::Filespec if $^O eq 'VMS';
+
+use Test::More;
+
+# Check Taint attribute works. This requires this test to be run
+# manually with the -T flag: "perl -T -Mblib t/examp.t"
+sub is_tainted {
+ my $foo;
+ return ! eval { ($foo=join('',@_)), kill 0; 1; };
+}
+sub mk_tainted {
+ my $string = shift;
+ return substr($string.$^X, 0, length($string));
+}
+
+plan skip_all => "Taint attributes not supported with DBI::PurePerl" if $DBI::PurePerl;
+plan skip_all => "Taint attribute tests require taint mode (perl -T)" unless is_tainted($^X);
+plan skip_all => "Taint attribute tests not functional with DBI_AUTOPROXY" if $ENV{DBI_AUTOPROXY};
+
+plan tests => 36;
+
+# get a dir always readable on all platforms
+my $dir = getcwd() || cwd();
+$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
+$dir =~ m/(.*)/; $dir = $1 || die; # untaint $dir
+
+my ($r, $dbh);
+
+$dbh = DBI->connect('dbi:ExampleP:', '', '', { PrintError=>0, RaiseError=>1, Taint => 1 });
+
+my $std_sql = "select mode,size,name from ?";
+my $csr_a = $dbh->prepare($std_sql);
+ok(ref $csr_a);
+
+ok($dbh->{'Taint'});
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 1);
+
+$dbh->{'TaintOut'} = 0;
+ok($dbh->{'Taint'} == 0);
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 0);
+
+$dbh->{'Taint'} = 0;
+ok($dbh->{'Taint'} == 0);
+ok($dbh->{'TaintIn'} == 0);
+ok($dbh->{'TaintOut'} == 0);
+
+$dbh->{'TaintIn'} = 1;
+ok($dbh->{'Taint'} == 0);
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 0);
+
+$dbh->{'TaintOut'} = 1;
+ok($dbh->{'Taint'} == 1);
+ok($dbh->{'TaintIn'} == 1);
+ok($dbh->{'TaintOut'} == 1);
+
+$dbh->{'Taint'} = 0;
+my $st;
+eval { $st = $dbh->prepare($std_sql); };
+ok(ref $st);
+
+ok($st->{'Taint'} == 0);
+
+ok($st->execute( $dir ), 'should execute ok');
+
+my @row = $st->fetchrow_array;
+ok(@row);
+
+ok(!is_tainted($row[0]));
+ok(!is_tainted($row[1]));
+ok(!is_tainted($row[2]));
+
+print "TaintIn\n";
+$st->{'TaintIn'} = 1;
+
+@row = $st->fetchrow_array;
+ok(@row);
+
+ok(!is_tainted($row[0]));
+ok(!is_tainted($row[1]));
+ok(!is_tainted($row[2]));
+
+print "TaintOut\n";
+$st->{'TaintOut'} = 1;
+
+@row = $st->fetchrow_array;
+ok(@row);
+
+ok(is_tainted($row[0]));
+ok(is_tainted($row[1]));
+ok(is_tainted($row[2]));
+
+$st->finish;
+
+my $tainted_sql = mk_tainted($std_sql);
+my $tainted_dot = mk_tainted('.');
+
+$dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
+eval { $dbh->prepare($tainted_sql); 1; };
+ok($@ =~ /Insecure dependency/, $@);
+eval { $csr_a->execute($tainted_dot); 1; };
+ok($@ =~ /Insecure dependency/, $@);
+undef $@;
+
+$dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0;
+
+eval { $dbh->prepare($tainted_sql); 1; };
+ok(!$@, $@);
+eval { $csr_a->execute($tainted_dot); 1; };
+ok(!$@, $@);
+
+$csr_a->{Taint} = 0;
+ok($csr_a->{Taint} == 0);
+
+$csr_a->finish;
+
+$dbh->disconnect;
+
+1;
diff --git a/t/14utf8.t b/t/14utf8.t
new file mode 100644
index 0000000..c141e38
--- /dev/null
+++ b/t/14utf8.t
@@ -0,0 +1,76 @@
+#!perl -w
+# vim:ts=8:sw=4
+$|=1;
+
+use Test::More;
+use DBI;
+
+plan skip_all => "Requires perl 5.8"
+ unless $] >= 5.008;
+
+eval {
+ require Storable;
+ import Storable qw(dclone);
+ require Encode;
+ import Encode qw(_utf8_on _utf8_off is_utf8);
+};
+
+plan skip_all => "Unable to load required module ($@)"
+ unless defined &_utf8_on;
+
+plan tests => 16;
+
+$dbh = DBI->connect("dbi:Sponge:foo","","", {
+ PrintError => 0,
+ RaiseError => 1,
+});
+
+my $source_rows = [ # data for DBD::Sponge to return via fetch
+ [ 41, "AAA", 9 ],
+ [ 42, "BB", undef ],
+ [ 43, undef, 7 ],
+ [ 44, "DDD", 6 ],
+];
+
+my($sth, $col0, $col1, $col2, $rows);
+
+# set utf8 on one of the columns so we can check it carries through into the
+# keys of fetchrow_hashref
+my @col_names = qw(Col1 Col2 Col3);
+_utf8_on($col_names[1]);
+ok is_utf8($col_names[1]);
+ok !is_utf8($col_names[0]);
+
+$sth = $dbh->prepare("foo", {
+ rows => dclone($source_rows),
+ NAME => \@col_names,
+});
+
+ok($sth->bind_columns(\($col0, $col1, $col2)) );
+ok($sth->execute(), $DBI::errstr);
+
+ok $sth->fetch;
+cmp_ok $col1, 'eq', "AAA";
+ok !is_utf8($col1);
+
+# force utf8 flag on
+_utf8_on($col1);
+ok is_utf8($col1);
+
+ok $sth->fetch;
+cmp_ok $col1, 'eq', "BB";
+# XXX sadly this test doesn't detect the problem when using DBD::Sponge
+# because DBD::Sponge uses $sth->_set_fbav (correctly) and that uses
+# sv_setsv which doesn't have the utf8 persistence that sv_setpv does.
+ok !is_utf8($col1); # utf8 flag should have been reset
+
+ok $sth->fetch;
+ok !defined $col1; # null
+ok !is_utf8($col1); # utf8 flag should have been reset
+
+ok my $hash = $sth->fetchrow_hashref;
+ok 1 == grep { is_utf8($_) } keys %$hash;
+
+$sth->finish;
+
+# end
diff --git a/t/15array.t b/t/15array.t
new file mode 100644
index 0000000..2b91001
--- /dev/null
+++ b/t/15array.t
@@ -0,0 +1,254 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use Test::More tests => 55;
+
+## ----------------------------------------------------------------------------
+## 15array.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok('DBI');
+}
+
+# create a database handle
+my $dbh = DBI->connect("dbi:Sponge:dummy", '', '', {
+ RaiseError => 1,
+ ShowErrorStatement => 1,
+ AutoCommit => 1
+});
+
+# check that our db handle is good
+isa_ok($dbh, "DBI::db");
+
+my $rv;
+my $rows = [];
+my $tuple_status = [];
+my $dumped;
+
+my $sth = $dbh->prepare("insert", {
+ rows => $rows, # where to 'insert' (push) the rows
+ NUM_OF_PARAMS => 4,
+ execute_hook => sub { # DBD::Sponge hook to make certain data trigger an error for that row
+ local $^W;
+ return $_[0]->set_err(1,"errmsg") if grep { $_ and $_ eq "B" } @_;
+ return 1;
+ }
+ });
+
+isa_ok($sth, "DBI::st");
+
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+
+# -----------------------------------------------
+
+ok(! eval {
+ local $sth->{PrintError} = 0;
+ $sth->execute_array(
+ {
+ ArrayTupleStatus => $tuple_status
+ },
+ [ 1, 2, 3 ], # array of integers
+ 42, # scalar 42 treated as array of 42's
+ undef, # scalar undef treated as array of undef's
+ [ qw(A B C) ], # array of strings
+ ) },
+ '... execute_array should return false'
+);
+ok $@, 'execute_array failure with RaiseError should have died';
+like $sth->errstr, '/executing 3 generated 1 errors/';
+
+cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
+
+ok(eq_array(
+ $rows,
+ [ [1, 42, undef, 'A'], [3, 42, undef, 'C'] ]
+ ),
+ '... our rows are as expected');
+
+ok(eq_array(
+ $tuple_status,
+ [1, [1, 'errmsg', 'S1000'], 1]
+ ),
+ '... our tuple_status is as expected');
+
+# -----------------------------------------------
+# --- change one param and re-execute
+
+@$rows = ();
+ok( $sth->bind_param_array(4, [ qw(a b c) ]), '... bind_param_array should return true');
+ok( $sth->execute_array({ ArrayTupleStatus => $tuple_status }), '... execute_array should return true');
+
+cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
+
+ok(eq_array(
+ $rows,
+ [ [1, 42, undef, 'a'], [2, 42, undef, 'b'], [3, 42, undef, 'c'] ]
+ ),
+ '... our rows are as expected');
+
+ok(eq_array(
+ $tuple_status,
+ [1, 1, 1]
+ ),
+ '... our tuple_status is as expected');
+
+# -----------------------------------------------
+# --- call execute_array in array context to get executed AND affected
+@$rows = ();
+my ($executed, $affected) = $sth->execute_array({ ArrayTupleStatus => $tuple_status });
+ok($executed, '... execute_array should return true');
+cmp_ok($executed, '==', 3, '... we should have executed 3 rows');
+cmp_ok($affected, '==', 3, '... we should have affected 3 rows');
+
+# -----------------------------------------------
+# --- with no values for bind params, should execute zero times
+
+@$rows = ();
+$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [], [], [], []);
+ok($rv, '... execute_array should return true');
+ok(!($rv+0), '... execute_array should return 0 (but true)');
+
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status');
+
+# -----------------------------------------------
+# --- with only scalar values for bind params, should execute just once
+
+@$rows = ();
+$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, 6, 7, 8);
+cmp_ok($rv, '==', 1, '... execute_array should return 1');
+
+cmp_ok(scalar @{$rows}, '==', 1, '... we should have 1 rows');
+ok(eq_array( $rows, [ [5,6,7,8] ]), '... our rows are as expected');
+cmp_ok(scalar @{$tuple_status}, '==', 1,'... we should have 1 tuple_status');
+ok(eq_array( $tuple_status, [1]), '... our tuple_status is as expected');
+
+# -----------------------------------------------
+# --- with mix of scalar values and arrays only arrays control tuples
+
+@$rows = ();
+$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, [], 7, 8);
+cmp_ok($rv, '==', 0, '... execute_array should return 0');
+
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status');
+
+# -----------------------------------------------
+# --- catch 'undefined value' bug with zero bind values
+
+@$rows = ();
+my $sth_other = $dbh->prepare("insert", {
+ rows => $rows, # where to 'insert' (push) the rows
+ NUM_OF_PARAMS => 1,
+});
+
+isa_ok($sth_other, "DBI::st");
+
+$rv = $sth_other->execute_array( {}, [] );
+ok($rv, '... execute_array should return true');
+ok(!($rv+0), '... execute_array should return 0 (but true)');
+# no ArrayTupleStatus
+
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+
+# -----------------------------------------------
+# --- ArrayTupleFetch code-ref tests ---
+
+my $index = 0;
+
+my $fetchrow = sub { # generate 5 rows of two integer values
+ return if $index >= 2;
+ $index +=1;
+ # There doesn't seem any reliable way to force $index to be
+ # treated as a string (and so dumped as such). We just have to
+ # make the test case allow either 1 or '1'.
+ return [ $index, 'a','b','c' ];
+};
+
+@$rows = ();
+ok( $sth->execute_array({
+ ArrayTupleFetch => $fetchrow,
+ ArrayTupleStatus => $tuple_status
+ }), '... execute_array should return true');
+
+cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 2, '... we should have 2 tuple_status');
+
+ok(eq_array(
+ $rows,
+ [ [1, 'a', 'b', 'c'], [2, 'a', 'b', 'c'] ]
+ ),
+ '... rows should match'
+);
+
+ok(eq_array(
+ $tuple_status,
+ [1, 1]
+ ),
+ '... tuple_status should match'
+);
+
+# -----------------------------------------------
+# --- ArrayTupleFetch sth tests ---
+
+my $fetch_sth = $dbh->prepare("foo", {
+ rows => [ map { [ $_,'x','y','z' ] } 7..9 ],
+ NUM_OF_FIELDS => 4
+ });
+
+isa_ok($fetch_sth, "DBI::st");
+
+$fetch_sth->execute();
+
+@$rows = ();
+
+ok( $sth->execute_array({
+ ArrayTupleFetch => $fetch_sth,
+ ArrayTupleStatus => $tuple_status,
+ }), '... execute_array should return true');
+
+cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
+
+ok(eq_array(
+ $rows,
+ [ [7, 'x', 'y', 'z'], [8, 'x', 'y', 'z'], [9, 'x', 'y', 'z'] ]
+ ),
+ '... rows should match'
+);
+
+ok(eq_array(
+ $tuple_status,
+ [1, 1, 1]
+ ),
+ '... tuple status should match'
+);
+
+# -----------------------------------------------
+# --- error detection tests ---
+
+$sth->{RaiseError} = 0;
+$sth->{PrintError} = 0;
+
+ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [1],[2]), '... execute_array should return undef');
+is($sth->errstr, '2 bind values supplied but 4 expected', '... errstr is as expected');
+
+ok(!defined $sth->execute_array( { ArrayTupleStatus => { } }, [ 1, 2, 3 ]), '... execute_array should return undef');
+is( $sth->errstr, 'ArrayTupleStatus attribute must be an arrayref', '... errstr is as expected');
+
+ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,{},3,4), '... execute_array should return undef');
+is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a HASH', '... errstr is as expected');
+
+ok(!defined $sth->bind_param_array(":foo", [ qw(a b c) ]), '... bind_param_array should return undef');
+is( $sth->errstr, "Can't use named placeholder ':foo' for non-driver supported bind_param_array", '... errstr is as expected');
+
+$dbh->disconnect;
+
+1;
diff --git a/t/16destroy.t b/t/16destroy.t
new file mode 100644
index 0000000..a2945c4
--- /dev/null
+++ b/t/16destroy.t
@@ -0,0 +1,147 @@
+#!perl -w
+
+use strict;
+
+use Test::More tests => 20;
+
+BEGIN{ use_ok( 'DBI' ) }
+
+my $expect_active;
+
+## main Test Driver Package
+{
+ package DBD::Test;
+
+ use strict;
+ use warnings;
+
+ my $drh = undef;
+
+ sub driver {
+ return $drh if $drh;
+ my ($class, $attr) = @_;
+ $class = "${class}::dr";
+ ($drh) = DBI::_new_drh($class, {
+ Name => 'Test',
+ Version => '1.0',
+ }, 77 );
+ return $drh;
+ }
+
+ sub CLONE { undef $drh }
+}
+
+## Test Driver
+{
+ package DBD::Test::dr;
+
+ use warnings;
+ use Test::More;
+
+ sub connect { # normally overridden, but a handy default
+ my($drh, $dbname, $user, $auth, $attrs)= @_;
+ my ($outer, $dbh) = DBI::_new_dbh($drh);
+ $dbh->STORE(Active => 1);
+ $dbh->STORE(AutoCommit => 1);
+ $dbh->STORE( $_ => $attrs->{$_}) for keys %$attrs;
+ return $outer;
+ }
+
+ $DBD::Test::dr::imp_data_size = 0;
+ cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo');
+}
+
+## Test db package
+{
+ package DBD::Test::db;
+
+ use strict;
+ use warnings;
+ use Test::More;
+
+ $DBD::Test::db::imp_data_size = 0;
+ cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo');
+
+ sub STORE {
+ my ($dbh, $attrib, $value) = @_;
+ # would normally validate and only store known attributes
+ # else pass up to DBI to handle
+ if ($attrib eq 'AutoCommit') {
+ # convert AutoCommit values to magic ones to let DBI
+ # know that the driver has 'handled' the AutoCommit attribute
+ $value = ($value) ? -901 : -900;
+ }
+ return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/;
+ return $dbh->SUPER::STORE($attrib, $value);
+ }
+
+ sub DESTROY {
+ if ($expect_active < 0) { # inside child
+ my $self = shift;
+ exit $self->FETCH('Active') || 0 unless $^O eq 'MSWin32';
+
+ # On Win32, the forked child is actually a thread. So don't exit,
+ # and report failure directly.
+ fail 'Child should be inactive on DESTROY' if $self->FETCH('Active');
+ } else {
+ return $expect_active
+ ? ok( shift->FETCH('Active'), 'Should be active in DESTROY')
+ : ok( !shift->FETCH('Active'), 'Should not be active in DESTROY');
+ }
+ }
+}
+
+my $dsn = 'dbi:ExampleP:dummy';
+
+$INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver()
+ok my $drh = DBI->install_driver('Test'), 'Install test driver';
+
+NOSETTING: {
+ # Try defaults.
+ ok my $dbh = $drh->connect, 'Connect to test driver';
+ ok $dbh->{Active}, 'Should start active';
+ $expect_active = 1;
+}
+
+IAD: {
+ # Try InactiveDestroy.
+ ok my $dbh = $drh->connect($dsn, '', '', { InactiveDestroy => 1 }),
+ 'Create with ActiveDestroy';
+ ok $dbh->{InactiveDestroy}, 'InactiveDestroy should be set';
+ ok $dbh->{Active}, 'Should start active';
+ $expect_active = 0;
+}
+
+AIAD: {
+ # Try AutoInactiveDestroy.
+ ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }),
+ 'Create with AutoInactiveDestroy';
+ ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set';
+ ok $dbh->{Active}, 'Should start active';
+ $expect_active = 1;
+}
+
+FORK: {
+ # Try AutoInactiveDestroy and fork.
+ ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }),
+ 'Create with AutoInactiveDestroy again';
+ ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set';
+ ok $dbh->{Active}, 'Should start active';
+
+ my $pid = eval { fork() };
+ if (not defined $pid) {
+ chomp $@;
+ my $msg = "AutoInactiveDestroy destroy test skipped";
+ diag "$msg because $@\n";
+ pass $msg; # in lieu of the child status test
+ }
+ elsif ($pid) {
+ # parent.
+ $expect_active = 1;
+ wait;
+ ok $? == 0, 'Child should be inactive on DESTROY';
+ } else {
+ # child.
+ $expect_active = -1;
+ }
+}
diff --git a/t/19fhtrace.t b/t/19fhtrace.t
new file mode 100644
index 0000000..d310db4
--- /dev/null
+++ b/t/19fhtrace.t
@@ -0,0 +1,306 @@
+#!perl -w
+# vim:sw=4:ts=8
+
+use strict;
+
+use Test::More tests => 27;
+
+## ----------------------------------------------------------------------------
+## 09trace.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok( 'DBI' );
+}
+
+$|=1;
+
+our $fancylogfn = "fancylog$$.log";
+our $trace_file = "dbitrace$$.log";
+
+# Clean up when we're done.
+END { 1 while unlink $fancylogfn;
+ 1 while unlink $trace_file; };
+
+package PerlIO::via::TraceDBI;
+
+our $logline;
+
+sub OPEN {
+ return 1;
+}
+
+sub PUSHED
+{
+ my ($class,$mode,$fh) = @_;
+ # When writing we buffer the data
+ my $buf = '';
+ return bless \$buf,$class;
+}
+
+sub FILL
+{
+ my ($obj,$fh) = @_;
+ return $logline;
+}
+
+sub READLINE
+{
+ my ($obj,$fh) = @_;
+ return $logline;
+}
+
+sub WRITE
+{
+ my ($obj,$buf,$fh) = @_;
+# print "\n*** WRITING $buf\n";
+ $logline = $buf;
+ return length($buf);
+}
+
+sub FLUSH
+{
+ my ($obj,$fh) = @_;
+ return 0;
+}
+
+sub CLOSE {
+# print "\n*** CLOSING!!!\n";
+ $logline = "**** CERRADO! ***";
+ return -1;
+}
+
+1;
+
+package PerlIO::via::MyFancyLogLayer;
+
+sub OPEN {
+ my ($obj, $path, $mode, $fh) = @_;
+ $$obj = $path;
+ return 1;
+}
+
+sub PUSHED
+{
+ my ($class,$mode,$fh) = @_;
+ # When writing we buffer the data
+ my $logger;
+ return bless \$logger,$class;
+}
+
+sub WRITE
+{
+ my ($obj,$buf,$fh) = @_;
+ $$obj->log($buf);
+ return length($buf);
+}
+
+sub FLUSH
+{
+ my ($obj,$fh) = @_;
+ return 0;
+}
+
+sub CLOSE {
+ my $self = shift;
+ $$self->close();
+ return 0;
+}
+
+1;
+
+package MyFancyLogger;
+
+use Symbol qw(gensym);
+
+sub new
+{
+ my $self = {};
+ my $fh = gensym();
+ open $fh, '>', $fancylogfn;
+ $self->{_fh} = $fh;
+ $self->{_buf} = '';
+ return bless $self, shift;
+}
+
+sub log
+{
+ my $self = shift;
+ my $fh = $self->{_fh};
+ $self->{_buf} .= shift;
+ print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and
+ $self->{_buf} = ''
+ if $self->{_buf}=~tr/\n//;
+}
+
+sub close {
+ my $self = shift;
+ return unless exists $self->{_fh};
+ my $fh = $self->{_fh};
+ print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and
+ $self->{_buf} = ''
+ if $self->{_buf};
+ close $fh;
+ delete $self->{_fh};
+}
+
+1;
+
+package main;
+
+## ----------------------------------------------------------------------------
+# Connect to the example driver.
+
+my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
+ { PrintError => 0,
+ RaiseError => 1,
+ PrintWarn => 1,
+ });
+isa_ok( $dbh, 'DBI::db' );
+
+# Clean up when we're done.
+END { $dbh->disconnect if $dbh };
+
+## ----------------------------------------------------------------------------
+# Check the database handle attributes.
+
+cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute');
+
+1 while unlink $trace_file;
+
+my $tracefd;
+## ----------------------------------------------------------------------------
+# First use regular filehandle
+open $tracefd, '>>', $trace_file;
+
+my $oldfd = select($tracefd);
+$| = 1;
+select $oldfd;
+
+ok(-f $trace_file, '... regular fh: trace file successfully created');
+
+$dbh->trace(2, $tracefd);
+ok( 1, '... regular fh: filehandle successfully set');
+
+#
+# read current size of file
+#
+my $filesz = (stat $tracefd)[7];
+$dbh->trace_msg("First logline\n", 1);
+#
+# read new file size and verify its different
+#
+my $newfsz = (stat $tracefd)[7];
+SKIP: {
+ skip 'on VMS autoflush using select does not work', 1 if $^O eq 'VMS';
+ ok(($filesz != $newfsz), '... regular fh: trace_msg');
+}
+
+$dbh->trace(undef, "STDOUT"); # close $trace_file
+ok(-f $trace_file, '... regular fh: file successfully changed');
+
+$filesz = (stat $tracefd)[7];
+$dbh->trace_msg("Next logline\n");
+#
+# read new file size and verify its same
+#
+$newfsz = (stat $tracefd)[7];
+ok(($filesz == $newfsz), '... regular fh: trace_msg after changing trace output');
+
+#1 while unlink $trace_file;
+
+$dbh->trace(0); # disable trace
+
+{ # Open trace to glob. started failing in perl-5.10
+ my $tf = "foo.log";
+ 1 while unlink $tf;
+ 1 while unlink "*main::FOO";
+ 1 while unlink "*main::STDERR";
+ is (-f $tf, undef, "Tracefile removed");
+ ok (open (FOO, ">", $tf), "Tracefile FOO opened");
+ ok (-f $tf, "Tracefile created");
+ DBI->trace (1, *FOO);
+ is (-f "*main::FOO", undef, "Regression test");
+ DBI->trace_msg ("foo\n", 1);
+ DBI->trace (0, *STDERR);
+ close FOO;
+ open my $fh, "<", $tf;
+ is ((<$fh>)[-1], "foo\n", "Traced message");
+ close $fh;
+ is (-f "*main::STDERR", undef, "Regression test");
+ 1 while unlink $tf;
+ }
+
+SKIP: {
+ eval { require 5.008; };
+ skip "Layered I/O not available in Perl $^V", 13
+ if $@;
+## ----------------------------------------------------------------------------
+# Then use layered filehandle
+#
+open TRACEFD, '+>:via(TraceDBI)', 'layeredtrace.out';
+print TRACEFD "*** Test our layer\n";
+my $result = <TRACEFD>;
+is $result, "*** Test our layer\n", "... layered fh: file is layered: $result\n";
+
+$dbh->trace(1, \*TRACEFD);
+ok( 1, '... layered fh: filehandle successfully set');
+
+$dbh->trace_msg("Layered logline\n", 1);
+
+$result = <TRACEFD>;
+is $result, "Layered logline\n", "... layered fh: trace_msg: $result\n";
+
+$dbh->trace(1, "STDOUT"); # close $trace_file
+$result = <TRACEFD>;
+is $result, "Layered logline\n", "... layered fh: close doesn't close: $result\n";
+
+$dbh->trace_msg("Next logline\n", 1);
+$result = <TRACEFD>;
+is $result, "Layered logline\n", "... layered fh: trace_msg after change trace output: $result\n";
+
+## ----------------------------------------------------------------------------
+# Then use scalar filehandle
+#
+my $tracestr;
+open TRACEFD, '+>:scalar', \$tracestr;
+print TRACEFD "*** Test our layer\n";
+ok 1, "... scalar trace: file is layered: $tracestr\n";
+
+$dbh->trace(1, \*TRACEFD);
+ok 1, '... scalar trace: filehandle successfully set';
+
+$dbh->trace_msg("Layered logline\n", 1);
+ok 1, "... scalar trace: $tracestr\n";
+
+$dbh->trace(1, "STDOUT"); # close $trace_file
+ok 1, "... scalar trace: close doesn't close: $tracestr\n";
+
+$dbh->trace_msg("Next logline\n", 1);
+ok 1, "... scalar trace: after change trace output: $tracestr\n";
+
+## ----------------------------------------------------------------------------
+# Then use fancy logger
+#
+open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new();
+
+$dbh->trace('SQL', $fh);
+
+$dbh->trace_msg("Layered logline\n", 1);
+ok 1, "... logger: trace_msg\n";
+
+$dbh->trace(1, "STDOUT"); # close $trace_file
+ok 1, "... logger: close doesn't close\n";
+
+$dbh->trace_msg("Next logline\n", 1);
+ok 1, "... logger: trace_msg after change trace output\n";
+
+close $fh;
+
+}
+
+1;
+
+# end
diff --git a/t/20meta.t b/t/20meta.t
new file mode 100644
index 0000000..a8d609e
--- /dev/null
+++ b/t/20meta.t
@@ -0,0 +1,32 @@
+#!perl -w
+
+use strict;
+use Test::More tests => 8;
+
+$|=1;
+$^W=1;
+
+BEGIN { use_ok( 'DBI', ':sql_types' ) }
+BEGIN { use_ok( 'DBI::DBD::Metadata' ) } # just to check for syntax errors etc
+
+my $dbh = DBI->connect("dbi:ExampleP:.","","", { FetchHashKeyName => 'NAME_lc' })
+ or die "Unable to connect to ExampleP driver: $DBI::errstr";
+
+isa_ok($dbh, 'DBI::db');
+#$dbh->trace(3);
+
+#use Data::Dumper;
+#print Dumper($dbh->type_info_all);
+#print Dumper($dbh->type_info);
+#print Dumper($dbh->type_info(DBI::SQL_INTEGER));
+
+my @ti = $dbh->type_info;
+ok(@ti>0);
+
+is($dbh->type_info(SQL_INTEGER)->{DATA_TYPE}, SQL_INTEGER);
+is($dbh->type_info(SQL_INTEGER)->{TYPE_NAME}, 'INTEGER');
+
+is($dbh->type_info(SQL_VARCHAR)->{DATA_TYPE}, SQL_VARCHAR);
+is($dbh->type_info(SQL_VARCHAR)->{TYPE_NAME}, 'VARCHAR');
+
+1;
diff --git a/t/30subclass.t b/t/30subclass.t
new file mode 100644
index 0000000..3217a9e
--- /dev/null
+++ b/t/30subclass.t
@@ -0,0 +1,182 @@
+#!perl -w
+
+use strict;
+
+$|=1;
+$^W=1;
+
+my $calls = 0;
+my %my_methods;
+
+
+# =================================================
+# Example code for sub classing the DBI.
+#
+# Note that the extra ::db and ::st classes must be set up
+# as sub classes of the corresponding DBI classes.
+#
+# This whole mechanism is new and experimental - it may change!
+
+package MyDBI;
+@MyDBI::ISA = qw(DBI);
+
+# the MyDBI::dr::connect method is NOT called!
+# you can either override MyDBI::connect()
+# or use MyDBI::db::connected()
+
+package MyDBI::db;
+@MyDBI::db::ISA = qw(DBI::db);
+
+sub prepare {
+ my($dbh, @args) = @_;
+ ++$my_methods{prepare};
+ ++$calls;
+ my $sth = $dbh->SUPER::prepare(@args);
+ return $sth;
+}
+
+
+package MyDBI::st;
+@MyDBI::st::ISA = qw(DBI::st);
+
+sub fetch {
+ my($sth, @args) = @_;
+ ++$my_methods{fetch};
+ ++$calls;
+ # this is just to trigger (re)STORE on exit to test that the STORE
+ # doesn't clear any erro condition
+ local $sth->{Taint} = 0;
+ my $row = $sth->SUPER::fetch(@args);
+ if ($row) {
+ # modify fetched data as an example
+ $row->[1] = lc($row->[1]);
+
+ # also demonstrate calling set_err()
+ return $sth->set_err(1,"Don't be so negative",undef,"fetch")
+ if $row->[0] < 0;
+ # ... and providing alternate results
+ # (although typically would trap and hide and error from SUPER::fetch)
+ return $sth->set_err(2,"Don't exagerate",undef, undef, [ 42,"zz",0 ])
+ if $row->[0] > 42;
+ }
+ return $row;
+}
+
+
+# =================================================
+package main;
+
+use Test::More tests => 43;
+
+BEGIN {
+ use_ok( 'DBI' );
+}
+
+my $tmp;
+
+#DBI->trace(2);
+my $dbh = MyDBI->connect("dbi:Sponge:foo","","", {
+ PrintError => 0,
+ RaiseError => 1,
+ CompatMode => 1, # just for clone test
+});
+isa_ok($dbh, 'MyDBI::db');
+is($dbh->{CompatMode}, 1);
+undef $dbh;
+
+$dbh = DBI->connect("dbi:Sponge:foo","","", {
+ PrintError => 0,
+ RaiseError => 1,
+ RootClass => "MyDBI",
+ CompatMode => 1, # just for clone test
+ dbi_foo => 1, # just to help debugging clone etc
+});
+isa_ok( $dbh, 'MyDBI::db');
+is($dbh->{CompatMode}, 1);
+
+#$dbh->trace(5);
+my $sth = $dbh->prepare("foo",
+ # data for DBD::Sponge to return via fetch
+ { rows => [
+ [ 40, "AAA", 9 ],
+ [ 41, "BB", 8 ],
+ [ -1, "C", 7 ],
+ [ 49, "DD", 6 ]
+ ],
+ }
+);
+
+is($calls, 1);
+isa_ok($sth, 'MyDBI::st');
+
+my $row = $sth->fetch;
+is($calls, 2);
+is($row->[1], "aaa");
+
+$row = $sth->fetch;
+is($calls, 3);
+is($row->[1], "bb");
+
+is($DBI::err, undef);
+$row = eval { $sth->fetch };
+my $eval_err = $@;
+is(!defined $row, 1);
+is(substr($eval_err,0,50), "DBD::Sponge::st fetch failed: Don't be so negative");
+
+#$sth->trace(5);
+#$sth->{PrintError} = 1;
+$sth->{RaiseError} = 0;
+$row = eval { $sth->fetch };
+isa_ok($row, 'ARRAY');
+is($row->[0], 42);
+is($DBI::err, 2);
+like($DBI::errstr, qr/Don't exagerate/);
+is($@ =~ /Don't be so negative/, $@);
+
+
+my $dbh2 = $dbh->clone;
+isa_ok( $dbh2, 'MyDBI::db', "Clone A" );
+is($dbh2 != $dbh, 1);
+is($dbh2->{CompatMode}, 1);
+
+my $dbh3 = $dbh->clone({});
+isa_ok( $dbh3, 'MyDBI::db', 'Clone B' );
+is($dbh3 != $dbh, 1);
+is($dbh3 != $dbh2, 1);
+isa_ok( $dbh3, 'MyDBI::db');
+is($dbh3->{CompatMode}, 1);
+
+my $dbh2c = $dbh2->clone;
+isa_ok( $dbh2c, 'MyDBI::db', "Clone of clone A" );
+is($dbh2c != $dbh2, 1);
+is($dbh2c->{CompatMode}, 1);
+
+my $dbh3c = $dbh3->clone({ CompatMode => 0 });
+isa_ok( $dbh3c, 'MyDBI::db', 'Clone of clone B' );
+is((grep { $dbh3c == $_ } $dbh, $dbh2, $dbh3), 0);
+isa_ok( $dbh3c, 'MyDBI::db');
+ok(!$dbh3c->{CompatMode});
+
+$tmp = $dbh->sponge_test_installed_method('foo','bar');
+isa_ok( $tmp, "ARRAY", "installed method" );
+is_deeply( $tmp, [qw( foo bar )] );
+$tmp = eval { $dbh->sponge_test_installed_method() };
+is(!$tmp, 1);
+is($dbh->err, 42);
+is($dbh->errstr, "not enough parameters");
+
+
+$dbh = eval { DBI->connect("dbi:Sponge:foo","","", {
+ RootClass => 'nonesuch1', PrintError => 0, RaiseError => 0, });
+};
+ok( !defined($dbh), "Failed connect #1" );
+is(substr($@,0,25), "Can't locate nonesuch1.pm");
+
+$dbh = eval { nonesuch2->connect("dbi:Sponge:foo","","", {
+ PrintError => 0, RaiseError => 0, });
+};
+ok( !defined($dbh), "Failed connect #2" );
+is(substr($@,0,36), q{Can't locate object method "connect"});
+
+print "@{[ %my_methods ]}\n";
+1;
diff --git a/t/31methcache.t b/t/31methcache.t
new file mode 100644
index 0000000..2ffd0a5
--- /dev/null
+++ b/t/31methcache.t
@@ -0,0 +1,153 @@
+#!perl -w
+#
+# check that the inner-method lookup cache works
+# (or rather, check that it doesn't cache things when it shouldn't)
+
+BEGIN { eval "use threads;" } # Must be first
+my $use_threads_err = $@;
+use Config qw(%Config);
+# With this test code and threads, 5.8.1 has issues with freeing freed
+# scalars, while 5.8.9 doesn't; I don't know about in-between - DAPM
+my $has_threads = $Config{useithreads};
+die $use_threads_err if $has_threads && $use_threads_err;
+
+
+use strict;
+
+$|=1;
+$^W=1;
+
+
+
+use Test::More tests => 49;
+
+BEGIN {
+ use_ok( 'DBI' );
+}
+
+sub new_handle {
+ my $dbh = DBI->connect("dbi:Sponge:foo","","", {
+ PrintError => 0,
+ RaiseError => 1,
+ });
+
+ my $sth = $dbh->prepare("foo",
+ # data for DBD::Sponge to return via fetch
+ { rows =>
+ [
+ [ "row0" ],
+ [ "row1" ],
+ [ "row2" ],
+ [ "row3" ],
+ [ "row4" ],
+ [ "row5" ],
+ [ "row6" ],
+ ],
+ }
+ );
+
+ return ($dbh, $sth);
+}
+
+
+sub Foo::local1 { [ "local1" ] };
+sub Foo::local2 { [ "local2" ] };
+
+
+my $fetch_hook;
+{
+ package Bar;
+ @Bar::ISA = qw(DBD::_::st);
+ sub fetch { &$fetch_hook };
+}
+
+sub run_tests {
+ my ($desc, $dbh, $sth) = @_;
+ my $row = $sth->fetch;
+ is($row->[0], "row0", "$desc row0");
+
+ {
+ # replace CV slot
+ no warnings 'redefine';
+ local *DBD::Sponge::st::fetch = sub { [ "local0" ] };
+ $row = $sth->fetch;
+ is($row->[0], "local0", "$desc local0");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row1", "$desc row1");
+
+ {
+ # replace GP
+ local *DBD::Sponge::st::fetch = *Foo::local1;
+ $row = $sth->fetch;
+ is($row->[0], "local1", "$desc local1");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row2", "$desc row2");
+
+ {
+ # replace GV
+ local $DBD::Sponge::st::{fetch} = *Foo::local2;
+ $row = $sth->fetch;
+ is($row->[0], "local2", "$desc local2");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row3", "$desc row3");
+
+ {
+ # @ISA = NoSuchPackage
+ local $DBD::Sponge::st::{fetch};
+ local @DBD::Sponge::st::ISA = qw(NoSuchPackage);
+ eval { local $SIG{__WARN__} = sub {}; $row = $sth->fetch };
+ like($@, qr/Can't locate DBI object method/, "$desc locate DBI object");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row4", "$desc row4");
+
+ {
+ # @ISA = Bar
+ $fetch_hook = \&DBD::Sponge::st::fetch;
+ local $DBD::Sponge::st::{fetch};
+ local @DBD::Sponge::st::ISA = qw(Bar);
+ $row = $sth->fetch;
+ is($row->[0], "row5", "$desc row5");
+ $fetch_hook = sub { [ "local3" ] };
+ $row = $sth->fetch;
+ is($row->[0], "local3", "$desc local3");
+ }
+ $row = $sth->fetch;
+ is($row->[0], "row6", "$desc row6");
+}
+
+run_tests("plain", new_handle());
+
+
+SKIP: {
+ skip "no threads / perl < 5.8.9", 12 unless $has_threads;
+ # only enable this when handles are allowed to be shared across threads
+ #{
+ # my @h = new_handle();
+ # threads->new(sub { run_tests("threads", @h) })->join;
+ #}
+ threads->new(sub { run_tests("threads-h", new_handle()) })->join;
+};
+
+# using weaken attaches magic to the CV; see whether this interferes
+# with the cache magic
+
+use Scalar::Util qw(weaken);
+my $fetch_ref = \&DBI::st::fetch;
+weaken $fetch_ref;
+run_tests("magic", new_handle());
+
+SKIP: {
+ skip "no threads / perl < 5.8.9", 12 unless $has_threads;
+ # only enable this when handles are allowed to be shared across threads
+ #{
+ # my @h = new_handle();
+ # threads->new(sub { run_tests("threads", @h) })->join;
+ #}
+ threads->new(sub { run_tests("magic threads-h", new_handle()) })->join;
+};
+
+1;
diff --git a/t/35thrclone.t b/t/35thrclone.t
new file mode 100644
index 0000000..b2678e9
--- /dev/null
+++ b/t/35thrclone.t
@@ -0,0 +1,81 @@
+#!perl -w
+$|=1;
+
+# --- Test DBI support for threads created after the DBI was loaded
+
+BEGIN { eval "use threads;" } # Must be first
+my $use_threads_err = $@;
+
+use strict;
+use Config qw(%Config);
+use Test::More;
+
+BEGIN {
+ if (!$Config{useithreads} || $] < 5.008001) {
+ plan skip_all => "this $^O perl $] not supported for DBI iThreads";
+ }
+ die $use_threads_err if $use_threads_err; # need threads
+}
+
+my $threads = 4;
+plan tests => 4 + 4 * $threads;
+
+{
+ package threads_sub;
+ use base qw(threads);
+}
+
+use_ok('DBI');
+
+$DBI::PurePerl = $DBI::PurePerl; # just to silence used only once warning
+$DBI::neat_maxlen = 12345;
+cmp_ok($DBI::neat_maxlen, '==', 12345, '... assignment of neat_maxlen was successful');
+
+my @connect_args = ("dbi:ExampleP:", '', '');
+
+my $dbh_parent = DBI->connect_cached(@connect_args);
+isa_ok( $dbh_parent, 'DBI::db' );
+
+# this our function for the threads to run
+
+sub testing {
+ cmp_ok($DBI::neat_maxlen, '==', 12345, '... DBI::neat_maxlen still holding its value');
+
+ my $dbh = DBI->connect_cached(@connect_args);
+ isa_ok( $dbh, 'DBI::db' );
+ isnt($dbh, $dbh_parent, '... new $dbh is not the same instance as $dbh_parent');
+
+ SKIP: {
+ # skip seems broken with threads (5.8.3)
+ # skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($dbh->{Driver}->{Kids}, '==', 1, '... the Driver has one Kid')
+ unless $DBI::PurePerl && ok(1);
+ }
+
+ # RT #77137: a thread created from a thread was crashing the
+ # interpreter
+
+ threads->new(sub {})->join();
+}
+
+# load up the threads
+
+my @thr;
+push @thr, threads_sub->create( \&testing )
+ or die "thread->create failed ($!)"
+ foreach (1..$threads);
+
+# join all the threads
+
+foreach my $thread (@thr) {
+ $thread->join;
+
+ # provide a little insurance against thread scheduling issues (hopefully)
+ # http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4369660.html
+ eval { select undef, undef, undef, 0.2 };
+}
+
+pass('... all tests have passed');
+
+1;
diff --git a/t/40profile.t b/t/40profile.t
new file mode 100644
index 0000000..5cb0023
--- /dev/null
+++ b/t/40profile.t
@@ -0,0 +1,485 @@
+#!perl -w
+$|=1;
+
+#
+# test script for DBI::Profile
+#
+
+use strict;
+
+use Config;
+use DBI::Profile;
+use DBI qw(dbi_time);
+use Data::Dumper;
+use File::Spec;
+use Storable qw(dclone);
+
+use Test::More;
+
+BEGIN {
+ plan skip_all => "profiling not supported for DBI::PurePerl"
+ if $DBI::PurePerl;
+
+ # tie methods (STORE/FETCH etc) get called different number of times
+ plan skip_all => "test results assume perl >= 5.8.2"
+ if $] <= 5.008001;
+
+ # clock instability on xen systems is a reasonably common cause of failure
+ # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html
+ # so we'll skip automated testing on those systems
+ plan skip_all => "skipping profile tests on xen (due to clock instability)"
+ if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64
+ and $ENV{AUTOMATED_TESTING};
+
+ plan tests => 60;
+}
+
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Terse = 1;
+
+# log file to store profile results
+my $LOG_FILE = "profile$$.log";
+my $orig_dbi_debug = $DBI::dbi_debug;
+DBI->trace($DBI::dbi_debug, $LOG_FILE);
+END {
+ return if $orig_dbi_debug;
+ 1 while unlink $LOG_FILE;
+}
+
+
+print "Test enabling the profile\n";
+
+# make sure profiling starts disabled
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+ok($dbh, 'connect');
+ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE}, 'Profile and DBI_PROFILE not set');
+
+
+# can turn it on after the fact using a path number
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+$dbh->{Profile} = "4";
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ '!MethodName' ],
+} => 'DBI::Profile';
+
+# using a package name
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+$dbh->{Profile} = "/DBI::Profile";
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ ],
+} => 'DBI::Profile';
+
+# using a combined path and name
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+$dbh->{Profile} = "20/DBI::Profile";
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ '!MethodName', '!Caller2' ],
+} => 'DBI::Profile';
+
+my $t_file = __FILE__;
+$dbh->do("set foo=1"); my $line = __LINE__;
+my $expected_caller = "40profile.t line $line";
+$expected_caller .= " via ${1}40profile.t line 4"
+ if $0 =~ /(zv\w+_)/;
+print Dumper($dbh->{Profile});
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ '!MethodName', '!Caller2' ],
+ 'Data' => { 'do' => {
+ $expected_caller => [ 1, 0, 0, 0, 0, 0, 0 ]
+ } }
+} => 'DBI::Profile'
+ or warn Dumper $dbh->{Profile};
+
+
+# can turn it on at connect
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 });
+is_deeply $dbh->{Profile}{Path}, [ '!Statement', '!MethodName' ];
+cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 1, 'on at connect, 1 key');
+cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1, 'on at connect, 1 key'); # at least STORE
+ok(ref $dbh->{Profile}{Data}{""}{STORE}, 'STORE is ref');
+
+print "dbi_profile\n";
+# Try to avoid rounding problem on double precision systems
+# $got->[5] = '1150962858.01596498'
+# $expected->[5] = '1150962858.015965'
+# by treating as a string (because is_deeply stringifies)
+my $t1 = DBI::dbi_time() . "";
+my $dummy_statement = "Hi mom";
+my $dummy_methname = "my_method_name";
+my $leaf = dbi_profile($dbh, $dummy_statement, $dummy_methname, $t1, $t1 + 1);
+print Dumper($dbh->{Profile});
+cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 2, 'avoid rounding, 1 key');
+cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1,
+ 'avoid rounding, 1 dummy statement');
+is(ref($dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}), 'ARRAY',
+ 'dummy method name is array');
+
+ok $leaf, "should return ref to leaf node";
+is ref $leaf, 'ARRAY', "should return ref to leaf node";
+
+my $mine = $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname};
+
+is $leaf, $mine, "should return ref to correct leaf node";
+
+print "@$mine\n";
+is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ];
+
+my $t2 = DBI::dbi_time() . "";
+dbi_profile($dbh, $dummy_statement, $dummy_methname, $t2, $t2 + 2);
+print "@$mine\n";
+is_deeply $mine, [ 2, 3, 1, 1, 2, $t1, $t2 ];
+
+
+print "Test collected profile data\n";
+
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 });
+# do a (hopefully) measurable amount of work
+my $sql = "select mode,size,name from ?";
+my $sth = $dbh->prepare($sql);
+for my $loop (1..50) { # enough work for low-res timers or v.fast cpus
+ $sth->execute(".");
+ while ( my $hash = $sth->fetchrow_hashref ) {}
+}
+$dbh->do("set foo=1");
+
+print Dumper($dbh->{Profile});
+
+# check that the proper key was set in Data
+my $data = $dbh->{Profile}{Data}{$sql};
+ok($data, 'profile data');
+is(ref $data, 'ARRAY', 'ARRAY ref');
+ok(@$data == 7, '7 elements');
+ok((grep { defined($_) } @$data) == 7, 'all 7 defined');
+ok((grep { DBI::looks_like_number($_) } @$data) == 7, 'all 7 numeric');
+my ($count, $total, $first, $shortest, $longest, $time1, $time2) = @$data;
+ok($count > 3, 'count is 3');
+ok($total > $first, ' total > first');
+ok($total > $longest, 'total > longest') or
+ warn "total $total > longest $longest: failed\n";
+ok($longest > 0, 'longest > 0') or
+ warn "longest $longest > 0: failed\n"; # XXX theoretically not reliable
+ok($longest > $shortest, 'longest > shortest');
+ok($time1 >= $^T, 'time1 later than start time');
+ok($time2 >= $^T, 'time2 later than start time');
+ok($time1 <= $time2, 'time1 <= time2');
+my $next = int(dbi_time()) + 1;
+ok($next > $time1, 'next > time1') or
+ warn "next $next > first $time1: failed\n";
+ok($next > $time2, 'next > time2') or
+ warn "next $next > last $time2: failed\n";
+if ($shortest < 0) {
+ my $sys = "$Config{archname} $Config{osvers}"; # ie sparc-linux 2.4.20-2.3sparcsmp
+ warn <<EOT;
+Time went backwards at some point during the test on this $sys system!
+Perhaps you have time sync software (like NTP) that adjusted the clock
+by more than $shortest seconds during the test.
+Also some multiprocessor systems, and some virtualization systems can exhibit
+this kind of clock behaviour. Please retry.
+EOT
+ # don't treat small negative values as failure
+ $shortest = 0 if $shortest > -0.008;
+}
+
+
+my $tmp = sanitize_tree($dbh->{Profile});
+$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count
+is_deeply $tmp, (bless {
+ 'Path' => [ '!Statement' ],
+ 'Data' => {
+ '' => [ 6, 0, 0, 0, 0, 0, 0 ],
+ $sql => [ -1, 0, 0, 0, 0, 0, 0 ],
+ 'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ }
+} => 'DBI::Profile'), 'profile';
+
+print "Test profile format\n";
+my $output = $dbh->{Profile}->format();
+print "Profile Output\n$output";
+
+# check that output was produced in the expected format
+ok(length $output, 'non zero length');
+ok($output =~ /^DBI::Profile:/, 'DBI::Profile');
+ok($output =~ /\((\d+) calls\)/, 'some calls');
+ok($1 >= $count, 'calls >= count');
+
+# -----------------------------------------------------------------------------------
+
+# try statement and method name and reference-to-scalar path
+my $by_reference = 'foo';
+$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
+ RaiseError => 1,
+ Profile => { Path => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ] }
+});
+$sql = "select name from .";
+$sth = $dbh->prepare($sql);
+$sth->execute();
+$sth->fetchrow_hashref;
+$by_reference = 'bar';
+$sth->finish;
+undef $sth; # DESTROY
+
+$tmp = sanitize_tree($dbh->{Profile});
+ok $tmp->{Data}{usrnam}{""}{foo}{STORE}, 'username stored';
+$tmp->{Data}{usrnam}{""}{foo} = {};
+# make test insentitive to number of local files
+#warn Dumper($tmp);
+is_deeply $tmp, bless {
+ 'Path' => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ],
+ 'Data' => {
+ '' => { # because Profile was enabled by DBI just before Username was set
+ '' => {
+ 'foo' => {
+ 'STORE' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ }
+ }
+ },
+ 'usrnam' => {
+ '' => {
+ 'foo' => { },
+ },
+ 'select name from .' => {
+ 'foo' => {
+ 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+ 'bar' => {
+ 'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+ },
+ },
+ },
+} => 'DBI::Profile';
+
+$tmp = [ $dbh->{Profile}->as_node_path_list() ];
+is @$tmp, 8, 'should have 8 nodes';
+sanitize_profile_data_nodes($_->[0]) for @$tmp;
+#warn Dumper($dbh->{Profile}->{Data});
+is_deeply $tmp, [
+ [ [ 3, 0, 0, 0, 0, 0, 0 ], '', '', 'foo', 'STORE' ],
+ [ [ 2, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'STORE' ],
+ [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'connected' ],
+ [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'DESTROY' ],
+ [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'finish' ],
+ [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'execute' ],
+ [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'fetchrow_hashref' ],
+ [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'prepare' ]
+];
+
+
+print "testing '!File', '!Caller' and their variants in Path\n";
+
+$dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ];
+$dbh->{Profile}->{Data} = undef;
+
+my $file = (File::Spec->splitpath(__FILE__))[2]; # '40profile.t'
+my ($line1, $line2);
+sub a_sub {
+ $sth = $dbh->prepare("select name from ."); $line2 = __LINE__;
+}
+a_sub(); $line1 = __LINE__;
+
+$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
+#warn Dumper($tmp);
+is_deeply $tmp, {
+ "$file" => {
+ "$file via $file" => {
+ "$file line $line2" => {
+ "$file line $line2 via $file line $line1" => [ 1, 0, 0, 0, 0, 0, 0 ]
+ }
+ }
+ }
+};
+
+
+print "testing '!Time' and variants in Path\n";
+
+undef $sth;
+my $factor = 1_000_000;
+$dbh->{Profile}->{Path} = [ '!Time', "!Time~$factor", '!MethodName' ];
+$dbh->{Profile}->{Data} = undef;
+
+# give up a timeslice in the hope that the following few lines
+# run in well under a second even of slow/overloaded systems
+$t1 = int(dbi_time())+1; 1 while int(dbi_time()-0.01) < $t1; # spin till just after second starts
+$t2 = int($t1/$factor)*$factor;
+
+$sth = $dbh->prepare("select name from .");
+$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
+
+# if actual "!Time" recorded is 'close enough' then we'll pass
+# the test - it's not worth failing just because a system is slow
+$t1 = (keys %$tmp)[0] if (abs($t1 - (keys %$tmp)[0]) <= 5);
+
+is_deeply $tmp, {
+ $t1 => { $t2 => { prepare => [ 1, 0, 0, 0, 0, 0, 0 ] }}
+}, "!Time and !Time~$factor should work"
+ or warn Dumper([$t1, $t2, $tmp]);
+
+
+print "testing &norm_std_n3 in Path\n";
+
+$dbh->{Profile} = '&norm_std_n3'; # assign as string to get magic
+is_deeply $dbh->{Profile}{Path}, [
+ \&DBI::ProfileSubs::norm_std_n3
+];
+$dbh->{Profile}->{Data} = undef;
+$sql = qq{insert into foo20060726 (a,b) values (42,"foo")};
+dbi_profile( { foo => $dbh, bar => undef }, $sql, 'mymethod', 100000000, 100000002);
+$tmp = $dbh->{Profile}{Data};
+#warn Dumper($tmp);
+is_deeply $tmp, {
+ 'insert into foo<N> (a,b) values (<N>,"<S>")' => [ 1, '2', '2', '2', '2', '100000000', '100000000' ]
+}, '&norm_std_n3 should normalize statement';
+
+
+# -----------------------------------------------------------------------------------
+
+print "testing code ref in Path\n";
+
+sub run_test1 {
+ my ($profile) = @_;
+ $dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
+ RaiseError => 1,
+ Profile => $profile,
+ });
+ $sql = "select name from .";
+ $sth = $dbh->prepare($sql);
+ $sth->execute();
+ $sth->fetchrow_hashref;
+ $sth->finish;
+ undef $sth; # DESTROY
+ my $data = sanitize_profile_data_nodes($dbh->{Profile}{Data}, 1);
+ return ($data, $dbh) if wantarray;
+ return $data;
+}
+
+$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] });
+is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 11, 0,0,0,0,0,0 ] } } };
+
+$tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] });
+is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 11, 0,0,0,0,0,0 ] } } };
+
+$tmp = run_test1( { Path => [ 'foo', sub { \undef } ] });
+is_deeply $tmp, { 'foo' => undef }, 'should be vetoed';
+
+# check what code ref sees in $_
+$tmp = run_test1( { Path => [ sub { $_ } ] });
+is_deeply $tmp, {
+ '' => [ 6, 0, 0, 0, 0, 0, 0 ],
+ 'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ]
+}, '$_ should contain statement';
+
+# check what code ref sees in @_
+$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if $method =~ /^[A-Z]+$/; return (ref $h, $method) } ] });
+is_deeply $tmp, {
+ 'DBI::db' => {
+ 'connected' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+ 'DBI::st' => {
+ 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+}, 'should have @_ as keys';
+
+# check we can filter by method
+$tmp = run_test1( { Path => [ sub { return \undef unless $_[1] =~ /^fetch/; return $_[1] } ] });
+#warn Dumper($tmp);
+is_deeply $tmp, {
+ 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
+}, 'should be able to filter by method';
+
+DBI->trace(0, "STDOUT"); # close current log to flush it
+ok(-s $LOG_FILE, 'output should go to log file');
+
+# -----------------------------------------------------------------------------------
+
+print "testing as_text\n";
+
+# check %N$ indices
+$dbh->{Profile}->{Data} = { P1 => { P2 => [ 100, 400, 42, 43, 44, 45, 46, 47 ] } };
+my $as_text = $dbh->{Profile}->as_text({
+ path => [ 'top' ],
+ separator => ':',
+ format => '%1$s %2$d [ %10$d %11$d %12$d %13$d %14$d %15$d %16$d %17$d ]',
+});
+is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]", 'as_text');
+
+# test sortsub
+$dbh->{Profile}->{Data} = {
+ A => { Z => [ 101, 1, 2, 3, 4, 5, 6, 7 ] },
+ B => { Y => [ 102, 1, 2, 3, 4, 5, 6, 7 ] },
+};
+$as_text = $dbh->{Profile}->as_text({
+ separator => ':',
+ format => '%1$s %10$d ',
+ sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
+});
+is($as_text, "B:Y 102 A:Z 101 ", 'as_text sortsub');
+
+# general test, including defaults
+($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] });
+$as_text = $dbh->{Profile}->as_text();
+$as_text =~ s/\.00+/.0/g;
+#warn "[$as_text]";
+is $as_text, q{foo > DESTROY > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+foo > STORE > baz: 0.0s / 5 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+foo > connected > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+foo > execute > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+foo > fetchrow_hashref > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+foo > finish > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+foo > prepare > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
+}, 'as_text general';
+
+# -----------------------------------------------------------------------------------
+
+print "dbi_profile_merge_nodes\n";
+my $total_time = dbi_profile_merge_nodes(
+ my $totals=[],
+ [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
+ [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
+);
+$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
+is("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00",
+ 'merged nodes');
+is($total_time, 0.93, 'merged time');
+
+$total_time = dbi_profile_merge_nodes(
+ $totals=[], {
+ foo => [ 10, 1.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
+ bar => [ 17, 1.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
+ }
+);
+$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
+is("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00",
+ 'merged time foo/bar');
+is($total_time, 2.93, 'merged nodes foo/bar time');
+
+exit 0;
+
+
+sub sanitize_tree {
+ my $data = shift;
+ my $skip_clone = shift;
+ return $data unless ref $data;
+ $data = dclone($data) unless $skip_clone;
+ sanitize_profile_data_nodes($data->{Data}) if $data->{Data};
+ return $data;
+}
+
+sub sanitize_profile_data_nodes {
+ my $node = shift;
+ if (ref $node eq 'HASH') {
+ sanitize_profile_data_nodes($_) for values %$node;
+ }
+ elsif (ref $node eq 'ARRAY') {
+ if (@$node == 7 and DBI::looks_like_number($node->[0])) {
+ # sanitize the profile data node to simplify tests
+ $_ = 0 for @{$node}[1..@$node-1]; # not 0
+ }
+ }
+ return $node;
+}
diff --git a/t/41prof_dump.t b/t/41prof_dump.t
new file mode 100644
index 0000000..c921893
--- /dev/null
+++ b/t/41prof_dump.t
@@ -0,0 +1,105 @@
+#!perl -wl
+# Using -l to ensure ProfileDumper is isolated from changes to $/ and $\ and such
+
+$|=1;
+
+use strict;
+
+#
+# test script for DBI::ProfileDumper
+#
+
+use DBI;
+use Config;
+use Test::More;
+
+BEGIN {
+ plan skip_all => 'profiling not supported for DBI::PurePerl'
+ if $DBI::PurePerl;
+
+ # clock instability on xen systems is a reasonably common cause of failure
+ # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html
+ # so we'll skip automated testing on those systems
+ plan skip_all => "skipping profile tests on xen (due to clock instability)"
+ if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64
+ and $ENV{AUTOMATED_TESTING};
+
+ plan tests => 15;
+}
+
+BEGIN {
+ use_ok( 'DBI' );
+ use_ok( 'DBI::ProfileDumper' );
+}
+
+my $prof_file = "dbi$$.prof";
+my $prof_backup = $prof_file . ".prev";
+END { 1 while unlink $prof_file;
+ 1 while unlink $prof_backup; }
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '',
+ { RaiseError=>1, Profile=>"2/DBI::ProfileDumper/File:$prof_file" });
+isa_ok( $dbh, 'DBI::db' );
+isa_ok( $dbh->{Profile}, "DBI::ProfileDumper" );
+isa_ok( $dbh->{Profile}{Data}, 'HASH' );
+isa_ok( $dbh->{Profile}{Path}, 'ARRAY' );
+
+# do a little work
+my $sql = "select mode,size,name from ?";
+my $sth = $dbh->prepare($sql);
+isa_ok( $sth, 'DBI::st' );
+$sth->execute(".");
+
+# check that flush_to_disk doesn't change Path if Path is undef (it
+# did before 1.49)
+{
+ local $dbh->{Profile}->{Path} = undef;
+ $sth->{Profile}->flush_to_disk();
+ is($dbh->{Profile}->{Path}, undef);
+}
+
+$sth->{Profile}->flush_to_disk();
+while ( my $hash = $sth->fetchrow_hashref ) {}
+
+# force output
+undef $sth;
+$dbh->disconnect;
+undef $dbh;
+
+# wrote the profile to disk?
+ok( -s $prof_file, 'Profile is on disk and nonzero size' );
+
+# XXX We're breaking encapsulation here
+open(PROF, $prof_file) or die $!;
+my @prof = <PROF>;
+close PROF;
+
+print @prof;
+
+# has a header?
+like( $prof[0], '/^DBI::ProfileDumper\s+([\d.]+)/', 'Found a version number' );
+
+# version matches VERSION? (DBI::ProfileDumper uses $self->VERSION so
+# it's a stringified version object that looks like N.N.N)
+$prof[0] =~ /^DBI::ProfileDumper\s+([\d.]+)/;
+is( $1, DBI::ProfileDumper->VERSION, "Version numbers match in $prof[0]" );
+
+like( $prof[1], qr{^Path\s+=\s+\[\s+\]}, 'Found the Path');
+ok( $prof[2] =~ m{^Program\s+=\s+(\S+)}, 'Found the Program');
+
+# check that expected key is there
+like(join('', @prof), qr/\+\s+1\s+\Q$sql\E/m);
+
+# unlink($prof_file); # now done by 'make clean'
+
+# should be able to load DBI::ProfileDumper::Apache outside apache
+# this also naturally checks for syntax errors etc.
+SKIP: {
+ skip "developer-only test", 1
+ unless (-d ".svn" || -d ".git") && -f "MANIFEST.SKIP";
+ skip "Apache module not installed", 1
+ unless eval { require Apache };
+ require_ok('DBI::ProfileDumper::Apache')
+}
+
+1;
diff --git a/t/42prof_data.t b/t/42prof_data.t
new file mode 100644
index 0000000..f9ce4a3
--- /dev/null
+++ b/t/42prof_data.t
@@ -0,0 +1,150 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use DBI;
+use Config;
+use Test::More;
+use Data::Dumper;
+
+BEGIN {
+ plan skip_all => 'profiling not supported for DBI::PurePerl'
+ if $DBI::PurePerl;
+
+ # clock instability on xen systems is a reasonably common cause of failure
+ # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html
+ # so we'll skip automated testing on those systems
+ plan skip_all => "skipping profile tests on xen (due to clock instability)"
+ if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64
+ and $ENV{AUTOMATED_TESTING};
+
+ plan tests => 31;
+}
+
+BEGIN {
+ use_ok( 'DBI::ProfileDumper' );
+ use_ok( 'DBI::ProfileData' );
+}
+
+my $sql = "select mode,size,name from ?";
+
+my $prof_file = "dbi$$.prof";
+my $prof_backup = $prof_file . ".prev";
+END { 1 while unlink $prof_file;
+ 1 while unlink $prof_backup; }
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '',
+ { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" });
+isa_ok( $dbh, 'DBI::db', 'Created connection' );
+
+# do a little work, but enough to ensure we don't get 0's on systems with low res timers
+foreach (1..6) {
+ $dbh->do("set dummy=$_");
+ my $sth = $dbh->prepare($sql);
+ for my $loop (1..50) {
+ $sth->execute(".");
+ $sth->fetchrow_hashref;
+ $sth->finish;
+ }
+ $sth->{Profile}->flush_to_disk();
+}
+$dbh->disconnect;
+undef $dbh;
+
+
+# wrote the profile to disk?
+ok(-s $prof_file, "Profile written to disk, non-zero size" );
+
+# load up
+my $prof = DBI::ProfileData->new(
+ File => $prof_file,
+ Filter => sub {
+ my ($path_ref, $data_ref) = @_;
+ $path_ref->[0] =~ s/set dummy=\d/set dummy=N/;
+ },
+);
+isa_ok( $prof, 'DBI::ProfileData' );
+cmp_ok( $prof->count, '>=', 3, 'At least 3 profile data items' );
+
+# try a few sorts
+my $nodes = $prof->nodes;
+$prof->sort(field => "longest");
+my $longest = $nodes->[0][4];
+ok($longest);
+$prof->sort(field => "longest", reverse => 1);
+cmp_ok( $nodes->[0][4], '<', $longest );
+
+$prof->sort(field => "count");
+my $most = $nodes->[0];
+ok($most);
+$prof->sort(field => "count", reverse => 1);
+cmp_ok( $nodes->[0][0], '<', $most->[0] );
+
+# remove the top count and make sure it's gone
+my $clone = $prof->clone();
+isa_ok( $clone, 'DBI::ProfileData' );
+$clone->sort(field => "count");
+ok($clone->exclude(key1 => $most->[7]));
+
+# compare keys of the new first element and the old one to make sure
+# exclude works
+ok($clone->nodes()->[0][7] ne $most->[7] &&
+ $clone->nodes()->[0][8] ne $most->[8]);
+
+# there can only be one
+$clone = $prof->clone();
+isa_ok( $clone, 'DBI::ProfileData' );
+ok($clone->match(key1 => $clone->nodes->[0][7]));
+ok($clone->match(key2 => $clone->nodes->[0][8]));
+ok($clone->count == 1);
+
+# take a look through Data
+my $Data = $prof->Data;
+print "SQL: $_\n" for keys %$Data;
+ok(exists($Data->{$sql}), "Data for '$sql' should exist")
+ or print Dumper($Data);
+ok(exists($Data->{$sql}{execute}), "Data for '$sql'->{execute} should exist");
+
+# did the Filter convert set dummy=1 (etc) into set dummy=N?
+ok(exists($Data->{"set dummy=N"}));
+
+# test escaping of \n and \r in keys
+$dbh = DBI->connect("dbi:ExampleP:", '', '',
+ { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" });
+isa_ok( $dbh, 'DBI::db', 'Created connection' );
+
+my $sql2 = 'select size from . where name = "LITERAL: \r\n"';
+my $sql3 = "select size from . where name = \"EXPANDED: \r\n\"";
+
+# do a little work
+foreach (1,2,3) {
+ my $sth2 = $dbh->prepare($sql2);
+ isa_ok( $sth2, 'DBI::st' );
+ $sth2->execute();
+ $sth2->fetchrow_hashref;
+ $sth2->finish;
+ my $sth3 = $dbh->prepare($sql3);
+ isa_ok( $sth3, 'DBI::st' );
+ $sth3->execute();
+ $sth3->fetchrow_hashref;
+ $sth3->finish;
+}
+$dbh->disconnect;
+undef $dbh;
+
+# load dbi.prof
+$prof = DBI::ProfileData->new( File => $prof_file, DeleteFiles => 1 );
+isa_ok( $prof, 'DBI::ProfileData' );
+
+ok(not(-e $prof_file), "file should be deleted when DeleteFiles set" );
+
+
+# make sure the keys didn't get garbled
+$Data = $prof->Data;
+ok(exists $Data->{$sql2}, "Data for '$sql2' should exist")
+ or print Dumper($Data);
+ok(exists $Data->{$sql3}, "Data for '$sql3' should exist")
+ or print Dumper($Data);
+
+1;
diff --git a/t/43prof_env.t b/t/43prof_env.t
new file mode 100644
index 0000000..6726cf7
--- /dev/null
+++ b/t/43prof_env.t
@@ -0,0 +1,52 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+#
+# test script for using DBI_PROFILE env var to enable DBI::Profile
+# and testing non-ref assignments to $h->{Profile}
+#
+
+BEGIN { $ENV{DBI_PROFILE} = 6 } # prior to use DBI
+
+use DBI;
+use DBI::Profile;
+use Config;
+use Data::Dumper;
+
+BEGIN {
+ if ($DBI::PurePerl) {
+ print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 11;
+
+DBI->trace(0, "STDOUT");
+
+my $dbh1 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+is(ref $dbh1->{Profile}, "DBI::Profile");
+is(ref $dbh1->{Profile}{Data}, 'HASH');
+is(ref $dbh1->{Profile}{Path}, 'ARRAY');
+
+my $dbh2 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+is(ref $dbh2->{Profile}, "DBI::Profile");
+is(ref $dbh2->{Profile}{Data}, 'HASH');
+is(ref $dbh2->{Profile}{Path}, 'ARRAY');
+
+is $dbh1->{Profile}, $dbh2->{Profile}, '$h->{Profile} should be shared';
+
+$dbh1->do("set dummy=1");
+$dbh1->do("set dummy=2");
+
+my $profile = $dbh1->{Profile};
+
+my $p_data = $profile->{Data};
+is keys %$p_data, 3; # '', $sql1, $sql2
+ok $p_data->{''};
+ok $p_data->{"set dummy=1"};
+ok $p_data->{"set dummy=2"};
+
+__END__
diff --git a/t/48dbi_dbd_sqlengine.t b/t/48dbi_dbd_sqlengine.t
new file mode 100644
index 0000000..c916d51
--- /dev/null
+++ b/t/48dbi_dbd_sqlengine.t
@@ -0,0 +1,81 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use Cwd;
+use File::Path;
+use File::Spec;
+use Test::More;
+
+my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i;
+
+my $tbl;
+BEGIN { $tbl = "db_". $$ . "_" };
+#END { $tbl and unlink glob "${tbl}*" }
+
+use_ok ("DBI");
+use_ok ("DBI::DBD::SqlEngine");
+use_ok ("DBD::File");
+
+my $sql_statement = DBI::DBD::SqlEngine::Statement->isa('SQL::Statement');
+my $dbh = DBI->connect( "DBI:File:", undef, undef, { PrintError => 0, RaiseError => 0, } ); # Can't use DBI::DBD::SqlEngine direct
+
+for my $sql ( split "\n", <<"" )
+ CREATE TABLE foo (id INT, foo TEXT)
+ CREATE TABLE bar (id INT, baz TEXT)
+ INSERT INTO foo VALUES (1, "Hello world")
+ INSERT INTO bar VALUES (1, "Bugfixes welcome")
+ INSERT bar VALUES (2, "Bug reports, too")
+ SELECT foo FROM foo where ID=1
+ UPDATE bar SET id=5 WHERE baz="Bugfixes welcome"
+ DELETE FROM foo
+ DELETE FROM bar WHERE baz="Bugfixes welcome"
+
+{
+ my $sth;
+ $sql =~ s/^\s+//;
+ eval { $sth = $dbh->prepare( $sql ); };
+ ok( $sth, "prepare '$sql'" );
+}
+
+for my $line ( split "\n", <<"" )
+ Junk -- Junk
+ CREATE foo (id INT, foo TEXT) -- missing table
+ INSERT INTO bar (1, "Bugfixes welcome") -- missing "VALUES"
+ UPDATE bar id=5 WHERE baz="Bugfixes welcome" -- missing "SET"
+ DELETE * FROM foo -- waste between "DELETE" and "FROM"
+
+{
+ my $sth;
+ $line =~ s/^\s+//;
+ my ($sql, $test) = ( $line =~ m/^([^-]+)\s+--\s+(.*)$/ );
+ eval { $sth = $dbh->prepare( $sql ); };
+ ok( !$sth, "$test: prepare '$sql'" );
+}
+
+SKIP: {
+ # some SQL::Statement / SQL::Parser related tests
+ skip( "Not running with SQL::Statement", 3 ) unless ($sql_statement);
+ for my $line ( split "\n", <<"" )
+ Junk -- Junk
+ CREATE TABLE bar (id INT, baz CHARACTER VARYING(255)) -- invalid column type
+
+ {
+ my $sth;
+ $line =~ s/^\s+//;
+ my ($sql, $test) = ( $line =~ m/^([^-]+)\s+--\s+(.*)$/ );
+ eval { $sth = $dbh->prepare( $sql ); };
+ ok( !$sth, "$test: prepare '$sql'" );
+ }
+
+ my $dbh2 = DBI->connect( "DBI:File:", undef, undef, { sql_dialect => "ANSI" } );
+ my $sth;
+ eval { $sth = $dbh2->prepare( "CREATE TABLE foo (id INTEGER PRIMARY KEY, phrase CHARACTER VARYING(40) UNIQUE)" ); };
+ ok( $sth, "prepared statement using ANSI dialect" );
+ skip( "Gofer proxy prevents fetching embedded SQL::Parser object", 1 );
+ my $sql_parser = $dbh2->FETCH("sql_parser_object");
+ cmp_ok( $sql_parser->dialect(), "eq", "ANSI", "SQL::Parser has 'ANSI' as dialect" );
+}
+
+done_testing ();
diff --git a/t/49dbd_file.t b/t/49dbd_file.t
new file mode 100644
index 0000000..0c64328
--- /dev/null
+++ b/t/49dbd_file.t
@@ -0,0 +1,174 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use Cwd;
+use File::Path;
+use File::Spec;
+use Test::More;
+
+my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i;
+
+my $tbl;
+BEGIN { $tbl = "db_". $$ . "_" };
+#END { $tbl and unlink glob "${tbl}*" }
+
+use_ok ("DBI");
+use_ok ("DBD::File");
+
+do "t/lib.pl";
+
+my $dir = test_dir ();
+
+my $rowidx = 0;
+my @rows = ( [ "Hello World" ], [ "Hello DBI Developers" ], );
+
+my $dbh;
+
+# Check if we can connect at all
+ok ($dbh = DBI->connect ("dbi:File:"), "Connect clean");
+is (ref $dbh, "DBI::db", "Can connect to DBD::File driver");
+
+my $f_versions = $dbh->func ("f_versions");
+note $f_versions;
+ok ($f_versions, "f_versions");
+
+# Check if all the basic DBI attributes are accepted
+ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
+ RaiseError => 1,
+ PrintError => 1,
+ AutoCommit => 1,
+ ChopBlanks => 1,
+ ShowErrorStatement => 1,
+ FetchHashKeyName => "NAME_lc",
+ }), "Connect with DBI attributes");
+
+# Check if all the f_ attributes are accepted, in two ways
+ok ($dbh = DBI->connect ("dbi:File:f_ext=.txt;f_dir=.;f_encoding=cp1252;f_schema=test"), "Connect with driver attributes in DSN");
+
+my $encoding = "iso-8859-1";
+
+# now use dir to prove file existence
+ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
+ f_ext => ".txt",
+ f_dir => $dir,
+ f_schema => undef,
+ f_encoding => $encoding,
+ f_lock => 0,
+
+ RaiseError => 0,
+ PrintError => 0,
+ }), "Connect with driver attributes in hash");
+
+my $sth;
+ok ($sth = $dbh->prepare ("select * from t_sbdgf_53442Gz"), "Prepare select from non-existing file");
+
+{ my @msg;
+ eval {
+ local $SIG{__DIE__} = sub { push @msg, @_ };
+ $sth->execute;
+ };
+ like ("@msg", qr{Cannot open .*t_sbdgf_}, "Cannot open non-existing file");
+ eval {
+ note $dbh->f_get_meta ("t_sbdgf_53442Gz", "f_fqfn");
+ };
+ }
+
+SKIP: {
+ my $fh;
+ my $tbl2 = $tbl . "2";
+
+ my $tbl2_file1 = File::Spec->catfile ($dir, "$tbl2.txt");
+ open $fh, ">", $tbl2_file1 or skip;
+ print $fh "You cannot read this anyway ...";
+ close $fh;
+
+ my $tbl2_file2 = File::Spec->catfile ($dir, "$tbl2");
+ open $fh, ">", $tbl2_file2 or skip;
+ print $fh "Neither that";
+ close $fh;
+
+ ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (first file)");
+ ok (! -f $tbl2_file1, "$tbl2_file1 removed");
+ ok ( -f $tbl2_file2, "$tbl2_file2 exists");
+ ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (second file)");
+ ok (! -f $tbl2_file2, "$tbl2_file2 removed");
+ }
+
+my @tfhl;
+
+# Now test some basic SQL statements
+my $tbl_file = File::Spec->catfile (Cwd::abs_path( $dir ), "$tbl.txt");
+ok ($dbh->do ("create table $tbl (txt varchar (20))"), "Create table $tbl") or diag $dbh->errstr;
+ok (-f $tbl_file, "Test table exists");
+
+is ($dbh->f_get_meta ($tbl, "f_fqfn"), $tbl_file, "get single table meta data");
+is_deeply ($dbh->f_get_meta ([$tbl, "t_sbdgf_53442Gz"], [qw(f_dir f_ext)]),
+ {
+ $tbl => {
+ f_dir => $dir,
+ f_ext => ".txt",
+ },
+ t_sbdgf_53442Gz => {
+ f_dir => $dir,
+ f_ext => ".txt",
+ },
+ },
+ "get multiple meta data");
+
+# Expected: ("unix", "perlio", "encoding(iso-8859-1)")
+# use Data::Peek; DDumper [ @tfh ];
+my @layer = grep { $_ eq "encoding($encoding)" } @tfhl;
+is (scalar @layer, 1, "encoding shows in layer");
+
+SKIP: {
+ $using_dbd_gofer and skip "modifying meta data doesn't work with Gofer-AutoProxy", 4;
+ ok ($dbh->f_set_meta ($tbl, "f_dir", $dir), "set single meta datum");
+ is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set single meta datum");
+ ok ($dbh->f_set_meta ($tbl, { f_dir => $dir }), "set multiple meta data");
+ is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set multiple meta attributes");
+ }
+
+ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl");
+$rowidx = 0;
+SKIP: {
+ $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1;
+ ok ($sth->execute, "execute on $tbl");
+ $dbh->errstr and diag;
+ }
+
+my $uctbl = uc($tbl);
+ok ($sth = $dbh->prepare ("select * from $uctbl"), "Prepare select * from $uctbl");
+$rowidx = 0;
+SKIP: {
+ $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1;
+ ok ($sth->execute, "execute on $uctbl");
+ $dbh->errstr and diag;
+ }
+
+ok ($dbh->do ("drop table $tbl"), "table drop");
+is (-s "$tbl.txt", undef, "Test table removed");
+
+done_testing ();
+
+sub DBD::File::Table::fetch_row ($$)
+{
+ my ($self, $data) = @_;
+ my $meta = $self->{meta};
+ if ($rowidx >= scalar @rows) {
+ $self->{row} = undef;
+ }
+ else {
+ $self->{row} = $rows[$rowidx++];
+ }
+ return $self->{row};
+ } # fetch_row
+
+sub DBD::File::Table::push_names ($$$)
+{
+ my ($self, $data, $row_aryref) = @_;
+ my $meta = $self->{meta};
+ @tfhl = PerlIO::get_layers ($meta->{fh});
+ @{$meta->{col_names}} = @{$row_aryref};
+ } # push_names
diff --git a/t/50dbm_simple.t b/t/50dbm_simple.t
new file mode 100755
index 0000000..e176161
--- /dev/null
+++ b/t/50dbm_simple.t
@@ -0,0 +1,264 @@
+#!perl -w
+$|=1;
+
+use strict;
+use warnings;
+
+require DBD::DBM;
+
+use File::Path;
+use File::Spec;
+use Test::More;
+use Cwd;
+use Config qw(%Config);
+use Storable qw(dclone);
+
+my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
+
+use DBI;
+use vars qw( @mldbm_types @dbm_types );
+
+BEGIN {
+
+ # 0=SQL::Statement if avail, 1=DBI::SQL::Nano
+ # next line forces use of Nano rather than default behaviour
+ # $ENV{DBI_SQL_NANO}=1;
+ # This is done in zv*n*_50dbm_simple.t
+
+ push @mldbm_types, '';
+ if (eval { require 'MLDBM.pm'; }) {
+ push @mldbm_types, qw(Data::Dumper Storable); # both in CORE
+ push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' };
+ push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; };
+ push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; };
+ }
+
+ # Potential DBM modules in preference order (SDBM_File first)
+ # skip NDBM and ODBM as they don't support EXISTS
+ my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File);
+ my @use_dbms = @ARGV;
+ if( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} ) {
+ @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS};
+ }
+
+ if (lc "@use_dbms" eq "all") {
+ # test with as many of the major DBM types as are available
+ @dbm_types = grep { eval { local $^W; require "$_.pm" } } @dbms;
+ }
+ elsif (@use_dbms) {
+ @dbm_types = @use_dbms;
+ }
+ else {
+ # we only test SDBM_File by default to avoid tripping up
+ # on any broken DBM's that may be installed in odd places.
+ # It's only DBD::DBM we're trying to test here.
+ # (However, if SDBM_File is not available, then use another.)
+ for my $dbm (@dbms) {
+ if (eval { local $^W; require "$dbm.pm" }) {
+ @dbm_types = ($dbm);
+ last;
+ }
+ }
+ }
+
+ if( eval { require List::MoreUtils; } )
+ {
+ List::MoreUtils->import("part");
+ }
+ else
+ {
+ # XXX from PP part of List::MoreUtils
+ eval <<'EOP';
+sub part(&@) {
+ my ($code, @list) = @_;
+ my @parts;
+ push @{ $parts[$code->($_)] }, $_ for @list;
+ return @parts;
+}
+EOP
+ }
+}
+
+my $dbi_sql_nano = not DBD::DBM::Statement->isa('SQL::Statement');
+
+do "t/lib.pl";
+
+my $dir = test_dir ();
+
+my %tests_statement_results = (
+ 2 => [
+ "DROP TABLE IF EXISTS fruit", -1,
+ "CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))", '0E0',
+ "INSERT INTO fruit VALUES (1,'oranges' )", 1,
+ "INSERT INTO fruit VALUES (2,'to_change' )", 1,
+ "INSERT INTO fruit VALUES (3, NULL )", 1,
+ "INSERT INTO fruit VALUES (4,'to delete' )", 1,
+ "INSERT INTO fruit VALUES (?,?); #5,via placeholders", 1,
+ "INSERT INTO fruit VALUES (6,'to delete' )", 1,
+ "INSERT INTO fruit VALUES (7,'to_delete' )", 1,
+ "DELETE FROM fruit WHERE dVal='to delete'", 2,
+ "UPDATE fruit SET dVal='apples' WHERE dKey=2", 1,
+ "DELETE FROM fruit WHERE dKey=7", 1,
+ "SELECT * FROM fruit ORDER BY dKey DESC", [
+ [ 5, 'via placeholders' ],
+ [ 3, '' ],
+ [ 2, 'apples' ],
+ [ 1, 'oranges' ],
+ ],
+ "DELETE FROM fruit", 4,
+ $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM fruit", [ [ 0 ] ] ),
+ "DROP TABLE fruit", -1,
+ ],
+ 3 => [
+ "DROP TABLE IF EXISTS multi_fruit", -1,
+ "CREATE TABLE multi_fruit (dKey INT, dVal VARCHAR(10), qux INT)", '0E0',
+ "INSERT INTO multi_fruit VALUES (1,'oranges' , 11 )", 1,
+ "INSERT INTO multi_fruit VALUES (2,'to_change', 0 )", 1,
+ "INSERT INTO multi_fruit VALUES (3, NULL , 13 )", 1,
+ "INSERT INTO multi_fruit VALUES (4,'to_delete', 14 )", 1,
+ "INSERT INTO multi_fruit VALUES (?,?,?); #5,via placeholders,15", 1,
+ "INSERT INTO multi_fruit VALUES (6,'to_delete', 16 )", 1,
+ "INSERT INTO multi_fruit VALUES (7,'to delete', 17 )", 1,
+ "INSERT INTO multi_fruit VALUES (8,'to remove', 18 )", 1,
+ "UPDATE multi_fruit SET dVal='apples', qux='12' WHERE dKey=2", 1,
+ "DELETE FROM multi_fruit WHERE dVal='to_delete'", 2,
+ "DELETE FROM multi_fruit WHERE qux=17", 1,
+ "DELETE FROM multi_fruit WHERE dKey=8", 1,
+ "SELECT * FROM multi_fruit ORDER BY dKey DESC", [
+ [ 5, 'via placeholders', 15 ],
+ [ 3, undef, 13 ],
+ [ 2, 'apples', 12 ],
+ [ 1, 'oranges', 11 ],
+ ],
+ "DELETE FROM multi_fruit", 4,
+ $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM multi_fruit", [ [ 0 ] ] ),
+ "DROP TABLE multi_fruit", -1,
+ ],
+);
+
+print "Using DBM modules: @dbm_types\n";
+print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types;
+
+my %test_statements;
+my %expected_results;
+
+for my $columns ( 2 .. 3 )
+{
+ my $i = 0;
+ my @tests = part { $i++ % 2 } @{ $tests_statement_results{$columns} };
+ @{ $test_statements{$columns} } = @{$tests[0]};
+ @{ $expected_results{$columns} } = @{$tests[1]};
+}
+
+unless (@dbm_types) {
+ plan skip_all => "No DBM modules available";
+}
+
+for my $mldbm ( @mldbm_types ) {
+ my $columns = ($mldbm) ? 3 : 2;
+ for my $dbm_type ( @dbm_types ) {
+ print "\n--- Using $dbm_type ($mldbm) ---\n";
+ eval { do_test( $dbm_type, $mldbm, $columns) }
+ or warn $@;
+ }
+}
+
+done_testing();
+
+sub do_test {
+ my ($dtype, $mldbm, $columns) = @_;
+
+ #diag ("Starting test: " . $starting_test_no);
+
+ # The DBI can't test locking here, sadly, because of the risk it'll hang
+ # on systems with broken NFS locking daemons.
+ # (This test script doesn't test that locking actually works anyway.)
+
+ # use f_lockfile in next release - use it here as test case only
+ my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;dbm_lockfile=.lck";
+
+ if ($using_dbd_gofer) {
+ $dsn .= ";f_dir=$dir";
+ }
+
+ my $dbh = DBI->connect( $dsn );
+
+ my $dbm_versions;
+ if ($DBI::VERSION >= 1.37 # needed for install_method
+ && !$ENV{DBI_AUTOPROXY} # can't transparently proxy driver-private methods
+ ) {
+ $dbm_versions = $dbh->dbm_versions;
+ }
+ else {
+ $dbm_versions = $dbh->func('dbm_versions');
+ }
+ note $dbm_versions;
+ ok($dbm_versions, 'dbm_versions');
+ isa_ok($dbh, 'DBI::db');
+
+ # test if it correctly accepts valid $dbh attributes
+ SKIP: {
+ skip "Can't set attributes after connect using DBD::Gofer", 2
+ if $using_dbd_gofer;
+ eval {$dbh->{f_dir}=$dir};
+ ok(!$@);
+ eval {$dbh->{dbm_mldbm}=$mldbm};
+ ok(!$@);
+ }
+
+ # test if it correctly rejects invalid $dbh attributes
+ #
+ eval {
+ local $SIG{__WARN__} = sub { } if $using_dbd_gofer;
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
+ $dbh->{dbm_bad_name}=1;
+ };
+ ok($@);
+
+ my @queries = @{$test_statements{$columns}};
+ my @results = @{$expected_results{$columns}};
+
+ SKIP:
+ for my $idx ( 0 .. $#queries ) {
+ my $sql = $queries[$idx];
+ $sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name
+ $sql =~ s/;$//;
+ #diag($sql);
+
+ # XXX FIX INSERT with NULL VALUE WHEN COLUMN NOT NULLABLE
+ $dtype eq 'BerkeleyDB' and !$mldbm and 0 == index($sql, 'INSERT') and $sql =~ s/NULL/''/;
+
+ $sql =~ s/\s*;\s*(?:#(.*))//;
+ my $comment = $1;
+
+ my $sth = $dbh->prepare($sql);
+ ok($sth, "prepare $sql") or diag($dbh->errstr || 'unknown error');
+
+ my @bind;
+ if($sth->{NUM_OF_PARAMS})
+ {
+ @bind = split /,/, $comment;
+ }
+ # if execute errors we will handle it, not PrintError:
+ $sth->{PrintError} = 0;
+ my $n = $sth->execute(@bind);
+ ok($n, 'execute') or diag($sth->errstr || 'unknown error');
+ next if (!defined($n));
+
+ is( $n, $results[$idx], $sql ) unless( 'ARRAY' eq ref $results[$idx] );
+ TODO: {
+ local $TODO = "AUTOPROXY drivers might throw away sth->rows()" if($ENV{DBI_AUTOPROXY});
+ is( $n, $sth->rows, '$sth->execute(' . $sql . ') == $sth->rows' ) if( $sql =~ m/^(?:UPDATE|DELETE)/ );
+ }
+ next unless $sql =~ /SELECT/;
+ my $results='';
+ my $allrows = $sth->fetchall_arrayref();
+ my $expected_rows = $results[$idx];
+ is( $sth->rows, scalar( @{$expected_rows} ), $sql );
+ is_deeply( $allrows, $expected_rows, 'SELECT results' );
+ }
+ $dbh->disconnect;
+ return 1;
+}
+1;
diff --git a/t/51dbm_file.t b/t/51dbm_file.t
new file mode 100644
index 0000000..4b97288
--- /dev/null
+++ b/t/51dbm_file.t
@@ -0,0 +1,130 @@
+#!perl -w
+$| = 1;
+
+use strict;
+use warnings;
+
+use File::Copy ();
+use File::Path;
+use File::Spec ();
+use Test::More;
+
+my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i;
+
+use DBI;
+
+do "t/lib.pl";
+
+my $dir = test_dir();
+
+my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
+ f_dir => $dir,
+ sql_identifier_case => 1, # SQL_IC_UPPER
+ }
+);
+
+ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
+
+my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir';
+
+$dbh->do(q/create table fred (a integer, b integer)/);
+ok( -f File::Spec->catfile( $dir, "FRED$dirfext" ), "FRED$dirfext exists" );
+
+rmtree $dir;
+mkpath $dir;
+
+if ($using_dbd_gofer)
+{
+ # can't modify attributes when connect through a Gofer instance
+ $dbh->disconnect();
+ $dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
+ f_dir => $dir,
+ sql_identifier_case => 2, # SQL_IC_LOWER
+ }
+ );
+}
+else
+{
+ $dbh->dbm_clear_meta('fred'); # otherwise the col_names are still known!
+ $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER
+}
+
+$dbh->do(q/create table FRED (a integer, b integer)/);
+ok( -f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext exists" );
+
+my $tblfext;
+unless( $using_dbd_gofer )
+{
+ $tblfext = $dbh->{dbm_tables}->{fred}->{f_ext} || '';
+ $tblfext =~ s{/r$}{};
+ ok( -f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext exists" );
+}
+
+ok( $dbh->do(q/insert into fRED (a,b) values(1,2)/), 'insert into mixed case table' );
+
+# but change fRED to FRED and it works.
+
+ok( $dbh->do(q/insert into FRED (a,b) values(2,1)/), 'insert into uppercase table' );
+
+unless ($using_dbd_gofer)
+{
+ my $fn_tbl2 = $dbh->{dbm_tables}->{fred}->{f_fqfn};
+ $fn_tbl2 =~ s/fred(\.[^.]*)?$/freddy$1/;
+ my @dbfiles = grep { -f $_ } (
+ $dbh->{dbm_tables}->{fred}->{f_fqfn},
+ $dbh->{dbm_tables}->{fred}->{f_fqln},
+ $dbh->{dbm_tables}->{fred}->{f_fqbn} . ".dir"
+ );
+ foreach my $fn (@dbfiles)
+ {
+ my $tgt_fn = $fn;
+ $tgt_fn =~ s/fred(\.[^.]*)?$/freddy$1/;
+ File::Copy::copy( $fn, $tgt_fn );
+ }
+ $dbh->{dbm_tables}->{krueger}->{file} = $fn_tbl2;
+
+ my $r = $dbh->selectall_arrayref(q/select * from Krueger/);
+ ok( @$r == 2, 'rows found via cloned mixed case table' );
+
+ ok( $dbh->do(q/drop table if exists KRUeGEr/), 'drop table' );
+}
+
+my $r = $dbh->selectall_arrayref(q/select * from Fred/);
+ok( @$r == 2, 'rows found via mixed case table' );
+
+SKIP:
+{
+ DBD::DBM::Statement->isa("SQL::Statement") or skip("quoted identifiers aren't supported by DBI::SQL::Nano",1);
+ my $abs_tbl = File::Spec->catfile( $dir, 'fred' );
+ # work around SQL::Statement bug
+ DBD::DBM::Statement->isa("SQL::Statement") and SQL::Statement->VERSION() lt "1.32" and $abs_tbl =~ s|\\|/|g;
+ $r = $dbh->selectall_arrayref( sprintf( q|select * from "%s"|, $abs_tbl ) );
+ ok( @$r == 2, 'rows found via select via fully qualified path' );
+}
+
+if( $using_dbd_gofer )
+{
+ ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
+ ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" );
+}
+else
+{
+ my $tbl_info = { file => "fred$tblfext" };
+
+ ok( $dbh->disconnect(), "disconnect" );
+ $dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
+ f_dir => $dir,
+ sql_identifier_case => 2, # SQL_IC_LOWER
+ dbm_tables => { fred => $tbl_info },
+ }
+ );
+
+ $r = $dbh->selectall_arrayref(q/select * from Fred/);
+ ok( @$r == 2, 'rows found after reconnect using "dbm_tables"' );
+
+ ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
+ ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" );
+ ok( !-f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext removed" );
+}
+
+done_testing();
diff --git a/t/52dbm_complex.t b/t/52dbm_complex.t
new file mode 100644
index 0000000..31dc6e3
--- /dev/null
+++ b/t/52dbm_complex.t
@@ -0,0 +1,359 @@
+#!perl -w
+$| = 1;
+
+use strict;
+use warnings;
+
+require DBD::DBM;
+
+use File::Path;
+use File::Spec;
+use Test::More;
+use Cwd;
+use Config qw(%Config);
+use Storable qw(dclone);
+
+my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i;
+
+use DBI;
+use vars qw( @mldbm_types @dbm_types );
+
+BEGIN
+{
+
+ # 0=SQL::Statement if avail, 1=DBI::SQL::Nano
+ # next line forces use of Nano rather than default behaviour
+ # $ENV{DBI_SQL_NANO}=1;
+ # This is done in zv*n*_50dbm_simple.t
+
+ if ( eval { require 'MLDBM.pm'; } )
+ {
+ push @mldbm_types, qw(Data::Dumper Storable); # both in CORE
+ push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' };
+ push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; };
+ push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; };
+ }
+
+ # Potential DBM modules in preference order (SDBM_File first)
+ # skip NDBM and ODBM as they don't support EXISTS
+ my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File);
+ my @use_dbms = @ARGV;
+ if ( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} )
+ {
+ @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS};
+ }
+
+ if ( lc "@use_dbms" eq "all" )
+ {
+ # test with as many of the major DBM types as are available
+ @dbm_types = grep {
+ eval { local $^W; require "$_.pm" }
+ } @dbms;
+ }
+ elsif (@use_dbms)
+ {
+ @dbm_types = @use_dbms;
+ }
+ else
+ {
+ # we only test SDBM_File by default to avoid tripping up
+ # on any broken DBM's that may be installed in odd places.
+ # It's only DBD::DBM we're trying to test here.
+ # (However, if SDBM_File is not available, then use another.)
+ for my $dbm (@dbms)
+ {
+ if ( eval { local $^W; require "$dbm.pm" } )
+ {
+ @dbm_types = ($dbm);
+ last;
+ }
+ }
+ }
+
+ if ( eval { require List::MoreUtils; } )
+ {
+ List::MoreUtils->import("part");
+ }
+ else
+ {
+ # XXX from PP part of List::MoreUtils
+ eval <<'EOP';
+sub part(&@) {
+ my ($code, @list) = @_;
+ my @parts;
+ push @{ $parts[$code->($_)] }, $_ for @list;
+ return @parts;
+}
+EOP
+ }
+}
+
+my $haveSS = DBD::DBM::Statement->isa('SQL::Statement');
+
+plan skip_all => "DBI::SQL::Nano is being used" unless ( $haveSS );
+plan skip_all => "Not running with MLDBM" unless ( @mldbm_types );
+
+do "t/lib.pl";
+
+my $dir = test_dir ();
+
+my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, } );
+
+my $suffix;
+my $tbl_meta;
+
+sub break_at_warn
+{
+ note "break here";
+}
+$SIG{__WARN__} = \&break_at_warn;
+$SIG{__DIE__} = \&break_at_warn;
+
+sub load_tables
+{
+ my ( $dbmtype, $dbmmldbm ) = @_;
+ my $last_suffix;
+
+ if ($using_dbd_gofer)
+ {
+ $dbh->disconnect();
+ $dbh = DBI->connect( "dbi:DBM:", undef, undef, { f_dir => $dir, dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm } );
+ }
+ else
+ {
+ $last_suffix = $suffix;
+ $dbh->{dbm_type} = $dbmtype;
+ $dbh->{dbm_mldbm} = $dbmmldbm;
+ }
+
+ (my $serializer = $dbmmldbm ) =~ s/::/_/g;
+ $suffix = join( "_", $$, $dbmtype, $serializer );
+
+ if ($last_suffix)
+ {
+ for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s))
+ {
+ my $readsql = sprintf "SELECT * FROM $table", $last_suffix;
+ my $impsql = sprintf "CREATE TABLE $table AS IMPORT (?)", $suffix;
+ my ($readsth);
+ ok( $readsth = $dbh->prepare($readsql), "prepare: $readsql" );
+ ok( $readsth->execute(), "execute: $readsql" );
+ ok( $dbh->do( $impsql, {}, $readsth ), $impsql ) or warn $dbh->errstr();
+ }
+ }
+ else
+ {
+ for my $sql ( split( "\n", join( '', <<'EOD' ) ) )
+CREATE TABLE APPL_%s (id INT, applname CHAR, appluniq CHAR, version CHAR, appl_type CHAR)
+CREATE TABLE PREC_%s (id INT, appl_id INT, node_id INT, precedence INT)
+CREATE TABLE NODE_%s (id INT, nodename CHAR, os CHAR, version CHAR)
+CREATE TABLE LANDSCAPE_%s (id INT, landscapename CHAR)
+CREATE TABLE CONTACT_%s (id INT, surname CHAR, familyname CHAR, phone CHAR, userid CHAR, mailaddr CHAR)
+CREATE TABLE NM_LANDSCAPE_%s (id INT, ls_id INT, obj_id INT, obj_type INT)
+CREATE TABLE APPL_CONTACT_%s (id INT, contact_id INT, appl_id INT, contact_type CHAR)
+
+INSERT INTO APPL_%s VALUES ( 1, 'ZQF', 'ZFQLIN', '10.2.0.4', 'Oracle DB')
+INSERT INTO APPL_%s VALUES ( 2, 'YRA', 'YRA-UX', '10.2.0.2', 'Oracle DB')
+INSERT INTO APPL_%s VALUES ( 3, 'PRN1', 'PRN1-4.B2', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 4, 'PRN2', 'PRN2-4.B2', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 5, 'PRN1', 'PRN1-4.B1', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 7, 'PRN2', 'PRN2-4.B1', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 8, 'sql-stmt', 'SQL::Statement', '1.21', 'Project Web-Site')
+INSERT INTO APPL_%s VALUES ( 9, 'cpan.org', 'http://www.cpan.org/', '1.0', 'Web-Site')
+INSERT INTO APPL_%s VALUES (10, 'httpd', 'cpan-apache', '2.2.13', 'Web-Server')
+INSERT INTO APPL_%s VALUES (11, 'cpan-mods', 'cpan-mods', '8.4.1', 'PostgreSQL DB')
+INSERT INTO APPL_%s VALUES (12, 'cpan-authors', 'cpan-authors', '8.4.1', 'PostgreSQL DB')
+
+INSERT INTO NODE_%s VALUES ( 1, 'ernie', 'RHEL', '5.2')
+INSERT INTO NODE_%s VALUES ( 2, 'bert', 'RHEL', '5.2')
+INSERT INTO NODE_%s VALUES ( 3, 'statler', 'FreeBSD', '7.2')
+INSERT INTO NODE_%s VALUES ( 4, 'waldorf', 'FreeBSD', '7.2')
+INSERT INTO NODE_%s VALUES ( 5, 'piggy', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 6, 'kermit', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 7, 'samson', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 8, 'tiffy', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 9, 'rowlf', 'Debian Lenny', '5.0')
+INSERT INTO NODE_%s VALUES (10, 'fozzy', 'Debian Lenny', '5.0')
+
+INSERT INTO PREC_%s VALUES ( 1, 1, 1, 1)
+INSERT INTO PREC_%s VALUES ( 2, 1, 2, 2)
+INSERT INTO PREC_%s VALUES ( 3, 2, 2, 1)
+INSERT INTO PREC_%s VALUES ( 4, 2, 1, 2)
+INSERT INTO PREC_%s VALUES ( 5, 3, 5, 1)
+INSERT INTO PREC_%s VALUES ( 6, 3, 7, 2)
+INSERT INTO PREC_%s VALUES ( 7, 4, 6, 1)
+INSERT INTO PREC_%s VALUES ( 8, 4, 8, 2)
+INSERT INTO PREC_%s VALUES ( 9, 5, 7, 1)
+INSERT INTO PREC_%s VALUES (10, 5, 5, 2)
+INSERT INTO PREC_%s VALUES (11, 6, 8, 1)
+INSERT INTO PREC_%s VALUES (12, 7, 6, 2)
+INSERT INTO PREC_%s VALUES (13, 10, 9, 1)
+INSERT INTO PREC_%s VALUES (14, 10, 10, 1)
+INSERT INTO PREC_%s VALUES (15, 8, 9, 1)
+INSERT INTO PREC_%s VALUES (16, 8, 10, 1)
+INSERT INTO PREC_%s VALUES (17, 9, 9, 1)
+INSERT INTO PREC_%s VALUES (18, 9, 10, 1)
+INSERT INTO PREC_%s VALUES (19, 11, 3, 1)
+INSERT INTO PREC_%s VALUES (20, 11, 4, 2)
+INSERT INTO PREC_%s VALUES (21, 12, 4, 1)
+INSERT INTO PREC_%s VALUES (22, 12, 3, 2)
+
+INSERT INTO LANDSCAPE_%s VALUES (1, 'Logistic')
+INSERT INTO LANDSCAPE_%s VALUES (2, 'Infrastructure')
+INSERT INTO LANDSCAPE_%s VALUES (3, 'CPAN')
+
+INSERT INTO CONTACT_%s VALUES ( 1, 'Hans Peter', 'Mueller', '12345', 'HPMUE', 'hp-mueller@here.com')
+INSERT INTO CONTACT_%s VALUES ( 2, 'Knut', 'Inge', '54321', 'KINGE', 'k-inge@here.com')
+INSERT INTO CONTACT_%s VALUES ( 3, 'Lola', 'Nguyen', '+1-123-45678-90', 'LNYUG', 'lola.ngyuen@customer.com')
+INSERT INTO CONTACT_%s VALUES ( 4, 'Helge', 'Brunft', '+41-123-45678-09', 'HBRUN', 'helge.brunft@external-dc.at')
+
+-- TYPE: 1: APPL 2: NODE 3: CONTACT
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 1, 1, 1, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 2, 1, 2, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 3, 3, 3, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 4, 3, 4, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 5, 2, 5, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 6, 2, 6, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 7, 2, 7, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 8, 2, 8, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 9, 3, 9, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES (10, 3,10, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES (11, 1, 1, 1)
+INSERT INTO NM_LANDSCAPE_%s VALUES (12, 2, 2, 1)
+INSERT INTO NM_LANDSCAPE_%s VALUES (13, 2, 2, 3)
+INSERT INTO NM_LANDSCAPE_%s VALUES (14, 3, 1, 3)
+
+INSERT INTO APPL_CONTACT_%s VALUES (1, 3, 1, 'OWNER')
+INSERT INTO APPL_CONTACT_%s VALUES (2, 3, 2, 'OWNER')
+INSERT INTO APPL_CONTACT_%s VALUES (3, 4, 3, 'ADMIN')
+INSERT INTO APPL_CONTACT_%s VALUES (4, 4, 4, 'ADMIN')
+INSERT INTO APPL_CONTACT_%s VALUES (5, 4, 5, 'ADMIN')
+INSERT INTO APPL_CONTACT_%s VALUES (6, 4, 6, 'ADMIN')
+EOD
+ {
+ chomp $sql;
+ $sql =~ s/^\s+//;
+ $sql =~ s/--.*$//;
+ $sql =~ s/\s+$//;
+ next if ( '' eq $sql );
+ $sql = sprintf $sql, $suffix;
+ ok( $dbh->do($sql), $sql );
+ }
+ }
+
+ for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s))
+ {
+ my $tbl_name = lc sprintf($table, $suffix);
+ $tbl_meta->{$tbl_name} = { dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm };
+ }
+
+ unless ($using_dbd_gofer)
+ {
+ my $tbl_known_meta = $dbh->dbm_get_meta( "+", [ qw(dbm_type dbm_mldbm) ] );
+ is_deeply( $tbl_known_meta, $tbl_meta, "Know meta" );
+ }
+}
+
+sub do_tests
+{
+ my ( $dbmtype, $serializer ) = @_;
+
+ note "Running do_tests for $dbmtype + $serializer";
+
+ load_tables( $dbmtype, $serializer );
+
+ my %joins;
+ my $sql;
+
+ $sql = join( " ",
+ q{SELECT applname, appluniq, version, nodename },
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s }, ($suffix) x 3 ),
+ sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ),
+ );
+
+ $joins{$sql} = [
+ 'ZQF~ZFQLIN~10.2.0.4~ernie', 'ZQF~ZFQLIN~10.2.0.4~bert',
+ 'YRA~YRA-UX~10.2.0.2~bert', 'YRA~YRA-UX~10.2.0.2~ernie',
+ 'cpan-mods~cpan-mods~8.4.1~statler', 'cpan-mods~cpan-mods~8.4.1~waldorf',
+ 'cpan-authors~cpan-authors~8.4.1~waldorf', 'cpan-authors~cpan-authors~8.4.1~statler',
+ ];
+
+ $sql = join( " ",
+ q{SELECT applname, appluniq, version, landscapename, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, LANDSCAPE_%s, NM_LANDSCAPE_%s}, ($suffix) x 5 ),
+ sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id AND NM_LANDSCAPE_%s.obj_id=APPL_%s.id AND}, ($suffix) x 4 ),
+ sprintf( q{NM_LANDSCAPE_%s.obj_type=1 AND NM_LANDSCAPE_%s.ls_id=LANDSCAPE_%s.id}, ($suffix) x 3 ),
+ );
+ $joins{$sql} = [
+ 'ZQF~ZFQLIN~10.2.0.4~Logistic~ernie', 'ZQF~ZFQLIN~10.2.0.4~Logistic~bert',
+ 'YRA~YRA-UX~10.2.0.2~Infrastructure~bert', 'YRA~YRA-UX~10.2.0.2~Infrastructure~ernie',
+ ];
+ $sql = join( " ",
+ q{SELECT applname, appluniq, version, surname, familyname, phone, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ),
+ sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id AND}, ($suffix) x 4 ),
+ sprintf( q{APPL_CONTACT_%s.contact_id=CONTACT_%s.id AND PREC_%s.PRECEDENCE=1}, ($suffix) x 3 ),
+ );
+ $joins{$sql} = [
+ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy',
+ 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit',
+ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson',
+ ];
+ $sql = join( " ",
+ q{SELECT DISTINCT applname, appluniq, version, surname, familyname, phone, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ),
+ sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id}, ($suffix) x 4 ),
+ sprintf( q{AND APPL_CONTACT_%s.contact_id=CONTACT_%s.id}, ($suffix) x 2 ),
+ );
+ $joins{$sql} = [
+ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~piggy',
+ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy',
+ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson',
+ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~samson',
+ 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit',
+ 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~tiffy',
+ ];
+ $sql = join( " ",
+ q{SELECT CONCAT('[% NOW %]') AS "timestamp", applname, appluniq, version, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s}, ($suffix) x 3 ),
+ sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ),
+ );
+ $joins{$sql} = [
+ '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~ernie',
+ '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~bert',
+ '[% NOW %]~YRA~YRA-UX~10.2.0.2~bert',
+ '[% NOW %]~YRA~YRA-UX~10.2.0.2~ernie',
+ '[% NOW %]~cpan-mods~cpan-mods~8.4.1~statler',
+ '[% NOW %]~cpan-mods~cpan-mods~8.4.1~waldorf',
+ '[% NOW %]~cpan-authors~cpan-authors~8.4.1~waldorf',
+ '[% NOW %]~cpan-authors~cpan-authors~8.4.1~statler',
+ ];
+
+ while ( my ( $sql, $result ) = each(%joins) )
+ {
+ my $sth = $dbh->prepare($sql);
+ eval { $sth->execute() };
+ warn $@ if $@;
+ my @res;
+ while ( my $row = $sth->fetchrow_arrayref() )
+ {
+ push( @res, join( '~', @{$row} ) );
+ }
+ is( join( '^', sort @res ), join( '^', sort @{$result} ), $sql );
+ }
+}
+
+foreach my $dbmtype (@dbm_types)
+{
+ foreach my $serializer (@mldbm_types)
+ {
+ do_tests( $dbmtype, $serializer );
+ }
+}
+
+done_testing();
diff --git a/t/60preparse.t b/t/60preparse.t
new file mode 100755
index 0000000..6432feb
--- /dev/null
+++ b/t/60preparse.t
@@ -0,0 +1,148 @@
+#!perl -w
+
+use DBI qw(:preparse_flags);
+
+$|=1;
+
+use Test::More;
+
+BEGIN {
+ if ($DBI::PurePerl) {
+ plan skip_all => 'preparse not supported for DBI::PurePerl';
+ }
+ else {
+ plan tests => 39;
+ }
+}
+
+my $dbh = DBI->connect("dbi:ExampleP:", "", "", {
+ PrintError => 0,
+});
+isa_ok( $dbh, 'DBI::db' );
+
+sub pp {
+ my $dbh = shift;
+ my $rv = $dbh->preparse(@_);
+ return $rv;
+}
+
+# --------------------------------------------------------------------- #
+# DBIpp_cm_cs /* C style */
+# DBIpp_cm_hs /* # */
+# DBIpp_cm_dd /* -- */
+# DBIpp_cm_br /* {} */
+# DBIpp_cm_dw /* '-- ' dash dash whitespace */
+# DBIpp_cm_XX /* any of the above */
+
+# DBIpp_ph_qm /* ? */
+# DBIpp_ph_cn /* :1 */
+# DBIpp_ph_cs /* :name */
+# DBIpp_ph_sp /* %s (as return only, not accept) */
+# DBIpp_ph_XX /* any of the above */
+
+# DBIpp_st_qq /* '' char escape */
+# DBIpp_st_bs /* \ char escape */
+# DBIpp_st_XX /* any of the above */
+
+# ===================================================================== #
+# pp (h input return accept expected) #
+# ===================================================================== #
+
+## Comments:
+
+is( pp($dbh, "a#b\nc", DBIpp_cm_cs, DBIpp_cm_hs), "a/*b*/\nc" );
+is( pp($dbh, "a#b\nc", DBIpp_cm_dw, DBIpp_cm_hs), "a-- b\nc" );
+is( pp($dbh, "a/*b*/c", DBIpp_cm_hs, DBIpp_cm_cs), "a#b\nc" );
+is( pp($dbh, "a{b}c", DBIpp_cm_cs, DBIpp_cm_br), "a/*b*/c" );
+is( pp($dbh, "a--b\nc", DBIpp_cm_br, DBIpp_cm_dd), "a{b}\nc" );
+
+is( pp($dbh, "a-- b\n/*c*/d", DBIpp_cm_br, DBIpp_cm_cs|DBIpp_cm_dw), "a{ b}\n{c}d" );
+is( pp($dbh, "a/*b*/c#d\ne--f\nh-- i\nj{k}", 0, DBIpp_cm_XX), "a c\ne\nh\nj " );
+
+## Placeholders:
+
+is( pp($dbh, "a = :1", DBIpp_ph_qm, DBIpp_ph_cn), "a = ?" );
+is( pp($dbh, "a = :1", DBIpp_ph_sp, DBIpp_ph_cn), "a = %s" );
+is( pp($dbh, "a = ?" , DBIpp_ph_cn, DBIpp_ph_qm), "a = :p1" );
+is( pp($dbh, "a = ?" , DBIpp_ph_sp, DBIpp_ph_qm), "a = %s" );
+
+is( pp($dbh, "a = :name", DBIpp_ph_qm, DBIpp_ph_cs), "a = ?" );
+is( pp($dbh, "a = :name", DBIpp_ph_sp, DBIpp_ph_cs), "a = %s" );
+
+is( pp($dbh, "a = ? b = ? c = ?", DBIpp_ph_cn, DBIpp_ph_XX), "a = :p1 b = :p2 c = :p3" );
+
+## Placeholders inside comments (should be ignored where comments style is accepted):
+
+is( pp( $dbh,
+ "a = ? /*b = :1*/ c = ?",
+ DBIpp_cm_dw|DBIpp_ph_cn,
+ DBIpp_cm_cs|DBIpp_ph_qm),
+ "a = :p1 -- b = :1\n c = :p2" );
+
+## Placeholders inside single and double quotes (should be ignored):
+
+is( pp( $dbh,
+ "a = ? 'b = :1' c = ?",
+ DBIpp_ph_cn,
+ DBIpp_ph_XX),
+ "a = :p1 'b = :1' c = :p2" );
+
+is( pp( $dbh,
+ 'a = ? "b = :1" c = ?',
+ DBIpp_ph_cn,
+ DBIpp_ph_XX),
+ 'a = :p1 "b = :1" c = :p2' );
+
+## Comments inside single and double quotes (should be ignored):
+
+is( pp( $dbh,
+ "a = ? '{b = :1}' c = ?",
+ DBIpp_cm_cs|DBIpp_ph_cn,
+ DBIpp_cm_XX|DBIpp_ph_qm),
+ "a = :p1 '{b = :1}' c = :p2" );
+
+is( pp( $dbh,
+ 'a = ? "/*b = :1*/" c = ?',
+ DBIpp_cm_dw|DBIpp_ph_cn,
+ DBIpp_cm_XX|DBIpp_ph_qm),
+ 'a = :p1 "/*b = :1*/" c = :p2' );
+
+## Single and double quoted strings starting inside comments (should be ignored):
+
+is( pp( $dbh,
+ 'a = ? /*"b = :1 */ c = ?',
+ DBIpp_cm_br|DBIpp_ph_cn,
+ DBIpp_cm_XX|DBIpp_ph_qm),
+ 'a = :p1 {"b = :1 } c = :p2' );
+
+## Check error conditions are trapped:
+
+is( pp($dbh, "a = :value and b = :1", DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef );
+ok( $DBI::err );
+is( $DBI::errstr, "preparse found mixed placeholder styles (:1 / :name)" );
+
+is( pp($dbh, "a = :1 and b = :3", DBIpp_ph_qm, DBIpp_ph_cn), undef );
+ok( $DBI::err );
+is( $DBI::errstr, "preparse found placeholder :3 out of sequence, expected :2" );
+
+is( pp($dbh, "foo ' comment", 0, 0), "foo ' comment" );
+ok( $DBI::err );
+is( $DBI::errstr, "preparse found unterminated single-quoted string" );
+
+is( pp($dbh, 'foo " comment', 0, 0), 'foo " comment' );
+ok( $DBI::err );
+is( $DBI::errstr, "preparse found unterminated double-quoted string" );
+
+is( pp($dbh, 'foo /* comment', DBIpp_cm_XX, DBIpp_cm_XX), 'foo /* comment' );
+ok( $DBI::err );
+is( $DBI::errstr, "preparse found unterminated bracketed C-style comment" );
+
+is( pp($dbh, 'foo { comment', DBIpp_cm_XX, DBIpp_cm_XX), 'foo { comment' );
+ok( $DBI::err );
+is( $DBI::errstr, "preparse found unterminated bracketed {...} comment" );
+
+# --------------------------------------------------------------------- #
+
+$dbh->disconnect;
+
+1;
diff --git a/t/65transact.t b/t/65transact.t
new file mode 100644
index 0000000..f3d672b
--- /dev/null
+++ b/t/65transact.t
@@ -0,0 +1,35 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+use DBI;
+
+use Test::More;
+
+plan skip_all => 'Transactions not supported by DBD::Gofer'
+ if $ENV{DBI_AUTOPROXY} && $ENV{DBI_AUTOPROXY} =~ /^dbi:Gofer/i;
+
+plan tests => 10;
+
+my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef)
+ or die "Unable to connect to ExampleP driver: $DBI::errstr";
+
+print "begin_work...\n";
+ok($dbh->{AutoCommit});
+ok(!$dbh->{BegunWork});
+
+ok($dbh->begin_work);
+ok(!$dbh->{AutoCommit});
+ok($dbh->{BegunWork});
+
+$dbh->commit;
+ok($dbh->{AutoCommit});
+ok(!$dbh->{BegunWork});
+
+ok($dbh->begin_work({}));
+$dbh->rollback;
+ok($dbh->{AutoCommit});
+ok(!$dbh->{BegunWork});
+
+1;
diff --git a/t/70callbacks.t b/t/70callbacks.t
new file mode 100644
index 0000000..4acb9c3
--- /dev/null
+++ b/t/70callbacks.t
@@ -0,0 +1,207 @@
+#!perl -w
+# vim:ts=8:sw=4
+
+use strict;
+
+use Test::More;
+use DBI;
+
+BEGIN {
+ plan skip_all => '$h->{Callbacks} attribute not supported for DBI::PurePerl'
+ if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning
+ plan tests => 63;
+}
+
+$| = 1;
+my $dsn = "dbi:ExampleP:";
+my %called;
+
+ok my $dbh = DBI->connect($dsn, '', ''), "Create dbh";
+
+is $dbh->{Callbacks}, undef, "Callbacks initially undef";
+ok $dbh->{Callbacks} = my $cb = { };
+is ref $dbh->{Callbacks}, 'HASH', "Callbacks can be set to a hash ref";
+is $dbh->{Callbacks}, $cb, "Callbacks set to same hash ref";
+
+$dbh->{Callbacks} = undef;
+is $dbh->{Callbacks}, undef, "Callbacks set to undef again";
+
+ok $dbh->{Callbacks} = {
+ ping => sub {
+ is $_, 'ping', '$_ holds method name';
+ is @_, 1, '@_ holds 1 values';
+ is ref $_[0], 'DBI::db', 'first is $dbh';
+ $called{$_}++;
+ return;
+ },
+ quote_identifier => sub {
+ is @_, 4, '@_ holds 4 values';
+ my $dbh = shift;
+ is ref $dbh, 'DBI::db', 'first is $dbh';
+ is $_[0], 'foo';
+ is $_[1], 'bar';
+ is $_[2], undef;
+ $_[2] = { baz => 1 };
+ $called{$_}++;
+ return (1,2,3); # return something - which is not allowed
+ },
+ disconnect => sub { # test die from within a callback
+ die "You can't disconnect that easily!\n";
+ },
+ "*" => sub {
+ $called{$_}++;
+ return;
+ }
+};
+is keys %{ $dbh->{Callbacks} }, 4;
+
+is ref $dbh->{Callbacks}->{ping}, 'CODE';
+
+$_ = 42;
+ok $dbh->ping;
+is $called{ping}, 1;
+is $_, 42, '$_ not altered by callback';
+
+ok $dbh->ping;
+is $called{ping}, 2;
+
+ok $dbh->type_info_all;
+is $called{type_info_all}, 1, 'fallback callback';
+
+my $attr;
+eval { $dbh->quote_identifier('foo','bar', $attr) };
+is $called{quote_identifier}, 1;
+ok $@, 'quote_identifier callback caused fatal error';
+is ref $attr, 'HASH', 'param modified by callback - not recommended!';
+
+ok !eval { $dbh->disconnect };
+ok $@, "You can't disconnect that easily!\n";
+
+$dbh->{Callbacks} = undef;
+ok $dbh->ping;
+is $called{ping}, 2; # no change
+
+
+# --- test skipping dispatch and fallback callbacks
+
+$dbh->{Callbacks} = {
+ ping => sub {
+ undef $_; # tell dispatch to not call the method
+ return "42 bells";
+ },
+ data_sources => sub {
+ my ($h, $values_to_return) = @_;
+ undef $_; # tell dispatch to not call the method
+ my @ret = 11..10+($values_to_return||0);
+ return @ret;
+ },
+ commit => sub { # test using set_err within a callback
+ my $h = shift;
+ undef $_; # tell dispatch to not call the method
+ return $h->set_err(42, "faked commit failure");
+ },
+};
+
+# these tests are slightly convoluted because messing with the stack is bad for
+# your mental health
+my $rv = $dbh->ping;
+is $rv, "42 bells";
+my @rv = $dbh->ping;
+is scalar @rv, 1, 'should return a single value in list context';
+is "@rv", "42 bells";
+# test returning lists with different number of args to test
+# the stack handling in the dispatch code
+is join(":", $dbh->data_sources()), "";
+is join(":", $dbh->data_sources(0)), "";
+is join(":", $dbh->data_sources(1)), "11";
+is join(":", $dbh->data_sources(2)), "11:12";
+
+{
+local $dbh->{RaiseError} = 1;
+local $dbh->{PrintError} = 0;
+is eval { $dbh->commit }, undef, 'intercepted commit should return undef';
+like $@, '/DBD::\w+::db commit failed: faked commit failure/';
+is $DBI::err, 42;
+is $DBI::errstr, "faked commit failure";
+}
+
+# --- test connect_cached.*
+
+=for comment XXX
+
+The big problem here is that conceptually the Callbacks attribute
+is applied to the $dbh _during_ the $drh->connect() call, so you can't
+set a callback on "connect" on the $dbh because connect isn't called
+on the dbh, but on the $drh.
+
+So a "connect" callback would have to be defined on the $drh, but that's
+cumbersome for the user and then it would apply to all future connects
+using that driver.
+
+The best thing to do is probably to special-case "connect", "connect_cached"
+and (the already special-case) "connect_cached.reused".
+
+=cut
+
+my @args = (
+ $dsn, '', '', {
+ Callbacks => {
+ "connect_cached.new" => sub { $called{new}++; return; },
+ "connect_cached.reused" => sub { $called{cached}++; return; },
+ }
+ }
+);
+
+%called = ();
+
+ok $dbh = DBI->connect(@args), "Create handle with callbacks";
+is keys %called, 0, 'no callback for plain connect';
+
+ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks";
+is $called{new}, 1, "connect_cached.new called";
+is $called{cached}, undef, "connect_cached.reused not yet called";
+
+ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks";
+is $called{cached}, 1, "connect_cached.reused called";
+is $called{new}, 1, "connect_cached.new not called again";
+
+
+# --- test ChildCallbacks.
+%called = ();
+$args[-1] = {
+ Callbacks => my $dbh_callbacks = {
+ ping => sub { $called{ping}++; return; },
+ ChildCallbacks => my $sth_callbacks = {
+ execute => sub { $called{execute}++; return; },
+ fetch => sub { $called{fetch}++; return; },
+ }
+ }
+};
+
+ok $dbh = DBI->connect(@args), "Create handle with ChildCallbacks";
+ok $dbh->ping, 'Ping';
+is $called{ping}, 1, 'Ping callback should have been called';
+ok my $sth = $dbh->prepare('SELECT name from t'), 'Prepare a statement handle (child)';
+ok $sth->{Callbacks}, 'child should have Callbacks';
+is $sth->{Callbacks}, $sth_callbacks, "child Callbacks should be ChildCallbacks of parent"
+ or diag "(dbh Callbacks is $dbh_callbacks)";
+ok $sth->execute, 'Execute';
+is $called{execute}, 1, 'Execute callback should have been called';
+ok $sth->fetch, 'Fetch';
+is $called{fetch}, 1, 'Fetch callback should have been called';
+
+__END__
+
+A generic 'transparent' callback looks like this:
+(this assumes only scalar context will be used)
+
+ sub {
+ my $h = shift;
+ return if our $avoid_deep_recursion->{"$h $_"}++;
+ my $this = $h->$_(@_);
+ undef $_; # tell DBI not to call original method
+ return $this; # tell DBI to return this instead
+ };
+
+XXX should add a test for this
+XXX even better would be to run chunks of the test suite with that as a '*' callback. In theory everything should pass (except this test file, naturally)..
diff --git a/t/72childhandles.t b/t/72childhandles.t
new file mode 100644
index 0000000..48fbe37
--- /dev/null
+++ b/t/72childhandles.t
@@ -0,0 +1,149 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+#
+# test script for the ChildHandles attribute
+#
+
+use DBI;
+
+use Test::More;
+
+my $HAS_WEAKEN = eval {
+ require Scalar::Util;
+ # this will croak() if this Scalar::Util doesn't have a working weaken().
+ Scalar::Util::weaken( my $test = [] ); # same test as in DBI.pm
+ 1;
+};
+if (!$HAS_WEAKEN) {
+ chomp $@;
+ print "1..0 # Skipped: Scalar::Util::weaken not available ($@)\n";
+ exit 0;
+}
+
+plan tests => 16;
+
+my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
+
+my $drh;
+
+{
+ # make 10 connections
+ my @dbh;
+ for (1 .. 10) {
+ my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+ push @dbh, $dbh;
+ }
+
+ # get the driver handle
+ $drh = $dbh[0]->{Driver};
+ ok $drh;
+
+ # get the kids, should be the same list of connections
+ my $db_handles = $drh->{ChildHandles};
+ is ref $db_handles, 'ARRAY';
+ is scalar @$db_handles, scalar @dbh;
+
+ # make sure all the handles are there
+ my $found = 0;
+ foreach my $h (@dbh) {
+ ++$found if grep { $h == $_ } @$db_handles;
+ }
+ is $found, scalar @dbh;
+}
+
+# now all the out-of-scope DB handles should be gone
+{
+ my $handles = $drh->{ChildHandles};
+ my @db_handles = grep { defined } @$handles;
+ is scalar @db_handles, 0, "All handles should be undef now";
+}
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+
+my $empty = $dbh->{ChildHandles};
+is_deeply $empty, [], "ChildHandles should be an array-ref if wekref is available";
+
+# test child handles for statement handles
+{
+ my @sth;
+ my $sth_count = 20;
+ for (1 .. $sth_count) {
+ my $sth = $dbh->prepare('SELECT name FROM t');
+ push @sth, $sth;
+ }
+ my $handles = $dbh->{ChildHandles};
+ is scalar @$handles, scalar @sth;
+
+ # test a recursive walk like the one in the docs
+ my @lines;
+ sub show_child_handles {
+ my ($h, $level) = @_;
+ $level ||= 0;
+ push(@lines,
+ sprintf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h);
+ show_child_handles($_, $level + 1)
+ for (grep { defined } @{$h->{ChildHandles}});
+ }
+ my $drh = $dbh->{Driver};
+ show_child_handles($drh, 0);
+ print @lines[0..4];
+
+ is scalar @lines, $sth_count + 2;
+ like $lines[0], qr/^drh/;
+ like $lines[1], qr/^dbh/;
+ like $lines[2], qr/^sth/;
+}
+
+my $handles = $dbh->{ChildHandles};
+my @live = grep { defined $_ } @$handles;
+is scalar @live, 0, "handles should be gone now";
+
+# test visit_child_handles
+{
+ my $info;
+ my $visitor = sub {
+ my ($h, $info) = @_;
+ my $type = $h->{Type};
+ ++$info->{ $type }{ ($type eq 'st') ? $h->{Statement} : $h->{Name} };
+ return $info;
+ };
+ DBI->visit_handles($visitor, $info = {});
+ is_deeply $info, {
+ 'dr' => {
+ 'ExampleP' => 1,
+ ($using_dbd_gofer) ? (Gofer => 1) : ()
+ },
+ 'db' => { '' => 1 },
+ };
+
+ my $sth1 = $dbh->prepare('SELECT name FROM t');
+ my $sth2 = $dbh->prepare('SELECT name FROM t');
+ DBI->visit_handles($visitor, $info = {});
+ is_deeply $info, {
+ 'dr' => {
+ 'ExampleP' => 1,
+ ($using_dbd_gofer) ? (Gofer => 1) : ()
+ },
+ 'db' => { '' => 1 },
+ 'st' => { 'SELECT name FROM t' => 2 }
+ };
+
+}
+
+# test that the childhandle array does not grow uncontrollably
+SKIP: {
+ skip "slow tests avoided when using DBD::Gofer", 2 if $using_dbd_gofer;
+
+ for (1 .. 1000) {
+ my $sth = $dbh->prepare('SELECT name FROM t');
+ }
+ my $handles = $dbh->{ChildHandles};
+ cmp_ok scalar @$handles, '<', 1000;
+ my @live = grep { defined } @$handles;
+ is scalar @live, 0;
+}
+
+1;
diff --git a/t/80proxy.t b/t/80proxy.t
new file mode 100644
index 0000000..ab529b6
--- /dev/null
+++ b/t/80proxy.t
@@ -0,0 +1,473 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+
+require 5.004;
+use strict;
+
+
+use DBI;
+use Config;
+require VMS::Filespec if $^O eq 'VMS';
+require Cwd;
+
+my $haveFileSpec = eval { require File::Spec };
+my $failed_tests = 0;
+
+$| = 1;
+$^W = 1;
+
+# $\ = "\n"; # XXX Triggers bug, check this later (JW, 1998-12-28)
+
+# Can we load the modules? If not, exit the test immediately:
+# Reason is most probable a missing prerequisite.
+#
+# Is syslog available (required for the server)?
+
+eval {
+ local $SIG{__WARN__} = sub { $@ = shift };
+ require Storable;
+ require DBD::Proxy;
+ require DBI::ProxyServer;
+ require RPC::PlServer;
+ require Net::Daemon::Test;
+};
+if ($@) {
+ if ($@ =~ /^Can't locate (\S+)/) {
+ print "1..0 # Skipped: modules required for proxy are probably not installed (e.g., $1)\n";
+ exit 0;
+ }
+ die $@;
+}
+
+if ($DBI::PurePerl) {
+ # XXX temporary I hope
+ print "1..0 # Skipped: DBD::Proxy currently has a problem under DBI::PurePerl\n";
+ exit 0;
+}
+
+{
+ my $numTest = 0;
+ sub _old_Test($;$) {
+ my $result = shift; my $str = shift || '';
+ printf("%sok %d%s\n", ($result ? "" : "not "), ++$numTest, $str);
+ $result;
+ }
+ sub Test ($;$) {
+ my($ok, $msg) = @_;
+ $msg = ($msg) ? " ($msg)" : "";
+ my $line = (caller)[2];
+ ++$numTest;
+ ($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n";
+ warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok;
+ ++$failed_tests unless $ok;
+ return $ok;
+ }
+}
+
+
+# Create an empty config file to make sure that settings aren't
+# overloaded by /etc/dbiproxy.conf
+my $config_file = "dbiproxytst.conf";
+unlink $config_file;
+(open(FILE, ">$config_file") and
+ (print FILE "{}\n") and
+ close(FILE))
+ or die "Failed to create config file $config_file: $!";
+
+my $debug = ($ENV{DBI_TRACE}||=0) ? 1 : 0;
+my $dbitracelog = "dbiproxy.dbilog";
+
+my ($handle, $port, @child_args);
+
+my $numTests = 136;
+
+if (@ARGV) {
+ $port = $ARGV[0];
+}
+else {
+
+ unlink $dbitracelog;
+ unlink "dbiproxy.log";
+ unlink "dbiproxy.truss";
+
+ # Uncommentand adjust this to isolate pure-perl client from server settings:
+ # local $ENV{DBI_PUREPERL} = 0;
+
+ # If desperate uncomment this and add '-d' after $^X below:
+ # local $ENV{PERLDB_OPTS} = "AutoTrace NonStop=1 LineInfo=dbiproxy.dbg";
+
+ # pass our @INC to children (e.g., so -Mblib passes through)
+ $ENV{PERL5LIB} = join($Config{path_sep}, @INC);
+
+ # server DBI trace level always at least 1
+ my $dbitracelevel = DBI->trace(0) || 1;
+ @child_args = (
+ #'truss', '-o', 'dbiproxy.truss',
+ $^X, 'dbiproxy', '--test', # --test must be first command line arg
+ "--dbitrace=$dbitracelevel=$dbitracelog", # must be second arg
+ '--configfile', $config_file,
+ ($dbitracelevel >= 2 ? ('--debug') : ()),
+ '--mode=single',
+ '--logfile=STDERR',
+ '--timeout=90'
+ );
+ warn " starting test dbiproxy process: @child_args\n" if DBI->trace(0);
+ ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args);
+}
+
+my $dsn = "DBI:Proxy:hostname=127.0.0.1;port=$port;debug=$debug;dsn=DBI:ExampleP:";
+
+print "Making a first connection and closing it immediately.\n";
+Test(eval { DBI->connect($dsn, '', '', { 'PrintError' => 1 }) })
+ or print "Connect error: " . $DBI::errstr . "\n";
+
+print "Making a second connection.\n";
+my $dbh;
+Test($dbh = eval { DBI->connect($dsn, '', '', { 'PrintError' => 0 }) })
+ or print "Connect error: " . $DBI::errstr . "\n";
+
+print "example_driver_path=$dbh->{example_driver_path}\n";
+Test($dbh->{example_driver_path});
+
+print "Setting AutoCommit\n";
+$@ = "old-error"; # should be preserved across DBI calls
+Test($dbh->{AutoCommit} = 1);
+Test($dbh->{AutoCommit});
+Test($@ eq "old-error", "\$@ now '$@'");
+#$dbh->trace(2);
+
+eval {
+ local $dbh->{ AutoCommit } = 1; # This breaks die!
+ die "BANG!!!\n";
+};
+Test($@ eq "BANG!!!\n", "\$@ value lost");
+
+
+print "begin_work...\n";
+Test($dbh->{AutoCommit});
+Test(!$dbh->{BegunWork});
+
+Test($dbh->begin_work);
+Test(!$dbh->{AutoCommit});
+Test($dbh->{BegunWork});
+
+$dbh->commit;
+Test(!$dbh->{BegunWork});
+Test($dbh->{AutoCommit});
+
+Test($dbh->begin_work({}));
+$dbh->rollback;
+Test($dbh->{AutoCommit});
+Test(!$dbh->{BegunWork});
+
+
+print "Doing a ping.\n";
+$_ = $dbh->ping;
+Test($_);
+Test($_ eq '2'); # ping was DBD::ExampleP's ping
+
+print "Ensure CompatMode enabled.\n";
+Test($dbh->{CompatMode});
+
+print "Trying local quote.\n";
+$dbh->{'proxy_quote'} = 'local';
+Test($dbh->quote("quote's") eq "'quote''s'");
+Test($dbh->quote(undef) eq "NULL");
+
+print "Trying remote quote.\n";
+$dbh->{'proxy_quote'} = 'remote';
+Test($dbh->quote("quote's") eq "'quote''s'");
+Test($dbh->quote(undef) eq "NULL");
+
+# XXX the $optional param is undocumented and may be removed soon
+Test($dbh->quote_identifier('foo') eq '"foo"', $dbh->quote_identifier('foo'));
+Test($dbh->quote_identifier('f"o') eq '"f""o"', $dbh->quote_identifier('f"o'));
+Test($dbh->quote_identifier('foo','bar') eq '"foo"."bar"');
+Test($dbh->quote_identifier('foo',undef,'bar') eq '"foo"."bar"');
+Test($dbh->quote_identifier(undef,undef,'bar') eq '"bar"');
+
+print "Trying commit with invalid number of parameters.\n";
+eval { $dbh->commit('dummy') };
+Test($@ =~ m/^DBI commit: invalid number of arguments:/)
+ unless $DBI::PurePerl && Test(1);
+
+print "Trying select with unknown field name.\n";
+my $cursor_e = $dbh->prepare("select unknown_field_name from ?");
+Test(defined $cursor_e);
+Test(!$cursor_e->execute('a'));
+Test($DBI::err);
+Test($DBI::err == $dbh->err);
+Test($DBI::errstr =~ m/unknown_field_name/, $DBI::errstr);
+
+Test($DBI::errstr eq $dbh->errstr);
+Test($dbh->errstr eq $dbh->func('errstr'));
+
+my $dir = Cwd::cwd(); # a dir always readable on all platforms
+$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
+
+print "Trying a real select.\n";
+my $csr_a = $dbh->prepare("select mode,name from ?");
+Test(ref $csr_a);
+Test($csr_a->execute($dir))
+ or print "Execute failed: ", $csr_a->errstr(), "\n";
+
+print "Repeating the select with second handle.\n";
+my $csr_b = $dbh->prepare("select mode,name from ?");
+Test(ref $csr_b);
+Test($csr_b->execute($dir));
+Test($csr_a != $csr_b);
+Test($csr_a->{NUM_OF_FIELDS} == 2);
+if ($DBI::PurePerl) {
+ $csr_a->trace(2);
+ use Data::Dumper;
+ warn Dumper($csr_a->{Database});
+}
+Test($csr_a->{Database}->{Driver}->{Name} eq 'Proxy', "Name=$csr_a->{Database}->{Driver}->{Name}");
+$csr_a->trace(0), die if $DBI::PurePerl;
+
+my($col0, $col1);
+my(@row_a, @row_b);
+
+#$csr_a->trace(2);
+print "Trying bind_columns.\n";
+Test($csr_a->bind_columns(undef, \($col0, $col1)) );
+Test($csr_a->execute($dir));
+@row_a = $csr_a->fetchrow_array;
+Test(@row_a);
+Test($row_a[0] eq $col0);
+Test($row_a[1] eq $col1);
+
+print "Trying bind_param.\n";
+Test($csr_b->bind_param(1, $dir));
+Test($csr_b->execute());
+@row_b = @{ $csr_b->fetchrow_arrayref };
+Test(@row_b);
+
+Test("@row_a" eq "@row_b");
+@row_b = $csr_b->fetchrow_array;
+Test("@row_a" ne "@row_b")
+ or printf("Expected something different from '%s', got '%s'\n", "@row_a",
+ "@row_b");
+
+print "Trying fetchrow_hashref.\n";
+Test($csr_b->execute());
+my $row_b = $csr_b->fetchrow_hashref;
+Test($row_b);
+print "row_a: @{[ @row_a ]}\n";
+print "row_b: @{[ %$row_b ]}\n";
+Test($row_b->{mode} == $row_a[0]);
+Test($row_b->{name} eq $row_a[1]);
+
+print "Trying fetchrow_hashref with FetchHashKeyName.\n";
+do {
+#local $dbh->{TraceLevel} = 9;
+local $dbh->{FetchHashKeyName} = 'NAME_uc';
+Test($dbh->{FetchHashKeyName} eq 'NAME_uc');
+my $csr_c = $dbh->prepare("select mode,name from ?");
+Test($csr_c->execute($dir), $DBI::errstr);
+$row_b = $csr_c->fetchrow_hashref;
+Test($row_b);
+print "row_b: @{[ %$row_b ]}\n";
+Test($row_b->{MODE} eq $row_a[0]);
+};
+
+print "Trying finish.\n";
+Test($csr_a->finish);
+#Test($csr_b->finish);
+Test(1);
+
+print "Forcing destructor.\n";
+$csr_a = undef; # force destruction of this cursor now
+Test(1);
+
+print "Trying fetchall_arrayref.\n";
+Test($csr_b->execute());
+my $r = $csr_b->fetchall_arrayref;
+Test($r);
+Test(@$r);
+Test($r->[0]->[0] == $row_a[0]);
+Test($r->[0]->[1] eq $row_a[1]);
+
+Test($csr_b->finish);
+
+
+print "Retrying unknown field name.\n";
+my $csr_c;
+$csr_c = $dbh->prepare("select unknown_field_name1 from ?");
+Test($csr_c);
+Test(!$csr_c->execute($dir));
+Test($DBI::errstr =~ m/Unknown field names: unknown_field_name1/)
+ or printf("Wrong error string: %s", $DBI::errstr);
+
+print "Trying RaiseError.\n";
+$dbh->{RaiseError} = 1;
+Test($dbh->{RaiseError});
+Test($csr_c = $dbh->prepare("select unknown_field_name2 from ?"));
+Test(!eval { $csr_c->execute(); 1 });
+#print "$@\n";
+Test($@ =~ m/Unknown field names: unknown_field_name2/);
+$dbh->{RaiseError} = 0;
+Test(!$dbh->{RaiseError});
+
+print "Trying warnings.\n";
+{
+ my @warn;
+ local($SIG{__WARN__}) = sub { push @warn, @_ };
+ $dbh->{PrintError} = 1;
+ Test($dbh->{PrintError});
+ Test(($csr_c = $dbh->prepare("select unknown_field_name3 from ?")));
+ Test(!$csr_c->execute());
+ Test("@warn" =~ m/Unknown field names: unknown_field_name3/);
+ $dbh->{PrintError} = 0;
+ Test(!$dbh->{PrintError});
+}
+$csr_c->finish();
+
+
+print "Trying type_info_all.\n";
+my $array = $dbh->type_info_all();
+Test($array and ref($array) eq 'ARRAY')
+ or printf("Expected ARRAY, got %s, error %s\n", DBI::neat($array),
+ $dbh->errstr());
+Test($array->[0] and ref($array->[0]) eq 'HASH');
+my $ok = 1;
+for (my $i = 1; $i < @{$array}; $i++) {
+ print "$array->[$i]\n";
+ $ok = 0 unless ($array->[$i] and ref($array->[$i]) eq 'ARRAY');
+ print "$ok\n";
+}
+Test($ok);
+
+# Test the table_info method
+# First generate a list of all subdirectories
+$dir = $haveFileSpec ? File::Spec->curdir() : ".";
+Test(opendir(DIR, $dir));
+my(%dirs, %unexpected, %missing);
+while (defined(my $file = readdir(DIR))) {
+ $dirs{$file} = 1 if -d $file;
+}
+closedir(DIR);
+my $sth = $dbh->table_info(undef, undef, undef, undef);
+Test($sth) or warn "table_info failed: ", $dbh->errstr(), "\n";
+%missing = %dirs;
+%unexpected = ();
+while (my $ref = $sth->fetchrow_hashref()) {
+ print "table_info: Found table $ref->{'TABLE_NAME'}\n";
+ if (exists($missing{$ref->{'TABLE_NAME'}})) {
+ delete $missing{$ref->{'TABLE_NAME'}};
+ } else {
+ $unexpected{$ref->{'TABLE_NAME'}} = 1;
+ }
+}
+Test(!$sth->errstr())
+ or print "Fetching table_info rows failed: ", $sth->errstr(), "\n";
+Test(keys %unexpected == 0)
+ or print "Unexpected directories: ", join(",", keys %unexpected), "\n";
+Test(keys %missing == 0)
+ or print "Missing directories: ", join(",", keys %missing), "\n";
+
+# Test the tables method
+%missing = %dirs;
+%unexpected = ();
+print "Expecting directories ", join(",", keys %dirs), "\n";
+foreach my $table ($dbh->tables()) {
+ print "tables: Found table $table\n";
+ if (exists($missing{$table})) {
+ delete $missing{$table};
+ } else {
+ $unexpected{$table} = 1;
+ }
+}
+Test(!$sth->errstr())
+ or print "Fetching table_info rows failed: ", $sth->errstr(), "\n";
+Test(keys %unexpected == 0)
+ or print "Unexpected directories: ", join(",", keys %unexpected), "\n";
+Test(keys %missing == 0)
+ or print "Missing directories: ", join(",", keys %missing), "\n";
+
+
+# Test large recordsets
+for (my $i = 0; $i <= 300; $i += 100) {
+ print "Testing the fake directories ($i).\n";
+ Test($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i"));
+ Test($csr_a->execute(), $DBI::errstr);
+ my $ary = $csr_a->fetchall_arrayref;
+ Test(!$DBI::errstr, $DBI::errstr);
+ Test(@$ary == $i, "expected $i got ".@$ary);
+ if ($i) {
+ my @n1 = map { $_->[0] } @$ary;
+ my @n2 = reverse map { "file$_" } 1..$i;
+ Test("@n1" eq "@n2");
+ }
+ else {
+ Test(1);
+ }
+}
+
+
+# Test the RowCacheSize attribute
+Test($csr_a = $dbh->prepare("SELECT * FROM ?"));
+Test($dbh->{'RowCacheSize'} == 20);
+Test($csr_a->{'RowCacheSize'} == 20);
+Test($csr_a->execute('long_list_50'));
+Test($csr_a->fetchrow_arrayref());
+Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 19);
+Test($csr_a->finish());
+
+Test($dbh->{'RowCacheSize'} = 30);
+Test($dbh->{'RowCacheSize'} == 30);
+Test($csr_a->{'RowCacheSize'} == 30);
+Test($csr_a->execute('long_list_50'));
+Test($csr_a->fetchrow_arrayref());
+Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 29)
+ or print("Expected 29 records in cache, got " . @{$csr_a->{'proxy_data'}} .
+ "\n");
+Test($csr_a->finish());
+
+
+Test($csr_a->{'RowCacheSize'} = 10);
+Test($dbh->{'RowCacheSize'} == 30);
+Test($csr_a->{'RowCacheSize'} == 10);
+Test($csr_a->execute('long_list_50'));
+Test($csr_a->fetchrow_arrayref());
+Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 9)
+ or print("Expected 9 records in cache, got " . @{$csr_a->{'proxy_data'}} .
+ "\n");
+Test($csr_a->finish());
+
+$dbh->disconnect;
+
+# Test $dbh->func()
+# print "Testing \$dbh->func().\n";
+# my %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables();
+# $ok = 1;
+# foreach my $t ($dbh->func('lib', 'examplep_tables')) {
+# defined(delete $tables{$t}) or print "Unexpected table: $t\n";
+# }
+# Test(%tables == 0);
+
+if ($failed_tests) {
+ warn "Proxy: @child_args\n";
+ for my $class (qw(Net::Daemon RPC::PlServer Storable)) {
+ (my $pm = $class) =~ s/::/\//g; $pm .= ".pm";
+ my $version = eval { $class->VERSION } || '?';
+ warn sprintf "Using %-13s %-6s %s\n", $class, $version, $INC{$pm};
+ }
+ warn join(", ", map { "$_=$ENV{$_}" } grep { /^LC_|LANG/ } keys %ENV)."\n";
+ warn "More info can be found in $dbitracelog\n";
+ #system("cat $dbitracelog");
+}
+
+
+END {
+ local $?;
+ $handle->Terminate() if $handle;
+ undef $handle;
+ unlink $config_file if $config_file;
+ if (!$failed_tests) {
+ unlink 'dbiproxy.log';
+ unlink $dbitracelog if $dbitracelog;
+ }
+};
+
+1;
diff --git a/t/85gofer.t b/t/85gofer.t
new file mode 100644
index 0000000..8208195
--- /dev/null
+++ b/t/85gofer.t
@@ -0,0 +1,264 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use Cwd;
+use Config;
+use Data::Dumper;
+use Test::More 0.84;
+use Getopt::Long;
+
+use DBI qw(dbi_time);
+
+if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity
+ plan skip_all => "transport+policy tests skipped with non-gofer DBI_AUTOPROXY"
+ if $ap !~ /^dbi:Gofer/i;
+ plan skip_all => "transport+policy tests skipped with non-pedantic policy in DBI_AUTOPROXY"
+ if $ap !~ /policy=pedantic\b/i;
+}
+
+do "t/lib.pl";
+
+# 0=SQL::Statement if avail, 1=DBI::SQL::Nano
+# next line forces use of Nano rather than default behaviour
+# $ENV{DBI_SQL_NANO}=1;
+# This is done in zvn_50dbm.t
+
+GetOptions(
+ 'c|count=i' => \(my $opt_count = (-t STDOUT ? 100 : 0)),
+ 'dbm=s' => \my $opt_dbm,
+ 'v|verbose!' => \my $opt_verbose,
+ 't|transport=s' => \my $opt_transport,
+ 'p|policy=s' => \my $opt_policy,
+) or exit 1;
+
+
+# so users can try others from the command line
+if (!$opt_dbm) {
+ # pick first available, starting with SDBM_File
+ for (qw( SDBM_File GDBM_File DB_File BerkeleyDB )) {
+ if (eval { local $^W; require "$_.pm" }) {
+ $opt_dbm = ($_);
+ last;
+ }
+ }
+ plan skip_all => 'No DBM modules available' if !$opt_dbm;
+}
+
+my @remote_dsns = DBI->data_sources( "dbi:DBM:", {
+ dbm_type => $opt_dbm,
+ f_lockfile => 0,
+ f_dir => test_dir() } );
+my $remote_dsn = $remote_dsns[0];
+( my $remote_driver_dsn = $remote_dsn ) =~ s/dbi:dbm://i;
+# Long timeout for slow/overloaded systems (incl virtual machines with low priority)
+my $timeout = 240;
+
+if ($ENV{DBI_AUTOPROXY}) {
+ # this means we have DBD::Gofer => DBD::Gofer => DBD::DBM!
+ # rather than disable it we let it run because we're twisted
+ # and because it helps find more bugs (though debugging can be painful)
+ warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n"
+ unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t
+}
+
+# ensure subprocess (for pipeone and stream transport) will use the same modules as us, ie ./blib
+local $ENV{PERL5LIB} = join $Config{path_sep}, @INC;
+
+my %durations;
+my $getcwd = getcwd();
+my $username = eval { getpwuid($>) } || ''; # fails on windows
+my $can_ssh = ($username && $username eq 'timbo' && -d '.svn'
+ && system("sh -c 'echo > /dev/tcp/localhost/22' 2>/dev/null")==0
+);
+my $perl = "$^X -Mblib=$getcwd/blib"; # ensure sameperl and our blib (note two spaces)
+
+my %trials = (
+ null => {},
+ pipeone => { perl=>$perl, timeout=>$timeout },
+ stream => { perl=>$perl, timeout=>$timeout },
+ stream_ssh => ($can_ssh)
+ ? { perl=>$perl, timeout=>$timeout, url => "ssh:$username\@localhost" }
+ : undef,
+ #http => { url => "http://localhost:8001/gofer" },
+);
+
+# too dependant on local config to make a standard test
+delete $trials{http} unless $username eq 'timbo' && -d '.svn';
+
+my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials);
+note("Transports: @transports");
+my @policies = ($opt_policy) ? ($opt_policy) : qw(pedantic classic rush);
+note("Policies: @policies");
+note("Count: $opt_count");
+
+for my $trial (@transports) {
+ (my $transport = $trial) =~ s/_.*//;
+ my $trans_attr = $trials{$trial}
+ or next;
+
+ # XXX temporary restrictions, hopefully
+ if ( ($^O eq 'MSWin32') || ($^O eq 'VMS') ) {
+ # stream needs Fcntl macro F_GETFL for non-blocking
+ # and pipe seems to hang on some windows systems
+ next if $transport eq 'stream' or $transport eq 'pipeone';
+ }
+
+ for my $policy_name (@policies) {
+
+ eval { run_tests($transport, $trans_attr, $policy_name) };
+ ($@) ? fail("$trial: $@") : pass();
+
+ }
+}
+
+# to get baseline for comparisons if doing performance testing
+run_tests('no', {}, 'pedantic') if $opt_count;
+
+while ( my ($activity, $stats_hash) = each %durations ) {
+ note("");
+ $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+pedantic"};
+ for my $perf_tag (reverse sort keys %$stats_hash) {
+ my $dur = $stats_hash->{$perf_tag} || 0.0000001;
+ note sprintf " %6s %-16s: %.6fsec (%5d/sec)",
+ $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur;
+ my $baseline_dur = $stats_hash->{'~baseline~'};
+ note sprintf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000
+ unless $perf_tag eq '~baseline~';
+ note "";
+ }
+}
+
+
+sub run_tests {
+ my ($transport, $trans_attr, $policy_name) = @_;
+
+ my $policy = get_policy($policy_name);
+ my $skip_gofer_checks = ($transport eq 'no');
+
+
+ my $test_run_tag = "Testing $transport transport with $policy_name policy";
+ note "=============";
+ note "$test_run_tag";
+
+ my $driver_dsn = "transport=$transport;policy=$policy_name";
+ $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys %$trans_attr
+ if %$trans_attr;
+
+ my $dsn = "dbi:Gofer:$driver_dsn;dsn=$remote_dsn";
+ $dsn = $remote_dsn if $transport eq 'no';
+ note " $dsn";
+
+ my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1, PrintError => 0, ShowErrorStatement => 1 } );
+ die "$test_run_tag aborted: $DBI::errstr\n" unless $dbh; # no point continuing
+ ok $dbh, sprintf "should connect to %s", $dsn;
+
+ is $dbh->{Name}, ($policy->skip_connect_check)
+ ? $driver_dsn
+ : $remote_driver_dsn;
+
+ END { unlink glob "fruit.???" }
+ ok $dbh->do("DROP TABLE IF EXISTS fruit");
+ ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))");
+ die "$test_run_tag aborted ($DBI::errstr)\n" if $DBI::err;
+
+ my $sth = do {
+ local $dbh->{RaiseError} = 0;
+ $dbh->prepare("complete non-sql gibberish");
+ };
+ ($policy->skip_prepare_check)
+ ? isa_ok $sth, 'DBI::st'
+ : is $sth, undef, 'should detect prepare failure';
+
+ ok my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)");
+ ok $ins_sth->execute(1, 'oranges');
+ ok $ins_sth->execute(2, 'oranges');
+
+ my $rowset;
+ ok $rowset = $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit ORDER BY dKey");
+ is_deeply($rowset, [ [ '1', 'oranges' ], [ '2', 'oranges' ] ]);
+
+ ok $dbh->do("UPDATE fruit SET dVal='apples' WHERE dVal='oranges'");
+ ok $dbh->{go_response}->executed_flag_set, 'go_response executed flag should be true'
+ unless $skip_gofer_checks && pass();
+
+ ok $sth = $dbh->prepare("SELECT dKey, dVal FROM fruit");
+ ok $sth->execute;
+ ok $rowset = $sth->fetchall_hashref('dKey');
+ is_deeply($rowset, { '1' => { dKey=>1, dVal=>'apples' }, 2 => { dKey=>2, dVal=>'apples' } });
+
+ if ($opt_count and $transport ne 'pipeone') {
+ note "performance check - $opt_count selects and inserts";
+ my $start = dbi_time();
+ $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit")
+ for (1000..1000+$opt_count);
+ $durations{select}{"$transport+$policy_name"} = dbi_time() - $start;
+
+ # some rows in to get a (*very* rough) idea of overheads
+ $start = dbi_time();
+ $ins_sth->execute($_, 'speed')
+ for (1000..1000+$opt_count);
+ $durations{insert}{"$transport+$policy_name"} = dbi_time() - $start;
+ }
+
+ note "Testing go_request_count and caching of simple values";
+ my $go_request_count = $dbh->{go_request_count};
+ ok $go_request_count
+ unless $skip_gofer_checks && pass();
+
+ ok $dbh->do("DROP TABLE fruit");
+ is ++$go_request_count, $dbh->{go_request_count}
+ unless $skip_gofer_checks && pass();
+
+ # tests go_request_count, caching, and skip_default_methods policy
+ my $use_remote = ($policy->skip_default_methods) ? 0 : 1;
+ note sprintf "use_remote=%s (policy=%s, transport=%s) %s",
+ $use_remote, $policy_name, $transport, $dbh->{dbi_default_methods}||'';
+
+SKIP: {
+ skip "skip_default_methods checking doesn't work with Gofer over Gofer", 3
+ if $ENV{DBI_AUTOPROXY} or $skip_gofer_checks;
+ $dbh->data_sources({ foo_bar => $go_request_count });
+ is $dbh->{go_request_count}, $go_request_count + 1*$use_remote;
+ $dbh->data_sources({ foo_bar => $go_request_count }); # should use cache
+ is $dbh->{go_request_count}, $go_request_count + 1*$use_remote;
+ @_=$dbh->data_sources({ foo_bar => $go_request_count }); # no cached yet due to wantarray
+ is $dbh->{go_request_count}, $go_request_count + 2*$use_remote;
+}
+
+SKIP: {
+ skip "caching of metadata methods returning sth not yet implemented", 2;
+ note "Testing go_request_count and caching of sth";
+ $go_request_count = $dbh->{go_request_count};
+ my $sth_ti1 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count });
+ is $go_request_count + 1, $dbh->{go_request_count};
+
+ my $sth_ti2 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); # should use cache
+ is $go_request_count + 1, $dbh->{go_request_count};
+}
+
+ ok $dbh->disconnect;
+}
+
+sub get_policy {
+ my ($policy_class) = @_;
+ $policy_class = "DBD::Gofer::Policy::$policy_class" unless $policy_class =~ /::/;
+ _load_class($policy_class) or die $@;
+ return $policy_class->new();
+}
+
+sub _load_class { # return true or false+$@
+ my $class = shift;
+ (my $pm = $class) =~ s{::}{/}g;
+ $pm .= ".pm";
+ return 1 if eval { require $pm };
+ delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough
+ undef; # error in $@
+}
+
+done_testing;
+
+1;
diff --git a/t/86gofer_fail.t b/t/86gofer_fail.t
new file mode 100644
index 0000000..9a7b82b
--- /dev/null
+++ b/t/86gofer_fail.t
@@ -0,0 +1,168 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use DBI;
+use Data::Dumper;
+use Test::More;
+sub between_ok;
+
+# here we test the DBI_GOFER_RANDOM mechanism
+# and how gofer deals with failures
+
+plan skip_all => "requires Callbacks which are not supported with PurePerl" if $DBI::PurePerl;
+
+if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity
+ plan skip_all => "Gofer DBI_AUTOPROXY" if $ap =~ /^dbi:Gofer/i;
+
+ # this means we have DBD::Gofer => DBD::Gofer => DBD::whatever
+ # rather than disable it we let it run because we're twisted
+ # and because it helps find more bugs (though debugging can be painful)
+ warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n"
+ unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t
+}
+
+plan 'no_plan';
+
+my $tmp;
+my $dbh;
+my $fails;
+
+# we'll use the null transport for simplicity and speed
+# and the rush policy to limit the number of interactions with the gofer executor
+
+# silence the "DBI_GOFER_RANDOM..." warnings
+my @warns;
+$SIG{__WARN__} = sub { ("@_" =~ /^DBI_GOFER_RANDOM/) ? push(@warns, @_) : warn @_; };
+
+# --- 100% failure rate
+
+($fails, $dbh) = trial_impact("fail=100%,do", 10, "", sub { $_->do("set foo=1") });
+is $fails, 100, 'should fail 100% of the time';
+ok $@, '$@ should be set';
+like $@, '/fake error from do method induced by DBI_GOFER_RANDOM/';
+ok $dbh->errstr, 'errstr should be set';
+like $dbh->errstr, '/DBI_GOFER_RANDOM/', 'errstr should contain DBI_GOFER_RANDOM';
+ok !$dbh->{go_response}->executed_flag_set, 'go_response executed flag should be false';
+
+
+# XXX randomness can't be predicted, so it's just possible these will fail
+srand(42); # try to limit occasional failures (effect will vary by platform etc)
+
+sub trial_impact {
+ my ($spec, $count, $dsn_attr, $code, $verbose) = @_;
+ local $ENV{DBI_GOFER_RANDOM} = $spec;
+ my $dbh = dbi_connect("policy=rush;$dsn_attr");
+ local $_ = $dbh;
+ my $fail_percent = percentage_exceptions(200, $code, $verbose);
+ return $fail_percent unless wantarray;
+ return ($fail_percent, $dbh);
+}
+
+# --- 50% failure rate, with no retries
+
+$fails = trial_impact("fail=50%,do", 200, "retry_limit=0", sub { $_->do("set foo=1") });
+print "target approx 50% random failures, got $fails%\n";
+between_ok $fails, 10, 90, "should fail about 50% of the time, but at least between 10% and 90%";
+
+# --- 50% failure rate, with many retries (should yield low failure rate)
+
+$fails = trial_impact("fail=50%,prepare", 200, "retry_limit=5", sub { $_->prepare("set foo=1") });
+print "target less than 20% effective random failures (ideally 0), got $fails%\n";
+cmp_ok $fails, '<', 20, 'should fail < 20%';
+
+# --- 10% failure rate, with many retries (should yield zero failure rate)
+
+$fails = trial_impact("fail=10,do", 200, "retry_limit=10", sub { $_->do("set foo=1") });
+cmp_ok $fails, '<', 1, 'should fail < 1%';
+
+# --- 50% failure rate, test is_idempotent
+
+$ENV{DBI_GOFER_RANDOM} = "fail=50%,do"; # 50%
+
+# test go_retry_hook and that ReadOnly => 1 retries a non-idempotent statement
+ok my $dbh_50r1ro = dbi_connect("policy=rush;retry_limit=1", {
+ go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 },
+ ReadOnly => 1,
+} );
+between_ok percentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }),
+ 10, 40, 'should fail ~25% (ie 50% with one retry)';
+between_ok $dbh_50r1ro->{go_transport}->meta->{request_retry_count},
+ 20, 80, 'transport request_retry_count should be around 50';
+
+# test as above but with ReadOnly => 0
+ok my $dbh_50r1rw = dbi_connect("policy=rush;retry_limit=1", {
+ go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 },
+ ReadOnly => 0,
+} );
+between_ok percentage_exceptions(100, sub { $dbh_50r1rw->do("set foo=1") }),
+ 20, 80, 'should fail ~50%, ie no retries';
+ok !$dbh_50r1rw->{go_transport}->meta->{request_retry_count},
+ 'transport request_retry_count should be zero or undef';
+
+
+# --- check random is random and non-random is non-random
+
+my %fail_percents;
+for (1..5) {
+ $fails = trial_impact("fail=50%,do", 10, "", sub { $_->do("set foo=1") });
+ ++$fail_percents{$fails};
+}
+cmp_ok scalar keys %fail_percents, '>=', 2, 'positive percentage should fail randomly';
+
+%fail_percents = ();
+for (1..5) {
+ $fails = trial_impact("fail=-50%,do", 10, "", sub { $_->do("set foo=1") });
+ ++$fail_percents{$fails};
+}
+is scalar keys %fail_percents, 1, 'negative percentage should fail non-randomly';
+
+# ---
+print "Testing random delay\n";
+
+$ENV{DBI_GOFER_RANDOM} = "delay0.1=51%,do"; # odd percentage to force warn()s
+@warns = ();
+ok $dbh = dbi_connect("policy=rush;retry_limit=0");
+is percentage_exceptions(20, sub { $dbh->do("set foo=1") }),
+ 0, "should not fail for DBI_GOFER_RANDOM='$ENV{DBI_GOFER_RANDOM}'";
+my $delays = grep { m/delaying execution/ } @warns;
+between_ok $delays, 1, 19, 'should be delayed around 5 times';
+
+exit 0;
+
+# --- subs ---
+#
+sub between_ok {
+ my ($got, $min, $max, $label) = @_;
+ local $Test::Builder::Level = 2;
+ cmp_ok $got, '>=', $min, "$label (got $got)";
+ cmp_ok $got, '<=', $max, "$label (got $got)";
+}
+
+sub dbi_connect {
+ my ($gdsn, $attr) = @_;
+ return DBI->connect("dbi:Gofer:transport=null;$gdsn;dsn=dbi:ExampleP:", 0, 0, {
+ RaiseError => 1, PrintError => 0, ($attr) ? %$attr : ()
+ });
+}
+
+sub percentage_exceptions {
+ my ($count, $sub, $verbose) = @_;
+ my $i = $count;
+ my $exceptions = 0;
+ while ($i--) {
+ eval { $sub->() };
+ warn sprintf("percentage_exceptions $i: %s\n", $@|| $DBI::errstr || '') if $verbose;
+ if ($@) {
+ die "Unexpected failure: $@" unless $@ =~ /DBI_GOFER_RANDOM/;
+ ++$exceptions;
+ }
+ }
+ warn sprintf "percentage_exceptions %f/%f*100 = %f\n",
+ $exceptions, $count, $exceptions/$count*100
+ if $verbose;
+ return $exceptions/$count*100;
+}
diff --git a/t/87gofer_cache.t b/t/87gofer_cache.t
new file mode 100644
index 0000000..9ad2aeb
--- /dev/null
+++ b/t/87gofer_cache.t
@@ -0,0 +1,108 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use DBI;
+use Data::Dumper;
+use Test::More;
+use DBI::Util::CacheMemory;
+
+plan skip_all => "Gofer DBI_AUTOPROXY" if (($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer/i);
+
+plan 'no_plan';
+
+
+my $dsn = "dbi:Gofer:transport=null;policy=classic;dsn=dbi:ExampleP:";
+
+my @cache_classes = qw(DBI::Util::CacheMemory);
+push @cache_classes, "Cache::Memory" if eval { require Cache::Memory };
+push @cache_classes, "1"; # test alias for DBI::Util::CacheMemory
+
+for my $cache_class (@cache_classes) {
+ my $cache_obj = ($cache_class eq "1") ? $cache_class : $cache_class->new();
+ run_tests($cache_obj);
+}
+
+
+sub run_tests {
+ my $cache_obj = shift;
+
+ my $tmp;
+ print " using $cache_obj for $dsn\n";
+
+ my $dbh = DBI->connect($dsn, undef, undef, {
+ go_cache => $cache_obj,
+ RaiseError => 1, PrintError => 0, ShowErrorStatement => 1,
+ } );
+ ok my $go_transport = $dbh->{go_transport};
+ ok my $go_cache = $go_transport->go_cache;
+
+ # setup
+ $go_cache->clear;
+ is $go_cache->count, 0, 'cache should be empty after clear';
+
+ $go_transport->transmit_count(0);
+ is $go_transport->transmit_count, 0, 'transmit_count should be 0';
+
+ $go_transport->cache_hit(0);
+ $go_transport->cache_miss(0);
+ $go_transport->cache_store(0);
+
+ # request 1
+ ok my $rows1 = $dbh->selectall_arrayref("select name from ?", {}, ".");
+ cmp_ok $go_cache->count, '>', 0, 'cache should not be empty after select';
+
+ my $expected = ($ENV{DBI_AUTOPROXY}) ? 2 : 1;
+ is $go_transport->cache_hit, 0;
+ is $go_transport->cache_miss, $expected;
+ is $go_transport->cache_store, $expected;
+
+ is $go_transport->transmit_count, $expected, 'should make 1 round trip';
+ $go_transport->transmit_count(0);
+ is $go_transport->transmit_count, 0, 'transmit_count should be 0';
+
+ # request 2
+ ok my $rows2 = $dbh->selectall_arrayref("select name from ?", {}, ".");
+ is_deeply $rows2, $rows1;
+ is $go_transport->transmit_count, 0, 'should make 1 round trip';
+
+ is $go_transport->cache_hit, $expected;
+ is $go_transport->cache_miss, $expected;
+ is $go_transport->cache_store, $expected;
+}
+
+
+print "test per-sth go_cache\n";
+
+my $dbh = DBI->connect($dsn, undef, undef, {
+ go_cache => 1,
+ RaiseError => 1, PrintError => 0, ShowErrorStatement => 1,
+} );
+ok my $go_transport = $dbh->{go_transport};
+ok my $dbh_cache = $go_transport->go_cache;
+$dbh_cache->clear; # discard ping from connect
+
+my $cache2 = DBI::Util::CacheMemory->new( namespace => "foo2" );
+ok $cache2;
+ok $cache2 != $dbh_cache;
+
+my $sth1 = $dbh->prepare("select name from ?");
+is $sth1->go_cache, $dbh_cache;
+is $dbh_cache->size, 0;
+ok $dbh->selectall_arrayref($sth1, undef, ".");
+ok $dbh_cache->size;
+
+my $sth2 = $dbh->prepare("select * from ?", { go_cache => $cache2 });
+is $sth2->go_cache, $cache2;
+is $cache2->size, 0;
+ok $dbh->selectall_arrayref($sth2, undef, ".");
+ok $cache2->size;
+
+cmp_ok $cache2->size, '>', $dbh_cache->size;
+
+
+
+1;
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;
diff --git a/t/lib.pl b/t/lib.pl
new file mode 100644
index 0000000..e1512c6
--- /dev/null
+++ b/t/lib.pl
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+
+# lib.pl is the file where database specific things should live,
+# whereever possible. For example, you define certain constants
+# here and the like.
+
+use strict;
+
+use File::Basename;
+use File::Path;
+use File::Spec;
+
+my $test_dir;
+END { defined( $test_dir ) and rmtree $test_dir }
+
+sub test_dir
+{
+ unless( defined( $test_dir ) )
+ {
+ $test_dir = File::Spec->rel2abs( File::Spec->curdir () );
+ $test_dir = File::Spec->catdir ( $test_dir, "test_output_" . $$ );
+ $test_dir = VMS::Filespec::unixify($test_dir) if $^O eq 'VMS';
+ rmtree $test_dir;
+ mkpath $test_dir;
+ # There must be at least one directory in the test directory,
+ # and nothing guarantees that dot or dot-dot directories will exist.
+ mkpath ( File::Spec->catdir( $test_dir, '000_just_testing' ) );
+ }
+
+ return $test_dir;
+}
+
+1;
diff --git a/t/pod-coverage.t b/t/pod-coverage.t
new file mode 100644
index 0000000..64c2d58
--- /dev/null
+++ b/t/pod-coverage.t
@@ -0,0 +1,8 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+plan skip_all => "Currently a developer-only test" unless -d '.svn' || -d ".git";
+plan skip_all => "Currently FAILS FOR MANY MODULES!";
+all_pod_coverage_ok();
diff --git a/t/pod.t b/t/pod.t
new file mode 100644
index 0000000..23acc7d
--- /dev/null
+++ b/t/pod.t
@@ -0,0 +1,8 @@
+#!perl -w
+
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+
+1;
View Lorry Controller Status