use lib '.';
#BEGIN { $ENV{DBI_PUREPERL} = 2 };
require DBI;
$^W = 1;
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
BEGIN { $| = 1; print "1..29\n"; }
END {print "not ok 1\n" unless $loaded;}
use DBD::Sprite;
$loaded = 1;
print "ok 1\n";
######################### End of black magic.
# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):
unlink "./test.sdb";
# 2: MAKE A TEST DATABASE.
if ($^O =~ /Win/i)
{
system ("perl makesdb.pl test test test \".\" \".stb\" \"\\r\\n\" \",\"") ?
print "not ok 2 ($@$?)\n" : print "ok 2\n";
}
else
{
system ("./makesdb.pl test test test \".\" \".stb\" \"\\r\\n\" \",\"") ?
print "not ok 2 ($@$?)\n" : print "ok 2\n";
}
# 3: FETCH LIST OF DATABASES (SHOULD JUST BE ONE - OUR NEW TEST ONE)!
my @dataSources = DBI->data_sources('Sprite');
($#dataSources >= 0) ? print "ok 3\n" : print "not ok 3 ($#dataaSources !> 0)\n";
# 4: TEST CONNECT.
$dbh = DBI->connect('DBI:Sprite:test','test','test',{AutoCommit => 0}) || print "not ok 4 (".DBI::errstr.")\n";
print "ok 4\n" if ($dbh);
# 5: DROP THE TEST TABLE, IF THERE (RERAN TEST).
$dbh->{PrintError} = 0; #DON'T COMPLAIN THAT IT'S NOT THERE!
$res = $dbh->do('drop table testtable');
$dbh->{PrintError} = 1;
$res = $dbh->do(<<END_SQL);
create table testtable (
numfield NUMBER(5),
charfield CHAR(10),
vcharfield VARCHAR(20),
primary key (numfield)
)
END_SQL
($res == 0E0) ? print "ok 5\n" : print "not ok 5 ($res != 0E0)\n";
# 6: (RE)CREATE A TEST TABLE NAMED "TESTTABLE".
$res = $dbh->do('create sequence testtable');
($res == 1) ? print "ok 6\n" : print "not ok 6 ($res != 1)\n";
# 7: FETCH LIST OF ALL TABLES IN TEST DATABASE (SHOULD JUST BE ONE - TESTTABLE)!
my (@tables) = $dbh->tables();
($#tables == 0 && $tables[0] eq 'testtable') ? print "ok 7\n" :
print "not ok 7 (".join('|',@tables)."=\n";
# 8: PREPARE AN INSERT STATEMENT WITH BIND PARAMETERS.
$sth = $dbh->prepare(<<END_SQL);
insert into testtable values (testtable.NEXTVAL, ?, ?)
END_SQL
$sth ? print "ok 8\n" : print "not ok 8 (".$dbh->errstr.")\n";
# 9-11: EXECUTE THE INSERT STATEMENT TO INSERT 3 SAMPLE DATA RECORDS.
$res = $sth->execute('REDS', 'Cincinnati');
($res == 1) ? print "ok 9\n" : print "not ok 9 ($res != 1)\n";
$res = $sth->execute('YANKEES', 'New York');
($res == 1) ? print "ok 10\n" : print "not ok 10 ($res != 1)\n";
$res = $sth->execute('BRAVES', 'Atlanta');
($res == 1) ? print "ok 11\n" : print "not ok 11 ($res != 1)\n";
$sth->finish();
$dbh->commit();
# 12: NOW PREPARE A SELECT QUERY TO FETCH BACK ONE OF THEM.
$sth = $dbh->prepare(<<END_SQL);
select charfield, vcharfield
from testtable
where numfield = ?
END_SQL
$sth ? print "ok 12\n" : print "not ok 12 (".$dbh->errstr.")\n";
# 13: EXECUTE THE QUERY BINDING KEY VALUE=2.
$res = $sth->execute(2);
($res == 1) ? print "ok 13\n" : print "not ok 13 ($res != 1)\n";
# 14: FETCH THE TWO FIELDS OF THE RECORD BEING FETCHED AND SEE IF THEY ARE
# THE VALUES WE INSERTED!
my ($team, $city) = $sth->fetchrow_array();
($city eq 'New York' && $team eq 'YANKEES ') ? print "ok 14\n" :
print "not ok 14 ('$team' != 'YANKEES ' OR '$city' != 'New York')\n";
$sth->finish();
# 15: NOW PREPARE A SELECT QUERY WITH A USER-DEFINED FUNCTION
# TO FETCH BACK ANOTHER ONE OF THEM.
use JSprite;
JSprite::fn_register('reverseUP',__PACKAGE__);
$sth = $dbh->prepare(<<END_SQL);
select charfield, vcharfield
from testtable
where charfield like reverseUP(?) or charfield like 'x'
END_SQL
$sth ? print "ok 15\n" : print "not ok 15 (".$dbh->errstr.")\n";
# 16: EXECUTE THE QUERY BINDING KEY VALUE=2.
$res = $sth->execute('%Sevarb');
($res == 1) ? print "ok 16\n" : print "not ok 16 ($res != 1)\n";
# 17: FETCH THE TWO FIELDS OF THE RECORD BEING FETCHED AND SEE IF THEY ARE
# THE VALUES WE INSERTED!
$sth->bind_columns(undef, \$team, \$city) ? print "ok 17\n" : print "not ok 17 (".$dbh->errstr.")\n";
# 18: FETCH THE TWO FIELDS OF THE RECORD BEING FETCHED AND SEE IF THEY ARE
# THE VALUES WE INSERTED!
$sth->fetchrow_array();
($city eq 'Atlanta' && $team eq 'BRAVES ') ? print "ok 18\n" :
print "not ok 18 ('$city' != 'Atlanta' OR '$team' != 'BRAVES ')\n";
$sth->finish();
# 19: UPDATE VIA PERL WILDCARDS!
$sth = $dbh->prepare(<<END_SQL);
update testtable set vcharfield = CONCAT(vcharfield,"(\$1)")
where NUMFIELD =~ '(\\d+)'
END_SQL
$sth ? print "ok 19\n" : print "not ok 19 (".$dbh->errstr.")\n";
# 20: UPDATE VIA PERL WILDCARDS!
$res = $sth->execute();
($res == 3) ? print "ok 20\n" : print "not ok 20 ($res != 3)\n";
$sth->finish();
# 21: UPDATE VIA PERL WILDCARDS!
$sth = $dbh->prepare(<<END_SQL);
select charfield
from testtable
where vcharfield = 'Cincinnati(1)'
END_SQL
$sth ? print "ok 21\n" : print "not ok 21 (".$dbh->errstr.")\n";
$res = $sth->execute();
($res == 1) ? print "ok 22\n" : print "not ok 22 ($res != 1)\n";
$sth->bind_columns(\$team) ? print "ok 23\n" : print "not ok 23 (".$dbh->errstr.")\n";
$sth->fetchrow_array();
($team eq 'REDS ') ? print "ok 24\n" :
print "not ok 24 ($team)\n";
$sth->finish();
# 25: UPDATE VIA PERL WILDCARDS!
$sth = $dbh->prepare(<<END_SQL);
select testtable.NEXTVAL, CONCAT('Today is: ', TO_CHAR(SYSDATE, 'Mon DD, YYYY HH:MM:SS')) from DUAL
END_SQL
$sth ? print "ok 25\n" : print "not ok 25 (".$dbh->errstr.")\n";
$res = $sth->execute();
($res == 1) ? print "ok 26\n" : print "not ok 26 ($res != 1)\n";
my ($nextval, $sysdate) = $sth->fetchrow_array();
($nextval == 4) ? print "ok 27\n" :
print "not ok 27 ($nextval != 4)\n";
($sysdate =~ /^Today is: \w\w\w \d\d, \d\d\d\d \d\d\:\d\d:\d\d$/) ? print "ok 28\n" :
print "not ok 28 ($sysdate not valid)\n";
$sth->finish();
$dbh->commit();
my (@keys) = $dbh->primary_key(undef,undef,'testtable');
(!$#keys && $keys[0] eq 'NUMFIELD') ? print "ok 29\n" :
print "not ok 29 (primary key ($keys[0]) != 'NUMFIELD')\n";
$dbh->disconnect();
print "..done: 29 tests completed.\n";
sub reverseUP
{
my ($t) = shift;
$t =~ tr/a-z/A-Z/;
return (scalar(reverse($t)));
}