diff options
Diffstat (limited to 't')
-rwxr-xr-x | t/01basics.t | 336 | ||||
-rwxr-xr-x | t/02dbidrv.t | 254 | ||||
-rw-r--r-- | t/03handle.t | 410 | ||||
-rw-r--r-- | t/04mods.t | 59 | ||||
-rw-r--r-- | t/05concathash.t | 190 | ||||
-rw-r--r-- | t/06attrs.t | 311 | ||||
-rw-r--r-- | t/07kids.t | 102 | ||||
-rw-r--r-- | t/08keeperr.t | 291 | ||||
-rw-r--r-- | t/09trace.t | 137 | ||||
-rw-r--r-- | t/10examp.t | 579 | ||||
-rw-r--r-- | t/11fetch.t | 124 | ||||
-rw-r--r-- | t/12quote.t | 48 | ||||
-rw-r--r-- | t/13taint.t | 133 | ||||
-rw-r--r-- | t/14utf8.t | 76 | ||||
-rw-r--r-- | t/15array.t | 254 | ||||
-rw-r--r-- | t/16destroy.t | 147 | ||||
-rw-r--r-- | t/19fhtrace.t | 306 | ||||
-rw-r--r-- | t/20meta.t | 32 | ||||
-rw-r--r-- | t/30subclass.t | 182 | ||||
-rw-r--r-- | t/31methcache.t | 153 | ||||
-rw-r--r-- | t/35thrclone.t | 81 | ||||
-rw-r--r-- | t/40profile.t | 485 | ||||
-rw-r--r-- | t/41prof_dump.t | 105 | ||||
-rw-r--r-- | t/42prof_data.t | 150 | ||||
-rw-r--r-- | t/43prof_env.t | 52 | ||||
-rw-r--r-- | t/48dbi_dbd_sqlengine.t | 81 | ||||
-rw-r--r-- | t/49dbd_file.t | 174 | ||||
-rwxr-xr-x | t/50dbm_simple.t | 264 | ||||
-rw-r--r-- | t/51dbm_file.t | 130 | ||||
-rw-r--r-- | t/52dbm_complex.t | 359 | ||||
-rwxr-xr-x | t/60preparse.t | 148 | ||||
-rw-r--r-- | t/65transact.t | 35 | ||||
-rw-r--r-- | t/70callbacks.t | 207 | ||||
-rw-r--r-- | t/72childhandles.t | 149 | ||||
-rw-r--r-- | t/80proxy.t | 473 | ||||
-rw-r--r-- | t/85gofer.t | 264 | ||||
-rw-r--r-- | t/86gofer_fail.t | 168 | ||||
-rw-r--r-- | t/87gofer_cache.t | 108 | ||||
-rw-r--r-- | t/90sql_type_cast.t | 148 | ||||
-rw-r--r-- | t/lib.pl | 33 | ||||
-rw-r--r-- | t/pod-coverage.t | 8 | ||||
-rw-r--r-- | t/pod.t | 8 |
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(); @@ -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; |