#!/usr/bin/perl
use strict;
use Test::More;
use DBI;
# use warnings;
# use Data::Dumper;
# $Class::Tables::SQL_DEBUG++;
############################
## get DB connection info ##
############################
my %drivers = (
mysql => {
show => "show tables",
pkey => "int primary key not null auto_increment",
blob => "blob"
},
SQLite => {
show => "select name from sqlite_master where type='table'",
pkey => "integer primary key",
blob => "blob"
},
Pg => {
show => "select tablename from pg_tables where schemaname='public'",
pkey => "serial primary key",
blob => "bytea"
}
);
use lib 'testconfig';
my $Config;
eval q[
use Class::Tables::TestConfig;
$Config = Class::Tables::TestConfig->Config;
];
###################
## DB connection ##
###################
if ($Config->{dsn} =~ /^skip$/i) {
plan skip_all => "User has skipped the test suite. Run `perl Makefile.PL "
. "-s` to reconfigure the connection parameters for the "
. "test database.";
}
my $dbh = eval {
DBI->connect( @$Config{qw/dsn user password/},
{ RaiseError => 0, PrintError => 0 } )
};
if (not $dbh) {
plan skip_all => "Couldn't connect to the database for testing. Run `perl "
. "Makefile.PL -s` to reconfigure the connection parameters "
. "for the test database.";
} elsif ( ! $drivers{ $dbh->{Driver}{Name} } ) {
$dbh->disconnect;
my $drivers = join " " => sort keys %drivers;
plan skip_all => "Your database driver is not supported (supported: "
. "$drivers). Run `perl Makefile.PL -s` to reconfigure "
. "the connection parameters for the test database.";
} else {
plan tests => 70;
diag "Starting test suite. Run `perl Makefile.PL -s` to reconfigure "
. "connection parameters for the test database.";
}
## clear all tables first
my $driver = $dbh->{Driver}{Name};
my $q = $dbh->prepare( $drivers{$driver}{show} );
$q->execute;
while ( my ($table) = $q->fetchrow_array ) {
diag "DROPPING $table";
$dbh->do("drop table $table");
}
$q->finish;
######################
## insert test data ##
######################
my $pkey = $drivers{$driver}{pkey};
my $blob = $drivers{$driver}{blob};
$dbh->do($_) for (split /\s*;\s*/, <<"END_OF_SQL");
create table departments (
id $pkey,
name varchar(50) not null,
ends_with_id integer
);
create table employees (
id $pkey,
employee_name varchar(50) not null unique,
department_id integer,
employees_photo $blob
);
create table purchases (
purchase_id $pkey,
purchase_product integer not null,
purchase_employee_id integer not null,
purchase_quantity integer not null,
purchases_date date,
purchase_foo_id integer
);
create table products (
id $pkey,
name varchar(50) not null,
weight integer,
price decimal
);
insert into departments (name,ends_with_id)
values ('Hobbiton Division',0);
insert into departments (name,ends_with_id)
values ('Bree Division',0);
insert into departments (name,ends_with_id)
values ('Buckland Division',0);
insert into departments (name,ends_with_id)
values ('Michel Delving Division',0);
insert into employees (employee_name,department_id)
values ('Frodo Baggins',3);
insert into employees (employee_name,department_id)
values ('Bilbo Baggins',3);
insert into employees (employee_name,department_id)
values ('Samwise Gamgee',3);
insert into employees (employee_name,department_id)
values ('Perigrin Took',2);
insert into employees (employee_name,department_id)
values ('Fredegar Bolger',2);
insert into employees (employee_name,department_id)
values ('Meriadoc Brandybuck',2);
insert into employees (employee_name,department_id)
values ('Lotho Sackville-Baggins',4);
insert into employees (employee_name,department_id)
values ('Ted Sandyman',4);
insert into employees (employee_name,department_id)
values ('Will Whitfoot',4);
insert into employees (employee_name,department_id)
values ('Bandobras Took',1);
insert into employees (employee_name,department_id)
values ('Folco Boffin',1);
insert into products (name,weight,price)
values ('Southfarthing Pipeweed',10,200);
insert into products (name,weight,price)
values ('Prancing Pony Ale',150,300);
insert into products (name,weight,price)
values ('Farmer Cotton Mushrooms',200,150);
insert into products (name,weight,price)
values ('Green Dragon Ale',150,350);
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (2,6,6,'2002-12-10');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (4,3,1,'2002-12-10');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (1,2,20,'2002-12-09');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (3,4,8,'2002-12-11');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (1,1,1,'2002-12-13');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (3,1,2,'2002-12-15');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (3,3,3,'2002-12-12');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (3,3,15,'2002-12-08');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (2,6,11,'2002-12-08');
insert into purchases
(purchase_product,purchase_employee_id,purchase_quantity,purchases_date)
values (3,2,8,'2002-12-14')
END_OF_SQL
####################
## initialization ##
####################
my $timer = times;
use_ok('Class::Tables');
{
package MySubclass;
our @ISA = ('Class::Tables');
our $hello = 0;
sub search {
my $x = shift;
$hello++;
$x->SUPER::search(@_);
}
}
MySubclass->dbh($dbh);
# use Data::Dumper;
# print Dumper \%Class::Tables::CLASS;
#################
## subclassing ##
#################
my @classes = qw/Employees Departments Products Purchases/;
for (@classes) {
no strict 'refs';
is_deeply(
\@{"$_\::ISA"},
['MySubclass'],
"$_ class created w/ proper \@ISA" );
}
########################
## fetch class method ##
########################
for (@classes) {
isa_ok(
$_->fetch(1),
$_,
"$_->fetch" );
}
is( Employees->fetch(234332),
undef,
"fetch returns undef on failure" );
#########################
## search class method ##
#########################
is( Employees->search(id => 1)->id,
Employees->fetch(1)->id,
"search on id is equivalent to fetch" );
my @emps = Employees->search;
ok( scalar @emps,
"search with no args" );
is_deeply(
[ grep { ! $_->isa("Employees") } @emps ],
[],
"search returns Employees objects" );
is( join(":" => sort { $emps[$a]->name cmp $emps[$b]->name } 0 .. $#emps),
join(":" => 0 .. $#emps),
"search results sorted" );
is( scalar Employees->search(name => "asdfasdfasdf"),
undef,
"search returns undef on failure" );
is_deeply(
[ Employees->search(name => "asdfasdfasdf") ],
[],
"search returns empty list on failure" );
isa_ok(
scalar Employees->search( name => "Frodo Baggins" ),
"Employees",
"search result" );
is( Employees->search( name => "Frodo Baggins" )->name,
"Frodo Baggins",
"search result consistent" );
ok( scalar Employees->search(department => Departments->fetch(3)),
"search with object constraint on foreign key" );
########################
## instance accessors ##
########################
my %simple_accessors = (
Departments => {
id => '',
name => '',
ends_with_id => '',
employees => "Employees" # x
},
Employees => {
id => '',
name => '',
department => "Departments",
photo => '',
purchases => "Purchases" # x
},
Purchases => {
id => '',
product => "Products",
employee => "Employees",
quantity => '',
date => '',
foo_id => '',
},
Products => {
id => '',
name => '',
weight => '',
price => '',
purchases => "Purchases" # x
}
);
my $field_ok = 1;
for my $class (keys %simple_accessors) {
my $obj = $class->fetch(1);
my @supposed_accessors = $obj->field;
@supposed_accessors == @{[ keys %{ $simple_accessors{$class} } ]}
or $field_ok = 0;
for (@supposed_accessors) {
exists $simple_accessors{$class}{$_} or $field_ok = 0;
}
for my $accessor (keys %{ $simple_accessors{$class} }) {
is( ref $obj->$accessor,
$simple_accessors{$class}{$accessor},
"correct $class\->$accessor accessor" );
}
}
ok( $field_ok,
"field() accessor with no args" );
####
my $h = Employees->fetch(1);
is( "$h",
$h->name,
"objects stringify to name column" );
ok( scalar(() = $h->purchases) > 1,
"indirect foreign key returns list" );
ok( do { eval { $h->age }; $@ },
"die on bad accessor name" );
my $old_id = $h->id;
is( do { eval { $h->id(5) }; $h->id },
$old_id,
"id accessor read-only" );
my $new_guy = Employees->fetch(3);
my $count = $Class::Tables::SQL_QUERIES;
(undef) = $new_guy->photo;
ok( $count < $Class::Tables::SQL_QUERIES,
"blob accessors lazy-loaded" );
my @p1 = $h->purchases;
my @p2 = $h->purchases(product => 3);
ok( @p1 > @p2,
"additional search constraints in indirect key accessors" );
##############################
## object instance mutators ##
##############################
my $dept = Departments->fetch(1);
$h->department($dept);
is( $h->department->id,
$dept->id,
"change foreign key correctly using object" );
$h->name("Frodo Nine-Fingers");
is( $h->name,
"Frodo Nine-Fingers",
"change normal column correctly" );
$h->department( $dept->id );
isa_ok(
$h->department,
"Departments",
"change foreign key with id only" );
ok( scalar Employees->search(name => "Frodo Nine-Fingers", department => $dept),
"changes visible in database" );
$h->department(0);
is( $h->department,
undef,
"dangling foreign key accessors return undef" );
$h->department($dept);
##
#$h->department("asdfasdf");
#is( $h->department,
# $dept,
# "gracefully handle invalid keys" );
#$h->department( $dept );
#################
## concurrency ##
#################
my $p1 = Purchases->fetch(1);
my $p2 = Purchases->fetch(1);
$p1->quantity(1);
$p2->quantity(99999);
is( $p2->quantity,
$p1->quantity,
"updates concurrently visible" );
######################
## creating objects ##
######################
is( Employees->new(name => "Samwise Gamgee"),
undef,
"new returns undef on failure" );
my $new = Employees->new(name => "Grima Wormtongue", department => $dept);
isa_ok(
$new,
"Employees",
"new return value" );
ok( defined $new->id,
"got insert ID for new object" );
is( $new->name,
"Grima Wormtongue",
"new creates object with initial info" );
is( $new->department->id,
$dept->id,
"new creates object using object for foreign key" );
##########################
## dump instance method ##
##########################
my $dump = $h->dump;
isa_ok(
$dump,
"HASH",
"dump output" );
is( $dump->{'department.name'},
$h->department->name,
"dump output foreign keys inflated" );
isa_ok(
$dump->{purchases},
"ARRAY",
"dump output indirect foreign key" );
is( $dump->{purchases}[0]{'product.name'},
($h->purchases)[0]->product->name,
"dump output indirect foreign keys inflated" );
######################
## deleting objects ##
######################
my $id = $new->id;
$new->delete;
is( Employees->fetch($id),
undef,
"delete from database" );
@p1 = Purchases->search;
my $num = grep { $_->employee->id == 3 } @p1;
Employees->fetch(3)->delete;
is( scalar Purchases->search(employee => 3),
undef,
"cascading deletes turned on" );
@p2 = Purchases->search;
is( scalar @p1 - $num,
scalar @p2,
"cascading deletes leave the rest" );
{
local $Class::Tables::CASCADE = 0;
Employees->fetch(2)->delete;
isnt(
scalar Purchases->search(employee => 2),
undef,
"cascading deletes turned off" );
}
$_->delete for Employees->search;
is( scalar Employees->search,
undef,
"delete all in a table" );
#######################
## undef/null values ##
#######################
{
my $prod = Products->fetch(4);
$prod->weight(undef);
my $ar = $dbh->selectall_arrayref("select weight from products where id=4");
ok( exists $ar->[0][0] && ! defined $ar->[0][0],
"undef becomes NULL in database" );
}
## flyweight object goes out of scope, so next line must query the database
ok( ! defined Products->fetch(4)->weight,
"NULL database values come back undef" );
is( scalar( () = Products->search( weight => undef ) ),
1,
"search method handles searching with IS NULL" );
###########################
## subclassing revisited ##
###########################
isnt(
$MySubclass::hello,
0,
"subclass overrides methods" );
## done!
$timer = times - $timer;
diag "SUMMARY: $Class::Tables::SQL_QUERIES queries, ${timer}s (using $driver)";
#############
## cleanup ##
#############
END {
if ($dbh and $dbh->{Active}) {
$dbh->do($_) for (split /\s*;\s*/, <<' END_OF_SQL');
drop table /*! if exists */ departments;
drop table /*! if exists */ employees;
drop table /*! if exists */ products;
drop table /*! if exists */ purchases
END_OF_SQL
$dbh->disconnect;
}
}