diff options
Diffstat (limited to 't')
79 files changed, 6051 insertions, 0 deletions
diff --git a/t/01_compile.t b/t/01_compile.t new file mode 100644 index 0000000..eab165c --- /dev/null +++ b/t/01_compile.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +# Test that everything compiles, so the rest of the test suite can +# load modules without having to check if it worked. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More tests => 3; + +use_ok('DBI'); +use_ok('DBD::SQLite'); +use_ok('t::lib::Test'); + +diag("\$DBI::VERSION=$DBI::VERSION"); + +if (my @compile_options = DBD::SQLite::compile_options()) { + diag("Compile Options:"); + diag(join "", map { " $_\n" } @compile_options); +} diff --git a/t/02_logon.t b/t/02_logon.t new file mode 100644 index 0000000..a8c607d --- /dev/null +++ b/t/02_logon.t @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +# Tests basic login and pragma setting + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 18 * @CALL_FUNCS + 1; + +my $show_diag = 0; +foreach my $call_func (@CALL_FUNCS) { + + # Ordinary connect + SCOPE: { + my $dbh = connect_ok(); + ok( $dbh->{sqlite_version}, '->{sqlite_version} ok' ); + is( $dbh->{AutoCommit}, 1, 'AutoCommit is on by default' ); + diag("sqlite_version=$dbh->{sqlite_version}") unless $show_diag++; + ok( $dbh->$call_func('busy_timeout'), 'Found initial busy_timeout' ); + ok( $dbh->$call_func(5000, 'busy_timeout') ); + is( $dbh->$call_func('busy_timeout'), 5000, 'Set busy_timeout to new value' ); + } + + # Attributes in the connect string + SKIP: { + unless ( $] >= 5.008005 ) { + skip( 'Unicode is not supported before 5.8.5', 2 ); + } + my $file = 'foo'.$$; + my $dbh = DBI->connect( "dbi:SQLite:dbname=$file;sqlite_unicode=1", '', '' ); + isa_ok( $dbh, 'DBI::db' ); + is( $dbh->{sqlite_unicode}, 1, 'Unicode is on' ); + $dbh->disconnect; + unlink $file; + } + + # dbname, db, database + SCOPE: { + for my $key (qw/database db dbname/) { + my $file = 'foo'.$$; + unlink $file if -f $file; + ok !-f $file, 'database file does not exist'; + my $dbh = DBI->connect("dbi:SQLite:$key=$file"); + isa_ok( $dbh, 'DBI::db' ); + ok -f $file, "database file (specified by $key=$file) now exists"; + $dbh->disconnect; + unlink $file; + } + } + + # Connect to a memory database + SCOPE: { + my $dbh = DBI->connect( 'dbi:SQLite:dbname=:memory:', '', '' ); + isa_ok( $dbh, 'DBI::db' ); + } +} diff --git a/t/03_create_table.t b/t/03_create_table.t new file mode 100644 index 0000000..4c13449 --- /dev/null +++ b/t/03_create_table.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +# Tests simple table creation + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 7; +use Test::NoWarnings; + +my $dbh = connect_ok(); +$dbh->do(<<'END_SQL'); +CREATE TABLE f +( +f1 integer NOT NULL PRIMARY KEY, +f2 integer, +f3 text +) +END_SQL + +# Confirm fix for #34408: Primary key name wrong with newline in CREATE TABLE +my $pkh = $dbh->primary_key_info( undef, undef, 'f' ); +my @pk = $pkh->fetchall_arrayref(); +is_deeply( \@pk, [ [ [ undef, 'main', 'f', 'f1', 1, 'PRIMARY KEY' ] ] ], '->primary_key_info ok' ); + +my $sth = $dbh->prepare("SELECT f.f1, f.* FROM f"); +isa_ok( $sth, 'DBI::st' ); +ok( $sth->execute, '->execute ok' ); +my $names = $sth->{NAME}; +is( scalar(@$names), 4, 'Got 4 columns' ); +is_deeply( $names, [ 'f1', 'f1', 'f2', 'f3' ], 'Table prepending is disabled by default' ); + diff --git a/t/04_insert.t b/t/04_insert.t new file mode 100644 index 0000000..08ed7a3 --- /dev/null +++ b/t/04_insert.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 14; +use Test::NoWarnings; + +my $dbh = connect_ok(); + +ok( $dbh->do("CREATE TABLE f (f1, f2, f3)"), 'CREATE TABLE f' ); +ok( $dbh->do("delete from f"), 'DELETE FROM f' ); + +SCOPE: { + my $sth = $dbh->prepare("INSERT INTO f VALUES (?, ?, ?)", { go_last_insert_id_args => [undef, undef, undef, undef] }); + isa_ok($sth, 'DBI::st'); + my $rows = $sth->execute("Fred", "Bloggs", "fred\@bloggs.com"); + is( $rows, 1, '->execute returns 1 row' ); + + is( $sth->execute("test", "test", "1"), 1 ); + is( $sth->execute("test", "test", "2"), 1 ); + is( $sth->execute("test", "test", "3"), 1 ); + + SKIP: { + skip( 'last_insert_id requires DBI v1.43', 2 ) if $DBI::VERSION < 1.43; + is( $dbh->last_insert_id(undef, undef, undef, undef), 4 ); + is( $dbh->func('last_insert_rowid'), 4, 'last_insert_rowid should be 4' ); + } + + SKIP: { + skip( 'method installation requires DBI v1.608', 2 ) if $DBI::VERSION < 1.608; + can_ok($dbh, 'sqlite_last_insert_rowid'); + is( $dbh->sqlite_last_insert_rowid, 4, 'last_insert_rowid should be 4' ); + } +} + +is( $dbh->do("delete from f where f1='test'"), 3 ); diff --git a/t/05_select.t b/t/05_select.t new file mode 100644 index 0000000..73bd76b --- /dev/null +++ b/t/05_select.t @@ -0,0 +1,62 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 22; +use Test::NoWarnings; + +my $dbh = connect_ok( RaiseError => 1 ); +$dbh->do("CREATE TABLE f (f1, f2, f3)"); +my $sth = $dbh->prepare("INSERT INTO f VALUES (?, ?, ?)", { go_last_insert_id_args => [undef, undef, undef, undef] }); +$sth->execute("Fred", "Bloggs", "fred\@bloggs.com"); + +$sth = $dbh->prepare("SELECT * FROM f"); +ok($sth); +ok($sth->execute); +my $row = $sth->fetch; +ok($row); +is(@$row, 3); +my $rows = $sth->execute; +ok($rows); +ok($sth->fetch); +$sth->finish; +$sth = $dbh->prepare("INSERT INTO f (f1, f2, f3) VALUES (?, ?, ?)"); +ok($sth); +ok($sth->execute("test", "test", 1)); +$sth->finish; +$sth = $dbh->prepare("DELETE FROM f WHERE f3 = ?"); +ok($sth); +ok($sth->execute("1")); +$sth->finish; +$sth = $dbh->prepare("SELECT * FROM f"); +ok($sth); +ok($sth->execute()); +my $num_rows = 0; +while ($row = $sth->fetch) { + $num_rows++; +} +is($num_rows, 1, "Check num_rows ($num_rows) == 1"); +$sth->finish; +$dbh->do("delete from f where f1='test'"); +$sth = $dbh->prepare("INSERT INTO f (f1, f2, f3) VALUES (?, ?, ?)"); +ok($sth); +ok($sth->execute("test", "test", 1.05)); +$sth = $dbh->prepare("DELETE FROM f WHERE f3 = ?"); +ok($sth); +ok($sth->execute("1.05")); +$sth->finish; +$sth = $dbh->prepare("SELECT * FROM f"); +ok($sth); +ok($sth->execute()); +$num_rows = 0; +while ($row = $sth->fetch) { + $num_rows++; +} +ok($num_rows == 1); +$sth->finish; +$dbh->do("delete from f where f1='test'"); diff --git a/t/06_tran.t b/t/06_tran.t new file mode 100644 index 0000000..c3c9bc1 --- /dev/null +++ b/t/06_tran.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 6; +use Test::NoWarnings; + +my $dbh = connect_ok( + AutoCommit => 0, + RaiseError => 1, +); + +ok $dbh->{sqlite_use_immediate_transaction}, "sqlite_use_immediate_transaction is true by default"; + +$dbh->do("CREATE TABLE MST (id, lbl)"); +$dbh->do("CREATE TABLE TRN (no, id, qty)"); + +$dbh->commit; +$dbh->do("INSERT INTO MST VALUES(1, 'ITEM1')"); +$dbh->do("INSERT INTO MST VALUES(2, 'ITEM2')"); +$dbh->do("INSERT INTO MST VALUES(3, 'ITEM3')"); +$dbh->do("INSERT INTO TRN VALUES('A', 1, 5)"); +$dbh->do("INSERT INTO TRN VALUES('B', 2, 2)"); +$dbh->do("INSERT INTO TRN VALUES('C', 1, 4)"); +$dbh->do("INSERT INTO TRN VALUES('D', 3, 3)"); +$dbh->rollback; + +my $sth = $dbh->prepare( +"SELECT TRN.id AS ID, MST.LBL AS TITLE, + SUM(qty) AS TOTAL FROM TRN,MST +WHERE TRN.ID = MST.ID +GROUP BY TRN.ID ORDER BY TRN.ID DESC"); +my $rows = $sth->execute(); +ok($rows, "0E0"); +my $names = $sth->{NAME}; +print(join(', ', @$names), "\n"); +while(my $raD = $sth->fetchrow_arrayref()) { + print join(":", @$raD), "\n"; +} + +$dbh->rollback; + +{ + my $dbh = connect_ok( + AutoCommit => 0, + RaiseError => 1, + sqlite_use_immediate_transaction => 0, + ); + ok !$dbh->{sqlite_use_immediate_transaction}, "sqlite_use_immediate_transaction is false if you set explicitly"; +} diff --git a/t/07_error.t b/t/07_error.t new file mode 100644 index 0000000..68ea9ca --- /dev/null +++ b/t/07_error.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 8; +use Test::NoWarnings; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0 ); +eval { + $dbh->do('ssdfsdf sdf sd sdfsdfdsf sdfsdf'); +}; +ok($@, 'Statement 1 generated an error'); +is( $DBI::err, 1, '$DBI::err ok' ); +is( $DBI::errstr, 'near "ssdfsdf": syntax error', '$DBI::errstr ok' ); + +$dbh->do('create table testerror (a, b)'); +$dbh->do('insert into testerror values (1, 2)'); +$dbh->do('insert into testerror values (3, 4)'); + +$dbh->do('create unique index testerror_idx on testerror (a)'); +eval { + $dbh->do('insert into testerror values (1, 5)'); +}; +ok($@, 'Statement 2 generated an error'); +is( $DBI::err, 19, '$DBI::err ok' ); +like( $DBI::errstr, qr/column a is not unique/, '$DBI::errstr ok' ); diff --git a/t/08_busy.t b/t/08_busy.t new file mode 100644 index 0000000..049abcf --- /dev/null +++ b/t/08_busy.t @@ -0,0 +1,126 @@ +#!/usr/bin/perl + +# Test that two processes can write at once, assuming we commit timely. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok dbfile @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 11 * @CALL_FUNCS + 1; + +foreach my $call_func (@CALL_FUNCS) { + + my $dbh = connect_ok( + dbfile => 'foo', + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, + ); + + my $dbh2 = connect_ok( + dbfile => 'foo', + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, + ); + + my $dbfile = dbfile('foo'); + + # NOTE: Let's make it clear what we're doing here. + # $dbh starts locking with the first INSERT statement. + # $dbh2 tries to INSERT, but as the database is locked, + # it starts waiting. However, $dbh won't release the lock. + # Eventually $dbh2 gets timed out, and spits an error, saying + # the database is locked. So, we don't need to let $dbh2 wait + # too much here. It should be timed out anyway. + ok($dbh2->$call_func(300, 'busy_timeout')); + + ok($dbh->do("CREATE TABLE Blah ( id INTEGER, val VARCHAR )")); + ok($dbh->commit); + ok($dbh->do("INSERT INTO Blah VALUES ( 1, 'Test1' )")); + eval { + $dbh2->do("INSERT INTO Blah VALUES ( 2, 'Test2' )"); + }; + ok($@); + if ($@) { + print "# expected insert failure : $@"; + $dbh2->rollback; + } + + $dbh->commit; + ok($dbh2->do("INSERT INTO Blah VALUES ( 2, 'Test2' )")); + $dbh2->commit; + + $dbh2->disconnect; + undef($dbh2); + + # NOTE: The second test is to see what happens if a lock is + # is released while waiting. When both parent and child are + # ready, the database is locked by the child. The parent + # starts waiting for a long enough time (apparently we need + # to wait much longer than we expected, as testers may use + # very slow (virtual) machines to test, but don't worry, + # it's only for the slowest environment). After a short sleep, + # the child commits and releases the lock. Eventually the parent + # notices that, and does the pended INSERT (hopefully before + # it is timed out). As both the parent and the child wait till + # both are ready, we don't need to sleep for a long time. + pipe(READER, WRITER); + my $pid = fork; + if (!defined($pid)) { + # fork failed + SKIP: { + skip("No fork here", 3); + } + $dbh->disconnect; + unlink $dbfile; + } elsif (!$pid) { + # child + + # avoid resource collisions after fork + # http://www.slideshare.net/kazuho/un-5457977 + unless ($^O eq 'MSWin32') { # ignore fork emulation + $dbh->{InactiveDestroy} = 1; + undef $dbh; + } + + my $dbh2 = DBI->connect("dbi:SQLite:$dbfile", '', '', + { + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, + }); + $dbh2->do("INSERT INTO Blah VALUES ( 3, 'Test3' )"); + select WRITER; $| = 1; select STDOUT; + print WRITER "Ready\n"; + sleep(2); + $dbh2->commit; + $dbh2->disconnect; + exit; + } else { + # parent + close WRITER; + my $line = <READER>; + chomp($line); + ok($line, "Ready"); + ok($dbh->$call_func(100000, 'busy_timeout')); + eval { $dbh->do("INSERT INTO Blah VALUES (4, 'Test4' )") }; + ok !$@; + if ($@) { + print STDERR "# Your testing environment might be too slow to pass this test: $@"; + $dbh->rollback; + } + else { + $dbh->commit; + } + wait; + $dbh->disconnect; + unlink $dbfile; + } +} diff --git a/t/09_create_function.t b/t/09_create_function.t new file mode 100644 index 0000000..a868b5b --- /dev/null +++ b/t/09_create_function.t @@ -0,0 +1,130 @@ +#!/usr/bin/perl + +use 5.00503; +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 29 * @CALL_FUNCS + 1; + +sub now { + return time(); +} + +sub add2 { + my ( $a, $b ) = @_; + return $a + $b; +} + +sub my_sum { + my $sum = 0; + foreach my $x (@_) { + $sum += $x; + } + return $sum; +} + +sub error { + die "function is dying: ", @_, "\n"; +} + +sub void_return { +} + +sub return2 { + return ( 1, 2 ); +} + +sub return_null { + return undef; +} + +sub my_defined { + defined($_[0]) ? 1 : 0; +} + +sub noop { + return $_[0]; +} + +foreach my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok( PrintError => 0 ); + + ok($dbh->$call_func( "now", 0, \&now, "create_function" )); + my $result = $dbh->selectrow_arrayref( "SELECT now()" ); + + ok( $result->[0], 'Got a result' ); + + $dbh->do( 'CREATE TEMP TABLE func_test ( a, b )' ); + $dbh->do( 'INSERT INTO func_test VALUES ( 1, 3 )' ); + $dbh->do( 'INSERT INTO func_test VALUES ( 0, 4 )' ); + + ok($dbh->$call_func( "add2", 2, \&add2, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT add2(1,3)" ); + is($result->[0], 4, "SELECT add2(1,3)" ); + + $result = $dbh->selectall_arrayref( "SELECT add2(a,b) FROM func_test" ); + is_deeply( $result, [ [4], [4] ], "SELECT add2(a,b) FROM func_test" ); + + ok($dbh->$call_func( "my_sum", -1, \&my_sum, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT my_sum( '2', 3, 4, '5')" ); + is( $result->[0], 14, "SELECT my_sum( '2', 3, 4, '5')" ); + + ok($dbh->$call_func( "error", -1, \&error, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT error( 'I died' )" ); + ok( !$result ); + like( $DBI::errstr, qr/function is dying: I died/ ); + + ok($dbh->$call_func( "void_return", -1, \&void_return, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT void_return( 'I died' )" ); + is_deeply( $result, [ undef ], "SELECT void_return( 'I died' )" ); + + ok($dbh->$call_func( "return_null", -1, \&return_null, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT return_null()" ); + is_deeply( $result, [ undef ], "SELECT return_null()" ); + + ok($dbh->$call_func( "return2", -1, \&return2, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT return2()" ); + is_deeply( $result, [ 2 ], "SELECT return2()" ); + + ok($dbh->$call_func( "my_defined", 1, \&my_defined, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT my_defined(1)" ); + is_deeply( $result, [ 1 ], "SELECT my_defined(1)" ); + + $result = $dbh->selectrow_arrayref( "SELECT my_defined('')" ); + is_deeply( $result, [ 1 ], "SELECT my_defined('')" ); + + $result = $dbh->selectrow_arrayref( "SELECT my_defined('abc')" ); + is_deeply( $result, [ 1 ], "SELECT my_defined('abc')" ); + + $result = $dbh->selectrow_arrayref( "SELECT my_defined(NULL)" ); + is_deeply( $result, [ '0' ], "SELECT my_defined(NULL)" ); + + ok($dbh->$call_func( "noop", 1, \&noop, "create_function" )); + $result = $dbh->selectrow_arrayref( "SELECT noop(NULL)" ); + is_deeply( $result, [ undef ], "SELECT noop(NULL)" ); + + $result = $dbh->selectrow_arrayref( "SELECT noop(1)" ); + is_deeply( $result, [ 1 ], "SELECT noop(1)" ); + + $result = $dbh->selectrow_arrayref( "SELECT noop('')" ); + is_deeply( $result, [ '' ], "SELECT noop('')" ); + + $result = $dbh->selectrow_arrayref( "SELECT noop(1.0625)" ); + is_deeply( $result, [ 1.0625 ], "SELECT noop(1.0625)" ); + + # 2147483648 == 1<<31 + $result = $dbh->selectrow_arrayref( "SELECT noop(2147483648)" ); + is_deeply( $result, [ 2147483648 ], "SELECT noop(2147483648)" ); + + $result = $dbh->selectrow_arrayref( "SELECT typeof(noop(2147483648))" ); + is_deeply( $result, [ 'integer' ], "SELECT typeof(noop(2147483648))" ); + + $dbh->disconnect; +} diff --git a/t/10_create_aggregate.t b/t/10_create_aggregate.t new file mode 100644 index 0000000..d796f22 --- /dev/null +++ b/t/10_create_aggregate.t @@ -0,0 +1,135 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 21 * @CALL_FUNCS + 1; + +# Create the aggregate test packages +SCOPE: { + package count_aggr; + + sub new { + bless { count => 0 }, shift; + } + + sub step { + $_[0]{count}++; + return; + } + + sub finalize { + my $c = $_[0]{count}; + $_[0]{count} = undef; + + return $c; + } + + package obj_aggregate; + + sub new { + bless { count => 0 }, shift; + } + + sub step { + $_[0]{count}++ if defined $_[1]; + } + + sub finalize { + my $c = $_[0]{count}; + $_[0]{count} = undef; + return $c; + } + + package fail_aggregate; + + sub new { + my $class = shift; + if ( ref $class ) { + die "new() failed on request" if $class->{'fail'} eq 'new'; + return undef if $class->{'fail'} eq 'undef'; + return bless { %$class }, ref $class; + } else { + return bless { 'fail' => $_[0] }, $class; + } + } + + sub step { + die "step() failed on request" if $_[0]{fail} eq 'step'; + } + + sub finalize { + die "finalize() failed on request" if $_[0]{fail} eq 'finalize'; + } +} + +foreach my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok( PrintError => 0 ); + + $dbh->do( "CREATE TABLE aggr_test ( field )" ); + foreach my $val ( qw/NULL 1 'test'/ ) { + $dbh->do( "INSERT INTO aggr_test VALUES ( $val )" ); + } + + ok($dbh->$call_func( "newcount", 0, "count_aggr", "create_aggregate" )); + my $result = $dbh->selectrow_arrayref( "SELECT newcount() FROM aggr_test" ); + ok( $result && $result->[0] == 3 ); + + # Make sure that the init() function is called correctly + $result = $dbh->selectall_arrayref( "SELECT newcount() FROM aggr_test GROUP BY field" ); + ok( @$result == 3 && $result->[0][0] == 1 && $result->[1][0] == 1 ); + + + # Test aggregate on empty table + $dbh->do( "DROP TABLE aggr_empty_test;" ); + $dbh->do( "CREATE TABLE aggr_empty_test ( field )" ); + $result = $dbh->selectrow_arrayref( "SELECT newcount() FROM aggr_empty_test" ); + ok( $result && !$result->[0] ); + # Make sure that the init() function is called correctly + $result = $dbh->selectrow_arrayref( "SELECT newcount() FROM aggr_empty_test" ); + ok( $result && !$result->[0] ); + + ok($dbh->$call_func( "defined", 1, 'obj_aggregate', "create_aggregate" )); + $result = $dbh->selectrow_arrayref( "SELECT defined(field) FROM aggr_test" ); + ok( $result && $result->[0] == 2 ); + $result = $dbh->selectrow_arrayref( "SELECT defined(field) FROM aggr_test" ); + ok( $result && $result->[0] == 2 ); + $result = $dbh->selectrow_arrayref( "SELECT defined(field) FROM aggr_empty_test" ); + ok( $result && !$result->[0] ); + $result = $dbh->selectrow_arrayref( "SELECT defined(field) FROM aggr_empty_test" ); + ok( $result && !$result->[0] ); + + my $last_warn; + local $SIG{__WARN__} = sub { $last_warn = join "", @_ }; + foreach my $fail ( qw/ new step finalize/ ) { + $last_warn = ''; + my $aggr = fail_aggregate->new( $fail ); + ok($dbh->$call_func( "fail_$fail", -1, $aggr, 'create_aggregate' )); + $result = $dbh->selectrow_arrayref( "SELECT fail_$fail() FROM aggr_test" ); + # ok( !$result && $DBI::errstr =~ /$fail\(\) failed on request/ ); + ok( !defined $result->[0] && $last_warn =~ /$fail\(\) failed on request/ ); + + # No need to check this one, since step() will never be called + # on an empty table + next if $fail eq 'step'; + $result = $dbh->selectrow_arrayref( "SELECT fail_$fail() FROM aggr_empty_test" ); + # ok( !$result && $DBI::errstr =~ /$fail\(\) failed on request/ ); + ok( !defined $result->[0] && $last_warn =~ /$fail\(\) failed on request/ ); + } + + my $aggr = fail_aggregate->new( 'undef' ); + $last_warn = ''; + ok($dbh->$call_func( "fail_undef", -1, $aggr, 'create_aggregate' )); + $result = $dbh->selectrow_arrayref( "SELECT fail_undef() FROM aggr_test" ); + # ok( !$result && $DBI::errstr =~ /new\(\) should return a blessed reference/ ); + ok( !defined $result->[0] && $last_warn =~ /new\(\) should return a blessed reference/ ); + + $dbh->disconnect; +} diff --git a/t/12_unicode.t b/t/12_unicode.t new file mode 100644 index 0000000..bfbe08a --- /dev/null +++ b/t/12_unicode.t @@ -0,0 +1,138 @@ +#!/usr/bin/perl + +# This is a test for correct handling of the "unicode" database +# handle parameter. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +BEGIN { + if ( $] >= 5.008005 ) { + plan( tests => 26 ); + } else { + plan( skip_all => 'Unicode is not supported before 5.8.5' ); + } +} +use Test::NoWarnings; + +# +# Include std stuff +# +use Carp; +use DBI qw(:sql_types); + +# Unintuitively, still has the effect of loading bytes.pm :-) +no bytes; + +# Portable albeit kludgy: detects UTF-8 promotion of $hibyte from +# the abnormal length increase of $string concatenated to it. +sub is_utf8 { + no bytes; + my ($string) = @_; + my $hibyte = pack("C", 0xe9); + my @lengths = map { bytes::length($_) } ($string, $string . $hibyte); + return ($lengths[0] + 1 < $lengths[1]); +} + +# First, some UTF-8 framework self-test: +my @isochars = (ord("K"), 0xf6, ord("n"), ord("i"), ord("g")); +my $bytestring = pack("C*", @isochars); +my $utfstring = pack("U*", @isochars); + +ok(length($bytestring) == @isochars, 'Correct length for $bytestring'); +ok(length($utfstring) == @isochars, 'Correct length for $utfstring'); +ok( + is_utf8($utfstring), + '$utfstring should be marked as UTF-8 by Perl', +); +ok( + ! is_utf8($bytestring), + '$bytestring should *NOT* be marked as UTF-8 by Perl', +); + +# Sends $ain and $bin into TEXT resp. BLOB columns the database, then +# reads them again and returns the result as a list ($aout, $bout). +### Real DBD::SQLite testing starts here +my ($textback, $bytesback); +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo', RaiseError => 1 ); + is( $dbh->{sqlite_unicode}, 0, 'Unicode is off' ); + ok( + $dbh->do("CREATE TABLE table1 (a TEXT, b BLOB)"), + 'CREATE TABLE', + ); + + ($textback, $bytesback) = database_roundtrip($dbh, $bytestring, $bytestring); + + ok( + ! is_utf8($bytesback), + "Reading blob gives binary", + ); + ok( + ! is_utf8($textback), + "Reading text gives binary too (for now)", + ); + is($bytesback, $bytestring, "No blob corruption"); + is($textback, $bytestring, "Same text, different encoding"); +} + +# Start over but now activate Unicode support. +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo', sqlite_unicode => 1 ); + is( $dbh->{sqlite_unicode}, 1, 'Unicode is on' ); + + ($textback, $bytesback) = database_roundtrip($dbh, $utfstring, $bytestring); + + ok(! is_utf8($bytesback), "Reading blob still gives binary"); + ok(is_utf8($textback), "Reading text returns UTF-8"); + ok($bytesback eq $bytestring, "Still no blob corruption"); + ok($textback eq $utfstring, "Same text"); + + my $lengths = $dbh->selectall_arrayref( + "SELECT length(a), length(b) FROM table1" + ); + + ok( + $lengths->[0]->[0] == $lengths->[0]->[1], + "Database actually understands char set" + ) + or + warn "($lengths->[0]->[0] != $lengths->[0]->[1])"; +} + +# Test that passing a string with the utf-8 flag on is handled properly in a BLOB field +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + + ok( utf8::upgrade($bytestring), 'bytestring upgraded to utf-8' ); + ok( utf8::is_utf8($bytestring), 'bytestring has utf-8 flag' ); + + ($textback, $bytesback) = database_roundtrip($dbh, $utfstring, $bytestring); + ok( $bytesback eq $bytestring, 'No blob corruption with utf-8 flag on' ); + + ok( utf8::downgrade($bytestring), 'bytestring downgraded to bytes' ); + ok( !utf8::is_utf8($bytestring), 'bytestring does not have utf-8 flag' ); + + ($textback, $bytesback) = database_roundtrip($dbh, $utfstring, $bytestring); + ok( $bytesback eq $bytestring, 'No blob corruption with utf-8 flag off' ); +} + +sub database_roundtrip { + my ($dbh, $ain, $bin) = @_; + $dbh->do("DELETE FROM table1"); + my $sth = $dbh->prepare("INSERT INTO table1 (a, b) VALUES (?, ?)"); + $sth->bind_param(1, $ain, SQL_VARCHAR); + $sth->bind_param(2, $bin, SQL_BLOB ); + $sth->execute(); + $sth = $dbh->prepare("SELECT a, b FROM table1"); + $sth->execute(); + my @row = $sth->fetchrow_array; + undef $sth; + croak "Bad row length ".@row unless (@row == 2); + @row; +} diff --git a/t/13_create_collation.t b/t/13_create_collation.t new file mode 100644 index 0000000..8849249 --- /dev/null +++ b/t/13_create_collation.t @@ -0,0 +1,146 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok dies @CALL_FUNCS/; +use Test::More; +BEGIN { + my $COLLATION_TESTS = 10; + my $WRITE_ONCE_TESTS = 4; + + if ( $] >= 5.008005 ) { + plan( tests => $COLLATION_TESTS * @CALL_FUNCS + + $WRITE_ONCE_TESTS + 1); + } else { + plan( skip_all => 'Unicode is not supported before 5.8.5' ); + } +} +use Test::NoWarnings; +use Encode qw/decode/; +use DBD::SQLite; + +BEGIN { + # Sadly perl for windows (and probably sqlite, too) may hang + # if the system locale doesn't support european languages. + # en-us should be a safe default. if it doesn't work, use 'C'. + if ( $^O eq 'MSWin32') { + use POSIX 'locale_h'; + setlocale(LC_COLLATE, 'en-us'); + } +} + +# ad hoc collation functions +sub no_accents ($$) { + my ( $a, $b ) = map lc, @_; + tr[àâáäåãçðèêéëìîíïñòôóöõøùûúüý] + [aaaaaacdeeeeiiiinoooooouuuuy] for $a, $b; + $a cmp $b; +} + +sub by_length ($$) { + length($_[0]) <=> length($_[1]) +} + +sub by_num ($$) { + $_[0] <=> $_[1]; +} +sub by_num_desc ($$) { + $_[1] <=> $_[0]; +} + + +# collation 'no_accents' will be automatically loaded on demand +$DBD::SQLite::COLLATION{no_accents} = \&no_accents; + + +$" = ", "; # to embed arrays into message strings + +my $sql = "SELECT txt from collate_test ORDER BY txt"; + + + +# test interaction with the global COLLATION hash ("WriteOnce") + +dies (sub {$DBD::SQLite::COLLATION{perl} = sub {}}, + qr/already registered/, + "can't override builtin perl collation"); + +dies (sub {delete $DBD::SQLite::COLLATION{perl}}, + qr/deletion .* is forbidden/, + "can't delete builtin perl collation"); + +# once a collation is registered, we can't override it ... unless by +# digging into the tied object +$DBD::SQLite::COLLATION{foo} = \&by_num; +dies (sub {$DBD::SQLite::COLLATION{foo} = \&by_num_desc}, + qr/already registered/, + "can't override registered collation"); +my $tied = tied %DBD::SQLite::COLLATION; +delete $tied->{foo}; +$DBD::SQLite::COLLATION{foo} = \&by_num_desc; # override, no longer dies +is($DBD::SQLite::COLLATION{foo}, \&by_num_desc, "overridden collation"); + + + +# now really test the collation functions + +foreach my $call_func (@CALL_FUNCS) { + + for my $use_unicode (0, 1) { + + # connect + my $dbh = connect_ok( RaiseError => 1, sqlite_unicode => $use_unicode ); + + # populate test data + my @words = qw{ + berger Bergèòe bergèòe Bergere + HOT hôôe + héôéòoclite héôaïòe hêôre héòaut + HAT hâôer + féôu fêôe fèöe ferme + }; + if ($use_unicode) { + utf8::upgrade($_) foreach @words; + } + + $dbh->do( 'CREATE TEMP TABLE collate_test ( txt )' ); + $dbh->do( "INSERT INTO collate_test VALUES ( '$_' )" ) foreach @words; + + # test builtin collation "perl" + my @sorted = sort @words; + my $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE perl"); + is_deeply(\@sorted, $db_sorted, "collate perl (@sorted // @$db_sorted)"); + + SCOPE: { + use locale; + @sorted = sort @words; + } + + # test builtin collation "perllocale" + $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE perllocale"); + is_deeply(\@sorted, $db_sorted, + "collate perllocale (@sorted // @$db_sorted)"); + + # test additional collation "no_accents" + @sorted = sort no_accents @words; + $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE no_accents"); + is_deeply(\@sorted, $db_sorted, + "collate no_accents (@sorted // @$db_sorted)"); + + + # manual addition of a collation for this dbh + $dbh->$call_func(by_length => \&by_length, "create_collation"); + @sorted = sort by_length @words; + $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE by_length"); + is_deeply(\@sorted, $db_sorted, + "collate by_length (@sorted // @$db_sorted)"); + } +} + + + + diff --git a/t/14_progress_handler.t b/t/14_progress_handler.t new file mode 100644 index 0000000..21abf5a --- /dev/null +++ b/t/14_progress_handler.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 5 * @CALL_FUNCS + 1; + +my $N_OPCODES = 50; # how many opcodes before calling the progress handler + +# our progress_handler just remembers how many times it was called +my $n_callback = 0; +sub progress_handler { + $n_callback += 1; + return 0; +} + +foreach my $call_func (@CALL_FUNCS) { + $n_callback = 0; # reinitialize + + # connect and register the progress handler + my $dbh = connect_ok( RaiseError => 1 ); + ok($dbh->$call_func( $N_OPCODES, \&progress_handler, "progress_handler" )); + + # populate a temporary table with random numbers + $dbh->do( 'CREATE TEMP TABLE progress_test ( foo )' ); + $dbh->begin_work; + for my $count (1 .. 1000) { + my $rand = rand; + $dbh->do( "INSERT INTO progress_test(foo) VALUES ( $rand )" ); + } + $dbh->commit; + + # let the DB do some work (sorting the random numbers) + my $result = $dbh->do( "SELECT * from progress_test ORDER BY foo " ); + + # now the progress handler should have been called a number of times + ok($n_callback); + + + # unregister the progress handler, set counter back to zero, do more work + ok($dbh->$call_func( $N_OPCODES, undef, "progress_handler" )); + $n_callback = 0; + $result = $dbh->do( "SELECT * from progress_test ORDER BY foo DESC " ); + + # now the progress handler should have been called zero times + ok(!$n_callback); + + $dbh->disconnect; +} diff --git a/t/15_ak_dbd.t b/t/15_ak_dbd.t new file mode 100644 index 0000000..ddde0f7 --- /dev/null +++ b/t/15_ak_dbd.t @@ -0,0 +1,138 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 37; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok( dbfile => 'foo', RaiseError => 1, PrintError => 1, PrintWarn => 1 ); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) +) +END_SQL + +# Test quoting +my $quoted = $dbh->quote('test1'); +is( $quoted, "'test1'", '->quote(test1) ok' ); + +# Disconnect +ok( $dbh->disconnect, '->disconnect' ); + +# Reconnect +$dbh = connect_ok( dbfile => 'foo' ); + +# Delete the table and recreate it +ok( $dbh->do('DROP TABLE one'), 'DROP' ); + +# Create the table again +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NULL, + name CHAR (64) NULL +) +END_SQL + +# Insert into table +ok( $dbh->do("INSERT INTO one VALUES ( 1, 'A' )"), 'INSERT 1' ); + +# Delete it +ok( $dbh->do('DELETE FROM one WHERE id = 1'), 'DELETE 1' ); + +# When we "forget" execute, fail with error message +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id = 1'); + isa_ok( $sth, 'DBI::st' ); + my ($pe) = $sth->{PrintError}; + $sth->{PrintError} = 0; + my $rv = eval { + $sth->fetchrow; + }; + $sth->{PrintError} = $pe; + ok( $sth->execute, '->execute' ); + + # This should fail without error message: No rows returned. + my(@row, $ref); + SCOPE: { + local $^W = 0; + is( $sth->fetch, undef, '->fetch returns undef' ); + } + ok( $sth->finish, '->finish' ); +} + +# This section should exercise the sth->func( '_NumRows' ) private +# method by preparing a statement, then finding the number of rows +# within it. Prior to execution, this should fail. After execution, +# the number of rows affected by the statement will be returned. +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id = 1'); + isa_ok( $sth, 'DBI::st' ); + is( $sth->rows, -1, '->rows is negative' ); + ok( $sth->execute, '->execute ok' ); + is( $sth->rows, 0, '->rows returns 0' ); + ok( $sth->finish, '->finish' ); +} + +# Test whether or not a field containing a NULL is returned correctly +# as undef, or something much more bizarre +ok( $dbh->do("INSERT INTO one VALUES ( NULL, 'NULL-valued id' )"), 'INSERT 2' ); +SCOPE: { + my $sth = $dbh->prepare("SELECT id FROM one WHERE id IS NULL"); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + is_deeply( + $sth->fetchall_arrayref, + [ [ undef ] ], + 'NULL returned ok', + ); + ok( $sth->finish, '->finish' ); +} + +# Delete the test row from the table +ok( $dbh->do("DELETE FROM one WHERE id is NULL AND name = 'NULL-valued id'"), 'DELETE' ); + +# Test whether or not a char field containing a blank is returned +# correctly as blank, or something much more bizarre +ok( $dbh->do("INSERT INTO one VALUES ( 2, NULL )"), 'INSERT 3' ); +SCOPE: { + my $sth = $dbh->prepare("SELECT name FROM one WHERE id = 2 AND name IS NULL"); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + is_deeply( + $sth->fetchall_arrayref, + [ [ undef ] ], + '->fetchall_arrayref', + ); + ok( $sth->finish, '->finish' ); +} + + +# Delete the test row from the table +ok( $dbh->do('DELETE FROM ONE WHERE id = 2 AND name IS NULL'), 'DELETE' ); + +# Test the new funky routines to list the fields applicable to a SELECT +# statement, and not necessarily just those in a table... +SCOPE: { + my $sth = $dbh->prepare("SELECT * FROM one"); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, 'Execute' ); + ok( $sth->execute, 'Reexecute' ); + my @row = $sth->fetchrow_array; + ok( $sth->finish, '->finish' ); +} + +# Insert some more data into the test table......... +ok( $dbh->do("INSERT INTO one VALUES( 2, 'Gary Shea' )"), 'INSERT 4' ); +SCOPE: { + my $sth = $dbh->prepare("UPDATE one SET id = 3 WHERE name = 'Gary Shea'"); + isa_ok( $sth, 'DBI::st' ); +} diff --git a/t/16_column_info.t b/t/16_column_info.t new file mode 100644 index 0000000..9115658 --- /dev/null +++ b/t/16_column_info.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 12; +use Test::NoWarnings; + +my $dbh = DBI->connect('dbi:SQLite:dbname=:memory:',undef,undef,{RaiseError => 1}); + +# 1. Create a table +ok( $dbh->do(<<'END_SQL'), 'Created test table' ); + CREATE TABLE test ( + id INTEGER PRIMARY KEY NOT NULL, + name VARCHAR(255) + ); +END_SQL + +# 2. Create a temporary table +ok( $dbh->do(<<'END_SQL'), 'Created temp test table' ); + CREATE TEMP TABLE test2 ( + id INTEGER PRIMARY KEY NOT NULL, + flag INTEGER + ); +END_SQL + +# 3. Attach a memory database +ok( $dbh->do('ATTACH DATABASE ":memory:" AS db3'), 'ATTACH DATABASE ":memory:" AS db3' ); + +# 4. Create a table on the attached database +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE db3.three' ); + CREATE TABLE db3.three ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL + ) +END_SQL + +# 5. No errors from column_info() +my $sth = $dbh->column_info(undef, undef, 'test', undef); +is $@, '', 'No error creating the table'; + +# 6. Get column information +ok $sth, 'We can get column information'; + +my %expected = ( + TYPE_NAME => [qw( INTEGER VARCHAR )], + COLUMN_NAME => [qw( id name )], +); + +SKIP: { + skip( "The table didn't get created correctly or we can't get column information.", 5 ) unless $sth; + + my $info = $sth->fetchall_arrayref({}); + + # 7. Found 2 columns + is( scalar @$info, 2, 'We got information on two columns' ); + + foreach my $item (qw( TYPE_NAME COLUMN_NAME )) { + my @info = map { $_->{$item} } (@$info); + is_deeply( \@info, $expected{$item}, "We got the right info in $item" ); + } + + $info = $dbh->column_info(undef, undef, 't%', '%a%')->fetchall_arrayref({}); + + # 10. Found 3 columns + is( scalar @$info, 3, 'We matched information from multiple databases' ); + + my @fields = qw( TABLE_SCHEM TYPE_NAME COLUMN_NAME COLUMN_SIZE NULLABLE ); + my @info = map [ @$_{@fields} ], @$info; + my $expected = [ + [ 'db3', 'CHAR', 'name', 64, 0 ], + [ 'main', 'VARCHAR', 'name', 255, 1 ], + [ 'temp', 'INTEGER', 'flag', undef, 1 ] # TODO: column_info should always return a valid COLUMN_SIZE + ]; + + # 11. Correct info retrieved + is_deeply( \@info, $expected, 'We got the right info from multiple databases' ); +} diff --git a/t/17_createdrop.t b/t/17_createdrop.t new file mode 100644 index 0000000..6e93b55 --- /dev/null +++ b/t/17_createdrop.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +# This is a skeleton test. For writing new tests, take this file +# and modify/extend it. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 4; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok(); + +# Create a table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL + +# Drop the table +ok( $dbh->do('DROP TABLE one'), 'DROP TABLE' ); diff --git a/t/18_insertfetch.t b/t/18_insertfetch.t new file mode 100644 index 0000000..2eed8aa --- /dev/null +++ b/t/18_insertfetch.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl + +# This is a simple insert/fetch test. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 10; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok( RaiseError => 1 ); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL + +# Insert a row +ok( $dbh->do("INSERT INTO one VALUES ( 1, 'A' )"), 'INSERT' ); + +# Now SELECT the row out +is_deeply( + $dbh->selectall_arrayref('SELECT * FROM one WHERE id = 1'), + [ [ 1, 'A' ] ], + 'SELECT ok', +); + +# Delete the row +ok( $dbh->do("DELETE FROM one WHERE id = 1"), 'DELETE' ); + +# Select an empty result +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id = 1'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + my $row1 = $sth->fetchrow_arrayref; + is( $row1, undef, 'fetch select deleted' ); + my $row2 = $sth->fetchrow_arrayref; + is( $row2, undef, 'fetch empty statement handler' ); +} diff --git a/t/19_bindparam.t b/t/19_bindparam.t new file mode 100644 index 0000000..025f8af --- /dev/null +++ b/t/19_bindparam.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 39; +use Test::NoWarnings; +use DBI ':sql_types'; + +# Create a database +my $dbh = connect_ok( dbfile => 'foo', RaiseError => 1, PrintError => 1, PrintWarn => 1 ); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NULL +) +END_SQL + +my $konig = "Andreas K\xf6nig"; + +SCOPE: { + my $sth = $dbh->prepare("INSERT INTO one VALUES ( ?, ? )"); + isa_ok( $sth, 'DBI::st' ); + + # Automatic type detection + my $number = 1; + my $char = "A"; + ok( $sth->execute($number, $char), 'EXECUTE 1' ); + + # Does the driver remember the automatically detected type? + ok( $sth->execute("3", "Jochen Wiedmann"), 'EXECUTE 2' ); + $number = 2; + $char = "Tim Bunce"; + ok( $sth->execute($number, $char), 'EXECUTE 3'); + + # Now try the explicit type settings + ok( $sth->bind_param(1, " 4", SQL_INTEGER), 'bind 1' ); + ok( $sth->bind_param(2, $konig), 'bind 2' ); + ok( $sth->execute, '->execute' ); + + # Works undef -> NULL? + ok( $sth->bind_param(1, 5, SQL_INTEGER), 'bind 3' ); + ok( $sth->bind_param(2, undef), 'bind 4' ); + ok( $sth->execute, '->execute' ); + + # Works with PADTMPs? + my @values = (6, "Larry"); + for (my $i=0; $i<2; $i++) { + ok( $sth->bind_param($i+1, "$values[$i]"), 'bind '.($i+5) ); + } + ok( $sth->execute, '->execute' ); +} + +# Reconnect +ok( $dbh->disconnect, '->disconnect' ); +$dbh = connect_ok( dbfile => 'foo' ); +SCOPE: { + my $sth = $dbh->prepare("SELECT * FROM one ORDER BY id"); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + my $id = undef; + my $name = undef; + ok( $sth->bind_columns(undef, \$id, \$name), '->bind_columns' ); + ok( $sth->fetch, '->fetch' ); + is( $id, 1, 'id = 1' ); + is( $name, 'A', 'name = A' ); + ok( $sth->fetch, '->fetch' ); + is( $id, 2, 'id = 2' ); + is( $name, 'Tim Bunce', 'name = Tim Bunce' ); + ok( $sth->fetch, '->fetch' ); + is( $id, 3, 'id = 3' ); + is( $name, 'Jochen Wiedmann', 'name = Jochen Wiedmann' ); + ok( $sth->fetch, '->fetch' ); + is( $id, 4, 'id = 4' ); + is( $name, $konig, 'name = $konig' ); + ok( $sth->fetch, '->fetch' ); + is( $id, 5, 'id = 5' ); + is( $name, undef, 'name = undef' ); + ok( $sth->fetch, '->fetch' ); + is( $id, 6, 'id = 6' ); + is( $name, 'Larry', 'name = Larry' ); +} diff --git a/t/20_blobs.t b/t/20_blobs.t new file mode 100644 index 0000000..295a70f --- /dev/null +++ b/t/20_blobs.t @@ -0,0 +1,77 @@ +#!/usr/bin/perl + +# This is a test for correct handling of BLOBS; namely $dbh->quote +# is expected to work correctly. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 10; +use Test::NoWarnings; +use DBI ':sql_types'; + +sub ShowBlob($) { + my ($blob) = @_; + print("showblob length: ", length($blob), "\n"); + if ($ENV{SHOW_BLOBS}) { open(OUT, ">>$ENV{SHOW_BLOBS}") } + my $i = 0; + while (1) { + if (defined($blob) && length($blob) > ($i*32)) { + $b = substr($blob, $i*32); + } else { + $b = ""; + last; + } + if ($ENV{SHOW_BLOBS}) { printf OUT "%08lx %s\n", $i*32, unpack("H64", $b) } + else { printf("%08lx %s\n", $i*32, unpack("H64", $b)) } + $i++; + last if $i == 8; + } + if ($ENV{SHOW_BLOBS}) { close(OUT) } +} + +# Create a database +my $dbh = connect_ok(); +$dbh->{sqlite_handle_binary_nulls} = 1; + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name BLOB (128) NOT NULL +) +END_SQL + +# Create a blob +my $blob = ''; +my $b = ''; +for ( my $j = 0; $j < 256; $j++ ) { + $b .= chr($j); +} +for ( my $i = 0; $i < 128; $i++ ) { + $blob .= $b; +} + +# Insert a row into the test table +SCOPE: { + my $sth = $dbh->prepare("INSERT INTO one VALUES ( 1, ? )"); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->bind_param(1, $blob, SQL_BLOB), '->bind_param' ); + ok( $sth->execute, '->execute' ); +} + +# Now, try SELECT'ing the row out. +SCOPE: { + my $sth = $dbh->prepare("SELECT * FROM one WHERE id = 1"); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + ok( + $sth->fetchrow_arrayref->[1] eq $blob, + 'Got the blob back ok', + ); + ok( $sth->finish, '->finish' ); +} diff --git a/t/21_blobtext.t b/t/21_blobtext.t new file mode 100644 index 0000000..3954c7d --- /dev/null +++ b/t/21_blobtext.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 27; +use Test::NoWarnings; + +my $dbh = connect_ok( + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, +); + +ok($dbh->do("CREATE TABLE Blah ( id INTEGER, val VARCHAR )")); +ok($dbh->commit); + +my $blob = ""; + +my $b = ""; +for my $j (0..255) { + $b .= chr($j); +} +for my $i (0..127) { + $blob .= $b; +} + +ok($blob); +dumpblob($blob); + +my $sth = $dbh->prepare("INSERT INTO Blah VALUES (?, ?)"); + +ok($sth); + +for (1..5) { + ok($sth->execute($_, $blob)); +} + +$sth->finish; + +undef $sth; + +my $sel = $dbh->prepare("SELECT * FROM Blah WHERE id = ?"); + +ok($sel); + +for (1..5) { + $sel->execute($_); + my $row = $sel->fetch; + ok($row->[0] == $_); + dumpblob($row->[1]); + ok($row->[1] eq $blob); + ok(!$sel->fetch); +} + +$dbh->rollback; + +sub dumpblob { + my $blob = shift; + print("# showblob length: ", length($blob), "\n"); + + if ($ENV{SHOW_BLOBS}) { open(OUT, ">>$ENV{SHOW_BLOBS}") } + my $i = 0; + while (1) { + if (defined($blob) && length($blob) > ($i*32)) { + $b = substr($blob, $i*32); + } else { + $b = ""; + last; + } + if ($ENV{SHOW_BLOBS}) { printf OUT "%08lx %s\n", $i*32, unpack("H64", $b) } + else { printf("# %08lx %s\n", $i*32, unpack("H64", $b)) } + $i++; + last if $i == 8; + } + if ($ENV{SHOW_BLOBS}) { close(OUT) } +} + diff --git a/t/22_listfields.t b/t/22_listfields.t new file mode 100644 index 0000000..b20e930 --- /dev/null +++ b/t/22_listfields.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl + +# This is a test for statement attributes being present appropriately. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 12; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok(); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) +) +END_SQL + +SCOPE: { + # Create the statement + my $sth = $dbh->prepare('SELECT * from one'); + isa_ok( $sth, 'DBI::st' ); + + # Execute the statement + ok( $sth->execute, '->execute' ); + + # Check the field metadata + is( $sth->{NUM_OF_FIELDS}, 2, 'Found 2 fields' ); + is_deeply( $sth->{NAME}, [ 'id', 'name' ], 'Names are ok' ); + ok( $sth->finish, '->finish ok' ); +} + +SCOPE: { + # Check field metadata on a drop statement + my $sth = $dbh->prepare('DROP TABLE one'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + is( $sth->{NUM_OF_FIELDS}, 0, 'No fields in statement' ); + ok( $sth->finish, '->finish ok' ); +} diff --git a/t/23_nulls.t b/t/23_nulls.t new file mode 100644 index 0000000..1cd0625 --- /dev/null +++ b/t/23_nulls.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl + +# This is a test for correctly handling NULL values. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 9; + +# Create a database +my $dbh = connect_ok(); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER, + name CHAR (64) +) +END_SQL + +# Test whether or not a field containing a NULL is returned correctly +# as undef, or something much more bizarre. +ok( + $dbh->do('INSERT INTO one VALUES ( NULL, ? )', {}, 'NULL-valued id' ), + 'INSERT', +); + +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id IS NULL'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute ok' ); + my $row = $sth->fetchrow_arrayref; + is( scalar(@$row), 2, 'Two values in the row' ); + is( $row->[0], undef, 'First column is undef' ); + is( $row->[1], 'NULL-valued id', 'Second column is defined' ); + ok( $sth->finish, '->finish' ); +} diff --git a/t/24_numrows.t b/t/24_numrows.t new file mode 100644 index 0000000..c242e42 --- /dev/null +++ b/t/24_numrows.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +# This tests, whether the number of rows can be retrieved. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 18; +use Test::NoWarnings; + +sub rows { + my $sth = shift; + my $expected = shift; + my $count = 0; + while ($sth->fetchrow_arrayref) { + ++$count; + } + Test::More::is( $count, $expected, "Got $expected rows" ); +} + +# Create a database +my $dbh = connect_ok(); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL + +# Insert into table +ok( + $dbh->do("INSERT INTO one VALUES ( 1, 'A' )"), + 'INSERT 1', +); + +# Count the rows +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id = 1'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + rows( $sth, 1 ); + ok( $sth->finish, '->finish' ); +} + +# Insert another row +ok( + $dbh->do("INSERT INTO one VALUES ( 2, 'Jochen Wiedmann' )"), + 'INSERT 2', +); + +# Count the rows +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id >= 1'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + rows( $sth, 2 ); + ok( $sth->finish, '->finish' ); +} + +# Insert another row +ok( + $dbh->do("INSERT INTO one VALUES ( 3, 'Tim Bunce' )"), + 'INSERT 3', +); + +# Count the rows +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one WHERE id >= 2'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute' ); + rows( $sth, 2 ); + ok( $sth->finish, '->finish' ); +} diff --git a/t/25_chopblanks.t b/t/25_chopblanks.t new file mode 100644 index 0000000..3469a6c --- /dev/null +++ b/t/25_chopblanks.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +# Check whether 'ChopBlanks' works. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 14; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok( RaiseError => 1 ); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL + +# Fill the table +ok( + $dbh->do('INSERT INTO one values ( 1, ? )', {}, 'NULL' ), + 'INSERT 1', +); +ok( + $dbh->do('INSERT INTO one values ( 2, ? )', {}, ' '), + 'INSERT 2', +); +ok( + $dbh->do('INSERT INTO one values ( 3, ? )', {}, ' a b c '), + 'INSERT 3', +); + +# Test fetching with ChopBlanks off +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one ORDER BY id'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute ok' ); + $sth->{ChopBlanks} = 0; + my $rows = $sth->fetchall_arrayref; + is_deeply( $rows, [ + [ 1, 'NULL' ], + [ 2, ' ' ], + [ 3, ' a b c ' ], + ], 'ChopBlanks = 0' ); + ok( $sth->finish, '->finish' ); +} + +# Test fetching with ChopBlanks on +SCOPE: { + my $sth = $dbh->prepare('SELECT * FROM one ORDER BY id'); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute ok' ); + $sth->{ChopBlanks} = 1; + my $rows = $sth->fetchall_arrayref; + is_deeply( $rows, [ + [ 1, 'NULL' ], + [ 2, '' ], + [ 3, ' a b c' ], + ], 'ChopBlanks = 1' ); + ok( $sth->finish, '->finish' ); +} diff --git a/t/26_commit.t b/t/26_commit.t new file mode 100644 index 0000000..75716ed --- /dev/null +++ b/t/26_commit.t @@ -0,0 +1,121 @@ +#!/usr/bin/perl + +# This is testing the transaction support. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 28; +# use Test::NoWarnings; + +my $warning_count = 0; + + + + +##################################################################### +# Support functions + +sub insert { + Test::More::ok( + $_[0]->do("INSERT INTO one VALUES (1, 'Jochen')"), + 'INSERT 1', + ); +} + +sub rows { + my $dbh = shift; + my $expected = shift; + is_deeply( + $dbh->selectall_arrayref('select count(*) from one'), + [ [ $expected ] ], + "Found $expected rows", + ); +} + + + + + +##################################################################### +# Main Tests + +# Create a database +my $dbh = connect_ok( dbfile => 'foo', RaiseError => 1 ); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL + +# Turn AutoCommit off +$dbh->{AutoCommit} = 0; +ok( ! $dbh->{AutoCommit}, 'AutoCommit is off' ); +ok( ! $dbh->err, '->err is false' ); +ok( ! $dbh->errstr, '->err is false' ); + +# Check rollback +insert( $dbh ); +rows( $dbh, 1 ); +ok( $dbh->rollback, '->rollback ok' ); +rows( $dbh, 0 ); + +# Check commit +ok( $dbh->do('DELETE FROM one WHERE id = 1'), 'DELETE 1' ); +rows( $dbh, 0 ); +ok( $dbh->commit, '->commit ok' ); +rows( $dbh, 0 ); + +# Check auto rollback after disconnect +insert( $dbh ); +rows( $dbh, 1 ); +ok( $dbh->disconnect, '->disconnect ok' ); +$dbh = connect_ok( dbfile => 'foo' ); +rows( $dbh, 0 ); + +# Check that AutoCommit is back on again after the reconnect +is( $dbh->{AutoCommit}, 1, 'AutoCommit is on' ); + +# Check whether AutoCommit mode works. +insert( $dbh ); +rows( $dbh, 1 ); +ok( $dbh->disconnect, '->disconnect ok' ); +$dbh = connect_ok( dbfile => 'foo' ); +rows( $dbh, 1 ); + +# Check whether commit issues a warning in AutoCommit mode +ok( $dbh->do("INSERT INTO one VALUES ( 2, 'Tim' )"), 'INSERT 2' ); +SCOPE: { + local $@ = ''; + $SIG{__WARN__} = sub { + $warning_count++; + }; + eval { + $dbh->commit; + }; + $SIG{__WARN__} = 'DEFAULT'; + is( $warning_count, 1, 'Got one warning' ); +} + +# Check whether rollback issues a warning in AutoCommit mode +# We accept error messages as being legal, because the DBI +# requirement of just issueing a warning seems scary. +ok( $dbh->do("INSERT INTO one VALUES ( 3, 'Alligator' )"), 'INSERT 3' ); +SCOPE: { + local $@ = ''; + $SIG{__WARN__} = sub { + $warning_count++; + }; + eval { + $dbh->rollback; + }; + $SIG{__WARN__} = 'DEFAULT'; + is( $warning_count, 2, 'Got one warning' ); +} diff --git a/t/27_metadata.t b/t/27_metadata.t new file mode 100644 index 0000000..57d9a32 --- /dev/null +++ b/t/27_metadata.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More tests => 21; +use t::lib::Test; + +# 1-4. Connect & create tables +my $dbh = connect_ok(dbfile => 'foo'); +ok $dbh->do('CREATE TABLE meta1 (f1 INTEGER PRIMARY KEY, f2 CHAR(1))'), 'Create table meta1'; +ok $dbh->do('CREATE TABLE meta2 (f1 VARCHAR(2), f2 CHAR(1), PRIMARY KEY (f1))'), 'Create table meta2'; +ok $dbh->do('CREATE TABLE meta3 (f2 CHAR(1), f1 VARCHAR(2) PRIMARY KEY)'), 'Create table meta3'; + +$dbh->trace(0); +$DBI::neat_maxlen = 4000; + +# 5-10. Get & check primary_key_info +for my $table (qw(meta1 meta2 meta3)) { + ok my $sth = $dbh->primary_key_info(undef, undef, $table), "Get primary_key_info for $table"; + my $pki = $sth->fetchall_arrayref([3,4]); + #use Data::Dumper; print Dumper($pki); + is_deeply $pki, [['f1', 1]], "Correct primary_key_info returned for $table"; +} + +# 11-14. Multi column primary key +ok $dbh->do('CREATE TABLE meta4 (f1 VARCHAR(2), f2 CHAR(1), PRIMARY KEY (f1,f2))'), 'Create table meta4'; +ok my $sth = $dbh->primary_key_info(undef, undef, 'meta4'), 'Get primary_key_info for meta4'; +my $pki = $sth->fetchall_arrayref({COLUMN_NAME => 1, KEY_SEQ => 1}); +#use Data::Dumper; print Dumper($pki); +is @$pki, 2, 'Primary key contains 2 columns'; +is_deeply $pki, [{COLUMN_NAME => 'f1', KEY_SEQ => 1},{COLUMN_NAME => 'f2', KEY_SEQ => 2}], + 'Correct primary_key_info returned for meta4'; + +# 15,16. Test primary_key +ok my @pk = $dbh->primary_key(undef, undef, 'meta4'), 'Get primary_key for meta4'; +is_deeply \@pk, [qw(f1 f2)], 'Correct primary_key returned for meta4'; + +# 17-21. I'm not sure what this is testing +$dbh->do("INSERT INTO meta4 VALUES ('xyz', 'b')"); +$sth = $dbh->prepare('SELECT * FROM meta4'); +$sth->execute; +$sth->fetch; +my $types = $sth->{TYPE}; +my $names = $sth->{NAME}; +# diag "Types: @$types\nNames: @$names"; +is scalar @$types, scalar @$names, '$sth->{TYPE} array is same length as $sth->{NAME} array'; +# FIXME: This is wrong! $sth->{TYPE} should return an array of integers see: rt #46873 +TODO: { + local $TODO = '$sth->{TYPE} should return an array of integers.'; + isnt $types->[0], 'VARCHAR(2)', '$sth->{TYPE}[0] doesn\'t return a string'; + isnt $types->[1], 'CHAR(1)', '$sth->{TYPE}[1] doesn\'t return a string'; + like $types->[0], qr/^-?\d+$/, '$sth->{TYPE}[0] returns an integer'; + like $types->[1], qr/^-?\d+$/, '$sth->{TYPE}[1] returns an integer'; +} + diff --git a/t/28_schemachange.t b/t/28_schemachange.t new file mode 100644 index 0000000..66cef08 --- /dev/null +++ b/t/28_schemachange.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl + +# This test works, but as far as I can tell this doesn't actually test +# the thing that the test was originally meant to test. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More tests => 9; +use t::lib::Test; + +my $create1 = 'CREATE TABLE table1 (id INTEGER NOT NULL, name CHAR (64) NOT NULL)'; +my $create2 = 'CREATE TABLE table2 (id INTEGER NOT NULL, name CHAR (64) NOT NULL)'; +my $drop1 = 'DROP TABLE table1'; +my $drop2 = 'DROP TABLE table2'; + +# diag("Parent connecting... ($$)\n"); +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + ok( $dbh->do($create1), $create1 ); + ok( $dbh->do($create2), $create2 ); + ok( $dbh->disconnect, '->disconnect ok' ); +} +my $dbfile = dbfile('foo'); + +my $pid; +# diag("Forking... ($$)"); +if ( not defined( $pid = fork() ) ) { + die("fork: $!"); + +} elsif ( $pid == 0 ) { + # Pause to let the parent connect + sleep(2); + + # diag("Child starting... ($$)"); + my $dbh = DBI->connect( + "dbi:SQLite:dbname=$dbfile", '', '' + ) or die 'connect failed'; + $dbh->do($drop2) or die "DROP ok"; + $dbh->disconnect or die "disconnect ok"; + # diag("Child exiting... ($$)"); + + exit(0); + +} + +SCOPE: { + # Parent process + my $dbh = connect_ok( dbfile => 'foo' ); + # diag("Waiting for child... ($$)"); + ok( waitpid($pid, 0) != -1, "waitpid" ); + + # Make sure the child actually deleted table2 + ok( $dbh->do($drop1), $drop1 ) or diag("Error: '$DBI::errstr'"); + ok( $dbh->do($create2), $create2 ) or diag("Error: '$DBI::errstr'"); + ok( $dbh->disconnect, '->disconnect ok' ); +} diff --git a/t/29_cppcomments.t b/t/29_cppcomments.t new file mode 100644 index 0000000..040c083 --- /dev/null +++ b/t/29_cppcomments.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More; +use t::lib::Test; + +my @c_files = (<*.c>, <*.h>, <*.xs>); +plan tests => scalar(@c_files); + +FILE: +foreach my $file (@c_files) { + if ($file =~ /ppport.h/) { + pass("$file is not ours to be tested"); + next; + } + + open my $fh, '<', $file or die "$file: $!"; + my $line = 0; + while (<$fh>) { + $line++; + if (/^(.*)\/\//) { + my $m = $1; + if ($m !~ /\*/ && $m !~ /http:$/) { # skip the // in c++ comment in parse.c + fail("C++ comment in $file line $line"); + next FILE; + } + } + + if (/#define\s+DBD_SQLITE_CROAK_DEBUG/) { + fail("debug macro is enabled in $file line $line"); + next FILE; + } + } + pass("$file has no C++ comments"); + close $fh; +} diff --git a/t/30_auto_rollback.t b/t/30_auto_rollback.t new file mode 100644 index 0000000..7a23760 --- /dev/null +++ b/t/30_auto_rollback.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +# I've disabled warnings, so theoretically warnings shouldn't be printed + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 6; +use Test::NoWarnings; + +SCOPE: { + my $dbh = connect_ok( RaiseError => 1, PrintWarn => 0, Warn => 0 ); + ok( ! $dbh->{PrintWarn}, '->{PrintWarn} is false' ); + ok( $dbh->do("CREATE TABLE f (f1, f2, f3)"), 'CREATE TABLE ok' ); + ok( $dbh->begin_work, '->begin_work' ); + ok( + $dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 1), + 'INSERT ok', + ); +} diff --git a/t/31_bind_weird_number_param.t b/t/31_bind_weird_number_param.t new file mode 100644 index 0000000..888773a --- /dev/null +++ b/t/31_bind_weird_number_param.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my @to_be_tested; +BEGIN { @to_be_tested = (1.23E4); } + +use Test::More tests => 2 + @to_be_tested; +use t::lib::Test; + +my $dbh = connect_ok(); + +ok( $dbh->do("CREATE TABLE f (id, num)"), 'CREATE TABLE f' ); + +SCOPE: { + my $sth = $dbh->prepare("INSERT INTO f VALUES (?, ?)"); + for(my $id = 0; $id < @to_be_tested; $id++) { + $sth->execute($id, $to_be_tested[$id]); + my $av = $dbh->selectrow_arrayref("SELECT num FROM f WHERE id = ?", {}, $id); + ok( (@$av && $av->[0] == $to_be_tested[$id]), "accepts $to_be_tested[$id]: ".$av->[0]); + } +} diff --git a/t/32_inactive_error.t b/t/32_inactive_error.t new file mode 100644 index 0000000..86fcf57 --- /dev/null +++ b/t/32_inactive_error.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More tests => 4; +use t::lib::Test; + +my $dbh = connect_ok( PrintError => 0, RaiseError => 0 ); + +my $sth = $dbh->prepare('CREATE TABLE foo (f)'); + +$dbh->disconnect; + +$sth->{PrintError} = 1; + +# attempt to execute on inactive database handle +my @warning = (); +SCOPE: { + local $SIG{__WARN__} = sub { push @warning, @_; return }; + my $ret = eval { $sth->execute; }; + # we need PrintError => 1, or warn $@ if $@; + ok ! defined $ret; +} + +is( scalar(@warning), 1, 'Got 1 warning' ); +like( + $warning[0], + qr/attempt to execute on inactive database handle/, + 'Got the expected warning', +); diff --git a/t/33_non_latin_path.t b/t/33_non_latin_path.t new file mode 100644 index 0000000..45ba39e --- /dev/null +++ b/t/33_non_latin_path.t @@ -0,0 +1,105 @@ +#!/usr/bin/perl + +# Tests path containing non-latine-1 characters +# currently fails on Windows + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +BEGIN { + if ( $] >= 5.008005 ) { + plan( tests => (($^O eq 'cygwin') ? 15 : 27) ); + } else { + plan( skip_all => 'Unicode is not supported before 5.8.5' ); + } +} +use Test::NoWarnings; +use File::Temp (); +use File::Spec::Functions ':ALL'; + +my $dir = File::Temp::tempdir( CLEANUP => 1 ); +foreach my $subdir ( 'longascii', 'adatbázis', 'name with spaces', '¿¿¿ ¿¿¿¿¿¿') { + if ($^O eq 'cygwin') { + next if (($subdir eq 'adatbázis') || ($subdir eq '¿¿¿ ¿¿¿¿¿¿')); + } + # rt48048: don't need to "use utf8" nor "require utf8" + utf8::upgrade($subdir); + ok( + mkdir(catdir($dir, $subdir)), + "$subdir created", + ); + + # Open the database + my $dbfile = catfile($dir, $subdir, 'db.db'); + eval { + my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", undef, undef, { + RaiseError => 1, + PrintError => 0, + } ); + isa_ok( $dbh, 'DBI::db' ); + }; + is( $@, '', "Could connect to database in $subdir" ); + diag( $@ ) if $@; + unlink(_path($dbfile)) if -e _path($dbfile); + + # Repeat with the unicode flag on + my $ufile = $dbfile; + eval { + my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", undef, undef, { + RaiseError => 1, + PrintError => 0, + sqlite_unicode => 1, + } ); + isa_ok( $dbh, 'DBI::db' ); + }; + is( $@, '', "Could connect to database in $subdir" ); + diag( $@ ) if $@; + unlink(_path($ufile)) if -e _path($ufile); + + # when the name of the database file has non-latin characters + my $dbfilex = catfile($dir, "$subdir.db"); + eval { + DBI->connect("dbi:SQLite:dbname=$dbfilex", "", "", {RaiseError => 1, PrintError => 0}); + }; + ok(!$@, "Could connect to database in $dbfilex") or diag $@; + unlink(_path($dbfilex)) if -e _path($dbfilex); +} + + +# connect to an empty filename - sqlite will create a tempfile +eval { + my $dbh = DBI->connect("dbi:SQLite:dbname=", undef, undef, { + RaiseError => 1, + PrintError => 0, + } ); + isa_ok( $dbh, 'DBI::db' ); +}; +is( $@, '', "Could connect to temp database (empty filename)" ); +diag( $@ ) if $@; + + + + +sub _path { # copied from DBD::SQLite::connect + my $path = shift; + + if ($^O =~ /MSWin32/) { + require Win32; + require File::Basename; + + my ($file, $dir, $suffix) = File::Basename::fileparse($path); + my $short = Win32::GetShortPathName($path); + if ( $short && -f $short ) { + # Existing files will work directly. + $path = $short; + } elsif ( -d $dir ) { + $path = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix; + } + } + return $path; +} diff --git a/t/34_online_backup.t b/t/34_online_backup.t new file mode 100644 index 0000000..0675f2e --- /dev/null +++ b/t/34_online_backup.t @@ -0,0 +1,76 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use t::lib::Test qw/connect_ok dbfile @CALL_FUNCS/; + +BEGIN { + use DBD::SQLite; + unless ($DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= 3006011) { + plan skip_all => "this test requires SQLite 3.6.11 and newer"; + exit; + } +} + +use Test::NoWarnings; +use DBI; + +plan tests => 6 * @CALL_FUNCS + 1; + +foreach my $call_func (@CALL_FUNCS) { + # Connect to the test db and add some stuff: + my $foo = connect_ok( dbfile => 'foo', RaiseError => 1 ); + my $dbfile = dbfile('foo'); + $foo->do( + 'CREATE TABLE online_backup_test( id INTEGER PRIMARY KEY, foo INTEGER )' + ); + $foo->do("INSERT INTO online_backup_test (foo) VALUES ($$)"); + + # That should be in the "foo" database on disk now, so disconnect and try to + # back it up: + + $foo->disconnect; + + my $dbh = DBI->connect( + 'dbi:SQLite:dbname=:memory:', + undef, undef, + { RaiseError => 1 } + ); + + ok($dbh->$call_func($dbfile, 'backup_from_file')); + + { + my ($count) = $dbh->selectrow_array( + "SELECT count(foo) FROM online_backup_test WHERE foo=$$" + ); + is($count, 1, "Found our process ID in backed-up table"); + } + + # Add more data then attempt to copy it back to file: + $dbh->do( + 'CREATE TABLE online_backup_test2 ( id INTEGER PRIMARY KEY, foo INTEGER )' + ); + $dbh->do("INSERT INTO online_backup_test2 (foo) VALUES ($$)"); + + # backup to file (foo): + ok($dbh->$call_func($dbfile, 'backup_to_file')); + + $dbh->disconnect; + + # Reconnect to foo db and check data made it over: + { + my $foo = connect_ok( dbfile => 'foo', RaiseError => 1 ); + + my ($count) = $foo->selectrow_array( + "SELECT count(foo) FROM online_backup_test2 WHERE foo=$$" + ); + is($count, 1, "Found our process ID in table back on disk"); + + $foo->disconnect; + } + $dbh->disconnect; + + unlink $dbfile; +} diff --git a/t/35_table_info.t b/t/35_table_info.t new file mode 100644 index 0000000..f92c1db --- /dev/null +++ b/t/35_table_info.t @@ -0,0 +1,124 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 18; +use Test::NoWarnings; + +my @schema_info = ( + [undef, 'main', undef, undef, undef], + [undef, 'temp', undef, undef, undef] +); +my @systable_info = ( + [undef, 'main', 'sqlite_master', 'SYSTEM TABLE', undef, undef], + [undef, 'temp', 'sqlite_temp_master', 'SYSTEM TABLE', undef, undef] +); + +# Create a database +my $dbh = connect_ok(); + +# Check avalable schemas +my $sth = $dbh->table_info('', '%', ''); +ok $sth, 'We can get table/schema information'; +my $info = $sth->fetchall_arrayref; +is_deeply $info, \@schema_info, 'Correct table/schema information'; + +# Create a table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE one' ); +CREATE TABLE one ( + id INTEGER PRIMARY KEY NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL +my $table1_info = [undef, 'main', 'one', 'TABLE', undef, 'CREATE TABLE one ( + id INTEGER PRIMARY KEY NOT NULL, + name CHAR (64) NOT NULL +)']; + +# Create a temporary table +ok( $dbh->do(<<'END_SQL'), 'CREATE TEMP TABLE two' ); +CREATE TEMP TABLE two ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL +my $table2_info = [undef, 'temp', 'two', 'LOCAL TEMPORARY', undef, 'CREATE TABLE two ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +)']; + +# Attach a memory database +ok( $dbh->do('ATTACH DATABASE ":memory:" AS db3'), 'ATTACH DATABASE ":memory:" AS db3' ); + +# Create a table on the attached database +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE db3.three' ); +CREATE TABLE db3.three ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL +my $table3_info = [undef, 'db3', 'three', 'TABLE', undef, 'CREATE TABLE three ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +)']; + +# Get table_info for "one" +$info = $dbh->table_info(undef, undef, 'one')->fetchall_arrayref; +is_deeply $info, [$table1_info], 'Correct table_info for "one"'; + +# Get table_info for "main"."one" +$info = $dbh->table_info(undef, 'main', 'one')->fetchall_arrayref; +is_deeply $info, [$table1_info], 'Correct table_info for "main"."one"'; + +# Get table_info for "two" +$info = $dbh->table_info(undef, undef, 'two')->fetchall_arrayref; +is_deeply $info, [$table2_info], 'Correct table_info for "two"'; + +# Get table_info for "temp"."two" +$info = $dbh->table_info(undef, 'temp', 'two')->fetchall_arrayref; +is_deeply $info, [$table2_info], 'Correct table_info for "temp"."two"'; + +# Get table_info for "three" +$info = $dbh->table_info(undef, undef, 'three')->fetchall_arrayref; +is_deeply $info, [$table3_info], 'Correct table_info for "three"'; + +# Get table_info for "db3"."three" +$info = $dbh->table_info(undef, 'db3', 'three')->fetchall_arrayref; +is_deeply $info, [$table3_info], 'Correct table_info for "db3"."three"'; + +# Create another table "one" on the attached database +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE db3.one' ); +CREATE TABLE db3.one ( + id INTEGER PRIMARY KEY NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL +my $table4_info = [undef, 'db3', 'one', 'TABLE', undef, 'CREATE TABLE one ( + id INTEGER PRIMARY KEY NOT NULL, + name CHAR (64) NOT NULL +)']; + +# Get table_info for both tables named "one" +$info = $dbh->table_info(undef, undef, 'one')->fetchall_arrayref; +is_deeply $info, [$table4_info, $table1_info], 'Correct table_info for both tables named "one"'; + +# Get table_info for the system tables +$info = $dbh->table_info(undef, undef, undef, 'SYSTEM TABLE')->fetchall_arrayref; +is_deeply $info, \@systable_info, 'Correct table_info for the system tables'; + +# Get table_info for all tables +$info = $dbh->table_info()->fetchall_arrayref; +is_deeply $info, [$table2_info, @systable_info, $table4_info, $table3_info, $table1_info], + 'Correct table_info for all tables'; + +#use Data::Dumper; +#warn 'Catalog Names', substr Dumper($dbh->table_info('%', '', '')->fetchall_arrayref), 5; +#warn 'Schema Names', substr Dumper($dbh->table_info('', '%', '')->fetchall_arrayref), 5; +#warn 'Table Types', substr Dumper($dbh->table_info('', '', '', '%')->fetchall_arrayref), 5; +#warn 'table_info', substr Dumper($info), 5; + diff --git a/t/36_hooks.t b/t/36_hooks.t new file mode 100644 index 0000000..c97a6c6 --- /dev/null +++ b/t/36_hooks.t @@ -0,0 +1,153 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings qw/had_no_warnings clear_warnings/; + +use DBD::SQLite; + +plan tests => 24 * @CALL_FUNCS + 1; + +# hooks : just count the commits / rollbacks / updates +my ($n_commits, $n_rollbacks, $n_updates, @update_args); +sub commit_hook { $n_commits += 1; return 0; } +sub rollback_hook { $n_rollbacks += 1; return 0; } +sub update_hook { $n_updates += 1; + @update_args = @_; } + +my $sql_count_rows = "SELECT COUNT(foo) FROM hook_test"; + +foreach my $call_func (@CALL_FUNCS) { + + # connect + my $dbh = connect_ok( RaiseError => 1 ); + $dbh->do( 'CREATE TEMP TABLE hook_test ( foo )' ); + + # register the hooks + my $previous_commit_hook = $dbh->$call_func(\&commit_hook, + "commit_hook"); + my $previous_rollback_hook = $dbh->$call_func(\&rollback_hook, + "rollback_hook"); + my $previous_update_hook = $dbh->$call_func(\&update_hook, + "update_hook"); + ok(!$previous_commit_hook, "initial commit hook was undef"); + ok(!$previous_rollback_hook, "initial rollback hook was undef"); + ok(!$previous_update_hook, "initial update hook was undef"); + + # a couple of transactions + do_transaction($dbh) for 1..3; + + # commit hook should have been called three times + is($n_commits, 3, "3 commits"); + + # update hook should have been called 30 times + is($n_updates, 30, "30 updates"); + + # check args transmitted to update hook; + is($update_args[0], DBD::SQLite::INSERT, 'update hook arg 0: INSERT'); + is($update_args[1], 'temp', 'update hook arg 1: database'); + is($update_args[2], 'hook_test', 'update hook arg 2: table'); + ok($update_args[3], 'update hook arg 3: rowid'); + + # unregister the commit and update hooks, check if previous hooks are returned + $previous_commit_hook = $dbh->$call_func(undef, "commit_hook"); + ok($previous_commit_hook eq \&commit_hook, + "previous commit hook correctly returned"); + $previous_update_hook = $dbh->$call_func(undef, "update_hook"); + ok($previous_update_hook eq \&update_hook, + "previous update hook correctly returned"); + + # some more transactions .. commit and update hook should not be called + $n_commits = 0; + $n_updates = 0; + do_transaction($dbh) for 1..3; + is($n_commits, 0, "commit hook unregistered"); + is($n_updates, 0, "update hook unregistered"); + + # check here explicitly for warnings, before we clear them + had_no_warnings(); + + # remember how many rows we had so far + my ($n_rows) = $dbh->selectrow_array($sql_count_rows); + + # a commit hook that rejects the transaction + $dbh->$call_func(sub {return 1}, "commit_hook"); + eval {do_transaction($dbh)}; # in eval() because of RaiseError + ok ($@, "transaction was rejected: $@" ); + + # no explicit rollback, because SQLite already did it + # eval {$dbh->rollback;}; + # ok (!$@, "rollback OK $@"); + + # rollback hook should have been called + is($n_rollbacks, 1, "1 rollback"); + + # unregister the rollback hook, check if previous hook is returned + $previous_rollback_hook = $dbh->$call_func(undef, "rollback_hook"); + ok($previous_rollback_hook eq \&rollback_hook, + "previous hook correctly returned"); + + # try transaction again .. rollback hook should not be called + $n_rollbacks = 0; + eval {do_transaction($dbh)}; + is($n_rollbacks, 0, "rollback hook unregistered"); + + # check that the rollbacks did really occur + my ($n_rows_after) = $dbh->selectrow_array($sql_count_rows); + is($n_rows, $n_rows_after, "no rows added" ); + + # unregister commit hook, register an authorizer that forbids delete ops + $dbh->$call_func(undef, "commit_hook"); + my @authorizer_args; + my $authorizer = sub { + @authorizer_args = @_; + my $action_code = shift; + my $retval = $action_code == DBD::SQLite::DELETE ? DBD::SQLite::DENY + : DBD::SQLite::OK; + return $retval; + }; + $dbh->$call_func($authorizer, "set_authorizer"); + + # try an insert (should be authorized) and check authorizer args + $dbh->do("INSERT INTO hook_test VALUES ('auth_test')"); + is_deeply(\@authorizer_args, + [DBD::SQLite::INSERT, 'hook_test', undef, 'temp', undef], + "args to authorizer (INSERT)"); + + # try a delete (should be unauthorized) + eval {$dbh->do("DELETE FROM hook_test WHERE foo = 'auth_test'")}; + ok($@, "delete was rejected with message $@"); + is_deeply(\@authorizer_args, + [DBD::SQLite::DELETE, 'hook_test', undef, 'temp', undef], + "args to authorizer (DELETE)"); + + + # unregister the authorizer ... now DELETE should be authorized + $dbh->$call_func(undef, "set_authorizer"); + eval {$dbh->do("DELETE FROM hook_test WHERE foo = 'auth_test'")}; + ok(!$@, "delete was accepted"); + + + # sqlite3 did warn in tests above, so avoid complains from Test::Warnings + # (would be better to turn off warnings from sqlite3, but I didn't find + # any way to do that) + clear_warnings(); +} + + +sub do_transaction { + my $dbh = shift; + + $dbh->begin_work; + for my $count (1 .. 10) { + my $rand = rand; + $dbh->do( "INSERT INTO hook_test(foo) VALUES ( $rand )" ); + } + $dbh->commit; +} diff --git a/t/37_regexp.t b/t/37_regexp.t new file mode 100644 index 0000000..8936c2a --- /dev/null +++ b/t/37_regexp.t @@ -0,0 +1,89 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; + +my @words = qw{ + berger Bergère bergère Bergere + HOT hôte + hétéroclite hétaïre hêtre héraut + HAT hâter + fétu fête fève ferme + }; +my @regexes = qw( ^b\\w+ (?i:^b\\w+) ); + +BEGIN { + if ($] < 5.008005) { + plan skip_all => 'Unicode is not supported before 5.8.5'; + } +} +use Test::NoWarnings; + +plan tests => 2 * (3 + 2 * @regexes) * @CALL_FUNCS + 1; + +BEGIN { + # Sadly perl for windows (and probably sqlite, too) may hang + # if the system locale doesn't support european languages. + # en-us should be a safe default. if it doesn't work, use 'C'. + if ( $^O eq 'MSWin32') { + use POSIX 'locale_h'; + setlocale(LC_COLLATE, 'en-us'); + } +} +use locale; + +use DBD::SQLite; + + + +foreach my $call_func (@CALL_FUNCS) { + + for my $use_unicode (0, 1) { + + # connect + my $dbh = connect_ok( RaiseError => 1, sqlite_unicode => $use_unicode ); + + # populate test data + my @vals = @words; + if ($use_unicode) { + utf8::upgrade($_) foreach @vals; + } + + $dbh->do( 'CREATE TEMP TABLE regexp_test ( txt )' ); + $dbh->do( "INSERT INTO regexp_test VALUES ( '$_' )" ) foreach @vals; + + foreach my $regex (@regexes) { + my @perl_match = grep {/$regex/} @vals; + my $sql = "SELECT txt from regexp_test WHERE txt REGEXP '$regex' " + . "COLLATE perllocale"; + my $db_match = $dbh->selectcol_arrayref($sql); + + is_deeply(\@perl_match, $db_match, "REGEXP '$regex'"); + + my @perl_antimatch = grep {!/$regex/} @vals; + $sql =~ s/REGEXP/NOT REGEXP/; + my $db_antimatch = $dbh->selectcol_arrayref($sql); + is_deeply(\@perl_antimatch, $db_antimatch, "NOT REGEXP '$regex'"); + } + + # null + { + my $sql = "SELECT txt from regexp_test WHERE txt REGEXP NULL " + . "COLLATE perllocale"; + my $db_match = $dbh->selectcol_arrayref($sql); + + is_deeply([], $db_match, "REGEXP NULL"); + + $sql =~ s/REGEXP/NOT REGEXP/; + my $db_antimatch = $dbh->selectcol_arrayref($sql); + is_deeply([], $db_antimatch, "NOT REGEXP NULL"); + } + } +} + diff --git a/t/38_empty_statement.t b/t/38_empty_statement.t new file mode 100644 index 0000000..a0a297c --- /dev/null +++ b/t/38_empty_statement.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +plan tests => 8; + +my $dbh = connect_ok( RaiseError => 1 ); + +eval { $dbh->do("\n") }; +ok !$@, "empty statement does not spit a warning"; +diag $@ if $@; + +eval { $dbh->do(" ") }; +ok !$@, "empty statement does not spit a warning"; +diag $@ if $@; + +eval { $dbh->do("") }; +ok !$@, "empty statement does not spit a warning"; +diag $@ if $@; + +eval { $dbh->do("/* everything in a comment */") }; +ok !$@, "empty statement does not spit a warning"; +diag $@ if $@; + +eval { $dbh->do("-- everything in a comment") }; +ok !$@, "empty statement does not spit a warning"; +diag $@ if $@; + +eval { $dbh->do(undef) }; +ok !$@, "undef statement does not spit a warning, and does not die anyway"; +diag $@ if $@; diff --git a/t/39_foreign_keys.t b/t/39_foreign_keys.t new file mode 100644 index 0000000..b7632fc --- /dev/null +++ b/t/39_foreign_keys.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; + +BEGIN { + use DBD::SQLite; + unless ($DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= 3006019) { + plan skip_all => "this test requires SQLite 3.6.19 and newer"; + exit; + } +} + +use Test::NoWarnings; + +plan tests => 17; + +# following tests are from http://www.sqlite.org/foreignkeys.html + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); + +$dbh->do("PRAGMA foreign_keys = ON"); + +ok $dbh->do("CREATE TABLE artist ( + artistid INTEGER PRIMARY KEY, + artistname TEXT +)"); +ok $dbh->do("CREATE TABLE track ( + trackid INTEGER PRIMARY KEY, + trackname TEXT, + trackartist INTEGER, + FOREIGN KEY(trackartist) REFERENCES artist(artistid) +)"); + +ok insert_artist(1, "Dean Martin"); +ok insert_artist(2, "Frank Sinatra"); + +ok insert_track(11, "That's Amore", 1); +ok insert_track(12, "Christmas Blues", 1); +ok insert_track(13, "My Way", 2); + +# This fails because the value inserted into the trackartist +# column (3) does not correspond to row in the artist table. + +ok !insert_track(14, "Mr. Bojangles", 3); +ok $@ =~ qr/foreign key constraint failed/; + +# This succeeds because a NULL is inserted into trackartist. A +# corresponding row in the artist table is not required in this case. + +ok insert_track(14, "Mr. Bojangles", undef); + +# Trying to modify the trackartist field of the record after it has +# been inserted does not work either, since the new value of +# trackartist (3) still does not correspond to any row in the +# artist table. + +ok !update_track(3, "Mr. Bojangles"); +ok $@ =~ /foreign key constraint failed/; + +# Insert the required row into the artist table. It is then possible +# to update the inserted row to set trackartist to 3 (since a +# corresponding row in the artist table now exists). + +ok insert_artist(3, "Sammy Davis Jr."); +ok update_track(3, "Mr. Bojangles"); + +# Now that "Sammy Davis Jr." (artistid = 3) has been added to the +# database, it is possible to INSERT new tracks using this artist +# without violating the foreign key constraint: + +ok insert_track(15, "Boogie Woogie", 3); + +sub insert_artist { _do("INSERT INTO artist (artistid, artistname) VALUES (?, ?)", @_ ); } +sub insert_track { _do("INSERT INTO track (trackid, trackname, trackartist) VALUES (?, ?, ?)", @_); } +sub update_track { _do("UPDATE track SET trackartist = ? WHERE trackname = ?", @_); } + +sub _do { eval { $dbh->do(shift, undef, @_) }; } diff --git a/t/40_multiple_statements.t b/t/40_multiple_statements.t new file mode 100644 index 0000000..7f98693 --- /dev/null +++ b/t/40_multiple_statements.t @@ -0,0 +1,133 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +plan tests => 21; + +{ + # DBD::SQLite prepares/does the first statement only; + # the following statements will be discarded silently. + + my $dbh = connect_ok( RaiseError => 1 ); + eval { $dbh->do(q/ + create table foo (id integer); + insert into foo (id) values (1); + insert into foo (id) values (2); + /)}; + ok !$@, "do succeeds anyway"; + diag $@ if $@; + my $got = $dbh->selectall_arrayref('select id from foo'); + ok !@$got, "but got nothing as the inserts were discarded"; +} + +{ + # As of 1.29_01, you can do bulk inserts with the help of + # "sqlite_allows_multiple_statements" and + # "sqlite_unprepared_statements" attributes. + my $dbh = connect_ok( + RaiseError => 1, + sqlite_allow_multiple_statements => 1, + ); + ok $dbh->{sqlite_allow_multiple_statements}, "allows multiple statements"; + eval { $dbh->do(q/ + create table foo (id integer); + insert into foo (id) values (1); + insert into foo (id) values (2); + /, { sqlite_allow_multiple_statements => 1 })}; + ok !$@, "do succeeds anyway"; + diag $@ if $@; + + my $got = $dbh->selectall_arrayref('select id from foo'); + ok $got->[0][0] == 1 + && $got->[1][0] == 2, "and got the inserted values"; +} + +{ + # Do it more explicitly + my $dbh = connect_ok( + RaiseError => 1, + sqlite_allow_multiple_statements => 1, + ); + ok $dbh->{sqlite_allow_multiple_statements}, "allows multiple statements"; + my $statement = q/ + create table foo (id integer); + insert into foo (id) values (1); + insert into foo (id) values (2); + /; + $dbh->begin_work; + eval { + while ($statement) { + my $sth = $dbh->prepare($statement); + $sth->execute; + $statement = $sth->{sqlite_unprepared_statements}; + } + }; + ok !$@, "executed multiple statements successfully"; + diag $@ if $@; + $@ ? $dbh->rollback : $dbh->commit; + + my $got = $dbh->selectall_arrayref('select id from foo'); + ok $got->[0][0] == 1 + && $got->[1][0] == 2, "and got the inserted values"; +} + +{ + # Placeholders + my $dbh = connect_ok( + RaiseError => 1, + sqlite_allow_multiple_statements => 1, + ); + ok $dbh->{sqlite_allow_multiple_statements}, "allows multiple statements"; + eval { $dbh->do(q/ + create table foo (id integer); + insert into foo (id) values (?); + insert into foo (id) values (?); + /, undef, 1, 2)}; + ok !$@, "do succeeds anyway"; + diag $@ if $@; + + my $got = $dbh->selectall_arrayref('select id from foo'); + ok $got->[0][0] == 1 + && $got->[1][0] == 2, "and got the inserted values"; +} + +{ + # Do it more explicitly + my $dbh = connect_ok( + RaiseError => 1, + sqlite_allow_multiple_statements => 1, + ); + ok $dbh->{sqlite_allow_multiple_statements}, "allows multiple statements"; + my $statement = q/ + create table foo (id integer); + insert into foo (id) values (?); + insert into foo (id) values (?); + /; + $dbh->begin_work; + eval { + my @params = (1, 2); + while ($statement) { + my $sth = $dbh->prepare($statement); + $sth->execute(splice @params, 0, $sth->{NUM_OF_PARAMS}); + $statement = $sth->{sqlite_unprepared_statements}; + } + }; + ok !$@, "executed multiple statements successfully"; + diag $@ if $@; + $@ ? $dbh->rollback : $dbh->commit; + + ok !$@, "executed multiple statements successfully"; + diag $@ if $@; + + my $got = $dbh->selectall_arrayref('select id from foo'); + ok $got->[0][0] == 1 + && $got->[1][0] == 2, "and got the inserted values"; +} diff --git a/t/41_placeholders.t b/t/41_placeholders.t new file mode 100644 index 0000000..957c359 --- /dev/null +++ b/t/41_placeholders.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +plan tests => 13; + +my $dbh = connect_ok( RaiseError => 1 ); +ok $dbh->do('create table foo (id integer, value integer)'); + +ok $dbh->do('insert into foo values(?, ?)', undef, 1, 2); +ok $dbh->do('insert into foo values(?1, ?2)', undef, 2, 3); +ok $dbh->do('insert into foo values(:1, :2)', undef, 3, 4); +ok $dbh->do('insert into foo values(@1, @2)', undef, 4, 4); +my $sth = $dbh->prepare('insert into foo values(:foo, :bar)'); +ok $sth, "prepared sth with named parameters"; +$sth->bind_param(':foo', 5); +$sth->bind_param(':bar', 6); +my $warn; +eval { + local $SIG{__WARN__} = sub { $warn = shift; }; + $sth->bind_param(':baz', "AAAAAAA"); +}; +ok $@, "binding unexisting named parameters returns error"; +print "# expected bind error: $@"; +ok $warn, "... and warning"; +print "# expected bind warning: $warn"; +$sth->execute; +{ + my ($count) = $dbh->selectrow_array( + 'select count(id) from foo where id = ? and value = ?', + undef, 5, 6 + ); + + ok $count == 1, "successfully inserted row with named placeholders"; +} + +SKIP: { + skip "this placeholder requires SQLite 3.6.19 and newer", 2 + unless $DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= 3006019; + ok $dbh->do( + 'update foo set id = $1 where value = $2 and id is not $1', + undef, 3, 4 + ); + + my ($count) = $dbh->selectrow_array( + 'select count(id) from foo where id = ? and value = ?', + undef, 3, 4 + ); + + ok $count == 2; +} diff --git a/t/42_primary_key_info.t b/t/42_primary_key_info.t new file mode 100644 index 0000000..a87d5af --- /dev/null +++ b/t/42_primary_key_info.t @@ -0,0 +1,90 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use Test::NoWarnings; + +plan tests => (5 * 5) + (3 * 6 + 1) + 1; + +for my $quote ('', qw/' " ` []/) { + my ($begin_quote, $end_quote) = (substr($quote, 0, 1), substr($quote, -1, 1)); + my $dbh = connect_ok( RaiseError => 1 ); + ok $dbh->do( + "create table ${begin_quote}foo${end_quote} (${begin_quote}id${end_quote} integer primary key)" + ); + my $sth = $dbh->primary_key_info(undef, undef, 'foo'); + my $pk = $sth->fetchrow_hashref; + ok $pk->{TABLE_NAME} eq 'foo'; # dequoted + ok $pk->{COLUMN_NAME} eq 'id'; # dequoted + + ($pk) = $dbh->primary_key(undef, undef, 'foo'); + ok $pk eq 'id'; +} + +{ + my $dbh = connect_ok(); + $dbh->do("create table foo (id integer primary key)"); + $dbh->do("attach database ':memory:' as remote"); + $dbh->do("create table remote.bar (name text, primary key(name))"); + $dbh->do("create temporary table baz (tmp primary key)"); + + { + my $sth = $dbh->primary_key_info(undef, undef, 'foo'); + my @pk_info; + while(my $row = $sth->fetchrow_hashref) { push @pk_info, $row }; + is @pk_info => 1, "found 1 pk in a table"; + is $pk_info[0]{TABLE_SCHEM} => 'main', "scheme is correct"; + is $pk_info[0]{COLUMN_NAME} => 'id', "pk name is correct"; + } + + { + my $sth = $dbh->primary_key_info(undef, 'main', undef); + my @pk_info; + while(my $row = $sth->fetchrow_hashref) { push @pk_info, $row }; + is @pk_info => 1, "found 1 pk in a table"; + is $pk_info[0]{TABLE_SCHEM} => 'main', "scheme is correct"; + is $pk_info[0]{COLUMN_NAME} => 'id', "pk name is correct"; + } + + { + my $sth = $dbh->primary_key_info(undef, undef, 'bar'); + my @pk_info; + while(my $row = $sth->fetchrow_hashref) { push @pk_info, $row }; + is @pk_info => 1, "found 1 pk in an attached table"; + is $pk_info[0]{TABLE_SCHEM} => 'remote', "scheme is correct"; + is $pk_info[0]{COLUMN_NAME} => 'name', "pk name is correct"; + } + + { + my $sth = $dbh->primary_key_info(undef, 'remote', undef); + my @pk_info; + while(my $row = $sth->fetchrow_hashref) { push @pk_info, $row }; + is @pk_info => 1, "found 1 pk in an attached table"; + is $pk_info[0]{TABLE_SCHEM} => 'remote', "scheme is correct"; + is $pk_info[0]{COLUMN_NAME} => 'name', "pk name is correct"; + } + + { + my $sth = $dbh->primary_key_info(undef, 'temp', undef); + my @pk_info; + while(my $row = $sth->fetchrow_hashref) { push @pk_info, $row }; + is @pk_info => 1, "found 1 pk in a table"; + is $pk_info[0]{TABLE_SCHEM} => 'temp', "scheme is correct"; + is $pk_info[0]{COLUMN_NAME} => 'tmp', "pk name is correct"; + } + + { + my $sth = $dbh->primary_key_info(undef, undef, 'baz'); + my @pk_info; + while(my $row = $sth->fetchrow_hashref) { push @pk_info, $row }; + is @pk_info => 1, "found 1 pk in an attached table"; + is $pk_info[0]{TABLE_SCHEM} => 'temp', "scheme is correct"; + is $pk_info[0]{COLUMN_NAME} => 'tmp', "pk name is correct"; + } +}
\ No newline at end of file diff --git a/t/43_fts3.t b/t/43_fts3.t new file mode 100644 index 0000000..ed6d112 --- /dev/null +++ b/t/43_fts3.t @@ -0,0 +1,113 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +use DBD::SQLite; + +my @texts = ("il était une bergère", + "qui gardait ses moutons", + "elle fit un fromage", + "du lait de ses moutons"); + +my @tests = ( +# query => expected results + ["bergère" => 0 ], + ["berg*" => 0 ], + ["foobar" ], + ["moutons" => 1, 3 ], + ['"qui gardait"' => 1 ], + ["moutons NOT lait" => 1 ], + ["il était" => 0 ], + ["(il OR elle) AND un*" => 0, 2 ], +); + +BEGIN { + if ($] < 5.008005) { + plan skip_all => 'Unicode is not supported before 5.8.5'; + } + if (!grep /ENABLE_FTS3/, DBD::SQLite::compile_options()) { + plan skip_all => 'FTS3 is disabled for this DBD::SQLite'; + } +} +use Test::NoWarnings; + +plan tests => 2 * (1 + @tests) + 1; + +BEGIN { + # Sadly perl for windows (and probably sqlite, too) may hang + # if the system locale doesn't support european languages. + # en-us should be a safe default. if it doesn't work, use 'C'. + if ( $^O eq 'MSWin32') { + use POSIX 'locale_h'; + setlocale(LC_COLLATE, 'en-us'); + } +} +use locale; + + +sub locale_tokenizer { # see also: Search::Tokenizer + return sub { + my $string = shift; + + my $regex = qr/\w+/; + my $term_index = 0; + + return sub { + $string =~ /$regex/g or return; # either match, or no more token + my ($start, $end) = ($-[0], $+[0]); + my $term = substr($string, $start, my $len = $end-$start); + return ($term, $len, $start, $end, $term_index++); + }; + }; +} + + + +use DBD::SQLite; + + + +for my $use_unicode (0, 1) { + + # connect + my $dbh = connect_ok( RaiseError => 1, sqlite_unicode => $use_unicode ); + + # create fts3 table + $dbh->do(<<"") or die DBI::errstr; + CREATE VIRTUAL TABLE try_fts3 + USING fts3(content, tokenize=perl 'main::locale_tokenizer') + + # populate it + my $insert_sth = $dbh->prepare(<<"") or die DBI::errstr; + INSERT INTO try_fts3(content) VALUES(?) + + my @doc_ids; + for (my $i = 0; $i < @texts; $i++) { + $insert_sth->execute($texts[$i]); + $doc_ids[$i] = $dbh->last_insert_id("", "", "", ""); + } + + # queries +SKIP: { + skip "These tests require SQLite compiled with ENABLE_FTS3_PARENTHESIS option", scalar @tests + unless DBD::SQLite->can('compile_options') && + grep /ENABLE_FTS3_PARENTHESIS/, DBD::SQLite::compile_options(); + my $sql = "SELECT docid FROM try_fts3 WHERE content MATCH ?"; + for my $t (@tests) { + my ($query, @expected) = @$t; + @expected = map {$doc_ids[$_]} @expected; + my $results = $dbh->selectcol_arrayref($sql, undef, $query); + is_deeply($results, \@expected, "$query (unicode is $use_unicode)"); + } + +} + +} + + diff --git a/t/44_rtree.t b/t/44_rtree.t new file mode 100644 index 0000000..d2afc66 --- /dev/null +++ b/t/44_rtree.t @@ -0,0 +1,113 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +use DBD::SQLite; +use Data::Dumper; + +# NOTE: It seems to be better to compare rounded values +# because stored coordinate values may have slight errors +# since SQLite 3.7.13 (DBD::SQLite 1.38_01). + +sub is_deeply_approx { + my ($got, $expected, $name) = @_; + my $got_approx = [map { sprintf "%0.2f", $_ } @$got]; + my $expected_approx = [map { sprintf "%0.2f", $_ } @$expected]; + is_deeply($got_approx, $expected_approx, $name); +} + +my @coords = ( + # id, minX, maxX, minY, maxY + [1, 1, 200, 1, 200], # outside bounding box + [2, 25, 100, 25, 50], + [3, 50, 125, 40, 150], + [4, 25, 200, 125, 125], # hor. line + [5, 100, 100, 75, 175], # vert. line + [6, 100, 100, 75, 75], # point + [7, 150, 175, 150, 175] +); + +my @test_regions = ( + # minX, maxX, minY, maxY + [75, 75, 45, 45], # query point + [10, 140, 10, 175], # ... box + [30, 100, 75, 75] # ... hor. line +); + +my @test_results = ( + # results for contains tests (what does this region contain?) + [], + [2, 3, 5, 6], + [6], + + # results for overlaps tests (what does this region overlap with?) + [1..3], + [1..6], + [1, 3, 5, 6] +); + +BEGIN { + if (!grep /ENABLE_RTREE/, DBD::SQLite::compile_options()) { + plan skip_all => 'RTREE is disabled for this DBD::SQLite'; + } +} +use Test::NoWarnings; + +plan tests => @coords + (2 * @test_regions) + 4; + +# connect +my $dbh = connect_ok( RaiseError => 1 ); + +# TODO: test rtree and rtree_i32 tables + +# create R* Tree table +$dbh->do(<<"") or die DBI::errstr; + CREATE VIRTUAL TABLE try_rtree + USING rtree_i32(id, minX, maxX, minY, maxY); + +# populate it +my $insert_sth = $dbh->prepare(<<"") or die DBI::errstr; +INSERT INTO try_rtree VALUES (?,?,?,?,?) + +for my $coord (@coords) { + ok $insert_sth->execute(@$coord); +} + +# find by primary key +my $sql = "SELECT * FROM try_rtree WHERE id = ?"; + +my $idx = 0; +for my $id (1..2) { + my $results = $dbh->selectrow_arrayref($sql, undef, $id); + is_deeply_approx($results, $coords[$idx], "Coords for $id match"); + $idx++; +} + +# find contained regions +my $contained_sql = <<""; +SELECT id FROM try_rtree + WHERE minX >= ? AND maxX <= ? + AND minY >= ? AND maxY <= ? + +# Since SQLite 3.7.13, coordinate values may have slight errors. +for my $region (@test_regions) { + my $results = $dbh->selectcol_arrayref($contained_sql, undef, @$region); + is_deeply_approx($results, shift @test_results); +} + +# find overlapping regions +my $overlap_sql = <<""; +SELECT id FROM try_rtree + WHERE maxX >= ? AND minX <= ? + AND maxY >= ? AND minY <= ? + +for my $region (@test_regions) { + my $results = $dbh->selectcol_arrayref($overlap_sql, undef, @$region); + is_deeply_approx($results, shift @test_results); +} diff --git a/t/45_savepoints.t b/t/45_savepoints.t new file mode 100644 index 0000000..87e5d49 --- /dev/null +++ b/t/45_savepoints.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 5; +use Test::NoWarnings; + +my $dbh = connect_ok( + AutoCommit => 1, + RaiseError => 1, +); + +$dbh->begin_work; + +$dbh->do("CREATE TABLE MST (id, lbl)"); + +$dbh->do("SAVEPOINT svp_0"); + +$dbh->do("INSERT INTO MST VALUES(1, 'ITEM1')"); +$dbh->do("INSERT INTO MST VALUES(2, 'ITEM2')"); +$dbh->do("INSERT INTO MST VALUES(3, 'ITEM3')"); + +my $ac = $dbh->{AutoCommit}; + +ok((not $ac), 'AC != 1 inside txn'); + +{ + local $dbh->{AutoCommit} = $dbh->{AutoCommit}; + + $dbh->do("ROLLBACK TRANSACTION TO SAVEPOINT svp_0"); + + is $dbh->{AutoCommit}, $ac, + "rolling back savepoint doesn't alter AC"; +} + +is $dbh->selectrow_array("SELECT COUNT(*) FROM MST"), 0, + "savepoint rolled back"; + +$dbh->rollback; diff --git a/t/46_mod_perl.t b/t/46_mod_perl.t new file mode 100644 index 0000000..6492e1b --- /dev/null +++ b/t/46_mod_perl.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +BEGIN { + eval {require APR::Table; 1}; + if ($@) { + plan skip_all => 'requires APR::Table'; + } + else { + plan tests => 2; + } +} + +my $dbh = connect_ok( + AutoCommit => 1, + RaiseError => 1, +); + +eval { $dbh->do('SELECT 1') }; +ok !$@, "no errors"; +diag $@ if $@; diff --git a/t/47_execute.t b/t/47_execute.t new file mode 100644 index 0000000..8751c47 --- /dev/null +++ b/t/47_execute.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +# Trigger locking error and test prepared statement is still valid afterwards + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok dbfile @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 10 * @CALL_FUNCS + 1; + +foreach my $call_func (@CALL_FUNCS) { + + my $dbh = connect_ok( + dbfile => 'foo', + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, + ); + + my $dbh2 = connect_ok( + dbfile => 'foo', + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, + ); + + my $dbfile = dbfile('foo'); + + # NOTE: Let's make it clear what we're doing here. + # $dbh starts locking with the first INSERT statement. + # $dbh2 tries to INSERT, but as the database is locked, + # it starts waiting. However, $dbh won't release the lock. + # Eventually $dbh2 gets timed out, and spits an error, saying + # the database is locked. So, we don't need to let $dbh2 wait + # too much here. It should be timed out anyway. + ok($dbh->$call_func(300, 'busy_timeout')); + ok($dbh2->$call_func(300, 'busy_timeout')); + + $dbh->do("CREATE TABLE Blah ( id INTEGER )"); + $dbh->do("INSERT INTO Blah VALUES ( 1 )"); + $dbh->commit; + my $sth; + ok($sth = $dbh->prepare("SELECT id FROM Blah")); + $sth->execute; + { + my $row; + ok($row = $sth->fetch); + ok($row && $row->[0] == 1); + } + $sth->finish; + $dbh->commit; + $dbh2->do("BEGIN EXCLUSIVE"); + eval { + $sth->execute; + }; + ok($@); + if ($@) { + print "# expected execute failure : $@"; + $sth->finish; + $dbh->rollback; + } + $dbh2->commit; + $sth->execute; + { + my $row; + ok($row = $sth->fetch); + ok($row && $row->[0] == 1); + } + $sth->finish; + $dbh->commit; + + $dbh2->disconnect; + undef($dbh2); + $dbh->disconnect; + undef($dbh); + + unlink $dbfile; +} diff --git a/t/48_bind_param_is_sticky.t b/t/48_bind_param_is_sticky.t new file mode 100644 index 0000000..504dd74 --- /dev/null +++ b/t/48_bind_param_is_sticky.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl + +# Check data type assignment in bind_param is sticky + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use DBI qw(:sql_types); +use Test::More; +use Test::NoWarnings; + +plan tests => 10 + 1; + +my $dbh = connect_ok( + RaiseError => 1, + PrintError => 0, + AutoCommit => 0, +); +$dbh->do("CREATE TABLE Blah ( id INTEGER, val BLOB )"); +$dbh->commit; +my $sth; +ok($sth = $dbh->prepare("INSERT INTO Blah VALUES (?, ?)"), "prepare"); +$sth->bind_param(1, 1); +$sth->bind_param(2, 'foo', SQL_BLOB); +$sth->execute; +$sth->execute(2, 'bar'); +sub verify_types() { + my $rows = $dbh->selectall_arrayref("SELECT typeof(val) FROM Blah ORDER BY id"); + ok($rows, "selectall_arrayref returned data"); + ok(@{$rows} == 2, "... with expected number of rows"); + ok($rows->[0]->[0] eq 'blob', "$rows->[0]->[0] eq blob"); + ok($rows->[1]->[0] eq 'blob', "$rows->[1]->[0] eq blob"); +} +verify_types(); +$dbh->commit; +$dbh->do("DELETE FROM Blah"); +$sth->bind_param_array(1, [1, 2]); +$sth->bind_param_array(2, [qw/FOO BAR/], SQL_BLOB); +$sth->execute_array({}); +verify_types(); +$dbh->commit; + +$dbh->disconnect; +undef($dbh); diff --git a/t/49_trace_and_profile.t b/t/49_trace_and_profile.t new file mode 100644 index 0000000..b56826a --- /dev/null +++ b/t/49_trace_and_profile.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 12 * @CALL_FUNCS + 1; + +my $flag = 0; +for my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok(); + + # sqlite_trace should always be called as sqlite_trace, + # i.e. $dbh->func(..., "sqlite_trace") and $dbh->sqlite_trace(...) + my $func_name = $flag++ ? "trace" : "sqlite_trace"; + + # trace + my @trace; + $dbh->$call_func(sub { push @trace, [@_] }, $func_name); + $dbh->do('create table foo (id integer)'); + is $trace[0][0] => "create table foo (id integer)"; + + $dbh->do('insert into foo values (?)', undef, 1); + is $trace[1][0] => "insert into foo values ('1')"; + + $dbh->$call_func(undef, $func_name); + + $dbh->do('insert into foo values (?)', undef, 2); + is @trace => 2; + + $dbh->$call_func(sub { push @trace, [@_] }, $func_name); + $dbh->do('insert into foo values (?)', undef, 3); + is $trace[2][0] => "insert into foo values ('3')"; + + # profile + my @profile; + $dbh->$call_func(sub { push @profile, [@_] }, "profile"); + $dbh->do('create table bar (id integer)'); + is $profile[0][0] => "create table bar (id integer)"; + like $profile[0][1] => qr/^[0-9]+$/; + + $dbh->do('insert into bar values (?)', undef, 1); + is $profile[1][0] => "insert into bar values (?)"; + like $profile[1][1] => qr/^[0-9]+$/; + + $dbh->$call_func(undef, "profile"); + + $dbh->do('insert into bar values (?)', undef, 2); + is @profile => 2; + + $dbh->$call_func(sub { push @profile, [@_] }, "profile"); + $dbh->do('insert into bar values (?)', undef, 3); + is $profile[2][0] => "insert into bar values (?)"; + like $profile[2][1] => qr/^[0-9]+$/; +} diff --git a/t/50_foreign_key_info.t b/t/50_foreign_key_info.t new file mode 100644 index 0000000..fffa3d7 --- /dev/null +++ b/t/50_foreign_key_info.t @@ -0,0 +1,125 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; + +BEGIN { + use DBD::SQLite; + unless ($DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= 3006019) { + plan skip_all => "this test requires SQLite 3.6.19 and newer"; + exit; + } +} + +use Test::NoWarnings; + +# SQL below freely adapted from http://www.sqlite.org/foreignkeys.htm ... +# not the best datamodel in the world, but good enough for our tests. + +my @sql_statements = split /\n\n/, <<__EOSQL__; +PRAGMA foreign_keys = ON; + +CREATE TABLE artist ( + artistid INTEGER, + artistname TEXT, + UNIQUE(artistid) +); + +CREATE TABLE editor ( + editorid INTEGER PRIMARY KEY AUTOINCREMENT, + editorname TEXT +); + +ATTACH DATABASE ':memory:' AS remote; + +CREATE TABLE remote.album ( + albumartist INTEGER NOT NULL REFERENCES artist(artistid) + ON DELETE RESTRICT + ON UPDATE CASCADE, + albumname TEXT, + albumcover BINARY, + albumeditor INTEGER NOT NULL REFERENCES editor(editorid), + PRIMARY KEY(albumartist, albumname) +); + +CREATE TABLE song( + songid INTEGER PRIMARY KEY AUTOINCREMENT, + songartist INTEGER, + songalbum TEXT, + songname TEXT, + FOREIGN KEY(songartist, songalbum) REFERENCES album(albumartist, albumname) +); +__EOSQL__ + + +plan tests => @sql_statements + 20; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 ); +my $sth; +my $fk_data; +my $R = \%DBD::SQLite::db::DBI_code_for_rule; + +ok ($dbh->do($_), $_) foreach @sql_statements; + +$sth = $dbh->foreign_key_info(undef, undef, undef, + undef, undef, 'album'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); + +for ($fk_data->{albumartist}) { + is($_->{PKTABLE_NAME}, "artist" , "FK albumartist, table name"); + is($_->{PKCOLUMN_NAME}, "artistid", "FK albumartist, column name"); + is($_->{KEY_SEQ}, 1, "FK albumartist, key seq"); + is($_->{DELETE_RULE}, $R->{RESTRICT}, "FK albumartist, delete rule"); + is($_->{UPDATE_RULE}, $R->{CASCADE}, "FK albumartist, update rule"); + is($_->{UNIQUE_OR_PRIMARY}, 'UNIQUE', "FK albumartist, unique"); +} +for ($fk_data->{albumeditor}) { + is($_->{PKTABLE_NAME}, "editor", "FK albumeditor, table name"); + is($_->{PKCOLUMN_NAME}, "editorid", "FK albumeditor, column name"); + is($_->{KEY_SEQ}, 1, "FK albumeditor, key seq"); + # rules are 'NO ACTION' by default + is($_->{DELETE_RULE}, $R->{'NO ACTION'}, "FK albumeditor, delete rule"); + is($_->{UPDATE_RULE}, $R->{'NO ACTION'}, "FK albumeditor, update rule"); + is($_->{UNIQUE_OR_PRIMARY}, 'PRIMARY', "FK albumeditor, primary"); +} + + +$sth = $dbh->foreign_key_info(undef, undef, 'artist', + undef, undef, 'album'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +is_deeply([keys %$fk_data], ['albumartist'], "FK album with PK, only 1 result"); + + +$sth = $dbh->foreign_key_info(undef, undef, 'foobar', + undef, undef, 'album'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +is_deeply([keys %$fk_data], [], "FK album with PK foobar, 0 result"); + + +$sth = $dbh->foreign_key_info(undef, undef, undef, + undef, 'remote', undef); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +is_deeply([sort keys %$fk_data], [qw/albumartist albumeditor/], "FK remote.*, 2 results"); + + +$sth = $dbh->foreign_key_info(undef, 'remote', undef, + undef, undef, undef); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +is_deeply([sort keys %$fk_data], [qw/songalbum songartist/], "FK with PK remote.*, 2 results"); + + +$sth = $dbh->foreign_key_info(undef, undef, undef, + undef, undef, 'song'); +$fk_data = $sth->fetchall_hashref('FKCOLUMN_NAME'); +for ($fk_data->{songartist}) { + is($_->{KEY_SEQ}, 1, "FK song, key seq 1"); +} +for ($fk_data->{songalbum}) { + is($_->{KEY_SEQ}, 2, "FK song, key seq 2"); +} diff --git a/t/51_table_column_metadata.t b/t/51_table_column_metadata.t new file mode 100644 index 0000000..f140a11 --- /dev/null +++ b/t/51_table_column_metadata.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 16 * @CALL_FUNCS + 1; +for my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok(RaiseError => 1); + $dbh->do('create table foo (id integer primary key autoincrement, "name space", unique_col integer unique)'); + + { + my $data = $dbh->$call_func(undef, 'foo', 'id', 'table_column_metadata'); + ok $data && ref $data eq ref {}, "got a metadata"; + ok $data->{auto_increment}, "id is auto incremental"; + is $data->{data_type} => 'integer', "data type is correct"; + ok $data->{primary}, "id is a primary key"; + ok !$data->{not_null}, "id is not null"; + } + + { + my $data = $dbh->$call_func(undef, 'foo', 'name space', 'table_column_metadata'); + ok $data && ref $data eq ref {}, "got a metadata"; + ok !$data->{auto_increment}, "name space is not auto incremental"; + is $data->{data_type} => undef, "data type is not defined"; + ok !$data->{primary}, "name space is not a primary key"; + ok !$data->{not_null}, "name space is not null"; + } + + # exceptions + { + local $SIG{__WARN__} = sub {}; + eval { $dbh->$call_func(undef, undef, 'name space', 'table_column_metadata') }; + ok $@, "successfully died when tablename is undef"; + + eval { $dbh->$call_func(undef, '', 'name space', 'table_column_metadata') }; + ok !$@, "not died when tablename is an empty string"; + + eval { $dbh->$call_func(undef, 'foo', undef, 'table_column_metadata') }; + ok $@, "successfully died when columnname is undef"; + + eval { $dbh->$call_func(undef, 'foo', '', 'table_column_metadata') }; + ok !$@, "not died when columnname is an empty string"; + + $dbh->disconnect; + + eval { $dbh->$call_func(undef, 'foo', 'name space', 'table_column_metadata') }; + ok $@, "successfully died when dbh is inactive"; + } +} diff --git a/t/52_db_filename.t b/t/52_db_filename.t new file mode 100644 index 0000000..e4e62da --- /dev/null +++ b/t/52_db_filename.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use Test::NoWarnings; + +plan tests => 6 * @CALL_FUNCS + 1; + +for my $func (@CALL_FUNCS) { + { + my $db = filename($func); + ok !$db, "in-memory database"; + } + + { + my $db = filename($func, dbfile => ''); + ok !$db, "temporary database"; + } + + { + my $db = filename($func, dbfile => 'test.db'); + like $db => qr/test\.db[\d]*$/i, "test.db"; + unlink $db; + } +} + +sub filename { + my $func = shift; + my $dbh = connect_ok(@_); + $dbh->$func('db_filename'); +} diff --git a/t/53_status.t b/t/53_status.t new file mode 100644 index 0000000..ec8fc29 --- /dev/null +++ b/t/53_status.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +#use Test::NoWarnings; + +#plan tests => 6 * @CALL_FUNCS + 1; + +my $dbh = connect_ok(); +{ + $dbh->do('create table foo (id integer primary key, text)'); + my $sth = $dbh->prepare('insert into foo values(?, ?)'); + $sth->execute($_, "text$_") for 1..100; +} + +{ + my $status = DBD::SQLite::sqlite_status(); + ok $status && ref $status eq ref {}, "status is a hashref"; + my $num_of_keys = scalar keys %$status; + ok $num_of_keys, "status: $num_of_keys indicators"; + my $used_mem = $status->{memory_used}{current}; + ok defined $used_mem && $used_mem, "current used memory: $used_mem"; +} + +for my $func (@CALL_FUNCS) { + { + my $db_status = $dbh->$func('db_status'); + ok $db_status && ref $db_status eq ref {}, "db status is a hashref"; + my $num_of_keys = scalar keys %$db_status; + ok $num_of_keys, "db status: $num_of_keys indicators"; + my $used_cache = $db_status->{cache_used}{current}; + ok defined $used_cache && $used_cache, "current used cache: $used_cache"; + } + + { + my $sth = $dbh->prepare('select * from foo where text = ? order by text desc'); + $sth->execute("text1"); + my $st_status = $sth->$func('st_status'); + ok $st_status && ref $st_status eq ref {}, "st status is a hashref"; + my $num_of_keys = scalar keys %$st_status; + ok $num_of_keys, "st status: $num_of_keys indicators"; + my $sort = $st_status->{sort}; + ok defined $sort && $sort, "num of sort: $sort"; + } +} + +done_testing; diff --git a/t/cookbook_variance.t b/t/cookbook_variance.t new file mode 100644 index 0000000..cd66144 --- /dev/null +++ b/t/cookbook_variance.t @@ -0,0 +1,133 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +use Test::NoWarnings; + +plan tests => 3 * @CALL_FUNCS * 3 + 1; + +# The following snippets are copied from Cookbook.pod by hand. +# Don't forget to update here when the pod is updated. +# Or, use/coin something like Test::Snippets for better synching. + +SCOPE: { + package variance; + + sub new { bless [], shift; } + + sub step { + my ( $self, $value ) = @_; + + push @$self, $value; + } + + sub finalize { + my $self = $_[0]; + + my $n = @$self; + + # Variance is NULL unless there is more than one row + return undef unless $n || $n == 1; + + my $mu = 0; + foreach my $v ( @$self ) { + $mu += $v; + } + $mu /= $n; + + my $sigma = 0; + foreach my $v ( @$self ) { + $sigma += ($v - $mu)**2; + } + $sigma = $sigma / ($n - 1); + + return $sigma; + } +} + +SCOPE2: { + package variance2; + + sub new { bless {sum => 0, count=>0, hash=> {} }, shift; } + + sub step { + my ( $self, $value ) = @_; + my $hash = $self->{hash}; + + # by truncating and hashing, we can comsume many more data points + $value = int($value); # change depending on need for precision + # use sprintf for arbitrary fp precision + if (exists $hash->{$value}) { + $hash->{$value}++; + } else { + $hash->{$value} = 1; + } + $self->{sum} += $value; + $self->{count}++; + } + + sub finalize { + my $self = $_[0]; + + # Variance is NULL unless there is more than one row + return undef unless $self->{count} > 1; + + # calculate avg + my $mu = $self->{sum} / $self->{count}; + + my $sigma = 0; + while (my ($h, $v) = each %{$self->{hash}}) { + $sigma += (($h - $mu)**2) * $v; + } + $sigma = $sigma / ($self->{count} - 1); + + return $sigma; + } +} + +SCOPE3: { + package variance3; + + sub new { bless {mu=>0, count=>0, S=>0}, shift; } + + sub step { + my ( $self, $value ) = @_; + $self->{count}++; + my $delta = $value - $self->{mu}; + $self->{mu} += $delta/$self->{count}; + $self->{S} += $delta*($value - $self->{mu}); + } + + sub finalize { + my $self = $_[0]; + return $self->{S} / ($self->{count} - 1); + } +} + +foreach my $variance (qw/variance variance2 variance3/) { + foreach my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok( PrintError => 0 ); + $dbh->do('CREATE TABLE results (group_name, score)'); + my $sth = $dbh->prepare('INSERT INTO results VALUES (?,?)'); + $sth->execute('foo', 100); + $sth->execute('foo', 50); + $sth->finish; + + $dbh->$call_func($variance, 1, $variance, "create_aggregate"); + + my $result = $dbh->selectrow_arrayref(<<"END_SQL"); + SELECT group_name, ${variance}(score) + FROM results + GROUP BY group_name; +END_SQL + + is $result->[0] => 'foo'; + is $result->[1] => 1250; + } +} diff --git a/t/lib/Test.pm b/t/lib/Test.pm new file mode 100644 index 0000000..1d919bf --- /dev/null +++ b/t/lib/Test.pm @@ -0,0 +1,130 @@ +package t::lib::Test; + +# Support code for DBD::SQLite tests + +use strict; +use Exporter (); +use File::Spec (); +use Test::More (); + +our $VERSION = '1.38_01'; +our @ISA = 'Exporter'; +our @EXPORT = qw/connect_ok dies dbfile @CALL_FUNCS/; +our @CALL_FUNCS; + +my $parent; +my %dbfiles; + +BEGIN { + # Allow tests to load modules bundled in /inc + unshift @INC, 'inc'; + + $parent = $$; +} + +# Always load the DBI module +use DBI (); + +sub dbfile { $dbfiles{$_[0]} } + +# Delete temporary files +sub clean { + return + if $$ != $parent; + for my $dbfile (values %dbfiles) { + next if $dbfile eq ':memory:'; + unlink $dbfile if -f $dbfile; + my $journal = $dbfile . '-journal'; + unlink $journal if -f $journal; + } +} + +# Clean up temporary test files both at the beginning and end of the +# test script. +BEGIN { clean() } +END { clean() } + +# A simplified connect function for the most common case +sub connect_ok { + my $attr = { @_ }; + my $dbfile = defined $attr->{dbfile} ? delete $attr->{dbfile} : ':memory:'; + $dbfiles{$dbfile} = (defined $dbfile && length $dbfile && $dbfile ne ':memory:') ? $dbfile . $$ : $dbfile; + my @params = ( "dbi:SQLite:dbname=$dbfiles{$dbfile}", '', '' ); + if ( %$attr ) { + push @params, $attr; + } + my $dbh = DBI->connect( @params ); + Test::More::isa_ok( $dbh, 'DBI::db' ); + return $dbh; +} + +=head2 dies + + dies(sub {...}, $regex_expected_error, $msg) + +Tests that the given coderef (most probably a closure) dies with the +expected error message. + +=cut + +sub dies { + my ($coderef, $regex, $msg) = @_; + eval {$coderef->()}; + my $exception = $@; + Test::More::ok($exception =~ $regex, + $msg || "dies with exception: $exception"); +} + + + +=head2 @CALL_FUNCS + +The exported array C<@CALL_FUNCS> contains a list of coderefs +for testing several ways of calling driver-private methods. +On DBI versions prior to 1.608, such methods were called +through "func". Starting from 1.608, methods should be installed +within the driver (see L<DBI::DBD>) and are called through +C<< $dbh->sqlite_method_name(...) >>. This array helps to test +both ways. Usage : + + for my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok(); + ... + $dbh->$call_func(@args, 'method_to_call'); + ... + } + +On DBI versions prior to 1.608, the loop will run only once +and the method call will be equivalent to +C<< $dbh->func(@args, 'method_to_call') >>. +On more recent versions, the loop will run twice; +the second execution will call +C<< $dbh->sqlite_method_to_call(@args) >>. + +The number of tests to plan should be adapted accordingly. +It can be computed like this : + + plan tests => $n_normal_tests * @CALL_FUNCS + 1; + +The additional C< + 1> is required when using +L<Test::NoWarnings>, because that module adds +a final test in an END block outside of the loop. + +=cut + + +# old_style way ("func") +push @CALL_FUNCS, sub { + my $dbh = shift; + return $dbh->func(@_); +}; + +# new_style, using $dbh->sqlite_*(...) --- starting from DBI v1.608 +$DBI::VERSION >= 1.608 and push @CALL_FUNCS, sub { + my $dbh = shift; + my $func_name = pop; + my $method = "sqlite_" . $func_name; + return $dbh->$method(@_); +}; + +1; diff --git a/t/rt_15186_prepcached.t b/t/rt_15186_prepcached.t new file mode 100644 index 0000000..f617ef8 --- /dev/null +++ b/t/rt_15186_prepcached.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl + +# This is a regression test for bug #15186: +# http://rt.cpan.org/Public/Bug/Display.html?id=15186 +# About re-using statements with prepare_cached(). + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 13; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok( RaiseError => 1 ); + +# Create the table +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE one ( + id INTEGER NOT NULL, + name CHAR (64) NOT NULL +) +END_SQL + +# Fill the table +ok( + $dbh->do('INSERT INTO one values ( 1, ? )', {}, 'A'), + 'INSERT 1', +); +ok( + $dbh->do('INSERT INTO one values ( 2987, ? )', {}, 'Not used'), + 'INSERT 1', +); +ok( + $dbh->do('INSERT INTO one values ( 2, ? )', {}, 'Gary Shea'), + 'INSERT 1', +); + +# Check that prepare_cached works +my $sql = "SELECT name FROM one WHERE id = ?"; +SCOPE: { + my $sth = $dbh->prepare_cached($sql); + isa_ok( $sth, 'DBI::st' ); + is( + ($dbh->selectrow_array($sth, undef, 1))[0], + 'A', + 'Query 1 Row 1', + ); +} +SCOPE: { + my $sth = $dbh->prepare_cached($sql); + isa_ok( $sth, 'DBI::st' ); + is( + ($dbh->selectrow_array($sth, undef, 1))[0], + 'A', + 'Query 2 Row 1', + ); + is( + ($dbh->selectrow_array($sth, undef, 2))[0], + 'Gary Shea', + 'Query 2 Row 2', + ); +} +SCOPE: { + my $sth = $dbh->prepare_cached($sql); + isa_ok( $sth, 'DBI::st' ); + is( + ($dbh->selectrow_array($sth, undef, 2))[0], + 'Gary Shea', + 'Query 2 Row 2', + ); +} diff --git a/t/rt_21406_auto_finish.t b/t/rt_21406_auto_finish.t new file mode 100644 index 0000000..b621391 --- /dev/null +++ b/t/rt_21406_auto_finish.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 11; +use Test::NoWarnings; + +SCOPE: { + my $dbh = connect_ok( RaiseError => 1 ); + $dbh->do("CREATE TABLE f (f1, f2, f3)"); + $dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 1); + $dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 2); + $dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 3); + $dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 4); + $dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 5); + + my $sth1 = $dbh->prepare_cached('SELECT * FROM f ORDER BY f3', {}); + isa_ok( $sth1, 'DBI::st' ); + ok( $sth1->execute, '->execute ok' ); + is_deeply( $sth1->fetchrow_arrayref, [ 'foo', 'bar', 1 ], 'Row 1 ok' ); + is_deeply( $sth1->fetchrow_arrayref, [ 'foo', 'bar', 2 ], 'Row 2 ok' ); + + my $sth2 = $dbh->prepare_cached('SELECT * FROM f ORDER BY f3', {}, 3); + isa_ok( $sth2, 'DBI::st' ); + ok( $sth2->execute, '->execute ok' ); + is_deeply( $sth2->fetchrow_arrayref, [ 'foo', 'bar', 1 ], 'Row 1 ok' ); + is_deeply( $sth2->fetchrow_arrayref, [ 'foo', 'bar', 2 ], 'Row 2 ok' ); + ok( $sth2->finish, '->finish ok' ); +} diff --git a/t/rt_25371_asymmetric_unicode.t b/t/rt_25371_asymmetric_unicode.t new file mode 100644 index 0000000..40736f1 --- /dev/null +++ b/t/rt_25371_asymmetric_unicode.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +BEGIN { + if ( $] >= 5.008005 ) { + plan( tests => 23 ); + } else { + plan( skip_all => 'Unicode is not supported before 5.8.5' ); + } +} +use Test::NoWarnings; + +my $dbh = connect_ok( sqlite_unicode => 1 ); +is( $dbh->{sqlite_unicode}, 1, 'Unicode is on' ); + +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE foo ( + bar varchar(255) +) +END_SQL + +foreach ( "\0", "A", "\xe9", "\x{20ac}" ) { + ok( $dbh->do("INSERT INTO foo VALUES ( ? )", {}, $_), 'INSERT' ); + my $foo = $dbh->selectall_arrayref("SELECT bar FROM foo"); + is_deeply( $foo, [ [ $_ ] ], 'Value round-tripped ok' ); + my $len = $dbh->selectall_arrayref("SELECT length(bar) FROM foo"); + is $len->[0][0], 1 unless $_ eq "\0"; + my $match = $dbh->selectall_arrayref("SELECT bar FROM foo WHERE bar = ?", {}, $_); + is $match->[0][0], $_; + ok( $dbh->do("DELETE FROM foo"), 'DELETE ok' ); +} diff --git a/t/rt_25460_numeric_aggregate.t b/t/rt_25460_numeric_aggregate.t new file mode 100644 index 0000000..683845b --- /dev/null +++ b/t/rt_25460_numeric_aggregate.t @@ -0,0 +1,62 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 14; +use Test::NoWarnings; + +# Create the table +my $dbh = connect_ok(); +ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +create table foo ( + id integer primary key not null, + mygroup varchar(255) not null, + mynumber numeric(20,3) not null +) +END_SQL + +# Fill the table +my @data = qw{ + a -2 + a 1 + b 2 + b 1 + c 3 + c -1 + d 4 + d 5 + e 6 + e 7 +}; +$dbh->begin_work; +while ( @data ) { + ok $dbh->do( + 'insert into foo ( mygroup, mynumber ) values ( ?, ? )', {}, + shift(@data), shift(@data), + ); +} +$dbh->commit; + +# Issue the group/sum/sort/limit query +my $rv = $dbh->selectall_arrayref(<<'END_SQL'); +select mygroup, sum(mynumber) as total +from foo +group by mygroup +order by total +limit 3 +END_SQL + +is_deeply( + $rv, + [ + [ 'a', -1 ], + [ 'c', 2 ], + [ 'b', 3 ], + ], + 'group/sum/sort/limit query ok' +); diff --git a/t/rt_25924_user_defined_func_unicode.t b/t/rt_25924_user_defined_func_unicode.t new file mode 100644 index 0000000..fba2ef0 --- /dev/null +++ b/t/rt_25924_user_defined_func_unicode.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +BEGIN { + if ( $] >= 5.008005 ) { + plan( tests => 15 * @CALL_FUNCS + 1); + } else { + plan( skip_all => 'Unicode is not supported before 5.8.5' ); + } +} +use Test::NoWarnings; + +foreach my $call_func (@CALL_FUNCS) { + my $dbh = connect_ok( sqlite_unicode => 1 ); + ok($dbh->$call_func( "perl_uc", 1, \&perl_uc, "create_function" )); + + ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); +CREATE TABLE foo ( + bar varchar(255) +) +END_SQL + + my @words = qw{Bergère hôte hétaïre hêtre}; + foreach my $word (@words) { + # rt48048: don't need to "use utf8" nor "require utf8" + utf8::upgrade($word); + ok( $dbh->do("INSERT INTO foo VALUES ( ? )", {}, $word), 'INSERT' ); + my $foo = $dbh->selectall_arrayref("SELECT perl_uc(bar) FROM foo"); + is_deeply( $foo, [ [ perl_uc($word) ] ], 'unicode upcase ok' ); + ok( $dbh->do("DELETE FROM foo"), 'DELETE ok' ); + } + $dbh->disconnect; +} + +sub perl_uc { + my $string = shift; + return uc($string); +} diff --git a/t/rt_27553_prepared_cache_and_analyze.t b/t/rt_27553_prepared_cache_and_analyze.t new file mode 100644 index 0000000..668c317 --- /dev/null +++ b/t/rt_27553_prepared_cache_and_analyze.t @@ -0,0 +1,26 @@ +use strict; + +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 6; +use Test::NoWarnings; + +my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 ); + +$dbh->do("CREATE TABLE f (f1, f2, f3)"); + +my $sth = $dbh->prepare_cached("SELECT f.f1, f.* FROM f"); +ok($sth); + +$dbh->do("ANALYZE"); # invalidate prepared statement handles + +my $sth2 = $dbh->prepare_cached("SELECT f.f1, f.* FROM f"); +ok($sth2); + +my $ret = eval { $sth2->execute(); "ok" }; +ok !$@; +is($ret, 'ok'); diff --git a/t/rt_29058_group_by.t b/t/rt_29058_group_by.t new file mode 100644 index 0000000..bb8219d --- /dev/null +++ b/t/rt_29058_group_by.t @@ -0,0 +1,73 @@ +use strict; + +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 8; +use Test::NoWarnings; +use DBI qw(:sql_types); + +my $dbh = connect_ok(); +$dbh->do('CREATE TABLE foo (bar TEXT, num INT)'); + +foreach ( 1..5 ) { + $dbh->do( + 'INSERT INTO foo (bar, num) VALUES (?, ?)', + undef, ($_%2 ? "odd" : "even"), $_ + ); +} +# DBI->trace(9); + +# see if placeholder works +my ($v, $num) = $dbh->selectrow_array( + 'SELECT bar, num FROM foo WHERE num = ?', + undef, 3 +); +ok( $v eq 'odd' && $num == 3 ); + +# see if the sql itself works as expected +my $ar = $dbh->selectall_arrayref( + 'SELECT bar FROM foo GROUP BY bar HAVING count(*) > 1' +); +is( scalar(@$ar), 2, 'Got 2 results' ); + +# known workaround 1 +# ref: http://code.google.com/p/gears/issues/detail?id=163 +$ar = $dbh->selectall_arrayref( + 'SELECT bar FROM foo GROUP BY bar HAVING count(*) > 0+?', + undef, 1 +); +is( scalar(@$ar), 2, 'Got 2 results' ); + +# known workaround 2 +my $sth = $dbh->prepare( + 'SELECT bar FROM foo GROUP BY bar HAVING count(*) > ?', +); +$sth->bind_param(1, 1, { TYPE => SQL_INTEGER }); +$sth->execute; +$ar = $sth->fetchall_arrayref; +is( scalar(@$ar), 2, 'Got 2 results' ); + +# known workaround 3 +{ + local $dbh->{sqlite_see_if_its_a_number} = 1; + my $ar = $dbh->selectall_arrayref( + 'SELECT bar FROM foo GROUP BY bar HAVING count(*) > ?', + undef, 1 + ); + is( scalar(@$ar), 2, 'Got 2 results' ); +} + +# and this is what should be tested +#TODO: { + local $TODO = 'This test is currently broken again. Wait for a better fix, or use known workarounds shown above'; + $ar = $dbh->selectall_arrayref( + 'SELECT bar FROM foo GROUP BY bar HAVING count(*) > ?', + undef, 1 + ); + # print "4: @$_\n" for @$ar; + is( scalar(@$ar), 2, "we got ".(@$ar)." items" ); +#} diff --git a/t/rt_29629_sqlite_where_length.t b/t/rt_29629_sqlite_where_length.t new file mode 100644 index 0000000..481047e --- /dev/null +++ b/t/rt_29629_sqlite_where_length.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 19; +use Test::NoWarnings; +use DBI qw(:sql_types); + +my $dbh = connect_ok(); + +$dbh->do('drop table if exists artist'); +$dbh->do(<<'END_SQL'); +create table artist ( + id int not null primary key, + name text not null +) +END_SQL + +ok( $dbh->do(q/insert into artist (id,name) values(1, 'Leonardo da Vinci')/), 'insert'); + +# length works in a select list... +my $sth = $dbh->prepare('select length(name) from artist where id=?'); +ok( $sth->execute(1), 'execute, select length' ); +is( $sth->fetchrow_arrayref->[0], 17, 'select length result' ); + +# but not in a where clause... +my $statement = 'select count(*) from artist where length(name) > ?'; + +# ...not with bind args +$sth = $dbh->prepare($statement); +ok( $sth->execute(2), "execute: $statement : [2]" ); +TODO: { + local $TODO = 'This test is currently broken again. Wait for a better fix, or use known workarounds.'; + is( $sth->fetchrow_arrayref->[0], 1, "result of: $statement : [2]" ); +} + +### it does work, however, from the sqlite3 CLI... +# require Shell; +# $Shell::raw = 1; +# is( sqlite3($db, "'$statement;'"), "1\n", 'sqlite3 CLI' ); + +# ...works without bind args, though! +$statement =~ s/\?/2/; +$sth = $dbh->prepare($statement); +ok( $sth->execute, "execute: $statement" ); +is( $sth->fetchrow_arrayref->[0], 1, "result of: $statement" ); + +# (Jess Robinson discovered that it passes with an arg of 1) +$statement =~ s/2/1/; +$sth = $dbh->prepare($statement); +ok( $sth->execute, "execute: $statement" ); +is( $sth->fetchrow_arrayref->[0], 1, "result of: $statement" ); + +# (...but still not with bind args) +$statement =~ s/1/?/; +$sth = $dbh->prepare($statement); +ok( $sth->execute(1), "execute: $statement : [1]" ); +TODO: { + local $TODO = 'This test is currently broken again. Wait for a better fix, or use known workarounds.'; + is( $sth->fetchrow_arrayref->[0], 1, "result of: $statement [1]" ); +} + +# known workarounds 1: use bind_param explicitly + +$sth = $dbh->prepare($statement); +$sth->bind_param(1, 2, { TYPE => SQL_INTEGER }); +ok( $sth->execute, "execute: $statement : [2]" ); +is( $sth->fetchrow_arrayref->[0], 1, "result of: $statement : [2]" ); + +# known workarounds 2: add "+0" to let sqlite convert the binded param into number + +(my $tweaked_statement = $statement) =~ s/\?/\?\+0/; +$sth = $dbh->prepare($tweaked_statement); +ok( $sth->execute(2), "execute: $tweaked_statement : [2]" ); +is( $sth->fetchrow_arrayref->[0], 1, "result of: $tweaked_statement : [2]" ); + +# workaround 3: use sqlite_see_if_its_a_number attribute +{ + local $dbh->{sqlite_see_if_its_a_number} = 1; + $sth = $dbh->prepare($statement); + ok( $sth->execute(2), "execute: $statement : [2]" ); + is( $sth->fetchrow_arrayref->[0], 1, "result of: $statement : [2]" ); +} diff --git a/t/rt_31324_full_names.t b/t/rt_31324_full_names.t new file mode 100644 index 0000000..c74181b --- /dev/null +++ b/t/rt_31324_full_names.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 8; +use Test::NoWarnings; + +my $dbh = connect_ok( RaiseError => 1 ); +$dbh->do("CREATE TABLE f (f1, f2, f3)"); +$dbh->do("INSERT INTO f VALUES (?, ?, ?)", {}, 'foo', 'bar', 1); + +SCOPE: { + my $sth = $dbh->prepare('SELECT f1 as "a.a", * FROM f', {}); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute ok' ); + my $row = $sth->fetchrow_hashref; + is_deeply( $row, { + 'a.a' => 'foo', + 'f1' => 'foo', + 'f2' => 'bar', + 'f3' => 1, + }, 'Shortname row ok' ); +} + +$dbh->do("PRAGMA full_column_names = 1"); +$dbh->do("PRAGMA short_column_names = 0"); + +SCOPE: { + my $sth = $dbh->prepare('SELECT f1 as "a.a", * FROM f', {}); + isa_ok( $sth, 'DBI::st' ); + ok( $sth->execute, '->execute ok' ); + my $row = $sth->fetchrow_hashref; + is_deeply( $row, { + 'a.a' => 'foo', + 'f.f1' => 'foo', + 'f.f2' => 'bar', + 'f.f3' => 1, + }, 'Shortname row ok' ); +} diff --git a/t/rt_32889_prepare_cached_reexecute.t b/t/rt_32889_prepare_cached_reexecute.t new file mode 100644 index 0000000..e0a453b --- /dev/null +++ b/t/rt_32889_prepare_cached_reexecute.t @@ -0,0 +1,178 @@ +#!/usr/bin/perl + +# Tests that executing the same prepare_cached twice without a +# finish in between does not prevent it being automatically cleaned +# up and that it does not generate a warning. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 32; +use Test::NoWarnings; + +# Create the table +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + ok( $dbh->do(<<'END_SQL'), 'CREATE TABLE' ); + create table foo ( + id integer primary key not null + ) +END_SQL + $dbh->begin_work; + ok( $dbh->do('insert into foo values ( 1 )'), 'insert 1' ); + ok( $dbh->do('insert into foo values ( 2 )'), 'insert 2' ); + $dbh->commit; + $dbh->disconnect; +} + +# Collect the warnings +my $c = 0; +my @w = (); +$SIG{__WARN__} = sub { $c++; push @w, [ @_ ]; return }; + +# Conveniences +my $sql = 'select * from foo order by id'; + +sub fetchrow_1 { + my $row = $_[0]->fetchrow_arrayref; + is_deeply( $row, [ 1 ], 'Got row 1' ); +} + + + + + +###################################################################### +# A well-behaved non-cached statement + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare($sql); + } + $dbh->disconnect; + is( $c, 0, 'No warnings' ); +} + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare($sql); + $sth->execute; + } + $dbh->disconnect; + is( $c, 0, 'No warnings' ); +} + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare($sql); + $sth->execute; + fetchrow_1($sth); + } + $dbh->disconnect; + is( $c, 0, 'No warnings' ); +} + + + + + +###################################################################### +# A badly-behaved regular statement + +# Double execute, no warnings +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare($sql); + $sth->execute; + fetchrow_1($sth); + $sth->execute; + fetchrow_1($sth); + } + $dbh->disconnect; + is( $c, 0, 'No warnings' ); +} + +# We expect a warnings from this one +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + my $sth = $dbh->prepare($sql); + $sth->execute; + fetchrow_1($sth); + $dbh->disconnect; + is( $c, 1, 'Got a warning' ); +} + + + + + +###################################################################### +# A well-behaved cached statement + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare_cached($sql); + } + $dbh->disconnect; + is( $c, 1, 'No warnings' ); +} + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare_cached($sql); + $sth->execute; + fetchrow_1($sth); + $sth->finish; + } + $dbh->disconnect; + is( $c, 1, 'No warnings' ); +} + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare_cached($sql); + $sth->execute; + fetchrow_1($sth); + $sth->finish; + } + SCOPE: { + my $sth = $dbh->prepare_cached($sql); + $sth->execute; + fetchrow_1($sth); + $sth->finish; + } + $dbh->disconnect; + is( $c, 1, 'No warnings' ); +} + + + + + +##################################################################### +# Badly-behaved prepare_cached (but still acceptable) + +SCOPE: { + my $dbh = connect_ok( dbfile => 'foo' ); + SCOPE: { + my $sth = $dbh->prepare_cached($sql); + $sth->execute; + fetchrow_1($sth); + $sth->execute; + fetchrow_1($sth); + $sth->finish; + } + $dbh->disconnect; + is( $c, 1, 'No warnings' ); +} diff --git a/t/rt_36836_duplicate_key.t b/t/rt_36836_duplicate_key.t new file mode 100644 index 0000000..7380d8e --- /dev/null +++ b/t/rt_36836_duplicate_key.t @@ -0,0 +1,25 @@ +#!/usr/bin/perl + +# This is a simple insert/fetch test. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 5; +use Test::NoWarnings; + +# Create a database +my $dbh = connect_ok( PrintError => 0 ); + +# Create a database +ok( $dbh->do('CREATE TABLE one ( num INTEGER UNIQUE)'), 'create table' ); + +# Insert a row into the test table +ok( $dbh->do('INSERT INTO one ( num ) values ( 1 )'), 'insert' ); + +# Insert a duplicate +ok( ! $dbh->do('INSERT INTO one ( num ) values ( 1 )'), 'duplicate' ); diff --git a/t/rt_36838_unique_and_bus_error.t b/t/rt_36838_unique_and_bus_error.t new file mode 100644 index 0000000..2c3a819 --- /dev/null +++ b/t/rt_36838_unique_and_bus_error.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 4; +use Test::NoWarnings; + +my $dbh = connect_ok( RaiseError => 1, PrintError => 0 ); + +$dbh->do("CREATE TABLE nums (num INTEGER UNIQUE)"); + +ok $dbh->do("INSERT INTO nums (num) VALUES (?)", undef, 1); + +eval { $dbh->do("INSERT INTO nums (num) VALUES (?)", undef, 1); }; +ok $@ =~ /column num is not unique/, $@; # should not be a bus error diff --git a/t/rt_40594_nullable.t b/t/rt_40594_nullable.t new file mode 100644 index 0000000..8f3511b --- /dev/null +++ b/t/rt_40594_nullable.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More; +use t::lib::Test; +use DBD::SQLite; + +BEGIN { + if (!grep /^ENABLE_COLUMN_METADATA/, DBD::SQLite::compile_options()) { + plan skip_all => "Column metadata is disabled for this DBD::SQLite"; + } +} + +plan tests => 7; + +my $dbh = connect_ok(); + +ok $dbh->do("CREATE TABLE foo (id INTEGER PRIMARY KEY NOT NULL, col1 varchar(2) NOT NULL, col2 varchar(2), col3 char(2) NOT NULL)"); +my $sth = $dbh->prepare ('SELECT * FROM foo'); +ok $sth->execute; + +my $expected = { + NUM_OF_FIELDS => 4, + NAME_lc => [qw/id col1 col2 col3/], + TYPE => [qw/INTEGER varchar(2) varchar(2) char(2)/], + NULLABLE => [qw/0 0 1 0/], +}; + +for my $m (keys %$expected) { + is_deeply($sth->{$m}, $expected->{$m}); +} diff --git a/t/rt_48393_debug_panic_with_commit.t b/t/rt_48393_debug_panic_with_commit.t new file mode 100644 index 0000000..66880ea --- /dev/null +++ b/t/rt_48393_debug_panic_with_commit.t @@ -0,0 +1,62 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; + +BEGIN { + plan skip_all => + 'set $ENV{TEST_DBD_SQLITE_WITH_DEBUGGER} '. + 'to enable this test' + unless $ENV{TEST_DBD_SQLITE_WITH_DEBUGGER}; +} + +use Test::NoWarnings; + +plan tests => 2; + +my $file = 't/panic.pl'; +open my $fh, '>', $file; +print $fh <DATA>; +close $fh; + +if ($^O eq 'MSWin32') { + ok !system(qq{set PERLDB_OPTS="NonStop"; $^X -Mblib -d $file}); +} +else { + ok !system(qq{PERLDB_OPTS="NonStop" $^X -Mblib -d $file}); +} + +END { + unlink $file if $file && -f $file; + unlink 'test.db' if -f 'test.db'; +} + +__DATA__ +use strict; +use warnings; +use DBI; + +my $db_file = 'test.db'; + +unlink($db_file); +die "Could not delete $db_file - $!" if(-e $db_file); + +my $dbh = DBI->connect("dbi:SQLite:dbname=$db_file", undef, undef, { +RaiseError => 1, AutoCommit => 1 }); + +$dbh->do('CREATE TABLE t1 (id int)'); + +$dbh->begin_work or die $dbh->errstr; + +my $sth = $dbh->prepare('INSERT INTO t1 (id) VALUES (1)'); +$sth->execute; + +# XXX: Panic occurs here when running under the debugger +$dbh->commit or die $dbh->errstr; + diff --git a/t/rt_50503_fts3.t b/t/rt_50503_fts3.t new file mode 100644 index 0000000..5900784 --- /dev/null +++ b/t/rt_50503_fts3.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; + +BEGIN { + use DBD::SQLite; + unless ($DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= 3006006) { + plan skip_all => "this test requires SQLite 3.6.6 and newer"; + exit; + } + if (!grep /^ENABLE_FTS3/, DBD::SQLite::compile_options()) { + plan skip_all => "FTS3 is disabled for this DBD::SQLite"; + } +} + +use Test::NoWarnings; + +plan tests => 6; + +my $dbh = connect_ok( RaiseError => 1, AutoCommit => 0 ); + +$dbh->do(<<EOF); +CREATE VIRTUAL TABLE incident_fts +USING fts3 (incident_id VARCHAR, all_text VARCHAR, TOKENIZE simple) +EOF +$dbh->commit; + +insert_data($dbh, '595', time(), "sample text foo bar baz"); +insert_data($dbh, '595', time(), "sample text foo bar baz"); +insert_data($dbh, '595', time(), "sample text foo bar baz"); +insert_data($dbh, '595', time(), "sample text foo bar baz"); +$dbh->commit; + +{ + my $sth = $dbh->prepare("SELECT * FROM incident_fts WHERE all_text MATCH 'bar'"); + $sth->execute(); + + while (my $row = $sth->fetchrow_hashref("NAME_lc")) { + # The result may vary with or without an output, + # but anyway, either case seems failing at the destruction. + ok %$row; + #ok %$row, join ',', %$row; + } +} + +$dbh->commit; + +sub insert_data { + my($dbh, $inc_num, $date, $text) = @_; + # "OR REPLACE" isn't standard SQL, but it sure is useful + my $sth = $dbh->prepare('INSERT OR REPLACE INTO incident_fts (incident_id, all_text) VALUES (?, ?)'); + $sth->execute($inc_num, $text) || die "execute failed\n"; + $dbh->commit; +} diff --git a/t/rt_52573_manual_exclusive_lock.t b/t/rt_52573_manual_exclusive_lock.t new file mode 100644 index 0000000..db0f3e9 --- /dev/null +++ b/t/rt_52573_manual_exclusive_lock.t @@ -0,0 +1,214 @@ +#!/usr/bin/perl -w + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 92 * 4 + 2; +use Test::NoWarnings; + +my $dbh = connect_ok( + AutoCommit => 1, + RaiseError => 1, + PrintError => 0, +); + +$dbh->do('create table foo (id)'); + +my @funcs = ( + sub { shift->rollback }, + sub { shift->commit }, + sub { shift->do('rollback') }, + sub { shift->do('commit') }, +); + +foreach my $func (@funcs) { + # scenario 1: AutoCommit => 1 and no begin_work + + eval { $dbh->{AutoCommit} = 1 }; # initialize + ok $dbh->{AutoCommit}, "AutoCommit is on"; + ok !$dbh->{BegunWork}, "BegunWork is off"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'a statement works'; + diag $@ if $@; + # eval { $func->($dbh) }; + # ok !$@, "commit/rollback ignored"; + # diag $@ if $@; + ok $dbh->{AutoCommit}, "AutoCommit is still on"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + + # scenario 2: AutoCommit => 1 and begin_work and implicit BEGIN + + eval { $dbh->begin_work }; + ok !$@, "begin_work works"; + ok !$dbh->{AutoCommit}, "AutoCommit is turned off"; + ok $dbh->{BegunWork}, "BegunWork is turned on"; + eval { $dbh->begin_work }; + like $@ => qr/Already in a transaction/, "but second begin_work should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, "other statement should work"; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok $dbh->{AutoCommit}, "AutoCommit is turned on"; + ok !$dbh->{BegunWork}, "BegunWork is turned off"; + + # scenario 3: AutoCommit => 1 and begin_work and explicit and immediate BEGIN + + eval { $dbh->begin_work }; + ok !$@, "begin_work works"; + ok !$dbh->{AutoCommit}, "AutoCommit is turned off"; + ok $dbh->{BegunWork}, "BegunWork is turned on"; + eval { $dbh->do('BEGIN EXCLUSIVE TRANSACTION') }; + ok !$@, "first BEGIN should be passed through"; + diag $@ if $@; + eval { $dbh->do('BEGIN TRANSACTION') }; + like $@ => qr/cannot start a transaction/, "second BEGIN should fail"; + eval { $dbh->begin_work }; + like $@ => qr/Already in a transaction/, "and second begin_work also should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok $dbh->{AutoCommit}, "AutoCommit is turned on now"; + ok !$dbh->{BegunWork}, "BegunWork is turned off"; + + # scenario 4: AutoCommit => 1 and begin_work and explicit but not immediate BEGIN + eval { $dbh->begin_work }; + ok !$@, "begin_work works"; + ok !$dbh->{AutoCommit}, "AutoCommit is turned off"; + ok $dbh->{BegunWork}, "BegunWork is turned on"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'statement should work'; + diag $@ if $@; + eval { $dbh->do('BEGIN TRANSACTION') }; + like $@ => qr/cannot start a transaction/, "BEGIN after other statements should fail"; + eval { $dbh->begin_work }; + like $@ => qr/Already in a transaction/, "and second begin_work also should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok $dbh->{AutoCommit}, "AutoCommit is turned on now"; + ok !$dbh->{BegunWork}, "BegunWork is turned off"; + + # scenario 5: AutoCommit => 1 and explicit BEGIN and no begin_work + ok $dbh->{AutoCommit}, "AutoCommit is on"; + ok !$dbh->{BegunWork}, "BegunWork is off"; + eval { $dbh->do('BEGIN TRANSACTION'); }; + ok !$@, 'BEGIN should work'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is turned off"; + ok $dbh->{BegunWork}, "BegunWork is turned on"; + eval { $dbh->do('BEGIN TRANSACTION') }; + like $@ => qr/cannot start a transaction/, "second BEGIN should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok $dbh->{AutoCommit}, "AutoCommit is turned on now"; + ok !$dbh->{BegunWork}, "BegunWork is turned off"; + + # scenario 6: AutoCommit => 1 and explicit BEGIN and begin_work + ok $dbh->{AutoCommit}, "AutoCommit is on"; + ok !$dbh->{BegunWork}, "BegunWork is off"; + eval { $dbh->do('BEGIN TRANSACTION'); }; + ok !$@, 'BEGIN should work'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is turned off"; + ok $dbh->{BegunWork}, "BegunWork is turned on"; + eval { $dbh->do('BEGIN TRANSACTION') }; + like $@ => qr/cannot start a transaction/, "second BEGIN should fail"; + eval { $dbh->begin_work }; + like $@ => qr/Already in a transaction/, "and second begin_work also should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok $dbh->{AutoCommit}, "AutoCommit is turned on now"; + ok !$dbh->{BegunWork}, "BegunWork is turned off"; + + # scenario 7: AutoCommit => 0 and explicit BEGIN + eval { $dbh->{AutoCommit} = 1 }; # to initialize + ok $dbh->{AutoCommit}, "AutoCommit is on"; + ok !$dbh->{BegunWork}, "BegunWork is off"; + eval { $dbh->{AutoCommit} = 0 }; + ok !$@, "AutoCommit is turned off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $dbh->do('BEGIN TRANSACTION'); }; + ok !$@, 'BEGIN should work'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is turned off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $dbh->do('BEGIN TRANSACTION') }; + like $@ => qr/cannot start a transaction/, "second BEGIN should fail"; + eval { $dbh->begin_work }; + like $@ => qr/Already in a transaction/, "and begin_work also should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is still off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + + # scenario 8: AutoCommit => 0 and begin_work + eval { $dbh->{AutoCommit} = 1 }; # to initialize + ok $dbh->{AutoCommit}, "AutoCommit is on"; + ok !$dbh->{BegunWork}, "BegunWork is off"; + eval { $dbh->{AutoCommit} = 0 }; + ok !$@, "AutoCommit is turned off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $dbh->begin_work; }; + like $@ => qr/Already in a transaction/, "begin_work should fail"; + ok !$dbh->{AutoCommit}, "AutoCommit is still off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $dbh->do('BEGIN TRANSACTION') }; + ok !$@, "BEGIN should work"; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is still off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $dbh->begin_work }; + like $@ => qr/Already in a transaction/, "and second begin_work also should fail"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is still off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + + # scenario 9: AutoCommit => 0 and implicit BEGIN + eval { $dbh->{AutoCommit} = 1 }; # to initialize + ok $dbh->{AutoCommit}, "AutoCommit is on"; + ok !$dbh->{BegunWork}, "BegunWork is off"; + eval { $dbh->{AutoCommit} = 0 }; + ok !$@, "AutoCommit is turned off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $dbh->do('insert into foo (id) values (1)'); }; + ok !$@, 'other statement should work'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is still off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; + eval { $func->($dbh) }; + ok !$@, 'rolled back/committed'; + diag $@ if $@; + ok !$dbh->{AutoCommit}, "AutoCommit is still off"; + ok !$dbh->{BegunWork}, "BegunWork is still off"; +} +eval { $dbh->{AutoCommit} = 1 }; # to end transaction +$dbh->disconnect; diff --git a/t/rt_53235_icu_compatibility.t b/t/rt_53235_icu_compatibility.t new file mode 100644 index 0000000..ccec7a6 --- /dev/null +++ b/t/rt_53235_icu_compatibility.t @@ -0,0 +1,96 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More; +BEGIN { + require DBD::SQLite; + if (DBD::SQLite->can('compile_options') + && grep /ENABLE_ICU/, DBD::SQLite::compile_options()) { + plan( tests => 16 ); + } else { + plan( skip_all => 'requires SQLite ICU plugin to be enabled' ); + } +} +# use Test::NoWarnings; + +my @isochars = (ord("K"), 0xf6, ord("n"), ord("i"), ord("g")); +my $koenig = pack("U*", @isochars); +my $konig = 'konig'; +utf8::encode($koenig); + +{ # without ICU + my @expected = ($koenig, $konig); + + my $dbh = connect_ok(); + $dbh->do('create table foo (bar text)'); + foreach my $str (reverse @expected) { + $dbh->do('insert into foo values(?)', undef, $str); + } + my $sth = $dbh->prepare('select bar from foo order by bar'); + $sth->execute; + my @got; + while(my ($value) = $sth->fetchrow_array) { + push @got, $value; + } + for (my $i = 0; $i < @expected; $i++) { + is $got[$i] => $expected[$i], "got: $got[$i]"; + } +} + +{ # with ICU + my @expected = ($konig, $koenig); + + my $dbh = connect_ok(); + eval { $dbh->do('select icu_load_collation("de_DE", "german")') }; + ok !$@, "installed icu collation"; + # XXX: as of this writing, a warning is known to be printed. + $dbh->do('create table foo (bar text collate german)'); + foreach my $str (reverse @expected) { + $dbh->do('insert into foo values(?)', undef, $str); + } + my $sth = $dbh->prepare('select bar from foo order by bar'); + $sth->execute; + my @got; + while(my ($value) = $sth->fetchrow_array) { + push @got, $value; + } + for (my $i = 0; $i < @expected; $i++) { + is $got[$i] => $expected[$i], "got: $got[$i]"; + } +} + +{ # more ICU + my @expected = qw( + flusse + Flusse + fluße + Fluße + flüsse + flüße + Fuße + ); + + my $dbh = connect_ok(); + eval { $dbh->do('select icu_load_collation("de_DE", "german")') }; + ok !$@, "installed icu collation"; + # XXX: as of this writing, a warning is known to be printed. + $dbh->do('create table foo (bar text collate german)'); + foreach my $str (reverse @expected) { + $dbh->do('insert into foo values(?)', undef, $str); + } + my $sth = $dbh->prepare('select bar from foo order by bar'); + $sth->execute; + my @got; + while(my ($value) = $sth->fetchrow_array) { + push @got, $value; + } + for (my $i = 0; $i < @expected; $i++) { + is $got[$i] => $expected[$i], "got: $got[$i]"; + } +} diff --git a/t/rt_62370_diconnected_handles_operation.t b/t/rt_62370_diconnected_handles_operation.t new file mode 100644 index 0000000..6e735c2 --- /dev/null +++ b/t/rt_62370_diconnected_handles_operation.t @@ -0,0 +1,182 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok @CALL_FUNCS/; +use Test::More; +use DBD::SQLite; +#use Test::NoWarnings; + +my @methods = qw( + commit rollback +); + +plan tests => 2 * (6 + @methods) + 2 * @CALL_FUNCS * (14 + ($DBD::SQLite::sqlite_version_number >= 3006011) * 2); + +local $SIG{__WARN__} = sub {}; # to hide warnings/error messages + +# DBI methods + +for my $autocommit (0, 1) { + my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => $autocommit ); + $dbh->do('create table foo (id, text)'); + $dbh->do('insert into foo values(?,?)', undef, 1, 'text'); + { + local $@; + eval { $dbh->disconnect }; + ok !$@, "disconnected"; + } + + for my $method (@methods) { + local $@; + eval { $dbh->$method }; + ok $@, "$method dies with error: $@"; + } + + { + local $@; + eval { $dbh->last_insert_id(undef, undef, undef, undef) }; + ok $@, "last_insert_id dies with error: $@"; + } + + { + local $@; + eval { $dbh->do('insert into foo (?,?)', undef, 2, 'text2') }; + ok $@, "do dies with error: $@"; + } + + { + local $@; + eval { $dbh->selectrow_arrayref('select * from foo') }; + ok $@, "selectrow_arrayref dies with error: $@"; + } + + { # this should be the last test in this block + local $@; + eval { local $dbh->{AutoCommit} }; + ok !$@, "store doesn't cause segfault"; + } +} + +# SQLite private methods + +for my $call_func (@CALL_FUNCS) { + for my $autocommit (0, 1) { + my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => $autocommit ); + $dbh->do('create table foo (id, text)'); + $dbh->do('insert into foo values(?,?)', undef, 1, 'text'); + { + local $@; + eval { $dbh->disconnect }; + ok !$@, "disconnected"; + } + + { + local $@; + eval { $dbh->$call_func(500, 'busy_timeout') }; + ok $@, "busy timeout dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func('now', 0, sub { time }, 'create_function') }; + ok $@, "create_function dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(1, 'enable_load_extension') }; + ok $@, "enable_load_extension dies with error: $@"; + } + + { + package count_aggr; + + sub new { + bless { count => 0 }, shift; + } + + sub step { + $_[0]{count}++; + return; + } + + sub finalize { + my $c = $_[0]{count}; + $_[0]{count} = undef; + + return $c; + } + + package main; + + local $@; + eval { $dbh->$call_func('newcount', 0, 'count_aggr', 'create_aggregate') }; + ok $@, "create_aggregate dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func('by_num', sub ($$) {0}, 'create_collation') }; + ok $@, "create_collation dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func('by_num', sub ($$) {0}, 'create_collation') }; + ok $@, "create_collation dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(sub {1}, 'collation_needed') }; + ok $@, "collation_needed dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(50, sub {}, 'progress_handler') }; + ok $@, "progress_handler dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(sub {}, 'commit_hook') }; + ok $@, "commit hook dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(sub {}, 'rollback_hook') }; + ok $@, "rollback hook dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(sub {}, 'update_hook') }; + ok $@, "update hook dies with error: $@"; + } + + { + local $@; + eval { $dbh->$call_func(undef, 'set_authorizer') }; + ok $@, "set authorizer dies with error: $@"; + } + + if ($DBD::SQLite::sqlite_version_number >= 3006011) { + local $@; + eval { $dbh->$call_func('./backup_file', 'backup_from_file') }; + ok $@, "backup from file dies with error: $@"; + } + + if ($DBD::SQLite::sqlite_version_number >= 3006011) { + local $@; + eval { $dbh->$call_func('./backup_file', 'backup_to_file') }; + ok $@, "backup to file dies with error: $@"; + } + } +} diff --git a/t/rt_64177_ping_wipes_out_the_errstr.t b/t/rt_64177_ping_wipes_out_the_errstr.t new file mode 100644 index 0000000..db63363 --- /dev/null +++ b/t/rt_64177_ping_wipes_out_the_errstr.t @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 8; +use Test::NoWarnings; + +my $dbh = connect_ok(RaiseError => 1, PrintError => 0); +eval { $dbh->do('foobar') }; +ok $@, "raised error"; +ok $dbh->err, "has err"; +ok $dbh->errstr, "has errstr"; +ok $dbh->ping, "ping succeeded"; +ok $dbh->err, "err is not wiped out"; +ok $dbh->errstr, "errstr is not wiped out"; diff --git a/t/rt_67581_bind_params_mismatch.t b/t/rt_67581_bind_params_mismatch.t new file mode 100644 index 0000000..d778e77 --- /dev/null +++ b/t/rt_67581_bind_params_mismatch.t @@ -0,0 +1,146 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More tests => 34; +use DBI qw/:sql_types/; + +my $id = 0; +for my $has_pk (0..1) { + my $dbh = connect_ok(RaiseError => 1, PrintWarn => 0, PrintError => 0); + if ($has_pk) { + $dbh->do('create table foo (id integer, v integer primary key)'); + } + else { + $dbh->do('create table foo (id integer, v integer)'); + } + + { + my $sth = $dbh->prepare('insert into foo values (?, ?)'); + $sth->bind_param(1, ++$id); + $sth->bind_param(2, 1); + my $ret = eval { $sth->execute }; + ok defined $ret, "inserted without errors"; + + my ($value) = $dbh->selectrow_array('select v from foo where id = ?', undef, $id); + ok $value && $value == 1, "got correct value"; + } + + { + my $sth = $dbh->prepare('insert into foo values (?, ?)'); + $sth->bind_param(1, ++$id); + $sth->bind_param(2, 1.5); + my $ret = eval { $sth->execute }; + + if ($has_pk) { + ok $@, "died correctly"; + ok !defined $ret, "returns undef"; + ok $sth->errstr && $sth->errstr =~ /datatype mismatch/, "insert failed: type mismatch"; + } + else { + ok defined $ret, "inserted without errors"; + } + + my ($value) = $dbh->selectrow_array('select v from foo where id = ?', undef, $id); + + if ($has_pk) { + ok !$value , "not inserted/indexed"; + } + else { + ok $value && $value == 1.5, "got correct value"; + } + } + + { + my $sth = $dbh->prepare('insert into foo values (?, ?)'); + $sth->bind_param(1, ++$id); + $sth->bind_param(2, 'foo'); # may seem weird, but that's sqlite + my $ret = eval { $sth->execute }; + + if ($has_pk) { + ok $@, "died correctly"; + ok !defined $ret, "returns undef"; + ok $sth->errstr && $sth->errstr =~ /datatype mismatch/, "insert failed: type mismatch"; + } + else { + ok defined $ret, "inserted without errors"; + } + + my ($value) = $dbh->selectrow_array('select v from foo where id = ?', undef, $id); + + if ($has_pk) { + ok !$value , "not inserted/indexed"; + } + else { + ok $value && $value eq 'foo', "got correct value"; + } + } + + { + my $sth = $dbh->prepare('insert into foo values (?, ?)'); + $sth->bind_param(1, ++$id); + $sth->bind_param(2, 3, SQL_INTEGER); + my $ret = eval { $sth->execute }; + ok defined $ret, "inserted without errors"; + + my ($value) = $dbh->selectrow_array('select v from foo where id = ?', undef, $id); + ok $value && $value == 3, "got correct value"; + } + + { + my $sth = $dbh->prepare('insert into foo values (?, ?)'); + $sth->bind_param(1, ++$id); + $sth->bind_param(2, 3.5, SQL_INTEGER); + my $ret = eval { $sth->execute }; + + if ($has_pk) { + ok $@, "died correctly"; + ok !defined $ret, "returns undef"; + ok $sth->errstr && $sth->errstr =~ /datatype mismatch/, "insert failed: type mismatch"; + } + else { + ok defined $ret, "inserted without errors"; + } + + my ($value) = $dbh->selectrow_array('select v from foo where id = ?', undef, $id); + if ($has_pk) { + ok !$value, "not inserted/indexed"; + } + else { + ok $value && $value eq '3.5', "got correct value"; + } + } + + { + my $sth = $dbh->prepare('insert into foo values (?, ?)'); + $sth->bind_param(1, ++$id); + $sth->bind_param(2, 'qux', SQL_INTEGER); + + # only dies if type is explicitly specified + my $ret = eval { $sth->execute }; + + if ($has_pk) { + ok $@, "died correctly"; + ok !defined $ret, "returns undef"; + ok $sth->errstr && $sth->errstr =~ /datatype mismatch/, "insert failed: type mismatch"; + } + else { + ok defined $ret, "inserted without errors"; + } + + my ($value) = $dbh->selectrow_array('select v from foo where id = ?', undef, $id); + if ($has_pk) { + ok !$value, "not inserted/indexed"; + } + else { + ok $value && $value eq 'qux', "got correct value"; + } + } + + $dbh->disconnect; +} diff --git a/t/rt_71311_bind_col_and_unicode.t b/t/rt_71311_bind_col_and_unicode.t new file mode 100644 index 0000000..02f02b7 --- /dev/null +++ b/t/rt_71311_bind_col_and_unicode.t @@ -0,0 +1,118 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More; +BEGIN { + if ( $] >= 5.008005 ) { + plan( tests => 50 ); + } else { + plan( skip_all => 'Unicode is not supported before 5.8.5' ); + } +} +use Test::NoWarnings; +use DBI qw/:sql_types/; + +my $dbh = connect_ok(sqlite_unicode => 1); +$dbh->do('create table test1 (a integer, b blob)'); + +my $blob = "\x{82}\x{A0}"; +my $str = "\x{20ac}"; + +{ + my $sth = $dbh->prepare('insert into test1 values (?, ?)'); + + $sth->execute(1, $blob); + + $sth->bind_param(1, 2);; + $sth->bind_param(2, $blob, SQL_BLOB); + $sth->execute; + + $sth->bind_param(1, 3);; + $sth->bind_param(2, $blob, {TYPE => SQL_BLOB}); + $sth->execute; + + $sth->bind_param(2, undef, SQL_VARCHAR); + $sth->execute(4, $str); + + $sth->bind_param(1, 5);; + $sth->bind_param(2, utf8::encode($str), SQL_BLOB); + $sth->execute; + + $sth->bind_param(1, 6);; + $sth->bind_param(2, utf8::encode($str), {TYPE => SQL_BLOB}); + $sth->execute; + + $sth->finish; +} + +{ + my $sth = $dbh->prepare('select * from test1'); + $sth->execute; + + my $expected = [undef, 1, 0, 0, 1, 1, 1]; + for (1..6) { + my $row = $sth->fetch; + + ok $row && $row->[0] == $_; + ok $row && utf8::is_utf8($row->[1]) == $expected->[$_], + "row $_ is ".($expected->[$_] ? "unicode" : "not unicode"); + } + $sth->finish; +} + +{ + my $sth = $dbh->prepare('select * from test1'); + $sth->bind_col(1, \my $col1); + $sth->bind_col(2, \my $col2); + $sth->execute; + + my $expected = [undef, 1, 0, 0, 1, 1, 1]; + for (1..6) { + $sth->fetch; + + ok $col1 && $col1 == $_; + ok $col1 && utf8::is_utf8($col2) == $expected->[$_], + "row $_ is ".($expected->[$_] ? "unicode" : "not unicode"); + } + $sth->finish; +} + +{ + my $sth = $dbh->prepare('select * from test1'); + $sth->bind_col(1, \my $col1); + $sth->bind_col(2, \my $col2, SQL_BLOB); + $sth->execute; + + my $expected = [undef, 0, 0, 0, 0, 0, 0]; + for (1..6) { + $sth->fetch; + + ok $col1 && $col1 == $_; + ok $col2 && utf8::is_utf8($col2) == $expected->[$_], + "row $_ is ".($expected->[$_] ? "unicode" : "not unicode"); + } + $sth->finish; +} + +{ + my $sth = $dbh->prepare('select * from test1'); + $sth->bind_col(1, \my $col1); + $sth->bind_col(2, \my $col2, {TYPE => SQL_BLOB}); + $sth->execute; + + my $expected = [undef, 0, 0, 0, 0, 0, 0]; + for (1..6) { + $sth->fetch; + + ok $col1 && $col1 == $_; + ok $col2 && utf8::is_utf8($col2) == $expected->[$_], + "row $_ is ".($expected->[$_] ? "unicode" : "not unicode"); + } + $sth->finish; +} diff --git a/t/rt_73159_fts_tokenizer_segfault.t b/t/rt_73159_fts_tokenizer_segfault.t new file mode 100644 index 0000000..6f4d7bf --- /dev/null +++ b/t/rt_73159_fts_tokenizer_segfault.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 2; +use DBI; + +my $dbh = connect_ok(RaiseError => 1, PrintError => 0); + +sub locale_tokenizer { + return sub { + my $string = shift; + + use locale; + my $regex = qr/\w+/; + my $term_index = 0; + + return sub { # closure + $string =~ /$regex/g or return; # either match, or no more token + my ($start, $end) = ($-[0], $+[0]); + my $len = $end-$start; + my $term = substr($string, $start, $len); + return ($term, $len, $start, $end, $term_index++); + } + }; +} + +# "main::locale_tokenizer" is considered as another column name +# because of the comma after "tokenize=perl" +eval { + $dbh->do('CREATE VIRTUAL TABLE FIXMESSAGE USING FTS3(MESSAGE, tokenize=perl, "main::locale_tokenizer");'); +}; +ok $@, "cause an error but not segfault"; diff --git a/t/rt_73787_exponential_buffer_overflow.t b/t/rt_73787_exponential_buffer_overflow.t new file mode 100644 index 0000000..6115864 --- /dev/null +++ b/t/rt_73787_exponential_buffer_overflow.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test qw/connect_ok/; +use Test::More tests => 6; +use Test::NoWarnings; + +my $dbh = connect_ok(sqlite_see_if_its_a_number => 1); +$dbh->do('create table foo (id integer primary key, exp)'); +my $ct = 0; +for my $value (qw/2e100 10.04e100/) { + eval { + $dbh->do('insert into foo values (?, ?)', undef, $ct++, $value); + my $got = $dbh->selectrow_arrayref('select * from foo where exp = ?', undef, $value); + is $value => $got->[1], "got ".$got->[0]; + }; + ok !$@, "and without errors"; +} diff --git a/t/rt_77724_primary_key_with_a_whitespace.t b/t/rt_77724_primary_key_with_a_whitespace.t new file mode 100644 index 0000000..205ae47 --- /dev/null +++ b/t/rt_77724_primary_key_with_a_whitespace.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 4; +use Test::NoWarnings; + +my $dbh = connect_ok(RaiseError => 1, PrintError => 0); + +$dbh->do($_) for + q[CREATE TABLE "Country Info" ("Country Code" CHAR(2) PRIMARY KEY, "Name" VARCHAR(200))], + q[INSERT INTO "Country Info" VALUES ('DE', 'Germany')], + q[INSERT INTO "Country Info" VALUES ('FR', 'France')]; + +my $sth = $dbh->primary_key_info(undef, undef, "Country Info"); +my $row = $sth->fetchrow_hashref; +ok $row, 'Found the primary key column.'; + +is $row->{COLUMN_NAME} => "Country Code", + 'Key column name reported correctly.' + or note explain $row; diff --git a/t/rt_78833_utf8_flag_for_column_names.t b/t/rt_78833_utf8_flag_for_column_names.t new file mode 100644 index 0000000..0c219ed --- /dev/null +++ b/t/rt_78833_utf8_flag_for_column_names.t @@ -0,0 +1,159 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use t::lib::Test; +use Test::More tests => 29 * 2 + 1; +use Test::NoWarnings; +use Encode; + +unicode_test("\x{263A}"); # (decoded) smiley character +unicode_test("\x{0100}"); # (decoded) capital A with macron + +sub unicode_test { + my $unicode = shift; + + ok Encode::is_utf8($unicode), "correctly decoded"; + + my $unicode_encoded = encode_utf8($unicode); + + { # tests for an environment where everything is encoded + + my $dbh = connect_ok(sqlite_unicode => 0); + $dbh->do("pragma foreign_keys = on"); + my $unicode_quoted = $dbh->quote_identifier($unicode_encoded); + $dbh->do("create table $unicode_quoted (id, $unicode_quoted primary key)"); + $dbh->do("create table bar (id, ref references $unicode_quoted ($unicode_encoded))"); + + ok $dbh->do("insert into $unicode_quoted values (?, ?)", undef, 1, "text"), "insert successfully"; + ok $dbh->do("insert into $unicode_quoted (id, $unicode_quoted) values (?, ?)", undef, 2, "text2"), "insert with unicode name successfully"; + + { + my $sth = $dbh->prepare("insert into $unicode_quoted (id) values (:$unicode_encoded)"); + $sth->bind_param(":$unicode_encoded", 5); + $sth->execute; + my ($id) = $dbh->selectrow_array("select id from $unicode_quoted where id = :$unicode_encoded", undef, 5); + is $id => 5, "unicode placeholders"; + } + + { + my $sth = $dbh->prepare("select * from $unicode_quoted where id = ?"); + $sth->execute(1); + my $row = $sth->fetchrow_hashref; + is $row->{id} => 1, "got correct row"; + is $row->{$unicode_encoded} => "text", "got correct (encoded) unicode column data"; + ok !exists $row->{$unicode}, "(decoded) unicode column does not exist"; + } + + { + my $sth = $dbh->prepare("select $unicode_quoted from $unicode_quoted where id = ?"); + $sth->execute(1); + my $row = $sth->fetchrow_hashref; + is $row->{$unicode_encoded} => "text", "got correct (encoded) unicode column data"; + ok !exists $row->{$unicode}, "(decoded) unicode column does not exist"; + } + + { + my $sth = $dbh->prepare("select id from $unicode_quoted where $unicode_quoted = ?"); + $sth->execute("text"); + my ($id) = $sth->fetchrow_array; + is $id => 1, "got correct id by the (encoded) unicode column value"; + } + + { + my $sth = $dbh->column_info(undef, undef, $unicode_encoded, $unicode_encoded); + my $column_info = $sth->fetchrow_hashref; + is $column_info->{COLUMN_NAME} => $unicode_encoded, "column_info returns the correctly encoded column name"; + } + + { + my $sth = $dbh->primary_key_info(undef, undef, $unicode_encoded); + my $primary_key_info = $sth->fetchrow_hashref; + is $primary_key_info->{COLUMN_NAME} => $unicode_encoded, "primary_key_info returns the correctly encoded primary key name"; + } + + { + my $sth = $dbh->foreign_key_info(undef, undef, $unicode_encoded, undef, undef, 'bar'); + my $foreign_key_info = $sth->fetchrow_hashref; + is $foreign_key_info->{PKCOLUMN_NAME} => $unicode_encoded, "foreign_key_info returns the correctly encoded foreign key name"; + } + + { + my $sth = $dbh->table_info(undef, undef, $unicode_encoded); + my $table_info = $sth->fetchrow_hashref; + is $table_info->{TABLE_NAME} => $unicode_encoded, "table_info returns the correctly encoded table name"; + } + } + + { # tests for an environment where everything is decoded + + my $dbh = connect_ok(sqlite_unicode => 1); + $dbh->do("pragma foreign_keys = on"); + my $unicode_quoted = $dbh->quote_identifier($unicode); + $dbh->do("create table $unicode_quoted (id, $unicode_quoted primary key)"); + $dbh->do("create table bar (id, ref references $unicode_quoted ($unicode_quoted))"); + + ok $dbh->do("insert into $unicode_quoted values (?, ?)", undef, 1, "text"), "insert successfully"; + ok $dbh->do("insert into $unicode_quoted (id, $unicode_quoted) values (?, ?)", undef, 2, "text2"), "insert with unicode name successfully"; + + { + my $sth = $dbh->prepare("insert into $unicode_quoted (id) values (:$unicode)"); + $sth->bind_param(":$unicode", 5); + $sth->execute; + my ($id) = $dbh->selectrow_array("select id from $unicode_quoted where id = :$unicode", undef, 5); + is $id => 5, "unicode placeholders"; + } + + { + my $sth = $dbh->prepare("select * from $unicode_quoted where id = ?"); + $sth->execute(1); + my $row = $sth->fetchrow_hashref; + is $row->{id} => 1, "got correct row"; + is $row->{$unicode} => "text", "got correct (decoded) unicode column data"; + ok !exists $row->{$unicode_encoded}, "(encoded) unicode column does not exist"; + } + + { + my $sth = $dbh->prepare("select $unicode_quoted from $unicode_quoted where id = ?"); + $sth->execute(1); + my $row = $sth->fetchrow_hashref; + is $row->{$unicode} => "text", "got correct (decoded) unicode column data"; + ok !exists $row->{$unicode_encoded}, "(encoded) unicode column does not exist"; + } + + { + my $sth = $dbh->prepare("select id from $unicode_quoted where $unicode_quoted = ?"); + $sth->execute("text2"); + my ($id) = $sth->fetchrow_array; + is $id => 2, "got correct id by the (decoded) unicode column value"; + } + + { + my $sth = $dbh->column_info(undef, undef, $unicode, $unicode); + my $column_info = $sth->fetchrow_hashref; + is $column_info->{COLUMN_NAME} => $unicode, "column_info returns the correctly decoded column name"; + } + + { + my $sth = $dbh->primary_key_info(undef, undef, $unicode); + my $primary_key_info = $sth->fetchrow_hashref; + is $primary_key_info->{COLUMN_NAME} => $unicode, "primary_key_info returns the correctly decoded primary key name"; + } + + { + my $sth = $dbh->foreign_key_info(undef, undef, $unicode, undef, undef, 'bar'); + my $foreign_key_info = $sth->fetchrow_hashref; + is $foreign_key_info->{PKCOLUMN_NAME} => $unicode, "foreign_key_info returns the correctly decoded foreign key name"; + } + + { + my $sth = $dbh->table_info(undef, undef, $unicode); + my $table_info = $sth->fetchrow_hashref; + is $table_info->{TABLE_NAME} => $unicode, "table_info returns the correctly decoded table name"; + } + } +} |