Class-DBI-v3.0.17/0000755000175200017520000000000010701255372012203 5ustar tonytonyClass-DBI-v3.0.17/t/0000755000175200017520000000000010701255372012446 5ustar tonytonyClass-DBI-v3.0.17/t/04-lazy.t0000444000175200017520000000453510314754713014043 0ustar tonytonyuse strict; use Test::More; #---------------------------------------------------------------------- # Test lazy loading #---------------------------------------------------------------------- BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 25); } INIT { use lib 't/testlib'; use Lazy; } is_deeply [ Lazy->columns('Primary') ], [qw/this/], "Pri"; is_deeply [ sort Lazy->columns('Essential') ], [qw/opop this/], "Essential"; is_deeply [ sort Lazy->columns('things') ], [qw/that this/], "things"; is_deeply [ sort Lazy->columns('horizon') ], [qw/eep orp/], "horizon"; is_deeply [ sort Lazy->columns('vertical') ], [qw/oop opop/], "vertical"; is_deeply [ sort Lazy->columns('All') ], [qw/eep oop opop orp that this/], "All"; { my @groups = Lazy->__grouper->groups_for(Lazy->find_column('this')); is_deeply [ sort @groups ], [qw/Essential Primary things/], "this (@groups)"; } { my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that')); is_deeply [@groups], [qw/things/], "that (@groups)"; } Lazy->insert({ this => 1, that => 2, oop => 3, opop => 4, eep => 5 }); ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary'); ok($obj->_attribute_exists('this'), "Gets primary"); ok($obj->_attribute_exists('opop'), "Gets other essential"); ok(!$obj->_attribute_exists('that'), "But other things"); ok(!$obj->_attribute_exists('eep'), " nor eep"); ok(!$obj->_attribute_exists('orp'), " nor orp"); ok(!$obj->_attribute_exists('oop'), " nor oop"); ok(my $val = $obj->eep, 'Fetch eep'); ok($obj->_attribute_exists('orp'), 'Gets orp too'); ok(!$obj->_attribute_exists('oop'), 'But still not oop'); ok(!$obj->_attribute_exists('that'), 'nor that'); { Lazy->columns(All => qw/this that eep orp oop opop/); ok(my $obj = Lazy->retrieve(1), 'Retrieve by Primary'); ok !$obj->_attribute_exists('oop'), " Don't have oop"; my $null = $obj->eep; ok !$obj->_attribute_exists('oop'), " Don't have oop - even after getting eep"; } # Test contructor breaking. eval { # Need a hashref Lazy->insert(this => 10, that => 20, oop => 30, opop => 40, eep => 50); }; ok($@, $@); eval { # False column Lazy->insert({ this => 10, that => 20, theother => 30 }); }; ok($@, $@); eval { # Multiple false columns Lazy->insert({ this => 10, that => 20, theother => 30, andanother => 40 }); }; ok($@, $@); Class-DBI-v3.0.17/t/21-iterator.t0000444000175200017520000000447610314754713014720 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33); } use lib 't/testlib'; use Film; Film->retrieve_all->delete_all; my @film = ( Film->insert({ Title => 'Film 1' }), Film->insert({ Title => 'Film 2' }), Film->insert({ Title => 'Film 3' }), Film->insert({ Title => 'Film 4' }), Film->insert({ Title => 'Film 5' }), Film->insert({ Title => 'Film 6' }), ); { my $it1 = Film->retrieve_all; isa_ok $it1, "Class::DBI::Iterator"; my $it2 = Film->retrieve_all; isa_ok $it2, "Class::DBI::Iterator"; while (my $from1 = $it1->next) { my $from2 = $it2->next; is $from1->id, $from2->id, "Both iterators get $from1"; } } { my $it = Film->retrieve_all; is $it->first->title, "Film 1", "Film 1 first"; is $it->next->title, "Film 2", "Film 2 next"; is $it->first->title, "Film 1", "First goes back to 1"; is $it->next->title, "Film 2", "With 2 still next"; $it->reset; is $it->next->title, "Film 1", "Reset brings us to film 1 again"; is $it->next->title, "Film 2", "And 2 is still next"; } { my $it = Film->retrieve_all; my @slice = $it->slice(2,4); is @slice, 3, "correct slice size (array)"; is $slice[0]->title, "Film 3", "Film 3 first"; is $slice[2]->title, "Film 5", "Film 5 last"; } { my $it = Film->retrieve_all; my $slice = $it->slice(2,4); isa_ok $slice, "Class::DBI::Iterator", "slice as iterator"; is $slice->count, 3,"correct slice size (array)"; is $slice->first->title, "Film 3", "Film 3 first"; is $slice->next->title, "Film 4", "Film 4 next"; is $slice->first->title, "Film 3", "First goes back to 3"; is $slice->next->title, "Film 4", "With 4 still next"; $slice->reset; is $slice->next->title, "Film 3", "Reset brings us to film 3 again"; is $slice->next->title, "Film 4", "And 4 is still next"; # check if the original iterator still works is $it->count, 6, "back to the original iterator, is of right size"; is $it->first->title, "Film 1", "Film 1 first"; is $it->next->title, "Film 2", "Film 2 next"; is $it->first->title, "Film 1", "First goes back to 1"; is $it->next->title, "Film 2", "With 2 still next"; is $it->next->title, "Film 3", "Film 3 is still in original Iterator"; $it->reset; is $it->next->title, "Film 1", "Reset brings us to film 1 again"; is $it->next->title, "Film 2", "And 2 is still next"; } Class-DBI-v3.0.17/t/97-pod.t0000444000175200017520000000026210326716061013650 0ustar tonytonyuse Test::More; use strict; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; eval "use Test::Pod::Coverage 1.00"; all_pod_files_ok(); Class-DBI-v3.0.17/t/23-cascade.t0000444000175200017520000000142410314754713014442 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5); } use lib 't/testlib'; use Film; use Director; { # Cascade Strategies Director->has_many(nasties => Film => { cascade => 'Fail' }); my $dir = Director->insert({ name => "Nasty Noddy" }); my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' }); is $kk->director, $dir, "Director set OK"; is $dir->nasties, 1, "We have one nasty"; eval { $dir->delete }; like $@, qr/1/, "Can't delete while films exist"; my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' }); eval { $dir->delete }; like $@, qr/2/, "Still can't delete"; $dir->nasties->delete_all; eval { $dir->delete }; is $@, '', "Can delete once films are gone"; } Class-DBI-v3.0.17/t/19-set_sql.t0000444000175200017520000000472110314754713014541 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 17); } use lib 't/testlib'; use Film; use Actor; { # Check __ESSENTIAL__ expansion (RT#13038) my @cols = Film->columns('Essential'); is_deeply \@cols, ['title'], "1 Column in essential"; is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion'; } my $f1 = Film->insert({ title => 'A', director => 'AA', rating => 'PG' }); my $f2 = Film->insert({ title => 'B', director => 'BA', rating => 'PG' }); my $f3 = Film->insert({ title => 'C', director => 'AA', rating => '15' }); my $f4 = Film->insert({ title => 'D', director => 'BA', rating => '18' }); my $f5 = Film->insert({ title => 'E', director => 'AA', rating => '18' }); Film->set_sql( pgs => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE __TABLE__.rating = 'PG' ORDER BY title DESC } ); { (my $sth = Film->sql_pgs())->execute; my @pgs = Film->sth_to_objects($sth); is @pgs, 2, "Execute our own SQL"; is $pgs[0]->id, $f2->id, "get F2"; is $pgs[1]->id, $f1->id, "and F1"; } { my @pgs = Film->search_pgs; is @pgs, 2, "SQL creates search() method"; is $pgs[0]->id, $f2->id, "get F2"; is $pgs[1]->id, $f1->id, "and F1"; }; Film->set_sql( rating => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE rating = ? ORDER BY title DESC } ); { my @pgs = Film->search_rating('18'); is @pgs, 2, "Can pass parameters to created search()"; is $pgs[0]->id, $f5->id, "F5"; is $pgs[1]->id, $f4->id, "and F4"; }; { Actor->has_a(film => "Film"); Film->set_sql( namerate => qq{ SELECT __ESSENTIAL(f)__ FROM __TABLE(=f)__, __TABLE(Actor=a)__ WHERE __JOIN(a f)__ AND a.name LIKE ? AND f.rating = ? ORDER BY title } ); my $a1 = Actor->insert({ name => "A1", film => $f1 }); my $a2 = Actor->insert({ name => "A2", film => $f2 }); my $a3 = Actor->insert({ name => "B1", film => $f1 }); my @apg = Film->search_namerate("A_", "PG"); is @apg, 2, "2 Films with A* that are PG"; is $apg[0]->title, "A", "A"; is $apg[1]->title, "B", "and B"; } { # join in reverse Actor->has_a(film => "Film"); Film->set_sql( ratename => qq{ SELECT __ESSENTIAL(f)__ FROM __TABLE(=f)__, __TABLE(Actor=a)__ WHERE __JOIN(f a)__ AND f.rating = ? AND a.name LIKE ? ORDER BY title } ); my @apg = Film->search_ratename(PG => "A_"); is @apg, 2, "2 Films with A* that are PG"; is $apg[0]->title, "A", "A"; is $apg[1]->title, "B", "and B"; } Class-DBI-v3.0.17/t/13-constraint.t0000444000175200017520000000706310314754713015247 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 28); } use lib 't/testlib'; use Film; sub valid_rating { my $value = shift; my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/; return $ok; } Film->add_constraint('valid rating', Rating => \&valid_rating); my %info = ( Title => 'La Double Vie De Veronique', Director => 'Kryzstof Kieslowski', Rating => '18', ); { local $info{Title} = "nonsense"; local $info{Rating} = 19; eval { Film->insert({%info}) }; ok $@, $@; ok !Film->retrieve($info{Title}), "No film created"; is(Film->retrieve_all, 0, "So no films"); } ok(my $ver = Film->insert({%info}), "Can insert with valid rating"); is $ver->Rating, 18, "Rating 18"; ok $ver->Rating(12), "Change to 12"; ok $ver->update, "And update"; is $ver->Rating, 12, "Rating now 12"; { local *Film::_croak = sub { my ($self, $msg, %info) = @_; die %info ? bless \%info => "My::Error" : $msg; }; eval { $ver->Rating(13); $ver->update; }; isa_ok $@ => 'My::Error'; my $fail = $@->{data}{rating}{data}; is $fail->{column}->name_lc, "rating", "Rating fails"; is $fail->{value}, 13, "Can't set to 13"; is $ver->Rating, 12, "Rating still 12"; ok $ver->delete, "Delete"; } # this threw an infinite loop in old versions Film->add_constraint('valid director', Director => sub { 1 }); my $fred = Film->insert({ Rating => '12' }); # this test is a bit problematic because we don't supply a primary key # to the create() and the table doesn't use auto_increment or a sequence. ok $fred, "Got fred"; { ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]), "constrain_column"; my $narrower = eval { Film->insert({ Rating => 'Uc' }) }; like $@, qr/fails.*constraint/, "Fails listref constraint"; my $ok = eval { Film->insert({ Rating => 'U' }) }; is $@, '', "Can insert with rating U"; ok +Film->find_column('rating')->is_constrained, "Rating is constrained"; ok +Film->find_column('director')->is_constrained, "Director is not"; } { ok +Film->constrain_column(title => qr/The/), "constraint_column"; my $inferno = eval { Film->insert({ Title => 'Towering Infero' }) }; like $@, qr/fails.*constraint/, "Can't insert towering inferno"; my $the_inferno = eval { Film->insert({ Title => 'The Towering Infero' }) }; is $@, '', "But can insert THE towering inferno"; } { sub Film::_constrain_by_untaint { my ($class, $col, $string, $type) = @_; $class->add_constraint( untaint => $col => sub { my ($value, $self, $column_name, $changing) = @_; $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0; } ); } eval { Film->constrain_column(codirector => Untaint => 'date') }; is $@, '', 'Can constrain with untaint'; my $freeaa = eval { Film->insert({ title => "The Freaa", codirector => 'today' }) }; is $@, '', "Can insert codirector"; is $freeaa->codirector, '2001-03-03', "Set the codirector"; } { ok +Film->constrain_column(title => sub { length() <= 10 }), "and again"; my $toolong = eval { Film->insert({ Title => 'The Wonderful' }) }; like $@, qr/fails.*constraint/, "Can't insert too long title"; my $then = eval { Film->insert({ Title => 'The Blob' }) }; is $@, '', "But can insert The XXX"; } __DATA__ use CGI::Untaint; sub _constrain_by_untaint { my ($class, $col, $string, $type) = @_; $class->add_constraint(untaint => $col => sub { my ($value, $self, $column_name, $changing) = @_; my $h = CGI::Untaint->new({ %$changing }); return unless my $val = $h->extract("-as_$type" => $column_name); $changing->{$column_name} = $val; return 1; }); } Class-DBI-v3.0.17/t/05-Query.t0000444000175200017520000000614610314754713014172 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20); } use lib 't/testlib'; use Film; use Actor; Film->has_many(actors => Actor => { order_by => 'name' }); Actor->has_a(Film => 'Film'); my $film1 = Film->insert({ title => 'Film 1', rating => 'U' }); my $film2 = Film->insert({ title => 'Film 2', rating => '15' }); my $film3 = Film->insert({ title => 'Film 3', rating => '15' }); my $act1 = Actor->insert({ name => 'Fred', film => $film1, salary => 1 }); my $act2 = Actor->insert({ name => 'Fred', film => $film2, salary => 2 }); my $act3 = Actor->insert({ name => 'John', film => $film1, salary => 3 }); my $act4 = Actor->insert({ name => 'John', film => $film2, salary => 1 }); my $act5 = Actor->insert({ name => 'Pete', film => $film1, salary => 1 }); my $act6 = Actor->insert({ name => 'Pete', film => $film3, salary => 1 }); use Class::DBI::Query; $SIG{__WARN__} = sub {}; { my @actors = eval { my $query = Class::DBI::Query->new( { owner => 'Actor', where_clause => 'name = "Fred"' }); my $sth = $query->run(); Actor->sth_to_objects($sth); }; is @actors, 2, "** Full where in query"; is $@, '', "No errors"; isa_ok $actors[0], "Actor"; } { my @actors = eval { my $query = Class::DBI::Query->new( { owner => 'Actor', where_clause => 'name = ?' }); my $sth = $query->run('Fred'); Actor->sth_to_objects($sth); }; is @actors, 2, "** Placeholder in query"; is $@, '', "No errors"; isa_ok $actors[0], "Actor"; } { my @actors = eval { my $query = Class::DBI::Query->new({ owner => 'Actor' }); $query->add_restriction('name = ?'); my $sth = $query->run('Fred'); Actor->sth_to_objects($sth); }; is @actors, 2, "** Add restriction"; is $@, '', "No errors"; isa_ok $actors[0], "Actor"; } { my @actors = eval { my $query = Class::DBI::Query->new({ owner => 'Actor' }); my @tables = qw/Film Actor/; my $film_pri = Film->primary_column; $query->kings(@tables); $query->add_restriction("$tables[1].film = $tables[0].$film_pri"); $query->add_restriction('salary = ?'); $query->add_restriction('rating = ?'); my $sth = $query->run(1, 15); Actor->sth_to_objects($sth); }; is @actors, 2, "** Join"; is $@, '', "No errors"; isa_ok $actors[0], "Actor"; } { # Normal search my @films = Film->search(rating => 15); is @films, 2, "2 Films with 15 rating"; } { # Restrict a has_many my @actors = $film1->actors; is @actors, 3, "3 Actors in film 1"; my @underpaid = $film1->actors(salary => 1); is @underpaid, 2, "2 of them underpaid"; } { # Restrict a has_many as class method my @underpaid = Film->actors(salary => 1); my @under2 = Actor->search(salary => 1); is_deeply [ sort map $_->id, @underpaid ], [ sort map $_->id, @under2 ], "Can search on foreign key"; } { # Fully qualify table names my @actors = Film->actors(salary => 1, rating => 'U'); is @actors, 2, "Cross table search"; isa_ok $actors[0], "Actor"; } { # Fully qualify table names my @actors = Film->actors('actor.salary' => 1, 'film.rating' => 'U'); is @actors, 2, "Fully qualified tables"; isa_ok $actors[0], "Actor"; } Class-DBI-v3.0.17/t/99-misc.t0000444000175200017520000000657410332624102014026 0ustar tonytonyuse strict; use Test::More; use File::Temp qw/tempdir/; #---------------------------------------------------------------------- # Test various errors / warnings / deprecations etc #---------------------------------------------------------------------- BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22); } use File::Temp qw/tempfile/; my (undef, $DB) = tempfile(); my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1 }); END { unlink $DB if -e $DB } package Holiday; use base 'Class::DBI'; { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0]; }; no warnings 'once'; local *UNIVERSAL::wonka = sub { }; Holiday->columns(TEMP => 'wonka'); ::like $warning, qr/wonka.*clashes/, "Column clash warning for inherited"; undef $warning; Holiday->columns(Primary => 'new'); ::like $warning, qr/new.*clashes/, "Column clash warning with CDBI"; undef $warning; Holiday->add_constructor('by_train'); Holiday::Camp->add_constructor('by_train'); ::is $warning, undef, "subclassed constructor"; } { local $SIG{__WARN__} = sub { ::like $_[0], qr/deprecated/, "create trigger deprecated"; }; Holiday->add_trigger('create' => sub { 1 }); Holiday->add_trigger('delete' => sub { 1 }); } { eval { Holiday->add_constraint }; ::like $@, qr/needs a name/, "Constraint with no name"; eval { Holiday->add_constraint('check_mate') }; ::like $@, qr/needs a valid column/, "Constraint needs a column"; eval { Holiday->add_constraint('check_mate', 'jamtart') }; ::like $@, qr/needs a valid column/, "No such column"; eval { Holiday->add_constraint('check_mate', 'new') }; ::like $@, qr/needs a code ref/, "Need a coderef"; eval { Holiday->add_constraint('check_mate', 'new', {}) }; ::like $@, qr/not a code ref/, "Not a coderef"; eval { Holiday->has_a('new') }; ::like $@, qr/associated class/, "has_a needs a class"; eval { Holiday->add_constructor() }; ::like $@, qr/name/, "add_constructor needs a method name"; eval { Holiday->add_trigger(on_setting => sub { 1 }); }; ::like $@, qr/no longer exists/, "No on_setting trigger"; { local $SIG{__WARN__} = sub { ::like $_[0], qr/new.*clashes/, "Column clash warning"; }; } } package main; { package Holiday::Camp; use base 'Holiday'; __PACKAGE__->table("holiday"); __PACKAGE__->add_trigger(before_create => sub { my $self = shift; $self->_croak("Problem with $self\n"); }); package main; eval { Holiday::Camp->insert({}) }; like $@, qr/Problem with Holiday/, '$self stringifies with no PK values'; } eval { my $foo = Holiday->retrieve({ id => 1 }) }; like $@, qr/retrieve a reference/, "Can't retrieve a reference"; eval { my $foo = Holiday->insert(id => 10) }; like $@, qr/a hashref/, "Can't create without hashref"; { my $foo = bless {}, 'Holiday'; local $SIG{__WARN__} = sub { die $_[0] }; eval { $foo->has_a(date => 'Date::Simple') }; like $@, qr/object method/, "has_a is class-level: $@"; } eval { Holiday->update; }; like $@, qr/class method/, "Can't call update as class method"; is(Holiday->table, 'holiday', "Default table name"); Holiday->_flesh('Blanket'); eval { Holiday->insert({ yonkey => 84 }) }; like $@, qr/not a column/, "Can't create with nonsense column"; eval { Film->_require_class('Class::DBI::__::Nonsense') }; like $@, qr/Can't locate/, "Can't require nonsense class"; eval { Holiday->search_DeleteMe }; like $@, qr/locate.*DeleteMe/, $@; Class-DBI-v3.0.17/t/06-hasa.t0000444000175200017520000001030310350350355013762 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 24); } @YA::Film::ISA = 'Film'; local $SIG{__WARN__} = sub { }; INIT { use lib 't/testlib'; use Film; use Director; } Film->create_test_film; ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"); ok(my $pj = $btaste->Director, "Bad taste hasa() director"); ok(!ref($pj), ' ... which is not an object'); ok(Film->has_a('Director' => 'Director'), "Link Director table"); ok( Director->insert( { Name => 'Peter Jackson', Birthday => -300000000, IsInsane => 1 } ), 'insert Director' ); $btaste = Film->retrieve('Bad Taste'); ok($pj = $btaste->Director, "Bad taste now hasa() director"); isa_ok($pj => 'Director'); is($pj->id, 'Peter Jackson', ' ... and is the correct director'); # Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him. my $sj = Director->insert( { Name => 'Skippy Jackson', Birthday => (-300000000 + 60), IsInsane => 1, } ); is($sj->id, 'Skippy Jackson', 'We have a new director'); Film->has_a(CoDirector => 'Director'); $btaste->CoDirector($sj); $btaste->update; is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed'); is( $btaste->Director->Name, 'Peter Jackson', "Didnt interfere with each other" ); { # Ensure search can take an object my @films = Film->search(Director => $pj); is @films, 1, "1 Film directed by $pj"; is $films[0]->id, "Bad Taste", "Bad Taste"; } inheriting_hasa(); { # Skippy directs a film and Peter helps! $sj = Director->retrieve('Skippy Jackson'); $pj = Director->retrieve('Peter Jackson'); fail_with_bad_object($sj, $btaste); taste_bad($sj, $pj); } sub inheriting_hasa { my $btaste = YA::Film->retrieve('Bad Taste'); is(ref($btaste->Director), 'Director', 'inheriting hasa()'); is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()'); is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly'); } sub taste_bad { my ($dir, $codir) = @_; my $tastes_bad = YA::Film->insert( { Title => 'Tastes Bad', Director => $dir, CoDirector => $codir, Rating => 'R', NumExplodingSheep => 23 } ); is($tastes_bad->_Director_accessor, 'Skippy Jackson', 'Director_accessor'); is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director'); is($tastes_bad->CoDirector->Name, 'Peter Jackson', 'CoDirector'); is( $tastes_bad->_CoDirector_accessor, 'Peter Jackson', 'CoDirector_accessor' ); } sub fail_with_bad_object { my ($dir, $codir) = @_; eval { YA::Film->insert( { Title => 'Tastes Bad', Director => $dir, CoDirector => $codir, Rating => 'R', NumExplodingSheep => 23 } ); }; ok $@, $@; } package Foo; use base 'CDBase'; __PACKAGE__->table('foo'); __PACKAGE__->columns('All' => qw/ id fav /); # fav is a film __PACKAGE__->db_Main->do( qq{ CREATE TABLE foo ( id INTEGER, fav VARCHAR(255) ) } ); package Bar; use base 'CDBase'; __PACKAGE__->table('bar'); __PACKAGE__->columns('All' => qw/ id fav /); # fav is a foo __PACKAGE__->db_Main->do( qq{ CREATE TABLE bar ( id INTEGER, fav INTEGER ) } ); package main; Foo->has_a("fav" => "Film"); Bar->has_a("fav" => "Foo"); my $foo = Foo->insert({ id => 6, fav => 'Bad Taste' }); my $bar = Bar->insert({ id => 2, fav => 6 }); isa_ok($bar->fav, "Foo"); isa_ok($foo->fav, "Film"); { my $foo; Foo->add_trigger(after_create => sub { $foo = shift->fav }); my $gwh = Foo->insert({ id => 93, fav => 'Good Will Hunting' }); isa_ok $foo, "Film", "Object in after_create trigger"; } __END__ # TODO: breaks t/10 # http://lists.digitalcraftsmen.net/pipermail/classdbi/2005-November/000610.html # test has_a() on primary keys package MultiKey; use base 'CDBase'; __PACKAGE__->table('multikey'); __PACKAGE__->columns('Primary' => qw/ id film /); __PACKAGE__->has_a(film => "Film"); __PACKAGE__->db_Main->do( qq{ CREATE TABLE multikey ( id INTEGER, film VARCHAR(255) ) } ); package main; my $from_scalar = MultiKey->create({ id => 7, film => 'Bad Taste' }); isa_ok($from_scalar->film(), "Film"); Class-DBI-v3.0.17/t/09-has_many.t0000444000175200017520000000766410326714355014677 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 42); } use lib 't/testlib'; use Film; use Actor; use Director; Film->has_many(actors => Actor => 'Film', { order_by => 'name' }); Director->has_many(films => Film => 'Director', { order_by => 'title' }); Director->has_many( r_rated_films => Film => 'Director', { order_by => 'title', constraint => { Rating => 'R' } } ); Actor->has_a(Film => 'Film'); is(Actor->primary_column, 'id', "Actor primary OK"); ok(Actor->can('Salary'), "Actor table set-up OK"); ok(Film->can('actors'), " and have a suitable method in Film"); Film->create_test_film; ok(my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"); ok( my $pvj = Actor->insert( { Name => 'Peter Vere-Jones', Film => undef, Salary => '30_000', # For a voice! } ), 'insert Actor' ); is $pvj->Name, "Peter Vere-Jones", "PVJ name ok"; is $pvj->Film, undef, "No film"; ok $pvj->set_Film($btaste), "Set film"; $pvj->update; is $pvj->Film->id, $btaste->id, "Now film"; { my @actors = $btaste->actors; is(@actors, 1, "Bad taste has one actor"); is($actors[0]->Name, $pvj->Name, " - the correct one"); } my %pj_data = ( Name => 'Peter Jackson', Salary => '0', # it's a labour of love ); eval { my $pj = Film->add_to_actors(\%pj_data) }; like $@, qr/class/, "add_to_actors must be object method"; eval { my $pj = $btaste->add_to_actors(%pj_data) }; like $@, qr/needs/, "add_to_actors takes hash"; ok( my $pj = $btaste->add_to_actors( { Name => 'Peter Jackson', Salary => '0', # it's a labour of love } ), 'add_to_actors' ); is $pj->Name, "Peter Jackson", "PJ ok"; is $pvj->Name, "Peter Vere-Jones", "PVJ still ok"; { my @actors = $btaste->actors; is @actors, 2, " - so now we have 2"; is $actors[0]->Name, $pj->Name, "PJ first"; is $actors[1]->Name, $pvj->Name, "PVJ first"; } eval { my @actors = $btaste->actors({Name => $pj->Name}); is @actors, 1, "One actor from restricted (sorted) has_many"; is $actors[0]->Name, $pj->Name, "It's PJ"; }; is $@, '', "No errors"; my $as = Actor->insert( { Name => 'Arnold Schwarzenegger', Film => 'Terminator 2', Salary => '15_000_000' } ); eval { $btaste->actors($pj, $pvj, $as) }; ok $@, $@; is($btaste->actors, 2, " - so we still only have 2 actors"); my @bta_before = Actor->search(Film => 'Bad Taste'); is(@bta_before, 2, "We have 2 actors in bad taste"); ok($btaste->delete, "Delete bad taste"); my @bta_after = Actor->search(Film => 'Bad Taste'); is(@bta_after, 0, " - after deleting there are no actors"); # While we're here, make sure Actors have unreadable mutators and # unwritable accessors eval { $as->Name("Paul Reubens") }; ok $@, $@; eval { my $name = $as->set_Name }; ok $@, $@; is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie"); ok(my $director = Director->insert({ Name => 'Director 1', }), 'insert Director'); ok( $director->add_to_films( { Title => 'Film 1', Director => 'Director 1', Rating => 'PG', } ), 'add_to_films' ); ok( $director->add_to_r_rated_films( { Title => 'Film 2', Director => 'Director 1', } ), 'add_to_r_rated_films' ); eval { $director->add_to_r_rated_films( { Title => 'Film 3', Director => 'Director 1', Rating => 'G', } ); }; ok $@, $@; { my @films = $director->films; is(@films, 2, "Director 1 has three films"); is $films[0]->Title, "Film 1", "Film 1"; is $films[0]->Rating, "PG", "is PG"; is $films[1]->Title, "Film 2", "Film 2"; is $films[1]->Rating, "R", "is R"; } { my @films = $director->r_rated_films; is @films, 1, "... but only 1 R-Rated"; is $films[0]->Title, "Film 2", "- Film 2"; } # Subclass can override has_many package Film::Subclass; use base 'Film'; eval { Film::Subclass->has_many(actors => Actor => 'Film', { order_by => 'id' }); }; package main; ok ! $@, "We can set up a has_many subclass"; Class-DBI-v3.0.17/t/26-mutator.t0000444000175200017520000000140510356530200014541 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6); } INIT { local $SIG{__WARN__} = sub { like $_[0], qr/clashes with built-in method/, $_[0]; }; use lib 't/testlib'; require Film; } sub Film::accessor_name_for { my ($class, $col) = @_; return "sheep" if lc $col eq "numexplodingsheep"; return $col; } my $data = { Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', }; my $bt; eval { my $data = $data; $data->{sheep} = 1; ok $bt = Film->insert($data), "Modified accessor - with accessor"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { ok $bt->sheep(2), 'Modified accessor, set'; ok $bt->update, 'Update'; }; is $@, '', "No errors"; Class-DBI-v3.0.17/t/18-has_a.t0000444000175200017520000001343410523342145014134 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 41); } use lib 't/testlib'; use Film; use Director; @YA::Film::ISA = 'Film'; Film->create_test_film; ok my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"; ok my $pj = $btaste->Director, "Bad taste has a director"; ok !ref($pj), ' ... which is not an object'; ok(Film->has_a('director' => 'Director'), "Link Director table"); ok( Director->insert( { Name => 'Peter Jackson', Birthday => -300000000, IsInsane => 1 } ), 'insert Director' ); { ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste"; ok $pj = $btaste->Director, "Bad taste now hasa() director"; isa_ok $pj => 'Director'; { no warnings 'redefine'; no warnings 'once'; local *Ima::DBI::st::execute = sub { ::fail("Shouldn't need to query db"); }; is $pj->id, 'Peter Jackson', 'ID already stored'; } ok $pj->IsInsane, "But we know he's insane"; } # Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him. my $sj = Director->insert( { Name => 'Skippy Jackson', Birthday => (-300000000 + 60), IsInsane => 1, } ); { eval { $btaste->Director($btaste) }; like $@, qr/is not a Director/, "Can't set film as director"; is $btaste->Director->id, $pj->id, "PJ still the director"; # drop from cache so that next retrieve() is from db $btaste->remove_from_object_index; } { # Still inflated after update my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste->Director, "Director"; $btaste->numexplodingsheep(17); $btaste->update; isa_ok $btaste->Director, "Director"; $btaste->Director('Someone Else'); $btaste->update; isa_ok $btaste->Director, "Director"; is $btaste->Director->id, "Someone Else", "Can change director"; } is $sj->id, 'Skippy Jackson', 'Create new director - Skippy'; Film->has_a('codirector' => 'Director'); { eval { $btaste->CoDirector("Skippy Jackson") }; is $@, "", "Auto inflates"; isa_ok $btaste->CoDirector, "Director"; is $btaste->CoDirector->id, $sj->id, "To skippy"; } $btaste->CoDirector($sj); $btaste->update; is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed'); is( $btaste->Director->Name, 'Peter Jackson', "Didnt interfere with each other" ); { # Inheriting hasa my $btaste = YA::Film->retrieve('Bad Taste'); is(ref($btaste->Director), 'Director', 'inheriting hasa()'); is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()'); is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly'); } { $sj = Director->retrieve('Skippy Jackson'); $pj = Director->retrieve('Peter Jackson'); my $fail; eval { $fail = YA::Film->insert( { Title => 'Tastes Bad', Director => $sj, codirector => $btaste, Rating => 'R', NumExplodingSheep => 23 } ); }; ok $@, "Can't have film as codirector: $@"; is $fail, undef, "We didn't get anything"; my $tastes_bad = YA::Film->insert( { Title => 'Tastes Bad', Director => $sj, codirector => $pj, Rating => 'R', NumExplodingSheep => 23 } ); is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director'); is( $tastes_bad->_director_accessor->Name, 'Skippy Jackson', 'director_accessor' ); is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector'); is( $tastes_bad->_codirector_accessor->Name, 'Peter Jackson', 'codirector_accessor' ); } { { YA::Film->add_relationship_type(has_a => "YA::HasA"); package YA::HasA; use base 'Class::DBI::Relationship::HasA'; sub _inflator { my $self = shift; my $col = $self->accessor; my $super = $self->SUPER::_inflator($col); return $super unless $col eq $self->class->find_column('Director'); return sub { my $self = shift; $self->_attribute_store($col, 'Ghostly Peter') if $self->_attribute_exists($col) and not defined $self->_attrs($col); return &$super($self); }; } } { package Rating; sub new { my ($class, $mpaa, @details) = @_; bless { MPAA => $mpaa, WHY => "@details" }, $class; } sub mpaa { shift->{MPAA}; } sub why { shift->{WHY}; } } local *Director::mapme = sub { my ($class, $val) = @_; $val =~ s/Skippy/Peter/; $val; }; no warnings 'once'; local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] }; YA::Film->has_a( director => 'Director', inflate => 'mapme', deflate => 'sanity_check' ); YA::Film->has_a( rating => 'Rating', inflate => sub { my ($val, $parent) = @_; my $sheep = $parent->find_column('NumexplodingSheep'); if ($parent->_attrs($sheep) || 0 > 20) { return new Rating 'NC17', 'Graphic ovine violence'; } else { return new Rating $val, 'Just because'; } }, deflate => sub { shift->mpaa; } ); my $tbad = YA::Film->retrieve('Tastes Bad'); isa_ok $tbad->Director, 'Director'; is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle'; $tbad->Director('Skippy Jackson'); $tbad->update; is $tbad->Director, 'Ghostly Peter', 'Sanity checked'; isa_ok $tbad->Rating, 'Rating'; is $tbad->Rating->mpaa, 'NC17', 'Rating bumped'; $tbad->Rating(new Rating 'NS17', 'Shaken sheep'); no warnings 'redefine'; local *Director::mapme = sub { my ($class, $obj) = @_; $obj->isa('Film') ? $obj->Director : $obj; }; $pj->IsInsane(0); $pj->update; # Hush warnings ok $tbad->Director($btaste), 'Cross-class mapping'; is $tbad->Director, 'Peter Jackson', 'Yields PJ'; $tbad->update; $tbad = Film->retrieve('Tastes Bad'); ok !ref($tbad->Rating), 'Unmagical rating'; is $tbad->Rating, 'NS17', 'but prior change stuck'; } { # Broken has_a declaration eval { Film->has_a(driector => "Director") }; like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@"; } Class-DBI-v3.0.17/t/17-data_type.t0000444000175200017520000000200710314754713015032 0ustar tonytonyuse strict; use Test::More; BEGIN { eval { require DBD::Pg; }; plan skip_all => 'needs DBD::Pg for testing' if $@; } use lib 't/testlib'; use Binary; eval { Binary->CONSTRUCT; }; if ($@) { diag < 'Pg connection failed.'; } plan tests => 40; Binary->data_type(bin => DBI::SQL_BINARY); Binary->db_Main->{ AutoCommit } = 0; SKIP: { for my $id (1 .. 10) { my $bin = "foo\0$id"; my $obj = eval { Binary->insert( { # id => $id, bin => $bin, } ) }; skip $@, 40 if $@; isa_ok $obj, 'Binary'; is $obj->id, $id, "id is $id"; is $obj->bin, $bin, "insert: bin ok"; $obj->bin("bar\0$id"); $obj->update; if ($obj->id % 2) { $obj->dbi_commit; my $new_obj = $obj->retrieve($obj->id); is $obj->bin, "bar\0$id", "update: bin ok"; } else { $obj->dbi_rollback; my $new_obj = $obj->retrieve($obj->id); is $new_obj, undef, "Rolled back"; } } } Class-DBI-v3.0.17/t/02-Film.t0000444000175200017520000002373710314754713013756 0ustar tonytonyuse strict; use Test::More; $| = 1; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 91); } INIT { use lib 't/testlib'; use Film; } ok(Film->can('db_Main'), 'set_db()'); is(Film->__driver, "SQLite", "Driver set correctly"); { my $nul = eval { Film->retrieve() }; is $nul, undef, "Can't retrieve nothing"; like $@, qr/./, "retrieve needs parameters"; # TODO fix this... } { eval { my $id = Film->id }; like $@, qr/class method/, "Can't get id with no object"; } { eval { my $id = Film->title }; like $@, qr/class method/, "Can't get title with no object"; } eval { my $duh = Film->insert; }; like $@, qr/insert needs a hashref/, "insert needs a hashref"; ok +Film->create_test_film, "Create a test film"; my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film'; is($btaste->Title, 'Bad Taste', 'Title() get'); is($btaste->Director, 'Peter Jackson', 'Director() get'); is($btaste->Rating, 'R', 'Rating() get'); is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get'); { my $bt2 = Film->find_or_create(Title => 'Bad Taste'); is $bt2->Director, $btaste->Director, "find_or_create"; my @bt = Film->search(Title => 'Bad Taste'); is @bt, 1, " doesn't create a new one"; } ok my $gone = Film->find_or_create({ Title => 'Gone With The Wind', Director => 'Bob Baggadonuts', Rating => 'PG', NumExplodingSheep => 0 } ), "Add Gone With The Wind"; isa_ok $gone, 'Film'; ok $gone = Film->retrieve(Title => 'Gone With The Wind'), "Fetch it back again"; isa_ok $gone, 'Film'; # Shocking new footage found reveals bizarre Scarlet/sheep scene! is($gone->NumExplodingSheep, 0, 'NumExplodingSheep() get again'); $gone->NumExplodingSheep(5); is($gone->NumExplodingSheep, 5, 'NumExplodingSheep() set'); is($gone->numexplodingsheep, 5, 'numexplodingsheep() set'); is($gone->Rating, 'PG', 'Rating() get again'); $gone->Rating('NC-17'); is($gone->Rating, 'NC-17', 'Rating() set'); $gone->update; { my @films = eval { Film->retrieve_all }; is(@films, 2, "We have 2 films in total"); } my $gone_copy = Film->retrieve('Gone With The Wind'); ok($gone->NumExplodingSheep == 5, 'update()'); ok($gone->Rating eq 'NC-17', 'update() again'); # Grab the 'Bladerunner' entry. Film->insert({ Title => 'Bladerunner', Director => 'Bob Ridley Scott', Rating => 'R' }); my $blrunner = Film->retrieve('Bladerunner'); is(ref $blrunner, 'Film', 'retrieve() again'); is $blrunner->Title, 'Bladerunner', "Correct title"; is $blrunner->Director, 'Bob Ridley Scott', " and Director"; is $blrunner->Rating, 'R', " and Rating"; is $blrunner->NumExplodingSheep, undef, " and sheep"; # Make a copy of 'Bladerunner' and create an entry of the directors cut my $blrunner_dc = $blrunner->copy({ title => "Bladerunner: Director's Cut", rating => "15", }); is(ref $blrunner_dc, 'Film', "copy() produces a film"); is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct'); is($blrunner_dc->Director, 'Bob Ridley Scott', 'Director correct'); is($blrunner_dc->Rating, '15', 'Rating correct'); is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct'); # Set up own SQL: { Film->add_constructor(title_asc => "title LIKE ? ORDER BY title"); Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC"); { my @films = Film->title_asc("Bladerunner%"); is @films, 2, "We have 2 Bladerunners"; is $films[0]->Title, $blrunner->Title, "Ordered correctly"; } { my @films = Film->title_desc("Bladerunner%"); is @films, 2, "We have 2 Bladerunners"; is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly"; } } # Multi-column search { my @films = $blrunner->search_like(title => "Bladerunner%", rating => '15'); is @films, 1, "Only one Bladerunner is a 15"; } # Inline SQL { my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title"); is @films, 2, "Inline SQL"; is $films[0]->id, $btaste->id, "Correct film"; is $films[1]->id, $gone->id, "Correct film"; } # Inline SQL removes WHERE { my @films = Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title"); is @films, 2, "Inline SQL"; is $films[0]->id, $btaste->id, "Correct film"; is $films[1]->id, $gone->id, "Correct film"; } eval { my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' }); my $mandn = Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' }); my $new_leaf = Film->create({ Title => 'A New Leaf', Director => 'Elaine May' }); is(Film->search(Director => 'Elaine May')->count, 3, "3 Films by Elaine May"); ok(Film->retrieve('Ishtar')->delete, "Ishtar doesn't deserve an entry any more"); ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there'); { my $deprecated = 0; local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ }; ok( Film->delete(Director => 'Elaine May'), "In fact, delete all films by Elaine May" ); is(Film->search(Director => 'Elaine May')->count, 0, "0 Films by Elaine May"); is $deprecated, 1, "Got a deprecated warning"; } }; is $@, '', "No problems with deletes"; # Find all films which have a rating of NC-17. my @films = Film->search('Rating', 'NC-17'); is(scalar @films, 1, ' search returns one film'); is($films[0]->id, $gone->id, ' ... the correct one'); # Find all films which were directed by Bob @films = Film->search_like('Director', 'Bob %'); is(scalar @films, 3, ' search_like returns 3 films'); ok( eq_array( [ sort map { $_->id } @films ], [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ] ), 'the correct ones' ); # Find Ridley Scott films which don't have vomit @films = Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott'); is(scalar @films, 2, ' search where attribute is null returns 2 films'); ok( eq_array( [ sort map { $_->id } @films ], [ sort map { $_->id } $blrunner_dc, $blrunner ] ), 'the correct ones' ); # Test that a disconnect doesnt harm anything. Film->db_Main->disconnect; @films = Film->search({ Rating => 'NC-17' }); ok(@films == 1 && $films[0]->id eq $gone->id, 'auto reconnection'); # Test discard_changes(). my $orig_director = $btaste->Director; $btaste->Director('Lenny Bruce'); is($btaste->Director, 'Lenny Bruce', 'set new Director'); $btaste->discard_changes; is($btaste->Director, $orig_director, 'discard_changes()'); { Film->autoupdate(1); my $btaste2 = Film->retrieve($btaste->id); $btaste->NumExplodingSheep(18); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; }; { # unhook from live object cache, so next one is not from cache $btaste2->remove_from_object_index; my $btaste3 = Film->retrieve($btaste->id); is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit"; $btaste3->autoupdate(0); # obj a/c should override class a/c is @warnings, 0, "No warnings so far"; $btaste3->NumExplodingSheep(13); } is @warnings, 1, "DESTROY without update warns"; Film->autoupdate(0); } { # update unchanged object my $film = Film->retrieve($btaste->id); my $retval = $film->update; is $retval, -1, "Unchanged object"; } { $btaste->autoupdate(1); $btaste->NumExplodingSheep(32); my $btaste2 = Film->retrieve($btaste->id); is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit"; $btaste->autoupdate(0); } # Primary key of 0 { my $zero = Film->insert({ Title => 0, Rating => "U" }); ok defined $zero, "Create 0"; ok my $ret = Film->retrieve(0), "Retrieve 0"; is $ret->Title, 0, "Title OK"; is $ret->Rating, "U", "Rating OK"; } # Change after_update policy { my $bt = Film->retrieve($btaste->id); $bt->autoupdate(1); $bt->rating("17"); ok !$bt->_attribute_exists('rating'), "changed column needs reloaded"; ok $bt->_attribute_exists('title'), "but we still have the title"; # Don't re-load $bt->add_trigger( after_update => sub { my ($self, %args) = @_; my $discard_columns = $args{discard_columns}; @$discard_columns = qw/title/; }); $bt->rating("19"); ok $bt->_attribute_exists('rating'), "changed column needs reloaded"; ok !$bt->_attribute_exists('title'), "but no longer have the title"; } # Make sure that we can have other accessors. (Bugfix in 0.28) if (0) { Film->mk_accessors(qw/temp1 temp2/); my $blrunner = Film->retrieve('Bladerunner'); $blrunner->temp1("Foo"); $blrunner->NumExplodingSheep(2); eval { $blrunner->update }; ok(!$@, "Other accessors"); } # overloading { is "$blrunner", "Bladerunner", "stringify"; ok(Film->columns(Stringify => 'rating'), "Can change stringify column"); is "$blrunner", "R", "And still stringifies correctly"; ok( Film->columns(Stringify => qw/title rating/), "Can have multiple stringify columns" ); is "$blrunner", "Bladerunner/R", "And still stringifies correctly"; no warnings 'once'; local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating }; is "$blrunner", "Bladerunner:R", "Provide stringify_self()"; } { { ok my $byebye = DeletingFilm->insert({ Title => 'Goodbye Norma Jean', Rating => 'PG', } ), "Add a deleting Film"; isa_ok $byebye, 'DeletingFilm'; isa_ok $byebye, 'Film'; ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again"); } my $film; eval { $film = Film->retrieve('Goodbye Norma Jean') }; ok !$film, "It destroys itself"; } SKIP: { skip "Scalar::Util::weaken not available", 3 if !$Class::DBI::Weaken_Is_Available; # my bad taste is your bad taste my $btaste = Film->retrieve('Bad Taste'); my $btaste2 = Film->retrieve('Bad Taste'); is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2), "Retrieving twice gives ref to same object"; $btaste2->remove_from_object_index; my $btaste3 = Film->retrieve('Bad Taste'); isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3), "Removing from object_index and retrieving again gives new object"; $btaste3->clear_object_index; my $btaste4 = Film->retrieve('Bad Taste'); isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4), "Clearing cache and retrieving again gives new object"; } Class-DBI-v3.0.17/t/11-triggers.t0000444000175200017520000000321510701255322014672 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 13); } use lib 't/testlib'; use Film; sub create_trigger2 { ::ok(1, "Running create trigger 2"); } sub delete_trigger { ::ok(1, "Deleting " . shift->Title) } sub pre_up_trigger { $_[0]->_attribute_set(numexplodingsheep => 1); ::ok(1, "Running pre-update trigger"); } sub pst_up_trigger { ::ok(1, "Running post-update trigger"); } sub default_rating { $_[0]->Rating(15); } Film->add_trigger( before_create => \&default_rating ); Film->add_trigger( after_create => \&create_trigger2 ); Film->add_trigger( after_delete => \&delete_trigger ); Film->add_trigger( before_update => \&pre_up_trigger ); Film->add_trigger( after_update => \&pst_up_trigger ); ok( my $ver = Film->insert( { title => 'La Double Vie De Veronique', director => 'Kryzstof Kieslowski', # rating => '15', numexplodingsheep => 0, } ), "Create Veronique" ); is $ver->Rating, 15, "Default rating"; is $ver->NumExplodingSheep, 0, "Original sheep count"; ok $ver->Rating('12') && $ver->update, "Change the rating"; is $ver->NumExplodingSheep, 1, "Updated object's sheep count"; is + ( $ver->db_Main->selectall_arrayref( 'SELECT numexplodingsheep FROM ' . $ver->table . ' WHERE ' . $ver->primary_column . ' = ' . $ver->db_Main->quote($ver->id) ) )->[0]->[0], 1, "Updated database's sheep count"; ok $ver->delete, "Delete"; { Film->add_trigger( before_create => sub { my $self = shift; ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify"; } ); Film->insert({ director => "Me" }); } Class-DBI-v3.0.17/t/testlib/0000755000175200017520000000000010701255372014114 5ustar tonytonyClass-DBI-v3.0.17/t/testlib/MyFoo.pm0000444000175200017520000000110310312102653015463 0ustar tonytonypackage MyFoo; BEGIN { unshift @INC, './t/testlib'; } use base 'MyBase'; use strict; use Class::DBI::Column; __PACKAGE__->set_table(); __PACKAGE__->columns( All => qw/myid name val/, Class::DBI::Column->new(tdate => { placeholder => 'IF(1, CURDATE(), ?)' }) ); __PACKAGE__->has_a( tdate => 'Date::Simple', inflate => sub { Date::Simple->new(shift) }, deflate => 'format', ); sub create_sql { return qq{ myid mediumint not null auto_increment primary key, name varchar(50) not null default '', val char(1) default 'A', tdate date not null }; } 1; Class-DBI-v3.0.17/t/testlib/PgBase.pm0000444000175200017520000000104510042755120015603 0ustar tonytonypackage PgBase; use strict; use base 'Class::DBI'; my $db = $ENV{DBD_PG_DBNAME} || 'template1'; my $user = $ENV{DBD_PG_USER} || 'postgres'; my $pass = $ENV{DBD_PG_PASSWD} || ''; __PACKAGE__->connection("dbi:Pg:dbname=$db", $user, $pass, { AutoCommit => 1 }); sub CONSTRUCT { my $class = shift; my ($table, $sequence) = ($class->table, $class->sequence || ""); my $schema = $class->schema; $class->db_Main->do("CREATE TEMPORARY SEQUENCE $sequence") if $sequence; $class->db_Main->do("CREATE TEMPORARY TABLE $table ( $schema )"); } 1; Class-DBI-v3.0.17/t/testlib/MyBase.pm0000444000175200017520000000137210042755120015625 0ustar tonytonypackage MyBase; use strict; use base qw(Class::DBI); use vars qw/$dbh/; my @connect = ("dbi:mysql:test", "", ""); $dbh = DBI->connect(@connect) or die DBI->errstr; my @table; END { $dbh->do("DROP TABLE $_") foreach @table } __PACKAGE__->connection(@connect); sub set_table { my $class = shift; $class->table($class->create_test_table); } sub create_test_table { my $self = shift; my $table = $self->next_available_table; my $create = sprintf "CREATE TABLE $table ( %s )", $self->create_sql; push @table, $table; $dbh->do($create); return $table; } sub next_available_table { my $self = shift; my @tables = sort @{ $dbh->selectcol_arrayref( qq{ SHOW TABLES } ) }; my $table = $tables[-1] || "aaa"; return "z$table"; } 1; Class-DBI-v3.0.17/t/testlib/OtherFilm.pm0000444000175200017520000000054310311016127016331 0ustar tonytonypackage OtherFilm; use strict; use base 'Film'; __PACKAGE__->set_table('Different_Film'); sub create_sql { return qq{ title VARCHAR(255), director VARCHAR(80), codirector VARCHAR(80), rating CHAR(5), numexplodingsheep INTEGER, hasvomit CHAR(1) }; } 1; Class-DBI-v3.0.17/t/testlib/Log.pm0000444000175200017520000000131110044023652015157 0ustar tonytonypackage Log; BEGIN { unshift @INC, './t/testlib'; } use base 'MyBase'; use strict; use Time::Piece::MySQL; use POSIX; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/id message datetime_stamp/); __PACKAGE__->has_a( datetime_stamp => 'Time::Piece', inflate => 'from_mysql_datetime', deflate => 'mysql_datetime' ); __PACKAGE__->add_trigger(before_create => \&set_dts); __PACKAGE__->add_trigger(before_update => \&set_dts); sub set_dts { shift->datetime_stamp( POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime(time))); } sub create_sql { return qq{ id INT UNSIGNED AUTO_INCREMENT PRIMARY KEY, message VARCHAR(255), datetime_stamp DATETIME }; } 1; Class-DBI-v3.0.17/t/testlib/Blurb.pm0000444000175200017520000000055210350355446015523 0ustar tonytonypackage Blurb; BEGIN { unshift @INC, './t/testlib'; } use strict; use base 'Class::DBI::Test::SQLite'; __PACKAGE__->set_table('Blurbs'); __PACKAGE__->columns('Primary', 'Title'); __PACKAGE__->columns('Blurb', qw/ blurb/); sub create_sql { return qq{ title VARCHAR(255) PRIMARY KEY, blurb VARCHAR(255) } } 1; Class-DBI-v3.0.17/t/testlib/Actor.pm0000444000175200017520000000120710312626226015516 0ustar tonytonypackage Actor; BEGIN { unshift @INC, './t/testlib'; } use strict; use warnings; use base 'Class::DBI::Test::SQLite'; __PACKAGE__->set_table('Actor'); __PACKAGE__->columns(Primary => 'id'); __PACKAGE__->columns(All => qw/ Name Film Salary /); __PACKAGE__->columns(TEMP => qw/ nonpersistent /); __PACKAGE__->columns(Stringify => 'Name'); __PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?'); sub mutator_name_for { my ($class, $column) = @_; return "set_" . $column->name; } sub create_sql { return qq{ id INTEGER PRIMARY KEY, name CHAR(40), film VARCHAR(255), salary INT } } 1; Class-DBI-v3.0.17/t/testlib/CDBase.pm0000444000175200017520000000036610244603746015542 0ustar tonytonypackage CDBase; use strict; use base qw(Class::DBI); use File::Temp qw/tempfile/; my (undef, $DB) = tempfile(); my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1 }); END { unlink $DB if -e $DB } __PACKAGE__->connection(@DSN); 1; Class-DBI-v3.0.17/t/testlib/Lazy.pm0000444000175200017520000000077510311016127015366 0ustar tonytonypackage Lazy; BEGIN { unshift @INC, './t/testlib'; } use base 'Class::DBI::Test::SQLite'; use strict; __PACKAGE__->set_table("Lazy"); __PACKAGE__->columns('Primary', qw(this)); __PACKAGE__->columns('Essential', qw(opop)); __PACKAGE__->columns('things', qw(this that)); __PACKAGE__->columns('horizon', qw(eep orp)); __PACKAGE__->columns('vertical', qw(oop opop)); sub create_sql { return qq{ this INTEGER, that INTEGER, eep INTEGER, orp INTEGER, oop INTEGER, opop INTEGER }; } 1; Class-DBI-v3.0.17/t/testlib/MyStarLink.pm0000444000175200017520000000062607742015454016517 0ustar tonytonypackage MyStarLink; BEGIN { unshift @INC, './t/testlib'; } use base 'MyBase'; use strict; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/linkid film star/); __PACKAGE__->has_a(film => 'MyFilm'); __PACKAGE__->has_a(star => 'MyStar'); sub create_sql { return qq{ linkid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, film TINYINT NOT NULL, star TINYINT NOT NULL }; } 1; Class-DBI-v3.0.17/t/testlib/Binary.pm0000444000175200017520000000046507734113121015676 0ustar tonytonypackage Binary; BEGIN { unshift @INC, './t/testlib'; } use strict; use base 'PgBase'; __PACKAGE__->table(cdbibintest => 'cdbibintest'); __PACKAGE__->sequence('binseq'); __PACKAGE__->columns(All => qw(id bin)); # __PACKAGE__->data_type(bin => DBI::SQL_BINARY); sub schema { "id INTEGER, bin BYTEA" } 1; Class-DBI-v3.0.17/t/testlib/Order.pm0000444000175200017520000000053310311016127015512 0ustar tonytonypackage Order; BEGIN { unshift @INC, './t/testlib'; } use strict; use base 'Class::DBI::Test::SQLite'; __PACKAGE__->set_table('orders'); __PACKAGE__->table_alias('orders'); __PACKAGE__->columns(Primary => 'film'); __PACKAGE__->columns(Others => qw/orders/); sub create_sql { return qq{ film VARCHAR(255), orders INTEGER }; } 1; Class-DBI-v3.0.17/t/testlib/Director.pm0000444000175200017520000000054710311016127016217 0ustar tonytonypackage Director; BEGIN { unshift @INC, './t/testlib'; } use strict; use base 'Class::DBI::Test::SQLite'; __PACKAGE__->set_table('Directors'); __PACKAGE__->columns('All' => qw/ Name Birthday IsInsane /); sub create_sql { return qq{ name VARCHAR(80), birthday INTEGER, isinsane INTEGER }; } 1; Class-DBI-v3.0.17/t/testlib/MyStarLinkMCPK.pm0000444000175200017520000000111510042755120017150 0ustar tonytonypackage MyStarLinkMCPK; BEGIN { unshift @INC, './t/testlib'; } use base 'MyBase'; use MyStar; use MyFilm; use strict; # This is a many-to-many mapping table that uses the two foreign keys # as its own primary key - there's no extra 'auto-inc' column here __PACKAGE__->set_table(); __PACKAGE__->columns(Primary => qw/film star/); __PACKAGE__->columns(All => qw/film star/); __PACKAGE__->has_a(film => 'MyFilm'); __PACKAGE__->has_a(star => 'MyStar'); sub create_sql { return qq{ film INTEGER NOT NULL, star INTEGER NOT NULL, PRIMARY KEY (film, star) }; } 1; Class-DBI-v3.0.17/t/testlib/Film.pm0000444000175200017520000000160110314754713015340 0ustar tonytonypackage Film; BEGIN { unshift @INC, './t/testlib'; } use base 'Class::DBI::Test::SQLite'; use strict; __PACKAGE__->set_table('Movies'); __PACKAGE__->columns('Primary', 'Title'); __PACKAGE__->columns('Essential', qw( Title )); __PACKAGE__->columns('Directors', qw( Director CoDirector )); __PACKAGE__->columns('Other', qw( Rating NumExplodingSheep HasVomit )); sub create_sql { return qq{ title VARCHAR(255), director VARCHAR(80), codirector VARCHAR(80), rating CHAR(5), numexplodingsheep INTEGER, hasvomit CHAR(1) } } sub create_test_film { return shift->insert( { Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1, } ); } package DeletingFilm; use base 'Film'; sub DESTROY { shift->delete } 1; Class-DBI-v3.0.17/t/testlib/MyFilm.pm0000444000175200017520000000070310332624102015634 0ustar tonytonypackage MyFilm; BEGIN { unshift @INC, './t/testlib'; } use base 'MyBase'; use MyStarLink; use strict; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/filmid title/); __PACKAGE__->has_many(_stars => 'MyStarLink'); __PACKAGE__->columns(Stringify => 'title'); sub _carp { } sub stars { map $_->star, shift->_stars } sub create_sql { return qq{ filmid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, title VARCHAR(255) }; } 1; Class-DBI-v3.0.17/t/testlib/MyStar.pm0000444000175200017520000000057607742015454015705 0ustar tonytonypackage MyStar; BEGIN { unshift @INC, './t/testlib'; } use base 'MyBase'; use strict; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/starid name/); __PACKAGE__->has_many(films => [ MyStarLink => 'film' ]); # sub films { map $_->film, shift->_films } sub create_sql { return qq{ starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) }; } 1; Class-DBI-v3.0.17/t/03-subclassing.t0000444000175200017520000000140410311016127015353 0ustar tonytonyuse strict; use Test::More; #---------------------------------------------------------------------- # Make sure subclasses can be themselves subclassed #---------------------------------------------------------------------- BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6); } use lib 't/testlib'; use Film; INIT { @Film::Threat::ISA = qw/Film/; } ok(Film::Threat->db_Main->ping, 'subclass db_Main()'); is_deeply [ sort Film::Threat->columns ], [ sort Film->columns ], 'has the same columns'; my $bt = Film->create_test_film; ok my $btaste = Film::Threat->retrieve('Bad Taste'), "subclass retrieve"; isa_ok $btaste => "Film::Threat"; isa_ok $btaste => "Film"; is $btaste->Title, 'Bad Taste', 'subclass get()'; Class-DBI-v3.0.17/t/12-filter.t0000444000175200017520000000707410314754713014351 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 50); } use lib 't/testlib'; use Actor; use Film; Film->has_many(actors => 'Actor'); Actor->has_a('film' => 'Film'); Actor->add_constructor(double_search => 'name = ? AND salary = ?'); my $film = Film->insert({ Title => 'MY Film' }); my $film2 = Film->insert({ Title => 'Another Film' }); my @act = ( Actor->insert( { name => 'Actor 1', film => $film, salary => 10, } ), Actor->insert( { name => 'Actor 2', film => $film, salary => 20, } ), Actor->insert( { name => 'Actor 3', film => $film, salary => 30, } ), Actor->insert( { name => 'Actor 4', film => $film2, salary => 50, } ), ); eval { my @actors = $film->actors(name => 'Actor 1'); is @actors, 1, "Got one actor from restricted has_many"; is $actors[0]->name, "Actor 1", "Correct name"; }; is $@, '', "No errors"; { my @actors = Actor->double_search("Actor 1", 10); is @actors, 1, "Got one actor"; is $actors[0]->name, "Actor 1", "Correct name"; } { ok my @actors = Actor->salary_between(0, 100), "Range 0 - 100"; is @actors, 4, "Got all"; } { my @actors = Actor->salary_between(100, 200); is @actors, 0, "None in Range 100 - 200"; } { ok my @actors = Actor->salary_between(0, 10), "Range 0 - 10"; is @actors, 1, "Got 1"; is $actors[0]->name, $act[0]->name, "Actor 1"; } { ok my @actors = Actor->salary_between(20, 30), "Range 20 - 20"; @actors = sort { $a->salary <=> $b->salary } @actors; is @actors, 2, "Got 2"; is $actors[0]->name, $act[1]->name, "Actor 2"; is $actors[1]->name, $act[2]->name, "and Actor 3"; } { ok my @actors = Actor->search(Film => $film), "Search by object"; is @actors, 3, "3 actors in film 1"; } #---------------------------------------------------------------------- # Iterators #---------------------------------------------------------------------- sub test_normal_iterator { my $it = $film->actors; isa_ok $it, "Class::DBI::Iterator"; is $it->count, 3, " - with 3 elements"; my $i = 0; while (my $film = $it->next) { is $film->name, $act[ $i++ ]->name, "Get $i"; } ok !$it->next, "No more"; is $it->first->name, $act[0]->name, "Get first"; } test_normal_iterator; { Film->has_many(actor_ids => [ Actor => 'id' ]); my $it = $film->actor_ids; isa_ok $it, "Class::DBI::Iterator"; is $it->count, 3, " - with 3 elements"; my $i = 0; while (my $film_id = $it->next) { is $film_id, $act[ $i++ ]->id, "Get id $i"; } ok !$it->next, "No more"; is $it->first, $act[0]->id, "Get first"; } # make sure nothing gets clobbered; test_normal_iterator; { my @acts = $film->actors->slice(1, 2); is @acts, 2, "Slice gives 2 actor"; is $acts[0]->name, "Actor 2", "Actor 2"; is $acts[1]->name, "Actor 3", "and actor 3"; } { my @acts = $film->actors->slice(1); is @acts, 1, "Slice of 1 actor"; is $acts[0]->name, "Actor 2", "Actor 2"; } { my @acts = $film->actors->slice(2, 8); is @acts, 1, "Slice off the end"; is $acts[0]->name, "Actor 3", "Gets last actor only"; } package Class::DBI::My::Iterator; use base 'Class::DBI::Iterator'; sub slice { qw/fred barney/ } package main; Actor->iterator_class('Class::DBI::My::Iterator'); { my @acts = $film->actors->slice(1, 2); is @acts, 2, "Slice gives 2 results"; is_deeply [sort map "$_", @acts], [qw/barney fred/], "Fred and Barney"; ok $film->actors->delete_all, "Can delete via iterator"; is $film->actors, 0, "no actors left"; eval { $film->actors->delete_all }; is $@, '', "Deleting again does no harm"; } Class-DBI-v3.0.17/t/15-accessor.t0000444000175200017520000001137610314754713014671 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 55); } INIT { local $SIG{__WARN__} = sub { like $_[0], qr/clashes with built-in method/, $_[0] }; use lib 't/testlib'; require Film; require Actor; Actor->has_a(film => 'Film'); } sub Class::DBI::sheep { fail "sheep() Method called"; } sub Film::mutator_name_for { my ($class, $col) = @_; return "set_sheep" if lc $col eq "numexplodingsheep"; return $col; } sub Film::accessor_name_for { my ($class, $col) = @_; return "sheep" if lc $col eq "numexplodingsheep"; return $col; } sub Actor::accessor_name_for { my ($class, $col) = @_; return "movie" if lc $col eq "film"; return $col; } my $data = { Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', }; eval { my $data = $data; $data->{NumExplodingSheep} = 1; ok my $bt = Film->insert($data), "Modified accessor - with column name"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { my $data = $data; $data->{sheep} = 1; ok my $bt = Film->insert($data), "Modified accessor - with accessor"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { my @film = Film->search({ sheep => 1 }); is @film, 2, "Can search with modified accessor"; }; { eval { local $data->{set_sheep} = 1; ok my $bt = Film->insert($data), "Modified mutator - with mutator"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { local $data->{NumExplodingSheep} = 1; ok my $bt = Film->insert($data), "Modified mutator - with column name"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { local $data->{sheep} = 1; ok my $bt = Film->insert($data), "Modified mutator - with accessor"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; } { my $p_data = { name => 'Peter Jackson', film => 'Bad Taste', }; my $bt = Film->insert($data); my $ac = Actor->insert($p_data); eval { my $f = $ac->film }; like $@, qr/Can't locate object method "film"/, "no hasa film"; eval { ok my $f = $ac->movie, "hasa movie"; isa_ok $f, "Film"; is $f->id, $bt->id, " - Bad Taste"; }; is $@, '', "No errors"; { local $data->{Title} = "Another film"; my $film = Film->insert($data); eval { $ac->film($film) }; ok $@, $@; eval { $ac->movie($film) }; ok $@, $@; eval { ok $ac->set_film($film), "Set movie through hasa"; $ac->update; ok my $f = $ac->movie, "hasa movie"; isa_ok $f, "Film"; is $f->id, $film->id, " - Another Film"; }; is $@, '', "No problem"; } } { # have non persistent accessor? Film->columns(TEMP => qw/nonpersistent/); ok(Film->find_column('nonpersistent'), "nonpersistent is a column"); ok(!Film->has_real_column('nonpersistent'), " - but it's not real"); { my $film = Film->insert({ Title => "Veronique", nonpersistent => 42 }); is $film->title, "Veronique", "Title set OK"; is $film->nonpersistent, 42, "As is non persistent value"; $film->remove_from_object_index; ok $film = Film->retrieve('Veronique'), "Re-retrieve film"; is $film->title, "Veronique", "Title still OK"; is $film->nonpersistent, undef, "Non persistent value gone"; ok $film->nonpersistent(40), "Can set it"; is $film->nonpersistent, 40, "And it's there again"; ok $film->update, "Commit the film"; is $film->nonpersistent, 40, "And it's still there"; } } { # was bug with TEMP and no Essential is_deeply( Actor->columns('Essential'), Actor->columns('Primary'), "Actor has no specific essential columns" ); ok(Actor->find_column('nonpersistent'), "nonpersistent is a column"); ok(!Actor->has_real_column('nonpersistent'), " - but it's not real"); my $pj = eval { Actor->search(name => "Peter Jackson")->first }; is $@, '', "no problems retrieving actors"; isa_ok $pj => "Actor"; } { Film->autoupdate(1); my $naked = Film->insert({ title => 'Naked' }); my $sandl = Film->insert({ title => 'Secrets and Lies' }); my $rating = 1; my $update_failure = sub { my $obj = shift; eval { $obj->rating($rating++) }; return $@ =~ /read only/; }; ok !$update_failure->($naked), "Can update Naked"; ok $naked->make_read_only, "Make Naked read only"; ok $update_failure->($naked), "Can't update Naked any more"; ok !$update_failure->($sandl), "But can still update Secrets and Lies"; my $july4 = eval { Film->insert({ title => "4 Days in July" }) }; isa_ok $july4 => "Film", "And can still insert new films"; ok(Film->make_read_only, "Make all Films read only"); ok $update_failure->($naked), "Still can't update Naked"; ok $update_failure->($sandl), "And can't update S&L any more"; eval { $july4->delete }; like $@, qr/read only/, "And can't delete 4 Days in July"; my $abigail = eval { Film->insert({ title => "Abigail's Party" }) }; like $@, qr/read only/, "Or insert new films"; $SIG{__WARN__} = sub { }; } Class-DBI-v3.0.17/t/10-mysql.t0000444000175200017520000001455510314754713014231 0ustar tonytony$| = 1; use strict; use Test::More; eval { require Date::Simple }; plan skip_all => "Need Date::Simple for this test" if $@; eval { require 't/testlib/MyFoo.pm' }; plan skip_all => "Need MySQL for this test" if $@; plan tests => 68; package main; ok( my $bar = MyFoo->insert({ name => "bar", val => 4, tdate => "2000-01-01" }), "bar" ); ok( my $baz = MyFoo->insert({ name => "baz", val => 7, tdate => "2000-01-01" }), "baz" ); is($baz->id, $bar->id + 1, "Auto incremented primary key"); is($bar->tdate, Date::Simple->new->format, " .. got today's date"); ok(my $wibble = $bar->copy, "Copy with auto_increment"); is($wibble->id, $baz->id + 1, " .. correct key"); ok(my $wobble = $bar->copy(6), "Copy without auto_increment"); is($wobble->id, 6, " .. correct key"); ok($wobble->tdate('2001-01-01') && $wobble->update, "Set the date of wobble"); isa_ok $wobble->tdate, "Date::Simple"; is($wobble->tdate, Date::Simple->new->format, " but it's set to today"); my $bobble = MyFoo->retrieve($wobble->id); is($bobble->tdate, Date::Simple->new->format, " set to today in DB too"); isa_ok $bobble->tdate, "Date::Simple"; is MyFoo->count_all, 4, "count_all()"; is MyFoo->minimum_value_of("val"), 4, "min()"; is MyFoo->maximum_value_of("val"), 7, "max()"; require './t/testlib/MyStarLinkMCPK.pm'; ok(my $f1 = MyFilm->insert({ title => "Veronique" }), "Create Veronique"); ok(my $f2 = MyFilm->insert({ title => "Red" }), "Create Red"); ok(my $s1 = MyStar->insert({ name => "Irene Jacob" }), "Irene Jacob"); ok(my $s2 = MyStar->insert({ name => "Jerzy Gudejko" }), "Create Jerzy"); ok(my $s3 = MyStar->insert({ name => "Frédérique Feder" }), "Create Fred"); ok(my $l1 = MyStarLink->insert({ film => $f1, star => $s1 }), "Link 1"); ok(my $l2 = MyStarLink->insert({ film => $f1, star => $s2 }), "Link 2"); ok(my $l3 = MyStarLink->insert({ film => $f2, star => $s1 }), "Link 3"); ok(my $l4 = MyStarLink->insert({ film => $f2, star => $s3 }), "Link 4"); ok(my $lm1 = MyStarLinkMCPK->insert({ film => $f1, star => $s1 }), "Link MCPK 1"); ok(my $lm2 = MyStarLinkMCPK->insert({ film => $f1, star => $s2 }), "Link MCPK 2"); ok(my $lm3 = MyStarLinkMCPK->insert({ film => $f2, star => $s1 }), "Link MCPK 3"); ok(my $lm4 = MyStarLinkMCPK->insert({ film => $f2, star => $s3 }), "Link MCPK 4"); { # Warnings for scalar context? my $err = ""; local $SIG{__WARN__} = sub { $err = $_[0]; }; $err = ""; 1 if MyStarLinkMCPK->_essential; is $err, "", "_essential() tolerates scalar context with multi-column key"; 1 if MyStarLinkMCPK->primary_column; like $err, qr/fetching in scalar context/, "but primary_column() complains"; } # try to create one with duplicate primary key my $lm5 = eval { MyStarLinkMCPK->insert({ film => $f2, star => $s3 }) }; ok(!$lm5, "Can't insert duplicate"); ok($@ =~ /^Can't insert .* duplicate/i, "Duplicate insert caused exception"); # create one to delete ok(my $lm6 = MyStarLinkMCPK->insert({ film => $f2, star => $s2 }), "Link MCPK 5"); ok(my $lm7 = MyStarLinkMCPK->retrieve(film => $f2, star => $s2), "Retrieve from table"); ok($lm7 && $lm7->delete, "Delete from table"); ok(!MyStarLinkMCPK->retrieve(film => $f2, star => $s2), "No longer in table"); # test stringify is "$lm1", "1/1", "stringify"; is "$lm4", "2/3", "stringify"; my $to_ids = sub { join ":", sort map $_->id, @_ }; { my @ver_star = $f1->stars; is @ver_star, 2, "Veronique has 2 stars "; isa_ok $ver_star[0] => 'MyStar'; is $to_ids->(@ver_star), $to_ids->($s1, $s2), "Correct stars"; } { my @irene = $s1->films; is @irene, 2, "Irene Jacob has 2 films"; isa_ok $irene[0] => 'MyFilm'; is $to_ids->(@irene), $to_ids->($f1, $f2), "Correct films"; } { my @jerzy = $s2->films; is @jerzy, 1, "Jerzy has 1 film"; is $jerzy[0]->id, $f1->id, " Veronique"; } { ok MyStar->has_many(filmids => [ MyStarLink => 'film', 'id' ]), "**** Multi-map"; my @filmid = $s1->filmids; ok !ref $filmid[0], "Film-id is not a reference"; my $first = $s1->filmids->first; ok !ref $first, "First is not a reference"; is $first, $filmid[0], "But it's the same as filmid[0]"; } { # cascades correctly my $lenin = MyFilm->insert({ title => "Leningrad Cowboys Go America" }); my $pimme = MyStar->insert({ name => "Pimme Korhonen" }); my $cowboy = MyStarLink->insert({ film => $lenin, star => $pimme }); $lenin->delete; is MyStar->search(name => 'Pimme Korhonen')->count, 1, "Pimme still exists"; is MyStarLink->search(star => $pimme->id)->count, 0, "But in no films"; } { ok MyStar->has_many(filmids_mcpk => [ MyStarLinkMCPK => 'film', 'id' ]), "**** Multi-map via MCPK"; my @filmid = $s1->filmids_mcpk; ok !ref $filmid[0], "Film-id is not a reference"; my $first = $s1->filmids_mcpk->first; ok !ref $first, "First is not a reference"; is $first, $filmid[0], "But it's the same as filmid[0]"; } { ok my $f0 = MyFilm->insert({ filmid => 0, title => "Year 0" }), "Create with explicit id = 0"; isa_ok $f0 => 'MyFilm'; is $f0->id, 0, "ID of 0"; } { # create doesn't mess with my hash. my %info = (Name => "Catherine Wilkening"); my $cw = MyStar->find_or_create(\%info); is scalar keys %info, 1, "Our hash still has only one key"; is $info{Name}, "Catherine Wilkening", "Still same name"; } { MyFilm->set_sql( retrieve_all_sorted => "SELECT __ESSENTIAL__ FROM __TABLE__ ORDER BY %s"); sub MyFilm::retrieve_all_sorted_by { my ($class, $order_by) = @_; return $class->sth_to_objects($class->sql_retrieve_all_sorted($order_by)); } my @all = MyFilm->retrieve_all_sorted_by("title"); is @all, 3, "3 films"; ok $all[2]->title gt $all[1]->title && $all[1]->title gt $all[0]->title, "sorted by title"; } { package Class::DBI::Search::Test::Limited; use base 'Class::DBI::Search::Basic'; sub fragment { my $self = shift; my $frag = $self->SUPER::fragment; if (defined(my $limit = $self->opt('limit'))) { $frag .= " LIMIT $limit"; } return $frag; } package main; MyFilm->add_searcher(search => "Class::DBI::Search::Test::Limited"); my @common = map MyFilm->insert({ title => "Common Title" }), 1 .. 3; { my @ltd = MyFilm->search( title => "Common Title", { order_by => 'filmid', limit => 1 } ); is @ltd, 1, "Limit to one film"; is $ltd[0]->id, $common[0]->id, "The correct one"; } { my @ltd = MyFilm->search( title => "Common Title", { order_by => 'filmid', limit => "1,1" } ); is @ltd, 1, "Limit to middle film"; is $ltd[0]->id, $common[1]->id, " - correctly"; } } Class-DBI-v3.0.17/t/24-meta_info.t0000555000175200017520000000154010321430577015020 0ustar tonytonyuse strict; use Test::More tests => 3; package Temp::DBI; use base qw(Class::DBI); Temp::DBI->columns(All => qw(id date)); Temp::DBI->has_a( date => 'Time::Piece', inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") }); package Temp::Person; use base 'Temp::DBI'; Temp::Person->table('people'); Temp::Person->columns(Info => qw(name pet)); Temp::Person->has_a( pet => 'Temp::Pet' ); package Temp::Pet; use base 'Temp::DBI'; Temp::Pet->table('pets'); Temp::Pet->columns(Info => qw(name)); Temp::Pet->has_many(owners => 'Temp::Person'); package main; my $pn_meta = Temp::Person->meta_info('has_a'); is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet"; my $pt_meta = Temp::Pet->meta_info; is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date"; is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners"; Class-DBI-v3.0.17/t/08-inheritcols.t0000444000175200017520000000100307630415501015372 0ustar tonytony#!/usr/bin/perl -w use strict; use Test::More tests => 3; use Class::DBI; package A; @A::ISA = qw(Class::DBI); __PACKAGE__->columns(Primary => 'id'); package A::B; @A::B::ISA = 'A'; __PACKAGE__->columns(All => qw(id b1)); package A::C; @A::C::ISA = 'A'; __PACKAGE__->columns(All => qw(id c1 c2 c3)); package main; is join (' ', sort A->columns), 'id', "A columns"; is join (' ', sort A::B->columns), 'b1 id', "A::B columns"; is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns"; Class-DBI-v3.0.17/t/14-might_have.t0000444000175200017520000000446010350355446015175 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 27); } use lib 't/testlib'; use Film; use Blurb; is(Blurb->primary_column, "title", "Primary key of Blurb = title"); is_deeply [ Blurb->_essential ], [ Blurb->primary_column ], "Essential = Primary"; eval { Blurb->retrieve(10) }; is $@, "", "No problem retrieving non-existent Blurb"; Film->might_have(info => Blurb => qw/blurb/); Film->create_test_film; { ok my $bt = Film->retrieve('Bad Taste'), "Get Film"; isa_ok $bt, "Film"; is $bt->info, undef, "No blurb yet"; # bug where we couldn't write a class with a might_have that didn't_have $bt->rating(16); eval { $bt->update }; is $@, '', "No problems updating when don't have"; is $bt->rating, 16, "Updated OK"; is $bt->blurb, undef, "Bad taste has no blurb"; $bt->blurb("Wibble bar"); $bt->update; is $bt->blurb, "Wibble bar", "And we can write the info"; } { my $bt = Film->retrieve('Bad Taste'); my $info = $bt->info; isa_ok $info, 'Blurb'; is $bt->blurb, $info->blurb, "Blurb is the same as fetching the long way"; ok $bt->blurb("New blurb"), "We can set the blurb"; $bt->update; is $bt->blurb, $info->blurb, "Blurb has been set"; $bt->rating(18); eval { $bt->update }; is $@, '', "No problems updating when do have"; is $bt->rating, 18, "Updated OK"; # cascade delete? { my $blurb = Blurb->retrieve('Bad Taste'); isa_ok $blurb => "Blurb"; $bt->delete; $blurb = Blurb->retrieve('Bad Taste'); is $blurb, undef, "Blurb has gone"; } } Film->create_test_film; { ok my $bt = Film->retrieve('Bad Taste'), "Get Film"; $bt->blurb("Wibble bar"); $bt->update; is $bt->blurb, "Wibble bar", "We can write the info"; # Bug #15635: Operation `bool': no method found $bt->info->delete; my $blurb = eval { $bt->blurb }; is $@, '', "Can delete the blurb"; is $blurb, undef, "Blurb is now undef"; eval { $bt->delete }; is $@, '', "Can delete the parent object"; } Film->create_test_film; { ok my $bt = Film->retrieve('Bad Taste'), "Get Film (recreated)"; is $bt->blurb, undef, "Bad taste has no blurb"; $bt->blurb(0); $bt->update; is $bt->blurb, 0, "We can write false values"; $bt->blurb(undef); $bt->update; is $bt->blurb, undef, "And explicit NULLs"; $bt->delete; } Class-DBI-v3.0.17/t/27-mutator-old.t0000644000175200017520000000146110472012631015324 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 7); } INIT { my $once = 0; local $SIG{__WARN__} = sub { fail $_[0] unless $_[0] =~ /deprecated/; pass "Deprecated warning" unless $once++ }; use lib 't/testlib'; require Film; } sub Film::accessor_name { my ($class, $col) = @_; return "sheep" if lc $col eq "numexplodingsheep"; return $col; } my $data = { Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', }; my $bt; eval { my $data = $data; $data->{sheep} = 1; ok $bt = Film->insert($data), "Modified accessor - with accessor"; isa_ok $bt, "Film"; }; is $@, '', "No errors"; eval { ok $bt->sheep(2), 'Modified accessor, set'; ok $bt->update, 'Update'; }; is $@, '', "No errors"; Class-DBI-v3.0.17/t/25-closures_in_meta.t0000555000175200017520000000301610332622530016405 0ustar tonytonyuse strict; use Test::More; package main; BEGIN { eval { require 't/testlib/MyBase.pm' }; plan skip_all => "Need MySQL for this test" if $@; eval "use DateTime::Format::MySQL"; plan skip_all => "Need DateTime::Format::MySQL for this test" if $@; } package Temp::DBI; BEGIN { eval { require 't/testlib/MyBase.pm' }; } use base 'MyBase'; # typically provided by Class::DBI::mysql sub autoinflate_dates { my $class = shift; my $columns = $class->_column_info; foreach my $c (keys %$columns) { my $type = $columns->{$c}->{type}; next unless ($type =~ m/^(date)/); my $i_method = "parse_$type"; my $d_method = "format_$type"; $class->has_a( $c => 'DateTime', inflate => sub { DateTime::Format::MySQL->$i_method(shift) }, deflate => sub { DateTime::Format::MySQL->$d_method(shift) }, ); } } package Temp::DateTable; use base 'Temp::DBI'; __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/my_id my_datetime my_date/,); __PACKAGE__->autoinflate_dates; sub create_sql { return qq{ my_id integer not null auto_increment primary key, my_datetime datetime, my_date date }; } # typically provided by Class::DBI::mysql sub _column_info { return { map { 'my_' . $_ => { type => $_ } } qw(datetime date) }; } package main; plan tests => 1; my $dt = DateTime->now(); my $row = Temp::DateTable->create( { map { my $method = "format_$_"; ("my_$_" => DateTime::Format::MySQL->$method($dt)) } qw(date datetime) } ); my $date = eval { $row->my_date }; isa_ok($date, 'DateTime'); 1; Class-DBI-v3.0.17/t/16-reserved.t0000444000175200017520000000114310311016127014661 0ustar tonytonyuse strict; use Test::More; BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5); } use lib 't/testlib'; require Film; require Order; Film->has_many(orders => 'Order'); Order->has_a(film => 'Film'); Film->create_test_film; my $film = Film->retrieve('Bad Taste'); isa_ok $film => 'Film'; $film->add_to_orders({ orders => 10 }); my $bto = Order->search(film => 'Bad Taste')->first; isa_ok $bto => 'Order'; is $bto->orders, 10, "Correct number of orders"; my $infilm = $bto->film; isa_ok $infilm, "Film"; is $infilm->id, $film->id, "Orders hasa Film"; Class-DBI-v3.0.17/t/98-failure.t0000444000175200017520000000304110311046676014516 0ustar tonytonyuse strict; use Test::More; #---------------------------------------------------------------------- # Test database failures #---------------------------------------------------------------------- BEGIN { eval "use DBD::SQLite"; plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 7); } use lib 't/testlib'; use Film; Film->create_test_film; { my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We have Bad Taste"; { no warnings 'redefine'; local *DBIx::ContextualFetch::st::execute = sub { die "Database died" }; eval { $btaste->delete }; ::like $@, qr/Database died/s, "We failed"; } my $still = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We still have Bad Taste"; } { my $btaste = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We have Bad Taste"; $btaste->numexplodingsheep(10); { no warnings 'redefine'; local *DBIx::ContextualFetch::st::execute = sub { die "Database died" }; eval { $btaste->update }; ::like $@, qr/update.*Database died/s, "We failed"; } $btaste->discard_changes; my $still = Film->retrieve('Bad Taste'); isa_ok $btaste, 'Film', "We still have Bad Taste"; is $btaste->numexplodingsheep, 1, "with 1 sheep"; } if (0) { my $sheep = Film->maximum_value_of('numexplodingsheep'); is $sheep, 1, "1 exploding sheep"; { local *DBIx::ContextualFetch::st::execute = sub { die "Database died" }; my $sheep = eval { Film->maximum_value_of('numexplodingsheep') }; ::like $@, qr/select.*Database died/s, "Handle database death in single value select"; } } Class-DBI-v3.0.17/t/22-deflate_order.t0000444000175200017520000000101010314754713015644 0ustar tonytony$| = 1; use strict; use Test::More; eval { require Time::Piece::MySQL }; plan skip_all => "Need Time::Piece::MySQL for this test" if $@; eval { require 't/testlib/Log.pm' }; plan skip_all => "Need MySQL for this test" if $@; plan tests => 2; package main; my $log = Log->insert( { message => 'initial message' } ); ok eval { $log->datetime_stamp }, "Have datetime"; diag $@ if $@; $log->message( 'a revised message' ); $log->update; ok eval { $log->datetime_stamp }, "Have datetime after update"; diag $@ if $@; Class-DBI-v3.0.17/t/01-columns.t0000444000175200017520000000716710332624102014531 0ustar tonytonyuse strict; use Test::More tests => 26; #----------------------------------------------------------------------- # Make sure that we can set up columns properly #----------------------------------------------------------------------- package State; use base 'Class::DBI'; use Class::DBI::Column; State->table('State'); State->columns(Essential => qw/Abbreviation Name/); State->columns(Primary => 'Name'); State->columns(Weather => qw/Snowfall/, Class::DBI::Column->new('Rain', { accessor => 'Rainfall' }) ); State->columns(Other => qw/Capital Population/); State->has_many(cities => "City"); sub mutator_name_for { my ($class, $column) = @_; return "set_" . $column->accessor; } sub Snowfall { 1 } package City; use base 'Class::DBI'; City->table('City'); City->columns(All => qw/Name State Population/); City->has_a(State => 'State'); #------------------------------------------------------------------------- package CD; use base 'Class::DBI'; CD->table('CD'); CD->columns('All' => qw/artist title length/); #------------------------------------------------------------------------- package main; is(State->table, 'State', 'State table()'); is(State->primary_column, 'name', 'State primary()'); is_deeply [ State->columns('Primary') ] => [qw/name/], 'State Primary:' . join ", ", State->columns('Primary'); is_deeply [ sort State->columns('Essential') ] => [qw/abbreviation name/], 'State Essential:' . join ", ", State->columns('Essential'); is_deeply [ sort State->columns('All') ] => [ sort qw/name abbreviation rain snowfall capital population/ ], 'State All:' . join ", ", State->columns('All'); is(CD->primary_column, 'artist', 'CD primary()'); is_deeply [ CD->columns('Primary') ] => [qw/artist/], 'CD primary:' . join ", ", CD->columns('Primary'); is_deeply [ sort CD->columns('All') ] => [qw/artist length title/], 'CD all:' . join ", ", CD->columns('All'); is_deeply [ sort CD->columns('Essential') ] => [qw/artist/], 'CD essential:' . join ", ", CD->columns('Essential'); { local $SIG{__WARN__} = sub { ok 1, "Error thrown" }; ok(!State->columns('Nonsense'), "No Nonsense group"); } ok(State->find_column('Rain'), 'find_column Rain'); ok(State->find_column('rain'), 'find_column rain'); ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG'); can_ok +State => qw/Rainfall _Rainfall_accessor set_Rainfall _set_Rainfall_accessor Snowfall _Snowfall_accessor set_Snowfall _set_Snowfall_accessor/; foreach my $method (qw/Rain _Rain_accessor rain snowfall/) { ok !State->can($method), "State can't $method"; } { eval { my @grps = State->__grouper->groups_for("Huh"); }; ok $@, "Huh not in groups"; my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/)); is @grps, 2, "Rain and Capital = 2 groups"; is $grps[0], 'Other', " - Other"; is $grps[1], 'Weather', " - Weather"; } { local $SIG{__WARN__} = sub { }; eval { Class::DBI->retrieve(1) }; like $@, qr/Can't retrieve unless primary columns are defined/, "Need primary key for retrieve"; } #----------------------------------------------------------------------- # Make sure that columns inherit properly #----------------------------------------------------------------------- package State; package A; @A::ISA = qw(Class::DBI); __PACKAGE__->columns(Primary => 'id'); package A::B; @A::B::ISA = 'A'; __PACKAGE__->columns(All => qw(id b1)); package A::C; @A::C::ISA = 'A'; __PACKAGE__->columns(All => qw(id c1 c2 c3)); package main; is join(' ', sort A->columns), 'id', "A columns"; is join(' ', sort A::B->columns), 'b1 id', "A::B columns"; is join(' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns"; Class-DBI-v3.0.17/lib/0000755000175200017520000000000010701255372012751 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/0000755000175200017520000000000010701255372014016 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/0000755000175200017520000000000010701255372014414 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/SQL/0000755000175200017520000000000010701255372015053 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/SQL/Transformer.pm0000444000175200017520000000610110313765344017713 0ustar tonytonypackage Class::DBI::SQL::Transformer; use strict; use warnings; =head1 NAME Class::DBI::SQL::Transformer - Transform SQL =head1 SYNOPSIS my $trans = $tclass->new($self, $sql, @args); return $self->SUPER::transform_sql($trans->sql => $trans->args); =head1 DESCRIPTION Class::DBI hooks into the transform_sql() method in Ima::DBI to provide its own SQL extensions. Class::DBI::SQL::Transformer does the heavy lifting of these transformations. =head1 CONSTRUCTOR =head2 new my $trans = $tclass->new($self, $sql, @args); Create a new transformer for the SQL and arguments that will be used with the given object (or class). =cut sub new { my ($me, $caller, $sql, @args) = @_; bless { _caller => $caller, _sql => $sql, _args => [@args], _transformed => 0, } => $me; } =head2 sql / args my $sql = $trans->sql; my @args = $trans->args; The transformed SQL and args. =cut # TODO Document what the different transformations are # and factor out how they're called so that people can pick and mix the # ones they want and add new ones. sub sql { my $self = shift; $self->_do_transformation if !$self->{_transformed}; return $self->{_transformed_sql}; } sub args { my $self = shift; $self->_do_transformation if !$self->{_transformed}; return @{ $self->{_transformed_args} }; } sub _expand_table { my $self = shift; my ($class, $alias) = split /=/, shift, 2; my $caller = $self->{_caller}; my $table = $class ? $class->table : $caller->table; $self->{cmap}{ $alias || $table } = $class || ref $caller || $caller; ($alias ||= "") &&= " $alias"; return $table . $alias; } sub _expand_join { my $self = shift; my $joins = shift; my @table = split /\s+/, $joins; my $caller = $self->{_caller}; my %tojoin = map { $table[$_] => $table[ $_ + 1 ] } 0 .. $#table - 1; my @sql; while (my ($t1, $t2) = each %tojoin) { my ($c1, $c2) = map $self->{cmap}{$_} || $caller->_croak("Don't understand table '$_' in JOIN"), ($t1, $t2); my $join_col = sub { my ($c1, $c2) = @_; my $meta = $c1->meta_info('has_a'); my ($col) = grep $meta->{$_}->foreign_class eq $c2, keys %$meta; $col; }; my $col = $join_col->($c1 => $c2) || do { ($c1, $c2) = ($c2, $c1); ($t1, $t2) = ($t2, $t1); $join_col->($c1 => $c2); }; $caller->_croak("Don't know how to join $c1 to $c2") unless $col; push @sql, sprintf " %s.%s = %s.%s ", $t1, $col, $t2, $c2->primary_column; } return join " AND ", @sql; } sub _do_transformation { my $me = shift; my $sql = $me->{_sql}; my @args = @{ $me->{_args} }; my $caller = $me->{_caller}; $sql =~ s/__TABLE\(?(.*?)\)?__/$me->_expand_table($1)/eg; $sql =~ s/__JOIN\((.*?)\)__/$me->_expand_join($1)/eg; $sql =~ s/__ESSENTIAL__/join ", ", $caller->_essential/eg; $sql =~ s/__ESSENTIAL\((.*?)\)__/join ", ", map "$1.$_", $caller->_essential/eg; if ($sql =~ /__IDENTIFIER__/) { my $key_sql = join " AND ", map "$_=?", $caller->primary_columns; $sql =~ s/__IDENTIFIER__/$key_sql/g; } $me->{_transformed_sql} = $sql; $me->{_transformed_args} = [@args]; $me->{_transformed} = 1; return 1; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Test/0000755000175200017520000000000010701255372015333 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/Test/SQLite.pm0000444000175200017520000000343210244603746017036 0ustar tonytonypackage Class::DBI::Test::SQLite; =head1 NAME Class::DBI::Test::SQLite - Base class for Class::DBI tests =head1 SYNOPSIS use base 'Class::DBI::Test::SQLite'; __PACKAGE__->set_table('test'); __PACKAGE__->columns(All => qw/id name film salary/); sub create_sql { return q{ id INTEGER PRIMARY KEY, name CHAR(40), film VARCHAR(255), salary INT } } =head1 DESCRIPTION This provides a simple base class for Class::DBI tests using SQLite. Each class for the test should inherit from this, provide a create_sql() method which returns a string representing the SQL used to create the table for the class, and then call set_table() to create the table, and tie it to the class. =cut use strict; use base 'Class::DBI'; use File::Temp qw/tempfile/; my (undef, $DB) = tempfile(); END { unlink $DB if -e $DB } my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1 }); __PACKAGE__->connection(@DSN); __PACKAGE__->set_sql(_table_pragma => 'PRAGMA table_info(__TABLE__)'); __PACKAGE__->set_sql(_create_me => 'CREATE TABLE __TABLE__ (%s)'); =head1 METHODS =head2 set_table __PACKAGE__->set_table('test'); This combines creating the table with the normal Class::DBI table() call. =cut sub set_table { my ($class, $table) = @_; $class->table($table); $class->_create_test_table; } sub _create_test_table { my $class = shift; my @vals = $class->sql__table_pragma->select_row; $class->sql__create_me($class->create_sql)->execute unless @vals; } =head2 create_sql (abstract) sub create_sql { return q{ id INTEGER PRIMARY KEY, name CHAR(40), film VARCHAR(255), salary INT } } This should return, as a text string, the schema for the table represented by this class. =cut sub create_sql { die "create_sql() not implemented by $_[0]\n" } 1; Class-DBI-v3.0.17/lib/Class/DBI/Relationship/0000755000175200017520000000000010701255372017055 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/Relationship/MightHave.pm0000444000175200017520000000335110350355446021272 0ustar tonytonypackage Class::DBI::Relationship::MightHave; use strict; use warnings; use base 'Class::DBI::Relationship'; sub remap_arguments { my ($proto, $class, $method, $f_class, @methods) = @_; $class->_require_class($f_class); return ($class, $method, $f_class, { import => \@methods }); } sub triggers { my $self = shift; my $method = $self->accessor; return ( before_update => sub { if (my $for_obj = shift->$method()) { $for_obj->update } }, before_delete => sub { if (my $for_obj = shift->$method()) { $for_obj->delete } }, ); } sub methods { my $self = shift; my ($class, $method) = ($self->class, $self->accessor); return ( $method => $self->_object_accessor, map { $_ => $self->_imported_accessor($_) } @{ $self->args->{import} } ); } sub _object_accessor { my $rel = shift; my ($class, $method) = ($rel->class, $rel->accessor); return sub { my $self = shift; my $meta = $class->meta_info($rel->name => $method); my ($f_class, @extra) = ($meta->foreign_class, @{ $meta->args->{import} }); return if defined($self->{"_${method}_object"}) && $self->{"_${method}_object"} ->isa('Class::DBI::Object::Has::Been::Deleted'); $self->{"_${method}_object"} ||= $f_class->retrieve($self->id); }; } sub _imported_accessor { my ($rel, $name) = @_; my ($class, $method) = ($rel->class, $rel->accessor); return sub { my $self = shift; my $meta = $class->meta_info($rel->name => $method); my ($f_class, @extra) = ($meta->foreign_class, @{ $meta->args->{import} }); my $for_obj = $self->$method() || do { return unless @_; # just fetching my $val = shift; $f_class->insert( { $f_class->primary_column => $self->id, $name => $val }); $self->$method(); }; $for_obj->$name(@_); }; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Relationship/HasA.pm0000444000175200017520000000525310523341706020231 0ustar tonytonypackage Class::DBI::Relationship::HasA; use strict; use warnings; use base 'Class::DBI::Relationship'; sub remap_arguments { my ($proto, $class, $want_col, $a_class, %meths) = @_; $class->_invalid_object_method("has_a") if ref $class; my $column = $class->find_column($want_col) or return $class->_croak("Column $want_col does not exist in $class"); $class->_croak("$class $column needs an associated class") unless $a_class; return ($class, $column, $a_class, \%meths); } sub triggers { my $self = shift; $self->class->_require_class($self->foreign_class); my $column = $self->accessor; return ( select => $self->_inflator, # after_create => $self->_inflator, # see t/6 "after_set_$column" => $self->_inflator, deflate_for_create => $self->_deflator(1), deflate_for_update => $self->_deflator, ); } sub _inflator { my $rel = shift; my $col = $rel->accessor; return sub { my $self = shift; defined(my $value = $self->_attrs($col)) or return; my $meta = $self->meta_info($rel->name => $col); my ($a_class, %meths) = ($meta->foreign_class, %{ $meta->args }); return if ref $value and $value->isa($a_class); my $inflator; my $get_new_value = sub { my ($inflator, $value, $want_class, $obj) = @_; my $new_value = (ref $inflator eq 'CODE') ? $inflator->($value, $obj) : $want_class->$inflator($value); return $new_value; }; # If we have a custom inflate ... if (exists $meths{'inflate'}) { $value = $get_new_value->($meths{'inflate'}, $value, $a_class, $self); return $self->_attribute_store($col, $value) if ref $value and $value->isa($a_class); $self->_croak("Inflate method didn't inflate right") if ref $value; } return $self->_croak("Can't inflate $col to $a_class using '$value': " . ref($value) . " is not a $a_class") if ref $value; $inflator = $a_class->isa('Class::DBI') ? "_simple_bless" : "new"; $value = $get_new_value->($inflator, $value, $a_class); return $self->_attribute_store($col, $value) if ref $value and $value->isa($a_class); # use ref as $obj may be overloaded and appear 'false' return $self->_croak( "Can't inflate $col to $a_class " . "via $inflator using '$value'") unless ref $value; }; } sub _deflator { my ($self, $always) = @_; my $col = $self->accessor; return sub { my $self = shift; return unless $self->_attribute_exists($col); $self->_attribute_store($col => $self->_deflated_column($col)) if ($always or $self->{__Changed}->{$col}); }; } sub _set_up_class_data { my $self = shift; $self->class->_extend_class_data(__hasa_rels => $self->accessor => [ $self->foreign_class, %{ $self->args } ]); $self->SUPER::_set_up_class_data; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Relationship/HasMany.pm0000444000175200017520000001141410326714355020756 0ustar tonytonypackage Class::DBI::Relationship::HasMany; use strict; use warnings; use base 'Class::DBI::Relationship'; sub remap_arguments { my ($proto, $class, $accessor, $f_class, $f_key, $args) = @_; return $class->_croak($class->name . " needs an accessor name") unless $accessor; return $class->_croak($class->name . " needs a foreign class") unless $f_class; { no strict 'refs'; defined &{"$class\::$accessor"} and return $class->_carp("$accessor method already exists in $class\n"); } my @f_method = (); if (ref $f_class eq "ARRAY") { ($f_class, @f_method) = @$f_class; } $class->_require_class($f_class); if (ref $f_key eq "HASH") { # didn't supply f_key, this is really $args $args = $f_key; $f_key = ""; } $f_key ||= do { my $meta = $f_class->meta_info('has_a'); my ($col) = grep $meta->{$_}->foreign_class eq $class, keys %$meta; $col || $class->table_alias; }; if (ref $f_key eq "ARRAY") { return $class->_croak("Multi-column foreign keys not supported") if @$f_key > 1; $f_key = $f_key->[0]; } $args ||= {}; $args->{mapping} = \@f_method; $args->{foreign_key} = $f_key; $args->{order_by} ||= $args->{sort}; # deprecated 0.96 warn "sort argument to has_many deprecated in favour of order_by" if $args->{sort}; # deprecated 0.96 return ($class, $accessor, $f_class, $args); } sub _set_up_class_data { my $self = shift; $self->class->_extend_class_data( __hasa_list => $self->foreign_class => $self->args->{foreign_key}); $self->SUPER::_set_up_class_data; } sub triggers { my $self = shift; if ($self->args->{no_cascade_delete}) { # old undocumented way warn "no_cascade_delete deprecated in favour of cascade => None"; return; } my $strategy = $self->args->{cascade} || "Delete"; $strategy = "Class::DBI::Cascade::$strategy" unless $strategy =~ /::/; $self->foreign_class->_require_class($strategy); $strategy->can('cascade') or return $self->_croak("$strategy is not a valid Cascade Strategy"); my $strat_obj = $strategy->new($self); return (before_delete => sub { $strat_obj->cascade(@_) }); } sub methods { my $self = shift; my $accessor = $self->accessor; return ( $accessor => $self->_has_many_method, "add_to_$accessor" => $self->_method_add_to, ); } sub _method_add_to { my $rel = shift; my $accessor = $rel->accessor; return sub { my ($self, $data) = @_; my $class = ref $self or return $self->_croak("add_to_$accessor called as class method"); return $self->_croak("add_to_$accessor needs data") unless ref $data eq "HASH"; my $meta = $class->meta_info($rel->name => $accessor); my ($f_class, $f_key, $args) = ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args); $data->{$f_key} = $self->id; # See if has_many constraints were defined and auto fill them if (defined $args->{constraint} && ref $args->{constraint} eq 'HASH') { while (my ($k, $v) = each %{ $args->{constraint} }) { $self->_croak( "Can't add_to_$accessor with $k = $data->{$k} (must be $v)") if defined($data->{$k}) && $data->{$k} ne $v; $data->{$k} = $v; } } $f_class->insert($data); }; } sub _has_many_method { my $self = shift; my $run_search = $self->_hm_run_search; my @mapping = @{ $self->args->{mapping} } or return $run_search; return sub { return $run_search->(@_)->set_mapping_method(@mapping) unless wantarray; my @ret = $run_search->(@_); foreach my $meth (@mapping) { @ret = map $_->$meth(), @ret } return @ret; } } sub _hm_run_search { my $rel = shift; my ($class, $accessor) = ($rel->class, $rel->accessor); return sub { my ($self, @search_args) = @_; @search_args = %{ $search_args[0] } if ref $search_args[0] eq "HASH"; my $meta = $class->meta_info($rel->name => $accessor); my ($f_class, $f_key, $args) = ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args); if (ref $self) { # For $artist->cds unshift @search_args, %{ $args->{constraint} } if defined($args->{constraint}) && ref $args->{constraint} eq 'HASH'; unshift @search_args, ($f_key => $self->id); push @search_args, { order_by => $args->{order_by} } if defined $args->{order_by}; return $f_class->search(@search_args); } else { # For Artist->cds # Cross-table join as class method # This stuff is highly experimental and will probably change beyond # recognition. Use at your own risk... my %kv = @search_args; my $query = Class::DBI::Query->new({ owner => $f_class }); $query->kings($class, $f_class); $query->add_restriction(sprintf "%s.%s = %s.%s", $f_class->table_alias, $f_key, $class->table_alias, $class->primary_column); $query->add_restriction("$_ = ?") for keys %kv; my $sth = $query->run(values %kv); return $f_class->sth_to_objects($sth); } }; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Cascade/0000755000175200017520000000000010701255372015737 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/Cascade/Delete.pm0000444000175200017520000000054310312100751017463 0ustar tonytonypackage Class::DBI::Cascade::Delete; =head1 NAME Class::DBI::Cascade::Delete - Delete related objects =head1 DESCRIPTION This is a Cascading Delete strategy that will delete any related objects. =cut use strict; use warnings; use base 'Class::DBI::Cascade::None'; sub cascade { my ($self, $obj) = @_; $self->foreign_for($obj)->delete_all; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Cascade/Fail.pm0000444000175200017520000000104110312100751017126 0ustar tonytonypackage Class::DBI::Cascade::Fail; =head1 NAME Class::DBI::Cascade::Fail - Do not cascade if foreign objects exist =head1 DESCRIPTION This is a Cascading Delete strategy that will throw an error if any object about to be deleted still has any other objects pointing at it. =cut use strict; use warnings; use base 'Class::DBI::Cascade::None'; sub cascade { my ($self, $obj) = @_; my $refs = $self->foreign_for($obj)->count or return; $self->{_rel}->foreign_class->_croak( "$refs objects still refer to $obj. Deletion failed"); } 1; Class-DBI-v3.0.17/lib/Class/DBI/Cascade/None.pm0000444000175200017520000000301210312100751017152 0ustar tonytonypackage Class::DBI::Cascade::None; =head1 NAME Class::DBI::Cascade::None - Do nothing upon deletion =head1 DESCRIPTION This is a Cascading Delete strategy that will do nothing, leaving orphaned records behind. It is the base class for most ofther Cascade strategies, and so provides several important methods: =head1 CONSTRUCTOR =head2 new my $strategy = Cascade::Class->new($Relationship); This must be instantiated with a Class::DBI::Relationship object. =head1 METHODS =head2 foreign_for my $iterator = $strategy->foreign_for($obj); This will return all the objects which are foreign to $obj across the relationship. It's a normal Class::DBI search you can get the results either as a list or as an iterator. =head2 cascade $strategy->cascade($obj); Cascade across the related objects to $obj. =head1 WRITING NEW STRATEGIES Creating a Cascade strategy should be fairly simple. You usually just need to inherit from here, and then supply a cascade() method that does the required thing with the results from foreign_for(). So, for example, Cascade::Delete is implemented simply as: package Class::DBI::Cascade::Delete; use base 'Class::DBI::Cascade::None'; sub cascade { my ($self, $obj) = @_; $self->foreign_for($obj)->delete_all; } =cut use strict; use warnings; sub new { my ($class, $rel) = @_; bless { _rel => $rel } => $class; } sub foreign_for { my ($self, $obj) = @_; return $self->{_rel} ->foreign_class->search($self->{_rel}->args->{foreign_key} => $obj->id); } sub cascade { return; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Search/0000755000175200017520000000000010701255372015621 5ustar tonytonyClass-DBI-v3.0.17/lib/Class/DBI/Search/Basic.pm0000444000175200017520000000734410311250122017167 0ustar tonytonypackage Class::DBI::Search::Basic; =head1 NAME Class::DBI::Search::Basic - Simple Class::DBI search =head1 SYNOPSIS my $searcher = Class::DBI::Search::Basic->new( $cdbi_class, @search_args ); my @results = $searcher->run_search; # Over in your Class::DBI subclass: __PACKAGE__->add_searcher( search => "Class::DBI::Search::Basic", isearch => "Class::DBI::Search::Plugin::CaseInsensitive", ); =head1 DESCRIPTION This is the start of a pluggable Search infrastructure for Class::DBI. At the minute Class::DBI::Search::Basic doubles up as both the default search within Class::DBI as well as the search base class. We will probably need to tease this apart more later and create an abstract base class for search plugins. =head1 METHODS =head2 new my $searcher = Class::DBI::Search::Basic->new( $cdbi_class, @search_args ); A Searcher is created with the class to which the results will belong, and the arguments passed to the search call by the user. =head2 opt if (my $order = $self->opt('order_by')) { ... } The arguments passed to search may contain an options hash. This will return the value of a given option. =head2 run_search my @results = $searcher->run_search; my $iterator = $searcher->run_search; Actually run the search. =head1 SUBCLASSING =head2 sql / bind / fragment The actual mechanics of generating the SQL and executing it split up into a variety of methods for you to override. run_search() is implemented as: return $cdbi->sth_to_objects($self->sql, $self->bind); Where sql() is $cdbi->sql_Retrieve($self->fragment); There are also a variety of private methods underneath this that could be overriden in a pinch, but if you need to do this I'd rather you let me know so that I can make them public, or at least so that I don't remove them from under your feet. =cut use strict; use warnings; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw/class args opts type/); sub new { my ($me, $proto, @args) = @_; my ($args, $opts) = $me->_unpack_args(@args); bless { class => ref $proto || $proto, args => $args, opts => $opts, type => "=", } => $me; } sub opt { my ($self, $option) = @_; $self->{opts}->{$option}; } sub _unpack_args { my ($self, @args) = @_; @args = %{ $args[0] } if ref $args[0] eq "HASH"; my $opts = @args % 2 ? pop @args : {}; return (\@args, $opts); } sub _search_for { my $self = shift; my @args = @{ $self->{args} }; my $class = $self->{class}; my %search_for; while (my ($col, $val) = splice @args, 0, 2) { my $column = $class->find_column($col) || (List::Util::first { $_->accessor eq $col } $class->columns) || $class->_croak("$col is not a column of $class"); $search_for{$column} = $class->_deflated_column($column, $val); } return \%search_for; } sub _qual_bind { my $self = shift; $self->{_qual_bind} ||= do { my $search_for = $self->_search_for; my $type = $self->type; my (@qual, @bind); for my $column (sort keys %$search_for) { # sort for prepare_cached if (defined(my $value = $search_for->{$column})) { push @qual, "$column $type ?"; push @bind, $value; } else { # perhaps _carp if $type ne "=" push @qual, "$column IS NULL"; } } [ \@qual, \@bind ]; }; } sub _qual { my $self = shift; $self->{_qual} ||= $self->_qual_bind->[0]; } sub bind { my $self = shift; $self->{_bind} ||= $self->_qual_bind->[1]; } sub fragment { my $self = shift; my $frag = join " AND ", @{ $self->_qual }; if (my $order = $self->opt('order_by')) { $frag .= " ORDER BY $order"; } return $frag; } sub sql { my $self = shift; return $self->class->sql_Retrieve($self->fragment); } sub run_search { my $self = shift; my $cdbi = $self->class; return $cdbi->sth_to_objects($self->sql, $self->bind); } 1; Class-DBI-v3.0.17/lib/Class/DBI/Iterator.pm0000444000175200017520000000435710311003120016525 0ustar tonytonypackage Class::DBI::Iterator; =head1 NAME Class::DBI::Iterator - Iterate over Class::DBI search results =head1 SYNOPSIS my $it = My::Class->search(foo => 'bar'); my $results = $it->count; my $first_result = $it->first; while ($it->next) { ... } my @slice = $it->slice(10,19); my $slice = $it->slice(10,19); $it->reset; $it->delete_all; =head1 DESCRIPTION Any Class::DBI search (including a has_many method) which returns multiple objects can be made to return an iterator instead simply by executing the search in scalar context. Then, rather than having to fetch all the results at the same time, you can fetch them one at a time, potentially saving a considerable amount of processing time and memory. =head1 CAVEAT Note that there is no provision for the data changing (or even being deleted) in the database inbetween performing the search and retrieving the next result. =cut use strict; use overload '0+' => 'count', fallback => 1; sub new { my ($me, $them, $data, @mapper) = @_; bless { _class => $them, _data => $data, _mapper => [@mapper], _place => 0, }, ref $me || $me; } sub set_mapping_method { my ($self, @mapper) = @_; $self->{_mapper} = [@mapper]; $self; } sub class { shift->{_class} } sub data { @{ shift->{_data} } } sub mapper { @{ shift->{_mapper} } } sub count { my $self = shift; $self->{_count} ||= scalar $self->data; } sub next { my $self = shift; my $use = $self->{_data}->[ $self->{_place}++ ] or return; my @obj = ($self->class->construct($use)); foreach my $meth ($self->mapper) { @obj = map $_->$meth(), @obj; } warn "Discarding extra inflated objects" if @obj > 1; return $obj[0]; } sub first { my $self = shift; $self->reset; return $self->next; } sub slice { my ($self, $start, $end) = @_; $end ||= $start; $self->{_place} = $start; my @return; while ($self->{_place} <= $end) { push @return, $self->next || last; } return @return if wantarray; my $slice = $self->new($self->class, \@return, $self->mapper,); return $slice; } sub delete_all { my $self = shift; my $count = $self->count or return; $self->first->delete; # to reset counter while (my $obj = $self->next) { $obj->delete; } $self->{_data} = []; 1; } sub reset { shift->{_place} = 0 } 1; Class-DBI-v3.0.17/lib/Class/DBI/Query.pm0000444000175200017520000001025410042755120016051 0ustar tonytonypackage Class::DBI::Query::Base; use strict; use base 'Class::Accessor'; use Storable 'dclone'; sub new { my ($class, $fields) = @_; my $self = $class->SUPER::new(); foreach my $key (keys %{ $fields || {} }) { $self->set($key => $fields->{$key}); } $self; } sub get { my ($self, $key) = @_; my @vals = @{ $self->{$key} || [] }; return wantarray ? @vals : $vals[0]; } sub set { my ($self, $key, @args) = @_; @args = map { ref $_ eq "ARRAY" ? @$_ : $_ } @args; $self->{$key} = [@args]; } sub clone { dclone shift } package Class::DBI::Query; use base 'Class::DBI::Query::Base'; __PACKAGE__->mk_accessors( qw/ owner essential sqlname where_clause restrictions order_by kings / ); =head1 NAME Class::DBI::Query - Deprecated SQL manager for Class::DBI =head1 SYNOPSIS my $sth = Class::DBI::Query ->new({ owner => $class, sqlname => $type, essential => \@columns, where_columns => \@where_cols, }) ->run($val); =head1 DESCRIPTION This abstracts away many of the details of the Class::DBI underlying SQL mechanism. For the most part you probably don't want to be interfacing directly with this. The underlying mechanisms are not yet stable, and are subject to change at any time. =cut =head1 OPTIONS A Query can have many options set before executing. Most can either be passed as an option to new(), or set later if you are building the query up dynamically: =head2 owner The Class::DBI subclass that 'owns' this query. In the vast majority of cases a query will return objects - the owner is the class of which instances will be returned. =head2 sqlname This should be the name of a query set up using set_sql. =head2 where_clause This is the raw SQL that will substituted into the 'WHERE %s' in your query. If you have multiple %s's in your query then you should supply a listref of where_clauses. This SQL can include placeholders, which will be used when you call run(). =head2 essential When retrieving rows from the database that match the WHERE clause of the query, these are the columns that we fetch back and pre-load the resulting objects with. By default this is the Essential column group of the owner class. =head1 METHODS =head2 where() $query->where($match, @columns); This will extend your 'WHERE' clause by adding a 'AND $column = ?' (or whatever $match is, isntead of "=") for each column passed. If you have multiple WHERE clauses this will extend the last one. =cut sub new { my ($class, $self) = @_; require Carp; Carp::carp "Class::DBI::Query deprecated"; $self->{owner} ||= caller; $self->{kings} ||= $self->{owner}; $self->{essential} ||= [ $self->{owner}->_essential ]; $self->{sqlname} ||= 'SearchSQL'; return $class->SUPER::new($self); } sub _essential_string { my $self = shift; my $table = $self->owner->table_alias; join ", ", map "$table.$_", $self->essential; } sub where { my ($self, $type, @cols) = @_; my @where = $self->where_clause; my $last = pop @where || ""; $last .= join " AND ", $self->restrictions; $last .= " ORDER BY " . $self->order_by if $self->order_by; push @where, $last; return @where; } sub add_restriction { my ($self, $sql) = @_; $self->restrictions($self->restrictions, $sql); } sub tables { my $self = shift; join ", ", map { join " ", $_->table, $_->table_alias } $self->kings; } # my $sth = $query->run(@vals); # Runs the SQL set up in $sqlname, e.g. # # SELECT %s (Essential) # FROM %s (Table) # WHERE %s = ? (SelectCol = @vals) # # substituting the relevant values via sprintf, and then executing with $select_val. sub run { my $self = shift; my $owner = $self->owner or Class::DBI->_croak("Query has no owner"); $owner = ref $owner || $owner; $owner->can('db_Main') or $owner->_croak("No database connection defined"); my $sql_name = $self->sqlname or $owner->_croak("Query has no SQL"); my @sel_vals = @_ ? ref $_[0] eq "ARRAY" ? @{ $_[0] } : (@_) : (); my $sql_method = "sql_$sql_name"; my $sth; eval { $sth = $owner->$sql_method($self->_essential_string, $self->tables, $self->where); $sth->execute(@sel_vals); }; if ($@) { $owner->_croak( "Can't select for $owner using '$sth->{Statement}' ($sql_name): $@", err => $@); return; } return $sth; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Column.pm0000444000175200017520000000256310312623534016210 0ustar tonytonypackage Class::DBI::Column; =head1 NAME Class::DBI::Column - A column in a table =head1 SYNOPSIS my $column = Class::DBI::Column->new($name); my $name = $column->name; my @groups = $column->groups; my $pri_col = $colg->primary; if ($column->in_database) { ... } =head1 DESCRIPTION Each Class::DBI class maintains a list of its columns as class data. This provides an interface to those columns. You probably shouldn't be dealing with this directly. =head1 METHODS =cut use strict; use base 'Class::Accessor::Fast'; use Carp; __PACKAGE__->mk_accessors( qw/name accessor mutator placeholder is_constrained/ ); use overload '""' => sub { shift->name_lc }, fallback => 1; =head2 new my $column = Class::DBI::Column->new($column) A new object for this column. =cut sub new { my $class = shift; my $name = shift or croak "Column needs a name"; my $opt = shift || {}; return $class->SUPER::new( { name => $name, accessor => $name, mutator => $name, _groups => {}, placeholder => '?', %$opt, } ); } sub name_lc { lc shift->name } sub add_group { my ($self, $group) = @_; $self->{_groups}->{$group} = 1; } sub groups { my $self = shift; my %groups = %{ $self->{_groups} }; delete $groups{All} if keys %groups > 1; return keys %groups; } sub in_database { return !scalar grep $_ eq "TEMP", shift->groups; } 1; Class-DBI-v3.0.17/lib/Class/DBI/Attribute.pm0000444000175200017520000000125510060567156016722 0ustar tonytonypackage Class::DBI::Attribute; =head1 NAME Class::DBI::Attribute - A value in a column. =head1 SYNOPSIS my $column = Class::DBI::Attribute->new($column => $value); =head1 DESCRIPTION This stores the row-value of a certain column in an object. You probably shouldn't be dealing with this directly, and its interface is liable to change without notice. =head1 METHODS =cut use strict; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw/column current_value known/); use overload '""' => sub { shift->current_value }, fallback => 1; sub new { my ($class, $col, $val) = @_; $class->SUPER::new({ column => $col, current_value => $val, known => 1, }); } 1; Class-DBI-v3.0.17/lib/Class/DBI/Relationship.pm0000444000175200017520000001002310312611054017374 0ustar tonytonypackage Class::DBI::Relationship; use strict; use warnings; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw/name class accessor foreign_class args/); sub set_up { my $proto = shift; my $self = $proto->_init(@_); $self->_set_up_class_data; $self->_add_triggers; $self->_add_methods; $self; } sub _init { my $proto = shift; my $name = shift; my ($class, $accessor, $foreign_class, $args) = $proto->remap_arguments(@_); $class->clear_object_index; return $proto->new( { name => $name, class => $class, foreign_class => $foreign_class, accessor => $accessor, args => $args, } ); } sub remap_arguments { my $self = shift; return @_; } sub _set_up_class_data { my $self = shift; $self->class->_extend_meta($self->name => $self->accessor => $self); } sub triggers { () } sub _add_triggers { my $self = shift; # need to treat as list in case there are multiples for the same point. my @triggers = $self->triggers or return; while (my ($point, $subref) = (splice @triggers, 0, 2)) { $self->class->add_trigger($point => $subref); } } sub methods { () } sub _add_methods { my $self = shift; my %methods = $self->methods or return; my $class = $self->class; no strict 'refs'; foreach my $method (keys %methods) { *{"$class\::$method"} = $methods{$method}; } } 1; __END__ =head1 NAME Class::DBI::Relationship - base class for Relationships =head1 DESCRIPTION A Class::DBI class represents a database table. But merely being able to represent single tables isn't really that useful - databases are all about relationships. So, Class::DBI provides a variety of Relationship models to represent common database occurences (HasA, HasMany and MightHave), and provides a way to add others. =head1 SUBCLASSING Relationships should inherit from Class::DBI::Relationship, and provide a variety of methods to represent the relationship. For examples of how these are used see Class::DBI::Relationship::HasA, Class::DBI::Relationship::HasMany and Class::DBI::Relationship::MightHave. =head2 remap_arguments sub remap_arguments { my $self = shift; # process @_; return ($class, accessor, $foreign_class, $args) } Subclasses should define a 'remap_arguments' method that takes the arguments with which your relationship method will be called, and transforms them into the structure that the Relationship modules requires. If this method is not provided, then it is assumed that your method will be called with these 3 arguments in this order. This should return a list of 4 items: =over 4 =item class The Class::DBI subclass to which this relationship applies. This will be passed in to you from the caller who actually set up the relationship, and is available for you to call methods on whilst performing this mapping. You should almost never need to change this. This usually an entire application base class (or Class::DBI itself), but could be a single class wishing to override a default relationship. =item accessor The method in the class which will provide access to the results of the relationship. =item foreign_class The class for the table with which the class has a relationship. =item args Any additional args that your relationship requires. It is recommended that you use this as a hashref to store any extra information your relationship needs rather than adding extra accessors, as this information will all be stored in the 'meta_info'. =back =head2 triggers sub triggers { return ( before_create => sub { ... }, after_create => sub { ... }, ); } Subclasses may define a 'triggers' method that returns a list of triggers that the relationship needs. This method can be omitted if there are no triggers to be set up. =head2 methods sub methods { return ( method1 => sub { ... }, method2 => sub { ... }, ); } Subclasses may define a 'methods' method that returns a list of methods to facilitate the relationship that should be created in the calling Class::DBI class. This method can be omitted if there are no methods to be set up. =cut Class-DBI-v3.0.17/lib/Class/DBI/ColumnGrouper.pm0000444000175200017520000000715610312102127017545 0ustar tonytonypackage Class::DBI::ColumnGrouper; =head1 NAME Class::DBI::ColumnGrouper - Columns and Column Groups =head1 SYNOPSIS my $colg = Class::DBI::ColumnGrouper->new; $colg->add_group(People => qw/star director producer/); my @cols = $colg->group_cols($group); my @all = $colg->all_columns; my @pri_col = $colg->primary; my @essential_cols = $colg->essential; =head1 DESCRIPTION Each Class::DBI class maintains a list of its columns as class data. This provides an interface to that. You probably don't want to be dealing with this directly. =head1 METHODS =cut use strict; use Carp; use Storable 'dclone'; use Class::DBI::Column; sub _unique { my %seen; map { $seen{$_}++ ? () : $_ } @_; } sub _uniq { my %tmp; return grep !$tmp{$_}++, @_; } =head2 new my $colg = Class::DBI::ColumnGrouper->new; A new blank ColumnnGrouper object. =head2 clone my $colg2 = $colg->clone; Clone an existing ColumnGrouper. =cut sub new { my $class = shift; bless { _groups => {}, _cols => {}, }, $class; } sub clone { my ($class, $prev) = @_; return dclone $prev; } =head2 add_column / find_column $colg->add_column($name); my Class::DBI::Column $col = $colg->find_column($name); Add or return a Column object for the given column name. =cut sub add_column { my ($self, $col) = @_; # TODO remove this croak "Need a Column, got $col" unless $col->isa("Class::DBI::Column"); $self->{_allcol}->{ $col->name_lc } ||= $col; } sub find_column { my ($self, $name) = @_; return $name if ref $name; return unless $self->{_allcol}->{ lc $name }; } =head2 add_group $colg->add_group(People => qw/star director producer/); This adds a list of columns as a column group. =cut sub add_group { my ($self, $group, @names) = @_; $self->add_group(Primary => $names[0]) if ($group eq "All" or $group eq "Essential") and not $self->group_cols('Primary'); $self->add_group(Essential => @names) if $group eq "All" and !$self->essential; @names = _unique($self->primary, @names) if $group eq "Essential"; my @cols = map $self->add_column($_), @names; $_->add_group($group) foreach @cols; $self->{_groups}->{$group} = \@cols; return $self; } =head2 group_cols / groups_for my @colg = $cols->group_cols($group); my @groups = $cols->groups_for(@cols); This returns a list of all columns which are in the given group, or the groups a given column is in. =cut sub group_cols { my ($self, $group) = @_; return $self->all_columns if $group eq "All"; @{ $self->{_groups}->{$group} || [] }; } sub groups_for { my ($self, @cols) = @_; return _uniq(map $_->groups, @cols); } =head2 columns_in my @cols = $colg->columns_in(@groups); This returns a list of all columns which are in the given groups. =cut sub columns_in { my ($self, @groups) = @_; return _uniq(map $self->group_cols($_), @groups); } =head2 all_columns my @all = $colg->all_columns; This returns a list of all the real columns. =head2 primary my $pri_col = $colg->primary; This returns a list of the columns in the Primary group. =head2 essential my @essential_cols = $colg->essential; This returns a list of the columns in the Essential group. =cut sub all_columns { my $self = shift; return grep $_->in_database, values %{ $self->{_allcol} }; } sub primary { my @cols = shift->group_cols('Primary'); if (!wantarray && @cols > 1) { local ($Carp::CarpLevel) = 1; confess( "Multiple columns in Primary group (@cols) but primary called in scalar context" ); return $cols[0]; } return @cols; } sub essential { my $self = shift; my @cols = $self->columns_in('Essential'); @cols = $self->primary unless @cols; return @cols; } 1; Class-DBI-v3.0.17/lib/Class/DBI.pm0000644000175200017520000031677410701255253014772 0ustar tonytonypackage Class::DBI::__::Base; require 5.006; use Class::Trigger 0.07; use base qw(Class::Accessor Class::Data::Inheritable Ima::DBI); package Class::DBI; use version; $VERSION = qv('3.0.17'); use strict; use warnings; use base "Class::DBI::__::Base"; use Class::DBI::ColumnGrouper; use Class::DBI::Query; use Carp (); use List::Util; use Clone (); use UNIVERSAL::moniker; use vars qw($Weaken_Is_Available); BEGIN { $Weaken_Is_Available = 1; eval { require Scalar::Util; import Scalar::Util qw(weaken); }; if ($@) { $Weaken_Is_Available = 0; } } use overload '""' => sub { shift->stringify_self }, bool => sub { not shift->_undefined_primary }, fallback => 1; sub stringify_self { my $self = shift; return (ref $self || $self) unless $self; # empty PK my @cols = $self->columns('Stringify'); @cols = $self->primary_columns unless @cols; return join "/", $self->get(@cols); } sub _undefined_primary { my $self = shift; return grep !defined, $self->_attrs($self->primary_columns); } #---------------------------------------------------------------------- # Deprecations #---------------------------------------------------------------------- __PACKAGE__->mk_classdata('__hasa_rels' => {}); { my %deprecated = ( # accessor_name => 'accessor_name_for', # 3.0.7 # mutator_name => 'accessor_name_for', # 3.0.7 ); no strict 'refs'; while (my ($old, $new) = each %deprecated) { *$old = sub { my @caller = caller; warn "Use of '$old' is deprecated at $caller[1] line $caller[2]. Use '$new' instead\n"; goto &$new; }; } } #---------------------------------------------------------------------- # Our Class Data #---------------------------------------------------------------------- __PACKAGE__->mk_classdata('__AutoCommit'); __PACKAGE__->mk_classdata('__hasa_list'); __PACKAGE__->mk_classdata('_table'); __PACKAGE__->mk_classdata('_table_alias'); __PACKAGE__->mk_classdata('sequence'); __PACKAGE__->mk_classdata('__grouper' => Class::DBI::ColumnGrouper->new()); __PACKAGE__->mk_classdata('__data_type' => {}); __PACKAGE__->mk_classdata('__driver'); __PACKAGE__->mk_classdata('iterator_class' => 'Class::DBI::Iterator'); __PACKAGE__->mk_classdata('purge_object_index_every' => 1000); __PACKAGE__->add_searcher(search => "Class::DBI::Search::Basic",); __PACKAGE__->add_relationship_type( has_a => "Class::DBI::Relationship::HasA", has_many => "Class::DBI::Relationship::HasMany", might_have => "Class::DBI::Relationship::MightHave", ); __PACKAGE__->mk_classdata('__meta_info' => {}); #---------------------------------------------------------------------- # SQL we'll need #---------------------------------------------------------------------- __PACKAGE__->set_sql(MakeNewObj => <<''); INSERT INTO __TABLE__ (%s) VALUES (%s) __PACKAGE__->set_sql(update => <<""); UPDATE __TABLE__ SET %s WHERE __IDENTIFIER__ __PACKAGE__->set_sql(Nextval => <<''); SELECT NEXTVAL ('%s') __PACKAGE__->set_sql(SearchSQL => <<''); SELECT %s FROM %s WHERE %s __PACKAGE__->set_sql(RetrieveAll => <<''); SELECT __ESSENTIAL__ FROM __TABLE__ __PACKAGE__->set_sql(Retrieve => <<''); SELECT __ESSENTIAL__ FROM __TABLE__ WHERE %s __PACKAGE__->set_sql(Flesh => <<''); SELECT %s FROM __TABLE__ WHERE __IDENTIFIER__ __PACKAGE__->set_sql(single => <<''); SELECT %s FROM __TABLE__ __PACKAGE__->set_sql(DeleteMe => <<""); DELETE FROM __TABLE__ WHERE __IDENTIFIER__ __PACKAGE__->mk_classdata('sql_transformer_class'); __PACKAGE__->sql_transformer_class('Class::DBI::SQL::Transformer'); # Override transform_sql from Ima::DBI to provide some extra # transformations sub transform_sql { my ($self, $sql, @args) = @_; my $tclass = $self->sql_transformer_class; $self->_require_class($tclass); my $T = $tclass->new($self, $sql, @args); return $self->SUPER::transform_sql($T->sql => $T->args); } #---------------------------------------------------------------------- # EXCEPTIONS #---------------------------------------------------------------------- sub _carp { my ($self, $msg) = @_; Carp::carp($msg || $self); return; } sub _croak { my ($self, $msg) = @_; Carp::croak($msg || $self); } sub _db_error { my ($self, %info) = @_; my $msg = delete $info{msg}; return $self->_croak($msg, %info); } #---------------------------------------------------------------------- # SET UP #---------------------------------------------------------------------- sub connection { my $class = shift; $class->set_db(Main => @_); } { my %Per_DB_Attr_Defaults = ( pg => { AutoCommit => 0 }, oracle => { AutoCommit => 0 }, ); sub _default_attributes { my $class = shift; return ( $class->SUPER::_default_attributes, FetchHashKeyName => 'NAME_lc', ShowErrorStatement => 1, AutoCommit => 1, ChopBlanks => 1, %{ $Per_DB_Attr_Defaults{ lc $class->__driver } || {} }, ); } } sub set_db { my ($class, $db_name, $data_source, $user, $password, $attr) = @_; # 'dbi:Pg:dbname=foo' we want 'Pg'. I think this is enough. my ($driver) = $data_source =~ /^dbi:(\w+)/i; $class->__driver($driver); $class->SUPER::set_db('Main', $data_source, $user, $password, $attr); } sub table { my ($proto, $table, $alias) = @_; my $class = ref $proto || $proto; $class->_table($table) if $table; $class->table_alias($alias) if $alias; return $class->_table || $class->_table($class->table_alias); } sub table_alias { my ($proto, $alias) = @_; my $class = ref $proto || $proto; $class->_table_alias($alias) if $alias; return $class->_table_alias || $class->_table_alias($class->moniker); } sub columns { my $proto = shift; my $class = ref $proto || $proto; my $group = shift || "All"; return $class->_set_columns($group => @_) if @_; return $class->all_columns if $group eq "All"; return $class->primary_column if $group eq "Primary"; return $class->_essential if $group eq "Essential"; return $class->__grouper->group_cols($group); } sub _column_class { 'Class::DBI::Column' } sub _set_columns { my ($class, $group, @columns) = @_; my @cols = map ref $_ ? $_ : $class->_column_class->new($_), @columns; # Careful to take copy $class->__grouper(Class::DBI::ColumnGrouper->clone($class->__grouper) ->add_group($group => @cols)); $class->_mk_column_accessors(@cols); return @columns; } sub all_columns { shift->__grouper->all_columns } sub id { my $self = shift; my $class = ref($self) or return $self->_croak("Can't call id() as a class method"); # we don't use get() here because all objects should have # exisitng values for PK columns, or else loop endlessly my @pk_values = $self->_attrs($self->primary_columns); UNIVERSAL::can($_ => 'id') and $_ = $_->id for @pk_values; return @pk_values if wantarray; $self->_croak( "id called in scalar context for class with multiple primary key columns") if @pk_values > 1; return $pk_values[0]; } sub primary_column { my $self = shift; my @primary_columns = $self->__grouper->primary; return @primary_columns if wantarray; $self->_carp( ref($self) . " has multiple primary columns, but fetching in scalar context") if @primary_columns > 1; return $primary_columns[0]; } *primary_columns = \&primary_column; sub _essential { shift->__grouper->essential } sub find_column { my ($class, $want) = @_; return $class->__grouper->find_column($want); } sub _find_columns { my $class = shift; my $cg = $class->__grouper; return map $cg->find_column($_), @_; } sub has_real_column { # is really in the database my ($class, $want) = @_; return ($class->find_column($want) || return)->in_database; } sub data_type { my $class = shift; my %datatype = @_; while (my ($col, $type) = each %datatype) { $class->_add_data_type($col, $type); } } sub _add_data_type { my ($class, $col, $type) = @_; my $datatype = $class->__data_type; $datatype->{$col} = $type; $class->__data_type($datatype); } # Make a set of accessors for each of a list of columns. We construct # the method name by calling accessor_name_for() and mutator_name_for() # with the normalized column name. # mutator name will be the same as accessor name unless you override it. # If both the accessor and mutator are to have the same method name, # (which will always be true unless you override mutator_name_for), a # read-write method is constructed for it. If they differ we create both # a read-only accessor and a write-only mutator. sub _mk_column_accessors { my $class = shift; foreach my $col (@_) { my $default_accessor = $col->accessor; my $acc = $class->accessor_name_for($col); my $mut = $class->mutator_name_for($col); my %method = (); if ( ($acc eq $mut) # if they are the same or ($mut eq $default_accessor) ) { # or only the accessor was customized %method = ('_' => $acc); # make the accessor the mutator too $col->accessor($acc); $col->mutator($acc); } else { %method = ( _ro_ => $acc, _wo_ => $mut, ); $col->accessor($acc); $col->mutator($mut); } foreach my $type (keys %method) { my $name = $method{$type}; my $acc_type = "make${type}accessor"; my $accessor = $class->$acc_type($col->name_lc); $class->_make_method($_, $accessor) for ($name, "_${name}_accessor"); } } } sub _make_method { my ($class, $name, $method) = @_; return if defined &{"$class\::$name"}; $class->_carp("Column '$name' in $class clashes with built-in method") if Class::DBI->can($name) and not($name eq "id" and join(" ", $class->primary_columns) eq "id"); no strict 'refs'; *{"$class\::$name"} = $method; $class->_make_method(lc $name => $method); } sub accessor_name_for { my ($class, $column) = @_; if ($class->can('accessor_name')) { warn "Use of 'accessor_name' is deprecated. Use 'accessor_name_for' instead\n"; return $class->accessor_name($column) } return $column->accessor; } sub mutator_name_for { my ($class, $column) = @_; if ($class->can('mutator_name')) { warn "Use of 'mutator_name' is deprecated. Use 'mutator_name_for' instead\n"; return $class->mutator_name($column) } return $column->mutator; } sub autoupdate { my $proto = shift; ref $proto ? $proto->_obj_autoupdate(@_) : $proto->_class_autoupdate(@_); } sub _obj_autoupdate { my ($self, $set) = @_; my $class = ref $self; $self->{__AutoCommit} = $set if defined $set; defined $self->{__AutoCommit} ? $self->{__AutoCommit} : $class->_class_autoupdate; } sub _class_autoupdate { my ($class, $set) = @_; $class->__AutoCommit($set) if defined $set; return $class->__AutoCommit; } sub make_read_only { my $proto = shift; $proto->add_trigger("before_$_" => sub { _croak "$proto is read only" }) foreach qw/create delete update/; return $proto; } sub find_or_create { my $class = shift; my $hash = ref $_[0] eq "HASH" ? shift: {@_}; my ($exists) = $class->search($hash); return defined($exists) ? $exists : $class->insert($hash); } sub insert { my $class = shift; return $class->_croak("insert needs a hashref") unless ref $_[0] eq 'HASH'; my $info = { %{ +shift } }; # make sure we take a copy my $data; while (my ($k, $v) = each %$info) { my $col = $class->find_column($k) || (List::Util::first { $_->mutator eq $k } $class->columns) || (List::Util::first { $_->accessor eq $k } $class->columns) || $class->_croak("$k is not a column of $class"); $data->{$col} = $v; } $class->normalize_column_values($data); $class->validate_column_values($data); return $class->_insert($data); } *create = \&insert; #---------------------------------------------------------------------- # Low Level Data Access #---------------------------------------------------------------------- sub _attrs { my ($self, @atts) = @_; return @{$self}{@atts}; } *_attr = \&_attrs; sub _attribute_store { my $self = shift; my $vals = @_ == 1 ? shift: {@_}; my (@cols) = keys %$vals; @{$self}{@cols} = @{$vals}{@cols}; } # If you override this method, you must use the same mechanism to log changes # for future updates, as other parts of Class::DBI depend on it. sub _attribute_set { my $self = shift; my $vals = @_ == 1 ? shift: {@_}; # We increment instead of setting to 1 because it might be useful to # someone to know how many times a value has changed between updates. for my $col (keys %$vals) { $self->{__Changed}{$col}++; } $self->_attribute_store($vals); } sub _attribute_delete { my ($self, @attributes) = @_; delete @{$self}{@attributes}; } sub _attribute_exists { my ($self, $attribute) = @_; exists $self->{$attribute}; } #---------------------------------------------------------------------- # Live Object Index (using weak refs if available) #---------------------------------------------------------------------- my %Live_Objects; my $Init_Count = 0; sub _init { my $class = shift; my $data = shift || {}; my $key = $class->_live_object_key($data); return $Live_Objects{$key} || $class->_fresh_init($key => $data); } sub _fresh_init { my ($class, $key, $data) = @_; my $obj = bless {}, $class; $obj->_attribute_store(%$data); # don't store it unless all keys are present if ($key && $Weaken_Is_Available) { weaken($Live_Objects{$key} = $obj); # time to clean up your room? $class->purge_dead_from_object_index if ++$Init_Count % $class->purge_object_index_every == 0; } return $obj; } sub _live_object_key { my ($me, $data) = @_; my $class = ref($me) || $me; my @primary = $class->primary_columns; # no key unless all PK columns are defined return "" unless @primary == grep defined $data->{$_}, @primary; # create single unique key for this object return join "\030", $class, map $_ . "\032" . $data->{$_}, sort @primary; } sub purge_dead_from_object_index { delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects }; } sub remove_from_object_index { my $self = shift; my $obj_key = $self->_live_object_key({ $self->_as_hash }); delete $Live_Objects{$obj_key}; } sub clear_object_index { %Live_Objects = (); } #---------------------------------------------------------------------- sub _prepopulate_id { my $self = shift; my @primary_columns = $self->primary_columns; return $self->_croak( sprintf "Can't create %s object with null primary key columns (%s)", ref $self, $self->_undefined_primary) if @primary_columns > 1; $self->_attribute_store($primary_columns[0] => $self->_next_in_sequence) if $self->sequence; } sub _insert { my ($proto, $data) = @_; my $class = ref $proto || $proto; my $self = $class->_init($data); $self->call_trigger('before_create'); $self->call_trigger('deflate_for_create'); $self->_prepopulate_id if $self->_undefined_primary; # Reinstate data my ($real, $temp) = ({}, {}); foreach my $col (grep $self->_attribute_exists($_), $self->all_columns) { ($class->has_real_column($col) ? $real : $temp)->{$col} = $self->_attrs($col); } $self->_insert_row($real); my @primary_columns = $class->primary_columns; $self->_attribute_store( $primary_columns[0] => $real->{ $primary_columns[0] }) if @primary_columns == 1; delete $self->{__Changed}; my %primary_columns; @primary_columns{@primary_columns} = (); my @discard_columns = grep !exists $primary_columns{$_}, keys %$real; $self->call_trigger('create', discard_columns => \@discard_columns); # XXX # Empty everything back out again! $self->_attribute_delete(@discard_columns); $self->call_trigger('after_create'); return $self; } sub _next_in_sequence { my $self = shift; return $self->sql_Nextval($self->sequence)->select_val; } sub _auto_increment_value { my $self = shift; my $dbh = $self->db_Main; # Try to do this in a standard method. Fall back to MySQL/SQLite # specific versions. TODO remove these when last_insert_id is more # widespread. # Note: I don't believe the last_insert_id can be zero. We need to # switch to defined() checks if it can. my $id = $dbh->last_insert_id(undef, undef, $self->table, undef) # std || $dbh->{mysql_insertid} # mysql || eval { $dbh->func('last_insert_rowid') } or $self->_croak("Can't get last insert id"); return $id; } sub _insert_row { my $self = shift; my $data = shift; eval { my @columns = keys %$data; my $sth = $self->sql_MakeNewObj( join(', ', @columns), join(', ', map $self->_column_placeholder($_), @columns), ); $self->_bind_param($sth, \@columns); $sth->execute(values %$data); my @primary_columns = $self->primary_columns; $data->{ $primary_columns[0] } = $self->_auto_increment_value if @primary_columns == 1 && !defined $data->{ $primary_columns[0] }; }; if ($@) { my $class = ref $self; return $self->_db_error( msg => "Can't insert new $class: $@", err => $@, method => 'insert' ); } return 1; } sub _bind_param { my ($class, $sth, $keys) = @_; my $datatype = $class->__data_type or return; for my $i (0 .. $#$keys) { if (my $type = $datatype->{ $keys->[$i] }) { $sth->bind_param($i + 1, undef, $type); } } } sub retrieve { my $class = shift; my @primary_columns = $class->primary_columns or return $class->_croak( "Can't retrieve unless primary columns are defined"); my %key_value; if (@_ == 1 && @primary_columns == 1) { my $id = shift; return unless defined $id; return $class->_croak("Can't retrieve a reference") if ref($id); $key_value{ $primary_columns[0] } = $id; } else { %key_value = @_; $class->_croak( "$class->retrieve(@_) parameters don't include values for all primary key columns (@primary_columns)" ) if keys %key_value < @primary_columns; } my @rows = $class->search(%key_value); $class->_carp("$class->retrieve(@_) selected " . @rows . " rows") if @rows > 1; return $rows[0]; } # Get the data, as a hash, but setting certain values to whatever # we pass. Used by copy() and move(). # This can take either a primary key, or a hashref of all the columns # to change. sub _data_hash { my $self = shift; my %data = $self->_as_hash; my @primary_columns = $self->primary_columns; delete @data{@primary_columns}; if (@_) { my $arg = shift; unless (ref $arg) { $self->_croak("Need hash-ref to edit copied column values") unless @primary_columns == 1; $arg = { $primary_columns[0] => $arg }; } @data{ keys %$arg } = values %$arg; } return \%data; } sub _as_hash { my $self = shift; my @columns = $self->all_columns; my %data; @data{@columns} = $self->get(@columns); return %data; } sub copy { my $self = shift; return $self->insert($self->_data_hash(@_)); } #---------------------------------------------------------------------- # CONSTRUCT #---------------------------------------------------------------------- sub construct { my ($proto, $data) = @_; my $class = ref $proto || $proto; my $self = $class->_init($data); $self->call_trigger('select'); return $self; } sub move { my ($class, $old_obj, @data) = @_; $class->_carp("move() is deprecated. If you really need it, " . "you should tell me quickly so I can abandon my plan to remove it."); return $old_obj->_croak("Can't move to an unrelated class") unless $class->isa(ref $old_obj) or $old_obj->isa($class); return $class->insert($old_obj->_data_hash(@data)); } sub delete { my $self = shift; return $self->_search_delete(@_) if not ref $self; $self->remove_from_object_index; $self->call_trigger('before_delete'); eval { $self->sql_DeleteMe->execute($self->id) }; if ($@) { return $self->_db_error( msg => "Can't delete $self: $@", err => $@, method => 'delete' ); } $self->call_trigger('after_delete'); undef %$self; bless $self, 'Class::DBI::Object::Has::Been::Deleted'; return 1; } sub _search_delete { my ($class, @args) = @_; $class->_carp( "Delete as class method is deprecated. Use search and delete_all instead." ); my $it = $class->search_like(@args); while (my $obj = $it->next) { $obj->delete } return 1; } # Return the placeholder to be used in UPDATE and INSERT queries. # Overriding this is deprecated in favour of # __PACKAGE__->find_column('entered')->placeholder('IF(1, CURDATE(), ?)); sub _column_placeholder { my ($self, $column) = @_; return $self->find_column($column)->placeholder; } sub update { my $self = shift; my $class = ref($self) or return $self->_croak("Can't call update as a class method"); $self->call_trigger('before_update'); return -1 unless my @changed_cols = $self->is_changed; $self->call_trigger('deflate_for_update'); my @primary_columns = $self->primary_columns; my $sth = $self->sql_update($self->_update_line); $class->_bind_param($sth, \@changed_cols); my $rows = eval { $sth->execute($self->_update_vals, $self->id); }; if ($@) { return $self->_db_error( msg => "Can't update $self: $@", err => $@, method => 'update' ); } # enable this once new fixed DBD::SQLite is released: if (0 and $rows != 1) { # should always only update one row $self->_croak("Can't update $self: row not found") if $rows == 0; $self->_croak("Can't update $self: updated more than one row"); } $self->call_trigger('after_update', discard_columns => \@changed_cols); # delete columns that changed (in case adding to DB modifies them again) $self->_attribute_delete(@changed_cols); delete $self->{__Changed}; return 1; } sub _update_line { my $self = shift; join(', ', map "$_ = " . $self->_column_placeholder($_), $self->is_changed); } sub _update_vals { my $self = shift; $self->_attrs($self->is_changed); } sub DESTROY { my ($self) = shift; if (my @changed = $self->is_changed) { my $class = ref $self; $self->_carp("$class $self destroyed without saving changes to " . join(', ', @changed)); } } sub discard_changes { my $self = shift; return $self->_croak("Can't discard_changes while autoupdate is on") if $self->autoupdate; $self->_attribute_delete($self->is_changed); delete $self->{__Changed}; return 1; } # We override the get() method from Class::Accessor to fetch the data for # the column (and associated) columns from the database, using the _flesh() # method. We also allow get to be called with a list of keys, instead of # just one. sub get { my $self = shift; return $self->_croak("Can't fetch data as class method") unless ref $self; my @cols = $self->_find_columns(@_); return $self->_croak("Can't get() nothing!") unless @cols; if (my @fetch_cols = grep !$self->_attribute_exists($_), @cols) { $self->_flesh($self->__grouper->groups_for(@fetch_cols)); } return $self->_attrs(@cols); } sub _flesh { my ($self, @groups) = @_; my @real = grep $_ ne "TEMP", @groups; if (my @want = grep !$self->_attribute_exists($_), $self->__grouper->columns_in(@real)) { my %row; @row{@want} = $self->sql_Flesh(join ", ", @want)->select_row($self->id); $self->_attribute_store(\%row); $self->call_trigger('select'); } return 1; } # We also override set() from Class::Accessor so we can keep track of # changes, and either write to the database now (if autoupdate is on), # or when update() is called. sub set { my $self = shift; my $column_values = {@_}; $self->normalize_column_values($column_values); $self->validate_column_values($column_values); while (my ($column, $value) = each %$column_values) { my $col = $self->find_column($column) or die "No such column: $column\n"; $self->_attribute_set($col => $value); # $self->SUPER::set($column, $value); eval { $self->call_trigger("after_set_$column") }; # eg inflate if ($@) { $self->_attribute_delete($column); return $self->_croak("after_set_$column trigger error: $@", err => $@); } } $self->update if $self->autoupdate; return 1; } sub is_changed { my $self = shift; grep $self->has_real_column($_), keys %{ $self->{__Changed} }; } sub any_changed { keys %{ shift->{__Changed} } } # By default do nothing. Subclasses should override if required. # # Given a hash ref of column names and proposed new values, # edit the values in the hash if required. # For insert $self is the class name (not an object ref). sub normalize_column_values { my ($self, $column_values) = @_; } # Given a hash ref of column names and proposed new values # validate that the whole set of new values in the hash # is valid for the object in relation to its current values # For insert $self is the class name (not an object ref). sub validate_column_values { my ($self, $column_values) = @_; my @errors; foreach my $column (keys %$column_values) { eval { $self->call_trigger("before_set_$column", $column_values->{$column}, $column_values); }; push @errors, $column => $@ if $@; } return unless @errors; $self->_croak( "validate_column_values error: " . join(" ", @errors), method => 'validate_column_values', data => {@errors} ); } # We override set_sql() from Ima::DBI so it has a default database connection. sub set_sql { my ($class, $name, $sql, $db, @others) = @_; $db ||= 'Main'; $class->SUPER::set_sql($name, $sql, $db, @others); $class->_generate_search_sql($name) if $sql =~ /select/i; return 1; } sub _generate_search_sql { my ($class, $name) = @_; my $method = "search_$name"; defined &{"$class\::$method"} and return $class->_carp("$method() already exists"); my $sql_method = "sql_$name"; no strict 'refs'; *{"$class\::$method"} = sub { my ($class, @args) = @_; return $class->sth_to_objects($name, \@args); }; } sub dbi_commit { my $proto = shift; $proto->SUPER::commit(@_); } sub dbi_rollback { my $proto = shift; $proto->SUPER::rollback(@_); } #---------------------------------------------------------------------- # Constraints / Triggers #---------------------------------------------------------------------- sub constrain_column { my $class = shift; my $col = $class->find_column(+shift) or return $class->_croak("constraint_column needs a valid column"); my $how = shift or return $class->_croak("constrain_column needs a constraint"); if (ref $how eq "ARRAY") { my %hash = map { $_ => 1 } @$how; $class->add_constraint(list => $col => sub { exists $hash{ +shift } }); } elsif (ref $how eq "Regexp") { $class->add_constraint(regexp => $col => sub { shift =~ $how }); } elsif (ref $how eq "CODE") { $class->add_constraint( code => $col => sub { local $_ = $_[0]; $how->($_) }); } else { my $try_method = sprintf '_constrain_by_%s', $how->moniker; if (my $dispatch = $class->can($try_method)) { $class->$dispatch($col => ($how, @_)); } else { $class->_croak("Don't know how to constrain $col with $how"); } } } sub add_constraint { my $class = shift; $class->_invalid_object_method('add_constraint()') if ref $class; my $name = shift or return $class->_croak("Constraint needs a name"); my $column = $class->find_column(+shift) or return $class->_croak("Constraint $name needs a valid column"); my $code = shift or return $class->_croak("Constraint $name needs a code reference"); return $class->_croak("Constraint $name '$code' is not a code reference") unless ref($code) eq "CODE"; $column->is_constrained(1); $class->add_trigger( "before_set_$column" => sub { my ($self, $value, $column_values) = @_; $code->($value, $self, $column, $column_values) or return $self->_croak( "$class $column fails '$name' constraint with '$value'", method => "before_set_$column", exception_type => 'constraint_failure', data => { column => $column, value => $value, constraint_name => $name, } ); } ); } sub add_trigger { my ($self, $name, @args) = @_; return $self->_croak("on_setting trigger no longer exists") if $name eq "on_setting"; $self->_carp( "$name trigger deprecated: use before_$name or after_$name instead") if ($name eq "create" or $name eq "delete"); $self->SUPER::add_trigger($name => @args); } #---------------------------------------------------------------------- # Inflation #---------------------------------------------------------------------- sub add_relationship_type { my ($self, %rels) = @_; while (my ($name, $class) = each %rels) { $self->_require_class($class); no strict 'refs'; *{"$self\::$name"} = sub { my $proto = shift; $class->set_up($name => $proto => @_); }; } } sub _extend_meta { my ($class, $type, $subtype, $val) = @_; my %hash = %{ Clone::clone($class->__meta_info || {}) }; $hash{$type}->{$subtype} = $val; $class->__meta_info(\%hash); } sub meta_info { my ($class, $type, $subtype) = @_; my $meta = $class->__meta_info; return $meta unless $type; return $meta->{$type} unless $subtype; return $meta->{$type}->{$subtype}; } sub _simple_bless { my ($class, $pri) = @_; return $class->_init({ $class->primary_column => $pri }); } sub _deflated_column { my ($self, $col, $val) = @_; $val ||= $self->_attrs($col) if ref $self; return $val unless ref $val; my $meta = $self->meta_info(has_a => $col) or return $val; my ($a_class, %meths) = ($meta->foreign_class, %{ $meta->args }); if (my $deflate = $meths{'deflate'}) { $val = $val->$deflate(ref $deflate eq 'CODE' ? $self : ()); return $val unless ref $val; } return $self->_croak("Can't deflate $col: $val is not a $a_class") unless UNIVERSAL::isa($val, $a_class); return $val->id if UNIVERSAL::isa($val => 'Class::DBI'); return "$val"; } #---------------------------------------------------------------------- # SEARCH #---------------------------------------------------------------------- sub retrieve_all { shift->sth_to_objects('RetrieveAll') } sub retrieve_from_sql { my ($class, $sql, @vals) = @_; $sql =~ s/^\s*(WHERE)\s*//i; return $class->sth_to_objects($class->sql_Retrieve($sql), \@vals); } sub add_searcher { my ($self, %rels) = @_; while (my ($name, $class) = each %rels) { $self->_require_class($class); $self->_croak("$class is not a valid Searcher") unless $class->can('run_search'); no strict 'refs'; *{"$self\::$name"} = sub { $class->new(@_)->run_search; }; } } # This should really be its own Search subclass. But the _do_search # version has been publicised as the way to do this. We need to # deprecate this eventually. sub search_like { shift->_do_search(LIKE => @_) } sub _do_search { my ($class, $type, @args) = @_; $class->_require_class('Class::DBI::Search::Basic'); my $search = Class::DBI::Search::Basic->new($class, @args); $search->type($type); $search->run_search; } #---------------------------------------------------------------------- # CONSTRUCTORS #---------------------------------------------------------------------- sub add_constructor { my ($class, $method, $fragment) = @_; return $class->_croak("constructors needs a name") unless $method; no strict 'refs'; my $meth = "$class\::$method"; return $class->_carp("$method already exists in $class") if *$meth{CODE}; *$meth = sub { my $self = shift; $self->sth_to_objects($self->sql_Retrieve($fragment), \@_); }; } sub sth_to_objects { my ($class, $sth, $args) = @_; $class->_croak("sth_to_objects needs a statement handle") unless $sth; unless (UNIVERSAL::isa($sth => "DBI::st")) { my $meth = "sql_$sth"; $sth = $class->$meth(); } my (%data, @rows); eval { $sth->execute(@$args) unless $sth->{Active}; $sth->bind_columns(\(@data{ @{ $sth->{NAME_lc} } })); push @rows, {%data} while $sth->fetch; }; return $class->_croak("$class can't $sth->{Statement}: $@", err => $@) if $@; return $class->_ids_to_objects(\@rows); } *_sth_to_objects = \&sth_to_objects; sub _my_iterator { my $self = shift; my $class = $self->iterator_class; $self->_require_class($class); return $class; } sub _ids_to_objects { my ($class, $data) = @_; return $#$data + 1 unless defined wantarray; return map $class->construct($_), @$data if wantarray; return $class->_my_iterator->new($class => $data); } #---------------------------------------------------------------------- # SINGLE VALUE SELECTS #---------------------------------------------------------------------- sub _single_row_select { my ($self, $sth, @args) = @_; Carp::confess("_single_row_select is deprecated in favour of select_row"); return $sth->select_row(@args); } sub _single_value_select { my ($self, $sth, @args) = @_; $self->_carp("_single_value_select is deprecated in favour of select_val"); return $sth->select_val(@args); } sub count_all { shift->sql_single("COUNT(*)")->select_val } sub maximum_value_of { my ($class, $col) = @_; $class->sql_single("MAX($col)")->select_val; } sub minimum_value_of { my ($class, $col) = @_; $class->sql_single("MIN($col)")->select_val; } sub _unique_entries { my ($class, %tmp) = shift; return grep !$tmp{$_}++, @_; } sub _invalid_object_method { my ($self, $method) = @_; $self->_carp( "$method should be called as a class method not an object method"); } #---------------------------------------------------------------------- # misc stuff #---------------------------------------------------------------------- sub _extend_class_data { my ($class, $struct, $key, $value) = @_; my %hash = %{ $class->$struct() || {} }; $hash{$key} = $value; $class->$struct(\%hash); } my %required_classes; # { required_class => class_that_last_required_it, ... } sub _require_class { my ($self, $load_class) = @_; $required_classes{$load_class} ||= my $for_class = ref($self) || $self; # return quickly if class already exists no strict 'refs'; return if exists ${"$load_class\::"}{ISA}; (my $load_module = $load_class) =~ s!::!/!g; return if eval { require "$load_module.pm" }; # Only ignore "Can't locate" errors for the specific module we're loading return if $@ =~ /^Can't locate \Q$load_module\E\.pm /; # Other fatal errors (syntax etc) must be reported (as per base.pm). chomp $@; # This error message prefix is especially handy when dealing with # classes that are being loaded by other classes recursively. # The final message shows the path, e.g.: # Foo can't load Bar: Bar can't load Baz: syntax error at line ... $self->_croak("$for_class can't load $load_class: $@"); } sub _check_classes { # may automatically call from CHECK block in future while (my ($load_class, $by_class) = each %required_classes) { next if $load_class->isa("Class::DBI"); $by_class->_croak( "Class $load_class used by $by_class has not been loaded"); } } 1; __END__ =head1 NAME Class::DBI - Simple Database Abstraction =head1 SYNOPSIS package Music::DBI; use base 'Class::DBI'; Music::DBI->connection('dbi:mysql:dbname', 'username', 'password'); package Music::Artist; use base 'Music::DBI'; Music::Artist->table('artist'); Music::Artist->columns(All => qw/artistid name/); Music::Artist->has_many(cds => 'Music::CD'); package Music::CD; use base 'Music::DBI'; Music::CD->table('cd'); Music::CD->columns(All => qw/cdid artist title year reldate/); Music::CD->has_many(tracks => 'Music::Track'); Music::CD->has_a(artist => 'Music::Artist'); Music::CD->has_a(reldate => 'Time::Piece', inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") }, deflate => 'ymd', ); Music::CD->might_have(liner_notes => LinerNotes => qw/notes/); package Music::Track; use base 'Music::DBI'; Music::Track->table('track'); Music::Track->columns(All => qw/trackid cd position title/); #-- Meanwhile, in a nearby piece of code! --# my $artist = Music::Artist->insert({ artistid => 1, name => 'U2' }); my $cd = $artist->add_to_cds({ cdid => 1, title => 'October', year => 1980, }); # Oops, got it wrong. $cd->year(1981); $cd->update; # etc. foreach my $track ($cd->tracks) { print $track->position, $track->title } $cd->delete; # also deletes the tracks my $cd = Music::CD->retrieve(1); my @cds = Music::CD->retrieve_all; my @cds = Music::CD->search(year => 1980); my @cds = Music::CD->search_like(title => 'October%'); =head1 INTRODUCTION Class::DBI provides a convenient abstraction layer to a database. It not only provides a simple database to object mapping layer, but can be used to implement several higher order database functions (triggers, referential integrity, cascading delete etc.), at the application level, rather than at the database. This is particularly useful when using a database which doesn't support these (such as MySQL), or when you would like your code to be portable across multiple databases which might implement these things in different ways. In short, Class::DBI aims to make it simple to introduce 'best practice' when dealing with data stored in a relational database. =head2 How to set it up =over 4 =item I You must have an existing database set up, have DBI.pm installed and the necessary DBD:: driver module for that database. See L and the documentation of your particular database and driver for details. =item I Class::DBI works on a simple one class/one table model. It is your responsibility to have your database tables already set up. Automating that process is outside the scope of Class::DBI. Using our CD example, you might declare a table something like this: CREATE TABLE cd ( cdid INTEGER PRIMARY KEY, artist INTEGER, # references 'artist' title VARCHAR(255), year CHAR(4), ); =item I It's usually wise to set up a "top level" class for your entire application to inherit from, rather than have each class inherit directly from Class::DBI. This gives you a convenient point to place system-wide overrides and enhancements to Class::DBI's behavior. package Music::DBI; use base 'Class::DBI'; =item I Class::DBI needs to know how to access the database. It does this through a DBI connection which you set up by calling the connection() method. Music::DBI->connection('dbi:mysql:dbname', 'user', 'password'); By setting the connection up in your application base class all the table classes that inherit from it will share the same connection. =item I package Music::CD; use base 'Music::DBI'; Each class will inherit from your application base class, so you don't need to repeat the information on how to connect to the database. =item I Inform Class::DBI what table you are using for this class: Music::CD->table('cd'); =item I This is done using the columns() method. In the simplest form, you tell it the name of all your columns (with the single primary key first): Music::CD->columns(All => qw/cdid artist title year/); If the primary key of your table spans multiple columns then declare them using a separate call to columns() like this: Music::CD->columns(Primary => qw/pk1 pk2/); Music::CD->columns(Others => qw/foo bar baz/); For more information about how you can more efficiently use subsets of your columns, see L =item I That's it! You now have a class with methods to L<"insert">, L<"retrieve">, L<"search"> for, L<"update"> and L<"delete"> objects from your table, as well as accessors and mutators for each of the columns in that object (row). =back Let's look at all that in more detail: =head1 CLASS METHODS =head2 connection __PACKAGE__->connection($data_source, $user, $password, \%attr); This sets up a database connection with the given information. This uses L to set up an inheritable connection (named Main). It is therefore usual to only set up a connection() in your application base class and let the 'table' classes inherit from it. package Music::DBI; use base 'Class::DBI'; Music::DBI->connection('dbi:foo:dbname', 'user', 'password'); package My::Other::Table; use base 'Music::DBI'; Class::DBI helps you along a bit to set up the database connection. connection() provides its own default attributes depending on the driver name in the data_source parameter. The connection() method provides defaults for these attributes: FetchHashKeyName => 'NAME_lc', ShowErrorStatement => 1, ChopBlanks => 1, AutoCommit => 1, (Except for Oracle and Pg, where AutoCommit defaults 0, placing the database in transactional mode). The defaults can always be extended (or overridden if you know what you're doing) by supplying your own \%attr parameter. For example: Music::DBI->connection(dbi:foo:dbname','user','pass',{ChopBlanks=>0}); The RootClass of L in also inherited from L, and you should be very careful not to change this unless you know what you're doing! =head3 Dynamic Database Connections / db_Main It is sometimes desirable to generate your database connection information dynamically, for example, to allow multiple databases with the same schema to not have to duplicate an entire class hierarchy. The preferred method for doing this is to supply your own db_Main() method rather than calling L<"connection">. This method should return a valid database handle, and should ensure it sets the standard attributes described above, preferably by combining $class->_default_attributes() with your own. Note, this handle *must* have its RootClass set to L, so it is usually not possible to just supply a $dbh obtained elsewhere. Note that connection information is class data, and that changing it at run time may have unexpected behaviour for instances of the class already in existence. =head2 table __PACKAGE__->table($table); $table = Class->table; $table = $obj->table; An accessor to get/set the name of the database table in which this class is stored. It -must- be set. Table information is inherited by subclasses, but can be overridden. =head2 table_alias package Shop::Order; __PACKAGE__->table('orders'); __PACKAGE__->table_alias('orders'); When Class::DBI constructs SQL, it aliases your table name to a name representing your class. However, if your class's name is an SQL reserved word (such as 'Order') this will cause SQL errors. In such cases you should supply your own alias for your table name (which can, of course, be the same as the actual table name). This can also be passed as a second argument to 'table': __PACKAGE__->table('orders', 'orders'); As with table, this is inherited but can be overridden. =head2 sequence / auto_increment __PACKAGE__->sequence($sequence_name); $sequence_name = Class->sequence; $sequence_name = $obj->sequence; If you are using a database which supports sequences and you want to use a sequence to automatically supply values for the primary key of a table, then you should declare this using the sequence() method: __PACKAGE__->columns(Primary => 'id'); __PACKAGE__->sequence('class_id_seq'); Class::DBI will use the sequence to generate a primary key value when objects are inserted without one. *NOTE* This method does not work for Oracle. However, L (which can be downloaded separately from CPAN) provides a suitable replacement sequence() method. If you are using a database with AUTO_INCREMENT (e.g. MySQL) then you do not need this, and any call to insert() without a primary key specified will fill this in automagically. Sequence and auto-increment mechanisms only apply to tables that have a single column primary key. For tables with multi-column primary keys you need to supply the key values manually. =head1 CONSTRUCTORS and DESTRUCTORS The following are methods provided for convenience to insert, retrieve and delete stored objects. It's not entirely one-size fits all and you might find it necessary to override them. =head2 insert my $obj = Class->insert(\%data); This is a constructor to insert new data into the database and create an object representing the newly inserted row. %data consists of the initial information to place in your object and the database. The keys of %data match up with the columns of your objects and the values are the initial settings of those fields. my $cd = Music::CD->insert({ cdid => 1, artist => $artist, title => 'October', year => 1980, }); If the table has a single primary key column and that column value is not defined in %data, insert() will assume it is to be generated. If a sequence() has been specified for this Class, it will use that. Otherwise, it will assume the primary key can be generated by AUTO_INCREMENT and attempt to use that. The C trigger is invoked directly after storing the supplied values into the new object and before inserting the record into the database. The object stored in $self may not have all the functionality of the final object after_creation, particularly if the database is going to be providing the primary key value. For tables with multi-column primary keys you need to supply all the key values, either in the arguments to the insert() method, or by setting the values in a C trigger. If the class has declared relationships with foreign classes via has_a(), you can pass an object to insert() for the value of that key. Class::DBI will Do The Right Thing. After the new record has been inserted into the database the data for non-primary key columns is discarded from the object. If those columns are accessed again they'll simply be fetched as needed. This ensures that the data in the application is consistent with what the database I stored. The C trigger is invoked after the database insert has executed. =head2 find_or_create my $cd = Music::CD->find_or_create({ artist => 'U2', title => 'Boy' }); This checks if a CD can be found to match the information passed, and if not inserts it. =head2 delete $obj->delete; Music::CD->search(year => 1980, title => 'Greatest %')->delete_all; Deletes this object from the database and from memory. If you have set up any relationships using C or C, this will delete the foreign elements also, recursively (cascading delete). $obj is no longer usable after this call. Multiple objects can be deleted by calling delete_all on the Iterator returned from a search. Each object found will be deleted in turn, so cascading delete and other triggers will be honoured. The C trigger is when an object instance is about to be deleted. It is invoked before any cascaded deletes. The C trigger is invoked after the record has been deleted from the database and just before the contents in memory are discarded. =head1 RETRIEVING OBJECTS Class::DBI provides a few very simple search methods. It is not the goal of Class::DBI to replace the need for using SQL. Users are expected to write their own searches for more complex cases. L, available on CPAN, provides a much more complex search interface than Class::DBI provides itself. =head2 retrieve $obj = Class->retrieve( $id ); $obj = Class->retrieve( %key_values ); Given key values it will retrieve the object with that key from the database. For tables with a single column primary key a single parameter can be used, otherwise a hash of key-name key-value pairs must be given. my $cd = Music::CD->retrieve(1) or die "No such cd"; =head2 retrieve_all my @objs = Class->retrieve_all; my $iterator = Class->retrieve_all; Retrieves objects for all rows in the database. This is probably a bad idea if your table is big, unless you use the iterator version. =head2 search @objs = Class->search(column1 => $value, column2 => $value ...); This is a simple search for all objects where the columns specified are equal to the values specified e.g.: @cds = Music::CD->search(year => 1990); @cds = Music::CD->search(title => "Greatest Hits", year => 1990); You may also specify the sort order of the results by adding a final hash of arguments with the key 'order_by': @cds = Music::CD->search(year => 1990, { order_by=>'artist' }); This is passed through 'as is', enabling order_by clauses such as 'year DESC, title'. =head2 search_like @objs = Class->search_like(column1 => $like_pattern, ....); This is a simple search for all objects where the columns specified are like the values specified. $like_pattern is a pattern given in SQL LIKE predicate syntax. '%' means "any zero or more characters", '_' means "any single character". @cds = Music::CD->search_like(title => 'October%'); @cds = Music::CD->search_like(title => 'Hits%', artist => 'Various%'); You can also use 'order_by' with these, as with search(). =head1 ITERATORS my $it = Music::CD->search_like(title => 'October%'); while (my $cd = $it->next) { print $cd->title; } Any of the above searches (as well as those defined by has_many) can also be used as an iterator. Rather than creating a list of objects matching your criteria, this will return a Class::DBI::Iterator instance, which can return the objects required one at a time. Currently the iterator initially fetches all the matching row data into memory, and defers only the creation of the objects from that data until the iterator is asked for the next object. So using an iterator will only save significant memory if your objects will inflate substantially when used. In the case of has_many relationships with a mapping method, the mapping method is not called until each time you call 'next'. This means that if your mapping is not a one-to-one, the results will probably not be what you expect. =head2 Subclassing the Iterator Music::CD->iterator_class('Music::CD::Iterator'); You can also subclass the default iterator class to override its functionality. This is done via class data, and so is inherited into your subclasses. =head2 QUICK RETRIEVAL my $obj = Class->construct(\%data); This is used to turn data from the database into objects, and should thus only be used when writing constructors. It is very handy for cheaply setting up lots of objects from data for without going back to the database. For example, instead of doing one SELECT to get a bunch of IDs and then feeding those individually to retrieve() (and thus doing more SELECT calls), you can do one SELECT to get the essential data of many objects and feed that data to construct(): return map $class->construct($_), $sth->fetchall_hash; The construct() method creates a new empty object, loads in the column values, and then invokes the C trigger. =head1 Changing Your Column Accessor Method Names =head2 accessor_name_for / mutator_name_for It is possible to change the name of the accessor method created for a column either declaratively or programmatically. If, for example, you have a column with a name that clashes with a method otherwise created by Class::DBI, such as 'meta_info', you could create that Column explicitly with a different accessor (and/or mutator) when setting up your columns: my $meta_col = Class::DBI::Column->new(meta_info => { accessor => 'metadata', }); __PACKAGE__->columns(All => qw/id name/, $meta_col); If you want to change the name of all your accessors, or all that match a certain pattern, you need to provide an accessor_name_for($col) method, which will convert a column name to a method name. e.g: if your local database naming convention was to prepend the word 'customer' to each column in the 'customer' table, so that you had the columns 'customerid', 'customername' and 'customerage', but you wanted your methods to just be $customer->name and $customer->age rather than $customer->customername etc., you could create a sub accessor_name_for { my ($class, $column) = @_; $column =~ s/^customer//; return $column; } Similarly, if you wanted to have distinct accessor and mutator methods, you could provide a mutator_name_for($col) method which would return the name of the method to change the value: sub mutator_name_for { my ($class, $column) = @_; return "set_" . $column->accessor; } If you override the mutator name, then the accessor method will be enforced as read-only, and the mutator as write-only. =head2 update vs auto update There are two modes for the accessors to work in: manual update and autoupdate. When in autoupdate mode, every time one calls an accessor to make a change an UPDATE will immediately be sent to the database. Otherwise, if autoupdate is off, no changes will be written until update() is explicitly called. This is an example of manual updating: # The calls to NumExplodingSheep() and Rating() will only make the # changes in memory, not in the database. Once update() is called # it writes to the database in one swell foop. $gone->NumExplodingSheep(5); $gone->Rating('NC-17'); $gone->update; And of autoupdating: # Turn autoupdating on for this object. $gone->autoupdate(1); # Each accessor call causes the new value to immediately be written. $gone->NumExplodingSheep(5); $gone->Rating('NC-17'); Manual updating is probably more efficient than autoupdating and it provides the extra safety of a discard_changes() option to clear out all unsaved changes. Autoupdating can be more convenient for the programmer. Autoupdating is I by default. If changes are neither updated nor rolled back when the object is destroyed (falls out of scope or the program ends) then Class::DBI's DESTROY method will print a warning about unsaved changes. =head2 autoupdate __PACKAGE__->autoupdate($on_or_off); $update_style = Class->autoupdate; $obj->autoupdate($on_or_off); $update_style = $obj->autoupdate; This is an accessor to the current style of auto-updating. When called with no arguments it returns the current auto-updating state, true for on, false for off. When given an argument it turns auto-updating on and off: a true value turns it on, a false one off. When called as a class method it will control the updating style for every instance of the class. When called on an individual object it will control updating for just that object, overriding the choice for the class. __PACKAGE__->autoupdate(1); # Autoupdate is now on for the class. $obj = Class->retrieve('Aliens Cut My Hair'); $obj->autoupdate(0); # Shut off autoupdating for this object. The update setting for an object is not stored in the database. =head2 update $obj->update; If L<"autoupdate"> is not enabled then changes you make to your object are not reflected in the database until you call update(). It is harmless to call update() if there are no changes to be saved. (If autoupdate is on there'll never be anything to save.) Note: If you have transactions turned on for your database (but see L<"TRANSACTIONS"> below) you will also need to call dbi_commit(), as update() merely issues the UPDATE to the database). After the database update has been executed, the data for columns that have been updated are deleted from the object. If those columns are accessed again they'll simply be fetched as needed. This ensures that the data in the application is consistent with what the database I stored. When update() is called the C($self) trigger is always invoked immediately. If any columns have been updated then the C trigger is invoked after the database update has executed and is passed: ($self, discard_columns => \@discard_columns) The trigger code can modify the discard_columns array to affect which columns are discarded. For example: Class->add_trigger(after_update => sub { my ($self, %args) = @_; my $discard_columns = $args{discard_columns}; # discard the md5_hash column if any field starting with 'foo' # has been updated - because the md5_hash will have been changed # by a trigger. push @$discard_columns, 'md5_hash' if grep { /^foo/ } @$discard_columns; }); Take care to not delete a primary key column unless you know what you're doing. The update() method returns the number of rows updated. If the object had not changed and thus did not need to issue an UPDATE statement, the update() call will have a return value of -1. If the record in the database has been deleted, or its primary key value changed, then the update will not affect any records and so the update() method will return 0. =head2 discard_changes $obj->discard_changes; Removes any changes you've made to this object since the last update. Currently this simply discards the column values from the object. If you're using autoupdate this method will throw an exception. =head2 is_changed my $changed = $obj->is_changed; my @changed_keys = $obj->is_changed; Indicates if the given $obj has changes since the last update. Returns a list of keys which have changed. (If autoupdate is on, this method will return an empty list, unless called inside a before_update or after_set_$column trigger) =head2 id $id = $obj->id; @id = $obj->id; Returns a unique identifier for this object based on the values in the database. It's the equivalent of $obj->get($self->columns('Primary')), with inflated values reduced to their ids. A warning will be generated if this method is used in scalar context on a table with a multi-column primary key. =head2 LOW-LEVEL DATA ACCESS On some occasions, such as when you're writing triggers or constraint routines, you'll want to manipulate data in a Class::DBI object without using the usual get() and set() accessors, which may themselves call triggers, fetch information from the database, etc. Rather than interacting directly with the data hash stored in a Class::DBI object (the exact implementation of which may change in future releases) you could use Class::DBI's low-level accessors. These appear 'private' to make you think carefully about using them - they should not be a common means of dealing with the object. The data within the object is modelled as a set of key-value pairs, where the keys are normalized column names (returned by find_column()), and the values are the data from the database row represented by the object. Access is via these functions: =over 4 =item _attrs @values = $object->_attrs(@cols); Returns the values for one or more keys. =item _attribute_store $object->_attribute_store( { $col0 => $val0, $col1 => $val1 } ); $object->_attribute_store($col0, $val0, $col1, $val1); Stores values in the object. They key-value pairs may be passed in either as a simple list or as a hash reference. This only updates values in the object itself; changes will not be propagated to the database. =item _attribute_set $object->_attribute_set( { $col0 => $val0, $col1 => $val1 } ); $object->_attribute_set($col0, $val0, $col1, $val1); Updates values in the object via _attribute_store(), but also logs the changes so that they are propagated to the database with the next update. (Unlike set(), however, _attribute_set() will not trigger an update if autoupdate is turned on.) =item _attribute_delete @values = $object->_attribute_delete(@cols); Deletes values from the object, and returns the deleted values. =item _attribute_exists $bool = $object->_attribute_exists($col); Returns a true value if the object contains a value for the specified column, and a false value otherwise. =back By default, Class::DBI uses simple hash references to store object data, but all access is via these routines, so if you want to implement a different data model, just override these functions. =head2 OVERLOADED OPERATORS Class::DBI and its subclasses overload the perl builtin I and I operators. This is a significant convenience. The perl builtin I operator is overloaded so that a Class::DBI object reference is true so long as all its key columns have defined values. (This means an object with an id() of zero is not considered false.) When a Class::DBI object reference is used in a string context it will, by default, return the value of the primary key. (Composite primary key values will be separated by a slash). You can also specify the column(s) to be used for stringification via the special 'Stringify' column group. So, for example, if you're using an auto-incremented primary key, you could use this to provide a more meaningful display string: Widget->columns(Stringify => qw/name/); If you need to do anything more complex, you can provide an stringify_self() method which stringification will call: sub stringify_self { my $self = shift; return join ":", $self->id, $self->name; } This overloading behaviour can be useful for columns that have has_a() relationships. For example, consider a table that has price and currency fields: package Widget; use base 'My::Class::DBI'; Widget->table('widget'); Widget->columns(All => qw/widgetid name price currency_code/); $obj = Widget->retrieve($id); print $obj->price . " " . $obj->currency_code; The would print something like "C<42.07 USD>". If the currency_code field is later changed to be a foreign key to a new currency table then $obj->currency_code will return an object reference instead of a plain string. Without overloading the stringify operator the example would now print something like "C<42.07 Widget=HASH(0x1275}>" and the fix would be to change the code to add a call to id(): print $obj->price . " " . $obj->currency_code->id; However, with overloaded stringification, the original code continues to work as before, with no code changes needed. This makes it much simpler and safer to add relationships to existing applications, or remove them later. =head1 TABLE RELATIONSHIPS Databases are all about relationships. Thus Class::DBI provides a way for you to set up descriptions of your relationhips. Class::DBI provides three such relationships: 'has_a', 'has_many', and 'might_have'. Others are available from CPAN. =head2 has_a Music::CD->has_a(column => 'Foreign::Class'); Music::CD->has_a(artist => 'Music::Artist'); print $cd->artist->name; 'has_a' is most commonly used to supply lookup information for a foreign key. If a column is declared as storing the primary key of another table, then calling the method for that column does not return the id, but instead the relevant object from that foreign class. It is also possible to use has_a to inflate the column value to a non Class::DBI based. A common usage would be to inflate a date field to a date/time object: Music::CD->has_a(reldate => 'Date::Simple'); print $cd->reldate->format("%d %b, %Y"); Music::CD->has_a(reldate => 'Time::Piece', inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") }, deflate => 'ymd', ); print $cd->reldate->strftime("%d %b, %Y"); If the foreign class is another Class::DBI representation retrieve is called on that class with the column value. Any other object will be instantiated either by calling new($value) or using the given 'inflate' method. If the inflate method name is a subref, it will be executed, and will be passed the value and the Class::DBI object as arguments. When the object is being written to the database the object will be deflated either by calling the 'deflate' method (if given), or by attempting to stringify the object. If the deflate method is a subref, it will be passed the Class::DBI object as an argument. *NOTE* You should not attempt to make your primary key column inflate using has_a() as bad things will happen. If you have two tables which share a primary key, consider using might_have() instead. =head2 has_many Class->has_many(method_to_create => "Foreign::Class"); Music::CD->has_many(tracks => 'Music::Track'); my @tracks = $cd->tracks; my $track6 = $cd->add_to_tracks({ position => 6, title => 'Tomorrow', }); This method declares that another table is referencing us (i.e. storing our primary key in its table). It creates a named accessor method in our class which returns a list of all the matching Foreign::Class objects. In addition it creates another method which allows a new associated object to be constructed, taking care of the linking automatically. This method is the same as the accessor method with "add_to_" prepended. The add_to_tracks example above is exactly equivalent to: my $track6 = Music::Track->insert({ cd => $cd, position => 6, title => 'Tomorrow', }); When setting up the relationship the foreign class's has_a() declarations are examined to discover which of its columns reference our class. (Note that because this happens at compile time, if the foreign class is defined in the same file, the class with the has_a() must be defined earlier than the class with the has_many(). If the classes are in different files, Class::DBI should usually be able to do the right things, as long as all classes inherit Class::DBI before 'use'ing any other classes.) If the foreign class has no has_a() declarations linking to this class, it is assumed that the foreign key in that class is named after the moniker() of this class. If this is not true you can pass an additional third argument to the has_many() declaration stating which column of the foreign class is the foreign key to this class. =head3 Limiting Music::Artist->has_many(cds => 'Music::CD'); my @cds = $artist->cds(year => 1980); When calling the method created by has_many, you can also supply any additional key/value pairs for restricting the search. The above example will only return the CDs with a year of 1980. =head3 Ordering Music::CD->has_many(tracks => 'Music::Track', { order_by => 'playorder' }); has_many takes an optional final hashref of options. If an 'order_by' option is set, its value will be set in an ORDER BY clause in the SQL issued. This is passed through 'as is', enabling order_by clauses such as 'length DESC, position'. =head3 Mapping Music::CD->has_many(styles => [ 'Music::StyleRef' => 'style' ]); If the second argument to has_many is turned into a listref of the Classname and an additional method, then that method will be called in turn on each of the objects being returned. The above is exactly equivalent to: Music::CD->has_many(_style_refs => 'Music::StyleRef'); sub styles { my $self = shift; return map $_->style, $self->_style_refs; } For an example of where this is useful see L<"MANY TO MANY RELATIONSHIPS"> below. =head3 Cascading Delete Music::Artist->has_many(cds => 'Music::CD', { cascade => 'Fail' }); It is also possible to control what happens to the 'child' objects when the 'parent' object is deleted. By default this is set to 'Delete' - so, for example, when you delete an artist, you also delete all their CDs, leaving no orphaned records. However you could also set this to 'None', which would leave all those orphaned records (although this generally isn't a good idea), or 'Fail', which will throw an exception when you try to delete an artist that still has any CDs. You can also write your own Cascade strategies by supplying a Class Name here. For example you could write a Class::DBI::Cascade::Plugin::Nullify which would set all related foreign keys to be NULL, and plug it into your relationship: Music::Artist->has_many(cds => 'Music::CD', { cascade => 'Class::DBI::Cascade::Plugin::Nullify' }); =head2 might_have Music::CD->might_have(method_name => Class => (@fields_to_import)); Music::CD->might_have(liner_notes => LinerNotes => qw/notes/); my $liner_notes_object = $cd->liner_notes; my $notes = $cd->notes; # equivalent to $cd->liner_notes->notes; might_have() is similar to has_many() for relationships that can have at most one associated objects. For example, if you have a CD database to which you want to add liner notes information, you might not want to add a 'liner_notes' column to your main CD table even though there is no multiplicity of relationship involved (each CD has at most one 'liner notes' field). So, you create another table with the same primary key as this one, with which you can cross-reference. But you don't want to have to keep writing methods to turn the the 'list' of liner_notes objects you'd get back from has_many into the single object you'd need. So, might_have() does this work for you. It creates an accessor to fetch the single object back if it exists, and it also allows you import any of its methods into your namespace. So, in the example above, the LinerNotes class can be mostly invisible - you can just call $cd->notes and it will call the notes method on the correct LinerNotes object transparently for you. Making sure you don't have namespace clashes is up to you, as is correctly creating the objects, but this may be made simpler in later versions. (Particularly if someone asks for this!) =head2 Notes has_a(), might_have() and has_many() check that the relevant class has already been loaded. If it hasn't then they try to load the module of the same name using require. If the require fails because it can't find the module then it will assume it's not a simple require (i.e., Foreign::Class isn't in Foreign/Class.pm) and that you will take care of it and ignore the warning. Any other error, such as a syntax error, triggers an exception. NOTE: The two classes in a relationship do not have to be in the same database, on the same machine, or even in the same type of database! It is quite acceptable for a table in a MySQL database to be connected to a different table in an Oracle database, and for cascading delete etc to work across these. This should assist greatly if you need to migrate a database gradually. =head1 MANY TO MANY RELATIONSHIPS Class::DBI does not currently support Many to Many relationships, per se. However, by combining the relationships that already exist it is possible to set these up. Consider the case of Films and Actors, with a linking Role table with a multi-column Primary Key. First of all set up the Role class: Role->table('role'); Role->columns(Primary => qw/film actor/); Role->has_a(film => 'Film'); Role->has_a(actor => 'Actor'); Then, set up the Film and Actor classes to use this linking table: Film->table('film'); Film->columns(All => qw/id title rating/); Film->has_many(stars => [ Role => 'actor' ]); Actor->table('actor'); Actor->columns(All => qw/id name/); Actor->has_many(films => [ Role => 'film' ]); In each case the 'mapping method' variation of has_many() is used to call the lookup method on the Role object returned. As these methods are the 'has_a' relationships on the Role, these will return the actual Actor and Film objects, providing a cheap many-to-many relationship. In the case of Film, this is equivalent to the more long-winded: Film->has_many(roles => "Role"); sub actors { my $self = shift; return map $_->actor, $self->roles } As this is almost exactly what is created internally, add_to_stars and add_to_films will generally do the right thing as they are actually doing the equivalent of add_to_roles: $film->add_to_actors({ actor => $actor }); Similarly a cascading delete will also do the right thing as it will only delete the relationship from the linking table. If the Role table were to contain extra information, such as the name of the character played, then you would usually need to skip these short-cuts and set up each of the relationships, and associated helper methods, manually. =head1 ADDING NEW RELATIONSHIP TYPES =head2 add_relationship_type The relationships described above are implemented through Class::DBI::Relationship subclasses. These are then plugged into Class::DBI through an add_relationship_type() call: __PACKAGE__->add_relationship_type( has_a => "Class::DBI::Relationship::HasA", has_many => "Class::DBI::Relationship::HasMany", might_have => "Class::DBI::Relationship::MightHave", ); If is thus possible to add new relationship types, or modify the behaviour of the existing types. See L for more information on what is required. =head1 DEFINING SQL STATEMENTS There are several main approaches to setting up your own SQL queries: For queries which could be used to create a list of matching objects you can create a constructor method associated with this SQL and let Class::DBI do the work for you, or just inline the entire query. For more complex queries you need to fall back on the underlying Ima::DBI query mechanism. (Caveat: since Ima::DBI uses sprintf-style interpolation, you need to be careful to double any "wildcard" % signs in your queries). =head2 add_constructor __PACKAGE__->add_constructor(method_name => 'SQL_where_clause'); The SQL can be of arbitrary complexity and will be turned into: SELECT (essential columns) FROM (table name) WHERE This will then create a method of the name you specify, which returns a list of objects as with any built in query. For example: Music::CD->add_constructor(new_music => 'year > 2000'); my @recent = Music::CD->new_music; You can also supply placeholders in your SQL, which must then be specified at query time: Music::CD->add_constructor(new_music => 'year > ?'); my @recent = Music::CD->new_music(2000); =head2 retrieve_from_sql On occasions where you want to execute arbitrary SQL, but don't want to go to the trouble of setting up a constructor method, you can inline the entire WHERE clause, and just get the objects back directly: my @cds = Music::CD->retrieve_from_sql(qq{ artist = 'Ozzy Osbourne' AND title like "%Crazy" AND year <= 1986 ORDER BY year LIMIT 2,3 }); =head2 Ima::DBI queries When you can't use 'add_constructor', e.g. when using aggregate functions, you can fall back on the fact that Class::DBI inherits from Ima::DBI and prefers to use its style of dealing with statements, via set_sql(). The Class::DBI set_sql() method defaults to using prepare_cached() unless the $cache parameter is defined and false (see L docs for more information). To assist with writing SQL that is inheritable into subclasses, several additional substitutions are available here: __TABLE__, __ESSENTIAL__ and __IDENTIFIER__. These represent the table name associated with the class, its essential columns, and the primary key of the current object, in the case of an instance method on it. For example, the SQL for the internal 'update' method is implemented as: __PACKAGE__->set_sql('update', <<""); UPDATE __TABLE__ SET %s WHERE __IDENTIFIER__ The 'longhand' version of the new_music constructor shown above would similarly be: Music::CD->set_sql(new_music => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE year > ? }); For such 'SELECT' queries L's set_sql() method is extended to create a helper shortcut method, named by prefixing the name of the SQL fragment with 'search_'. Thus, the above call to set_sql() will automatically set up the method Music::CD->search_new_music(), which will execute this search and return the relevant objects or Iterator. (If there are placeholders in the query, you must pass the relevant arguments when calling your search method.) This does the equivalent of: sub search_new_music { my ($class, @args) = @_; my $sth = $class->sql_new_music; $sth->execute(@args); return $class->sth_to_objects($sth); } The $sth which is used to return the objects here is a normal DBI-style statement handle, so if the results can't be turned into objects easily, it is still possible to call $sth->fetchrow_array etc and return whatever data you choose. Of course, any query can be added via set_sql, including joins. So, to add a query that returns the 10 Artists with the most CDs, you could write (with MySQL): Music::Artist->set_sql(most_cds => qq{ SELECT artist.id, COUNT(cd.id) AS cds FROM artist, cd WHERE artist.id = cd.artist GROUP BY artist.id ORDER BY cds DESC LIMIT 10 }); my @artists = Music::Artist->search_most_cds(); If you also need to access the 'cds' value returned from this query, the best approach is to declare 'cds' to be a TEMP column. (See L<"Non-Persistent Fields"> below). =head2 Class::DBI::AbstractSearch my @music = Music::CD->search_where( artist => [ 'Ozzy', 'Kelly' ], status => { '!=', 'outdated' }, ); The L module, available from CPAN, is a plugin for Class::DBI that allows you to write arbitrarily complex searches using perl data structures, rather than SQL. =head2 Single Value SELECTs =head3 select_val Selects which only return a single value can couple Class::DBI's sql_single() SQL, with the $sth->select_val() call which we get from DBIx::ContextualFetch. __PACKAGE__->set_sql(count_all => "SELECT COUNT(*) FROM __TABLE__"); # .. then .. my $count = $class->sql_count_all->select_val; This can also take placeholders and/or do column interpolation if required: __PACKAGE__->set_sql(count_above => q{ SELECT COUNT(*) FROM __TABLE__ WHERE %s > ? }); # .. then .. my $count = $class->sql_count_above('year')->select_val(2001); =head3 sql_single Internally Class::DBI defines a very simple SQL fragment called 'single': "SELECT %s FROM __TABLE__". This is used to implement the above Class->count_all(): $class->sql_single("COUNT(*)")->select_val; This interpolates the COUNT(*) into the %s of the SQL, and then executes the query, returning a single value. Any SQL set up via set_sql() can of course be supplied here, and select_val can take arguments for any placeholders there. Internally several helper methods are defined using this approach: =over 4 =item - count_all =item - maximum_value_of($column) =item - minimum_value_of($column) =back =head1 LAZY POPULATION In the tradition of Perl, Class::DBI is lazy about how it loads your objects. Often, you find yourself using only a small number of the available columns and it would be a waste of memory to load all of them just to get at two, especially if you're dealing with large numbers of objects simultaneously. You should therefore group together your columns by typical usage, as fetching one value from a group can also pre-fetch all the others in that group for you, for more efficient access. So for example, if we usually fetch the artist and title, but don't use the 'year' so much, then we could say the following: Music::CD->columns(Primary => qw/cdid/); Music::CD->columns(Essential => qw/artist title/); Music::CD->columns(Others => qw/year runlength/); Now when you fetch back a CD it will come pre-loaded with the 'cdid', 'artist' and 'title' fields. Fetching the 'year' will mean another visit to the database, but will bring back the 'runlength' whilst it's there. This can potentially increase performance. If you don't like this behavior, then just add all your columns to the Essential group, and Class::DBI will load everything at once. If you have a single column primary key you can do this all in one shot with one single column declaration: Music::CD->columns(Essential => qw/cdid artist title year runlength/); =head2 columns my @all_columns = $class->columns; my @columns = $class->columns($group); my @primary = $class->primary_columns; my $primary = $class->primary_column; my @essential = $class->_essential; There are four 'reserved' groups: 'All', 'Essential', 'Primary' and 'TEMP'. B<'All'> are all columns used by the class. If not set it will be created from all the other groups. B<'Primary'> is the primary key columns for this class. It I be set before objects can be used. If 'All' is given but not 'Primary' it will assume the first column in 'All' is the primary key. B<'Essential'> are the minimal set of columns needed to load and use the object. Only the columns in this group will be loaded when an object is retrieve()'d. It is typically used to save memory on a class that has a lot of columns but where only use a few of them are commonly used. It will automatically be set to B<'Primary'> if not explicitly set. The 'Primary' column is always part of the 'Essential' group. For simplicity primary_columns(), primary_column(), and _essential() methods are provided to return these. The primary_column() method should only be used for tables that have a single primary key column. =head2 Non-Persistent Fields Music::CD->columns(TEMP => qw/nonpersistent/); If you wish to have fields that act like columns in every other way, but that don't actually exist in the database (and thus will not persist), you can declare them as part of a column group of 'TEMP'. =head2 find_column Class->find_column($column); $obj->find_column($column); The columns of a class are stored as Class::DBI::Column objects. This method will return you the object for the given column, if it exists. This is most useful either in a boolean context to discover if the column exists, or to 'normalize' a user-entered column name to an actual Column. The interface of the Column object itself is still under development, so you shouldn't really rely on anything internal to it. =head1 TRANSACTIONS Class::DBI suffers from the usual problems when dealing with transactions. In particular, you should be very wary when committing your changes that you may actually be in a wider scope than expected and that your caller may not be expecting you to commit. However, as long as you are aware of this, and try to keep the scope of your transactions small, ideally always within the scope of a single method, you should be able to work with transactions with few problems. =head2 dbi_commit / dbi_rollback $obj->dbi_commit(); $obj->dbi_rollback(); These are thin aliases through to the DBI's commit() and rollback() commands to commit or rollback all changes to this object. =head2 Localised Transactions A nice idiom for turning on a transaction locally (with AutoCommit turned on globally) (courtesy of Dominic Mitchell) is: sub do_transaction { my $class = shift; my ( $code ) = @_; # Turn off AutoCommit for this scope. # A commit will occur at the exit of this block automatically, # when the local AutoCommit goes out of scope. local $class->db_Main->{ AutoCommit }; # Execute the required code inside the transaction. eval { $code->() }; if ( $@ ) { my $commit_error = $@; eval { $class->dbi_rollback }; # might also die! die $commit_error; } } And then you just call: Music::DBI->do_transaction( sub { my $artist = Music::Artist->insert({ name => 'Pink Floyd' }); my $cd = $artist->add_to_cds({ title => 'Dark Side Of The Moon', year => 1974, }); }); Now either both will get added, or the entire transaction will be rolled back. =head1 UNIQUENESS OF OBJECTS IN MEMORY Class::DBI supports uniqueness of objects in memory. In a given perl interpreter there will only be one instance of any given object at one time. Many variables may reference that object, but there can be only one. Here's an example to illustrate: my $artist1 = Music::Artist->insert({ artistid => 7, name => 'Polysics' }); my $artist2 = Music::Artist->retrieve(7); my $artist3 = Music::Artist->search( name => 'Polysics' )->first; Now $artist1, $artist2, and $artist3 all point to the same object. If you update a property on one of them, all of them will reflect the update. This is implemented using a simple object lookup index for all live objects in memory. It is not a traditional cache - when your objects go out of scope, they will be destroyed normally, and a future retrieve will instantiate an entirely new object. The ability to perform this magic for you replies on your perl having access to the Scalar::Util::weaken function. Although this is part of the core perl distribution, some vendors do not compile support for it. To find out if your perl has support for it, you can run this on the command line: perl -e 'use Scalar::Util qw(weaken)' If you get an error message about weak references not being implemented, Class::DBI will not maintain this lookup index, but give you a separate instances for each retrieve. A few new tools are offered for adjusting the behavior of the object index. These are still somewhat experimental and may change in a future release. =head2 remove_from_object_index $artist->remove_from_object_index(); This is an object method for removing a single object from the live objects index. You can use this if you want to have multiple distinct copies of the same object in memory. =head2 clear_object_index Music::DBI->clear_object_index(); You can call this method on any class or instance of Class::DBI, but the effect is universal: it removes all objects from the index. =head2 purge_object_index_every Music::Artist->purge_object_index_every(2000); Weak references are not removed from the index when an object goes out of scope. This means that over time the index will grow in memory. This is really only an issue for long-running environments like mod_perl, but every so often dead references are cleaned out to prevent this. By default, this happens every 1000 object loads, but you can change that default for your class by setting the 'purge_object_index_every' value. (Eventually this may handled in the DESTROY method instead.) As a final note, keep in mind that you can still have multiple distinct copies of an object in memory if you have multiple perl interpreters running. CGI, mod_perl, and many other common usage situations run multiple interpreters, meaning that each one of them may have an instance of an object representing the same data. However, this is no worse than it was before, and is entirely normal for database applications in multi-process environments. =head1 SUBCLASSING The preferred method of interacting with Class::DBI is for you to write a subclass for your database connection, with each table-class inheriting in turn from it. As well as encapsulating the connection information in one place, this also allows you to override default behaviour or add additional functionality across all of your classes. As the innards of Class::DBI are still in flux, you must exercise extreme caution in overriding private methods of Class::DBI (those starting with an underscore), unless they are explicitly mentioned in this documentation as being safe to override. If you find yourself needing to do this, then I would suggest that you ask on the mailing list about it, and we'll see if we can either come up with a better approach, or provide a new means to do whatever you need to do. =head1 CAVEATS =head2 Multi-Column Foreign Keys are not supported You can't currently add a relationship keyed on multiple columns. You could, however, write a Relationship plugin to do this, and the world would be eternally grateful... =head2 Don't change or inflate the value of your primary columns Altering your primary key column currently causes Bad Things to happen. I should really protect against this. =head1 SUPPORTED DATABASES Theoretically Class::DBI should work with almost any standard RDBMS. Of course, in the real world, we know that that's not true. It is known to work with MySQL, PostgreSQL, Oracle and SQLite, each of which have their own additional subclass on CPAN that you should explore if you're using them: L, L, L, L For the most part it's been reported to work with Sybase, although there are some issues with multi-case column/table names. Beyond that lies The Great Unknown(tm). If you have access to other databases, please give this a test run, and let me know the results. L (and hence Class::DBI) requires a database that supports table aliasing and a DBI driver that supports placeholders. This means it won't work with older releases of L (and any releases of its predecessor L), and L + FreeTDS may or may not work depending on your FreeTDS version. =head1 CURRENT AUTHOR Tony Bowden =head1 AUTHOR EMERITUS Michael G Schwern =head1 THANKS TO Tim Bunce, Tatsuhiko Miyagawa, Perrin Harkins, Alexander Karelas, Barry Hoggard, Bart Lateur, Boris Mouzykantskii, Brad Bowman, Brian Parker, Casey West, Charles Bailey, Christopher L. Everett Damian Conway, Dan Thill, Dave Cash, David Jack Olrik, Dominic Mitchell, Drew Taylor, Drew Wilson, Jay Strauss, Jesse Sheidlower, Jonathan Swartz, Marty Pauley, Michael Styer, Mike Lambert, Paul Makepeace, Phil Crow, Richard Piacentini, Simon Cozens, Simon Wilcox, Thomas Klausner, Tom Renfro, Uri Gutman, William McKee, the Class::DBI mailing list, the POOP group, and all the others who've helped, but that I've forgetten to mention. =head1 RELEASE PHILOSOPHY Class::DBI now uses a three-level versioning system. This release, for example, is version 3.0.17 The general approach to releases will be that users who like a degree of stability can hold off on upgrades until the major sub-version increases (e.g. 3.1.0). Those who like living more on the cutting edge can keep up to date with minor sub-version releases. Functionality which was introduced during a minor sub-version release may disappear without warning in a later minor sub-version release. I'll try to avoid doing this, and will aim to have a deprecation cycle of at least a few minor sub-versions, but you should keep a close eye on the CHANGES file, and have good tests in place. (This is good advice generally, of course.) Anything that is in a major sub-version release will go through a deprecation cycle of at least one further major sub-version before it is removed (and usually longer). =head2 Getting changes accepted There is an active Class::DBI community, however I am not part of it. I am not on the mailing list, and I don't follow the wiki. I also do not follow Perl Monks or CPAN reviews or annoCPAN or whatever the tool du jour happens to be. If you find a problem with Class::DBI, by all means discuss it in any of these places, but don't expect anything to happen unless you actually tell me about it. The preferred method for doing this is via the CPAN RT interface, which you can access at http://rt.cpan.org/ or by emailing bugs-Class-DBI@rt.cpan.org If you email me personally about Class::DBI issues, then I will probably bounce them on to there, unless you specifically ask me not to. Otherwise I can't keep track of what all needs fixed. (This of course means that if you ask me not to send your mail to RT, there's a much higher chance that nothing will every happen about your problem). =head2 Bug Reports If you're reporting a bug then it has a much higher chance of getting fixed quicker if you can include a failing test case. This should be a completely stand-alone test that could be added to the Class::DBI distribution. That is, it should use L or L, fail with the current code, but pass when I fix the problem. If it needs to have a working database to show the problem, then this should preferably use SQLite, and come with all the code to set this up. The nice people on the mailing list will probably help you out if you need assistance putting this together. You don't need to include code for actually fixing the problem, but of course it's often nice if you can. I may choose to fix it in a different way, however, so it's often better to ask first whether I'd like a patch, particularly before spending a lot of time hacking. =head2 Patches If you are sending patches, then please send either the entire code that is being changed or the output of 'diff -Bub'. Please also note what version the patch is against. I tend to apply all patches manually, so I'm more interested in being able to see what you're doing than in being able to apply the patch cleanly. Code formatting isn't an issue, as I automagically run perltidy against the source after any changes, so please format for clarity. Patches have a much better chance of being applied if they are small. People often think that it's better for me to get one patch with a bunch of fixes. It's not. I'd much rather get 100 small patches that can be applied one by one. A change that I can make and release in five minutes is always better than one that needs a couple of hours to ponder and work through. I often reject patches that I don't like. Please don't take it personally. I also like time to think about the wider implications of changes. Often a I of time. Feel free to remind me about things that I may have forgotten about, but as long as they're on rt.cpan.org I will get around to them eventually. =head2 Feature Requests Wish-list requests are fine, although you should probably discuss them on the mailing list (or equivalent) with others first. There's quite often a plugin somewhere that already does what you want. In general I am much more open to discussion on how best to provide the flexibility for you to make your Cool New Feature(tm) a plugin rather than adding it to Class::DBI itself. For the most part the core of Class::DBI already has most of the functionality that I believe it will ever need (and some more besides, that will probably be split off at some point). Most other things are much better off as plugins, with a separate life on CPAN or elsewhere (and with me nowhere near the critical path). Most of the ongoing work on Class::DBI is about making life easier for people to write extensions - whether they're local to your own codebase or released for wider consumption. =head1 SUPPORT Support for Class::DBI is mostly via the mailing list. To join the list, or read the archives, visit http://lists.digitalcraftsmen.net/mailman/listinfo/classdbi There is also a Class::DBI wiki at http://www.class-dbi.com/ The wiki contains much information that should probably be in these docs but isn't yet. (See above if you want to help to rectify this.) As mentioned above, I don't follow the list or the wiki, so if you want to contact me individually, then you'll have to track me down personally. There are lots of 3rd party subclasses and plugins available. For a list of the ones on CPAN see: http://search.cpan.org/search?query=Class%3A%3ADBI&mode=module An article on Class::DBI was published on Perl.com a while ago. It's slightly out of date , but it's a good introduction: http://www.perl.com/pub/a/2002/11/27/classdbi.html The wiki has numerous references to other articles, presentations etc. http://poop.sourceforge.net/ provides a document comparing a variety of different approaches to database persistence, such as Class::DBI, Alazabo, Tangram, SPOPS etc. =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO Class::DBI is built on top of L, L, L and L. The innards and much of the interface are easier to understand if you have an idea of how they all work as well. =cut Class-DBI-v3.0.17/README0000644000175200017520000022420410362672302013066 0ustar tonytonyNAME Class::DBI - Simple Database Abstraction SYNOPSIS package Music::DBI; use base 'Class::DBI'; Music::DBI->connection('dbi:mysql:dbname', 'username', 'password'); package Music::Artist; use base 'Music::DBI'; Music::Artist->table('artist'); Music::Artist->columns(All => qw/artistid name/); Music::Artist->has_many(cds => 'Music::CD'); package Music::CD; use base 'Music::DBI'; Music::CD->table('cd'); Music::CD->columns(All => qw/cdid artist title year reldate/); Music::CD->has_many(tracks => 'Music::Track'); Music::CD->has_a(artist => 'Music::Artist'); Music::CD->has_a(reldate => 'Time::Piece', inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") }, deflate => 'ymd', ); Music::CD->might_have(liner_notes => LinerNotes => qw/notes/); package Music::Track; use base 'Music::DBI'; Music::Track->table('track'); Music::Track->columns(All => qw/trackid cd position title/); #-- Meanwhile, in a nearby piece of code! --# my $artist = Music::Artist->insert({ artistid => 1, name => 'U2' }); my $cd = $artist->add_to_cds({ cdid => 1, title => 'October', year => 1980, }); # Oops, got it wrong. $cd->year(1981); $cd->update; # etc. foreach my $track ($cd->tracks) { print $track->position, $track->title } $cd->delete; # also deletes the tracks my $cd = Music::CD->retrieve(1); my @cds = Music::CD->retrieve_all; my @cds = Music::CD->search(year => 1980); my @cds = Music::CD->search_like(title => 'October%'); INTRODUCTION Class::DBI provides a convenient abstraction layer to a database. It not only provides a simple database to object mapping layer, but can be used to implement several higher order database functions (triggers, referential integrity, cascading delete etc.), at the application level, rather than at the database. This is particularly useful when using a database which doesn't support these (such as MySQL), or when you would like your code to be portable across multiple databases which might implement these things in different ways. In short, Class::DBI aims to make it simple to introduce 'best practice' when dealing with data stored in a relational database. How to set it up *Set up a database.* You must have an existing database set up, have DBI.pm installed and the necessary DBD:: driver module for that database. See DBI and the documentation of your particular database and driver for details. *Set up a table for your objects to be stored in.* Class::DBI works on a simple one class/one table model. It is your responsibility to have your database tables already set up. Automating that process is outside the scope of Class::DBI. Using our CD example, you might declare a table something like this: CREATE TABLE cd ( cdid INTEGER PRIMARY KEY, artist INTEGER, # references 'artist' title VARCHAR(255), year CHAR(4), ); *Set up an application base class* It's usually wise to set up a "top level" class for your entire application to inherit from, rather than have each class inherit directly from Class::DBI. This gives you a convenient point to place system-wide overrides and enhancements to Class::DBI's behavior. package Music::DBI; use base 'Class::DBI'; *Give it a database connection* Class::DBI needs to know how to access the database. It does this through a DBI connection which you set up by calling the connection() method. Music::DBI->connection('dbi:mysql:dbname', 'user', 'password'); By setting the connection up in your application base class all the table classes that inherit from it will share the same connection. *Set up each Class* package Music::CD; use base 'Music::DBI'; Each class will inherit from your application base class, so you don't need to repeat the information on how to connect to the database. *Declare the name of your table* Inform Class::DBI what table you are using for this class: Music::CD->table('cd'); *Declare your columns.* This is done using the columns() method. In the simplest form, you tell it the name of all your columns (with the single primary key first): Music::CD->columns(All => qw/cdid artist title year/); If the primary key of your table spans multiple columns then declare them using a separate call to columns() like this: Music::CD->columns(Primary => qw/pk1 pk2/); Music::CD->columns(Others => qw/foo bar baz/); For more information about how you can more efficiently use subsets of your columns, see "LAZY POPULATION" *Done.* That's it! You now have a class with methods to "insert", "retrieve", "search" for, "update" and "delete" objects from your table, as well as accessors and mutators for each of the columns in that object (row). Let's look at all that in more detail: CLASS METHODS connection __PACKAGE__->connection($data_source, $user, $password, \%attr); This sets up a database connection with the given information. This uses Ima::DBI to set up an inheritable connection (named Main). It is therefore usual to only set up a connection() in your application base class and let the 'table' classes inherit from it. package Music::DBI; use base 'Class::DBI'; Music::DBI->connection('dbi:foo:dbname', 'user', 'password'); package My::Other::Table; use base 'Music::DBI'; Class::DBI helps you along a bit to set up the database connection. connection() provides its own default attributes depending on the driver name in the data_source parameter. The connection() method provides defaults for these attributes: FetchHashKeyName => 'NAME_lc', ShowErrorStatement => 1, ChopBlanks => 1, AutoCommit => 1, (Except for Oracle and Pg, where AutoCommit defaults 0, placing the database in transactional mode). The defaults can always be extended (or overridden if you know what you're doing) by supplying your own \%attr parameter. For example: Music::DBI->connection(dbi:foo:dbname','user','pass',{ChopBlanks=>0}); The RootClass of DBIx::ContextualFetch in also inherited from Ima::DBI, and you should be very careful not to change this unless you know what you're doing! Dynamic Database Connections / db_Main It is sometimes desirable to generate your database connection information dynamically, for example, to allow multiple databases with the same schema to not have to duplicate an entire class hierarchy. The preferred method for doing this is to supply your own db_Main() method rather than calling "connection". This method should return a valid database handle, and should ensure it sets the standard attributes described above, preferably by combining $class->_default_attributes() with your own. Note, this handle *must* have its RootClass set to DBIx::ContextualFetch, so it is usually not possible to just supply a $dbh obtained elsewhere. Note that connection information is class data, and that changing it at run time may have unexpected behaviour for instances of the class already in existence. table __PACKAGE__->table($table); $table = Class->table; $table = $obj->table; An accessor to get/set the name of the database table in which this class is stored. It -must- be set. Table information is inherited by subclasses, but can be overridden. table_alias package Shop::Order; __PACKAGE__->table('orders'); __PACKAGE__->table_alias('orders'); When Class::DBI constructs SQL, it aliases your table name to a name representing your class. However, if your class's name is an SQL reserved word (such as 'Order') this will cause SQL errors. In such cases you should supply your own alias for your table name (which can, of course, be the same as the actual table name). This can also be passed as a second argument to 'table': __PACKAGE__->table('orders', 'orders'); As with table, this is inherited but can be overridden. sequence / auto_increment __PACKAGE__->sequence($sequence_name); $sequence_name = Class->sequence; $sequence_name = $obj->sequence; If you are using a database which supports sequences and you want to use a sequence to automatically supply values for the primary key of a table, then you should declare this using the sequence() method: __PACKAGE__->columns(Primary => 'id'); __PACKAGE__->sequence('class_id_seq'); Class::DBI will use the sequence to generate a primary key value when objects are inserted without one. *NOTE* This method does not work for Oracle. However, Class::DBI::Oracle (which can be downloaded separately from CPAN) provides a suitable replacement sequence() method. If you are using a database with AUTO_INCREMENT (e.g. MySQL) then you do not need this, and any call to insert() without a primary key specified will fill this in automagically. Sequence and auto-increment mechanisms only apply to tables that have a single column primary key. For tables with multi-column primary keys you need to supply the key values manually. CONSTRUCTORS and DESTRUCTORS The following are methods provided for convenience to insert, retrieve and delete stored objects. It's not entirely one-size fits all and you might find it necessary to override them. insert my $obj = Class->insert(\%data); This is a constructor to insert new data into the database and create an object representing the newly inserted row. %data consists of the initial information to place in your object and the database. The keys of %data match up with the columns of your objects and the values are the initial settings of those fields. my $cd = Music::CD->insert({ cdid => 1, artist => $artist, title => 'October', year => 1980, }); If the table has a single primary key column and that column value is not defined in %data, insert() will assume it is to be generated. If a sequence() has been specified for this Class, it will use that. Otherwise, it will assume the primary key can be generated by AUTO_INCREMENT and attempt to use that. The "before_create" trigger is invoked directly after storing the supplied values into the new object and before inserting the record into the database. The object stored in $self may not have all the functionality of the final object after_creation, particularly if the database is going to be providing the primary key value. For tables with multi-column primary keys you need to supply all the key values, either in the arguments to the insert() method, or by setting the values in a "before_create" trigger. If the class has declared relationships with foreign classes via has_a(), you can pass an object to insert() for the value of that key. Class::DBI will Do The Right Thing. After the new record has been inserted into the database the data for non-primary key columns is discarded from the object. If those columns are accessed again they'll simply be fetched as needed. This ensures that the data in the application is consistent with what the database *actually* stored. The "after_create" trigger is invoked after the database insert has executed. find_or_create my $cd = Music::CD->find_or_create({ artist => 'U2', title => 'Boy' }); This checks if a CD can be found to match the information passed, and if not inserts it. delete $obj->delete; Music::CD->search(year => 1980, title => 'Greatest %')->delete_all; Deletes this object from the database and from memory. If you have set up any relationships using "has_many" or "might_have", this will delete the foreign elements also, recursively (cascading delete). $obj is no longer usable after this call. Multiple objects can be deleted by calling delete_all on the Iterator returned from a search. Each object found will be deleted in turn, so cascading delete and other triggers will be honoured. The "before_delete" trigger is when an object instance is about to be deleted. It is invoked before any cascaded deletes. The "after_delete" trigger is invoked after the record has been deleted from the database and just before the contents in memory are discarded. RETRIEVING OBJECTS Class::DBI provides a few very simple search methods. It is not the goal of Class::DBI to replace the need for using SQL. Users are expected to write their own searches for more complex cases. Class::DBI::AbstractSearch, available on CPAN, provides a much more complex search interface than Class::DBI provides itself. retrieve $obj = Class->retrieve( $id ); $obj = Class->retrieve( %key_values ); Given key values it will retrieve the object with that key from the database. For tables with a single column primary key a single parameter can be used, otherwise a hash of key-name key-value pairs must be given. my $cd = Music::CD->retrieve(1) or die "No such cd"; retrieve_all my @objs = Class->retrieve_all; my $iterator = Class->retrieve_all; Retrieves objects for all rows in the database. This is probably a bad idea if your table is big, unless you use the iterator version. search @objs = Class->search(column1 => $value, column2 => $value ...); This is a simple search for all objects where the columns specified are equal to the values specified e.g.: @cds = Music::CD->search(year => 1990); @cds = Music::CD->search(title => "Greatest Hits", year => 1990); You may also specify the sort order of the results by adding a final hash of arguments with the key 'order_by': @cds = Music::CD->search(year => 1990, { order_by=>'artist' }); This is passed through 'as is', enabling order_by clauses such as 'year DESC, title'. search_like @objs = Class->search_like(column1 => $like_pattern, ....); This is a simple search for all objects where the columns specified are like the values specified. $like_pattern is a pattern given in SQL LIKE predicate syntax. '%' means "any zero or more characters", '_' means "any single character". @cds = Music::CD->search_like(title => 'October%'); @cds = Music::CD->search_like(title => 'Hits%', artist => 'Various%'); You can also use 'order_by' with these, as with search(). ITERATORS my $it = Music::CD->search_like(title => 'October%'); while (my $cd = $it->next) { print $cd->title; } Any of the above searches (as well as those defined by has_many) can also be used as an iterator. Rather than creating a list of objects matching your criteria, this will return a Class::DBI::Iterator instance, which can return the objects required one at a time. Currently the iterator initially fetches all the matching row data into memory, and defers only the creation of the objects from that data until the iterator is asked for the next object. So using an iterator will only save significant memory if your objects will inflate substantially when used. In the case of has_many relationships with a mapping method, the mapping method is not called until each time you call 'next'. This means that if your mapping is not a one-to-one, the results will probably not be what you expect. Subclassing the Iterator Music::CD->iterator_class('Music::CD::Iterator'); You can also subclass the default iterator class to override its functionality. This is done via class data, and so is inherited into your subclasses. QUICK RETRIEVAL my $obj = Class->construct(\%data); This is used to turn data from the database into objects, and should thus only be used when writing constructors. It is very handy for cheaply setting up lots of objects from data for without going back to the database. For example, instead of doing one SELECT to get a bunch of IDs and then feeding those individually to retrieve() (and thus doing more SELECT calls), you can do one SELECT to get the essential data of many objects and feed that data to construct(): return map $class->construct($_), $sth->fetchall_hash; The construct() method creates a new empty object, loads in the column values, and then invokes the "select" trigger. COPY AND MOVE copy $new_obj = $obj->copy; $new_obj = $obj->copy($new_id); $new_obj = $obj->copy({ title => 'new_title', rating => 18 }); This creates a copy of the given $obj, removes the primary key, sets any supplied column values and calls insert() to make a new record in the database. For tables with a single column primary key, copy() can be called with no parameters and the new object will be assigned a key automatically. Or a single parameter can be supplied and will be used as the new key. For tables with a multi-column primary key, copy() must be called with parameters which supply new values for all primary key columns, unless a "before_create" trigger will supply them. The insert() method will fail if any primary key columns are not defined. my $blrunner_dc = $blrunner->copy("Bladerunner: Director's Cut"); my $blrunner_unrated = $blrunner->copy({ Title => "Bladerunner: Director's Cut", Rating => 'Unrated', }); move my $new_obj = Sub::Class->move($old_obj); my $new_obj = Sub::Class->move($old_obj, $new_id); my $new_obj = Sub::Class->move($old_obj, \%changes); For transferring objects from one class to another. Similar to copy(), an instance of Sub::Class is inserted using the data in $old_obj (Sub::Class is a subclass of $old_obj's subclass). Like copy(), you can supply $new_id as the primary key of $new_obj (otherwise the usual sequence or autoincrement is used), or a hashref of multiple new values. TRIGGERS __PACKAGE__->add_trigger(trigger_point_name => \&code_to_execute); # e.g. __PACKAGE__->add_trigger(after_create => \&call_after_create); It is possible to set up triggers that will be called at various points in the life of an object. Valid trigger points are: before_create (also used for deflation) after_create before_set_$column (also used by add_constraint) after_set_$column (also used for inflation and by has_a) before_update (also used for deflation and by might_have) after_update before_delete after_delete select (also used for inflation and by construct and _flesh) You can create any number of triggers for each point, but you cannot specify the order in which they will be run. All triggers are passed the object they are being fired for, except when "before_set_$column" is fired during "insert", in which case the class is passed in place of the object, which does not yet exist. You may change object values if required. Some triggers are also passed extra parameters as name-value pairs. The individual triggers are further documented with the methods that trigger them. CONSTRAINTS __PACKAGE__->add_constraint('name', column => \&check_sub); # e.g. __PACKAGE__->add_constraint('over18', age => \&check_age); # Simple version sub check_age { my ($value) = @_; return $value >= 18; } # Cross-field checking - must have SSN if age < 18 sub check_age { my ($value, $self, $column_name, $changing) = @_; return 1 if $value >= 18; # We're old enough. return 1 if $changing->{SSN}; # We're also being given an SSN return 0 if !ref($self); # This is an insert, so we can't have an SSN return 1 if $self->ssn; # We already have one in the database return 0; # We can't find an SSN anywhere } It is also possible to set up constraints on the values that can be set on a column. The constraint on a column is triggered whenever an object is created and whenever the value in that column is being changed. The constraint code is called with four parameters: - The new value to be assigned - The object it will be assigned to (or class name when initially creating an object) - The name of the column (useful if many constraints share the same code) - A hash ref of all new column values being assigned (useful for cross-field validation) The constraints are applied to all the columns being set before the object data is changed. Attempting to create or modify an object where one or more constraint fail results in an exception and the object remains unchanged. The exception thrown has its data set to a hashref of the column being changed and the value being changed to. Note 1: Constraints are implemented using before_set_$column triggers. This will only prevent you from setting these values through a the provided insert() or set() methods. It will always be possible to bypass this if you try hard enough. Note 2: When an object is created constraints are currently only checked for column names included in the parameters to insert(). This is probably a bug and is likely to change in future. constrain_column Film->constrain_column(year => qr/^\d{4}$/); Film->constrain_column(rating => [qw/U Uc PG 12 15 18/]); Film->constrain_column(title => sub { length() <= 20 }); Simple anonymous constraints can also be added to a column using the constrain_column() method. By default this takes either a regex which must match, a reference to a list of possible values, or a subref which will have $_ aliased to the value being set, and should return a true or false value. However, this behaviour can be extended (or replaced) by providing a constraint handler for the type of argument passed to constrain_column. This behavior should be provided in a method named "_constrain_by_$type", where $type is the moniker of the argument. For example, the year example above could be provided by _constrain_by_array(). DATA NORMALIZATION Before an object is assigned data from the application (via insert or a set accessor) the normalize_column_values() method is called with a reference to a hash containing the column names and the new values which are to be assigned (after any validation and constraint checking, as described below). Currently Class::DBI does not offer any per-column mechanism here. The default method is empty. You can override it in your own classes to normalize (edit) the data in any way you need. For example the values in the hash for certain columns could be made lowercase. The method is called as an instance method when the values of an existing object are being changed, and as a class method when a new object is being created. DATA VALIDATION Before an object is assigned data from the application (via insert or a set accessor) the validate_column_values() method is called with a reference to a hash containing the column names and the new values which are to be assigned. The method is called as an instance method when the values of an existing object are being changed, and as a class method when a new object is being inserted. The default method calls the before_set_$column trigger for each column name in the hash. Each trigger is called inside an eval. Any failures result in an exception after all have been checked. The exception data is a reference to a hash which holds the column name and error text for each trigger error. When using this mechanism for form data validation, for example, this exception data can be stored in an exception object, via a custom _croak() method, and then caught and used to redisplay the form with error messages next to each field which failed validation. EXCEPTIONS All errors that are generated, or caught and propagated, by Class::DBI are handled by calling the _croak() method (as an instance method if possible, or else as a class method). The _croak() method is passed an error message and in some cases some extra information as described below. The default behaviour is simply to call Carp::croak($message). Applications that require custom behaviour should override the _croak() method in their application base class (or table classes for table-specific behaviour). For example: use Error; sub _croak { my ($self, $message, %info) = @_; # convert errors into exception objects # except for duplicate insert errors which we'll ignore Error->throw(-text => $message, %info) unless $message =~ /^Can't insert .* duplicate/; return; } The _croak() method is expected to trigger an exception and not return. If it does return then it should use "return;" so that an undef or empty list is returned as required depending on the calling context. You should only return other values if you are prepared to deal with the (unsupported) consequences. For exceptions that are caught and propagated by Class::DBI, $message includes the text of $@ and the original $@ value is available in $info{err}. That allows you to correctly propagate exception objects that may have been thrown 'below' Class::DBI (using Exception::Class::DBI for example). Exceptions generated by some methods may provide additional data in $info{data} and, if so, also store the method name in $info{method}. For example, the validate_column_values() method stores details of failed validations in $info{data}. See individual method documentation for what additional data they may store, if any. WARNINGS All warnings are handled by calling the _carp() method (as an instance method if possible, or else as a class method). The default behaviour is simply to call Carp::carp(). INSTANCE METHODS accessors Class::DBI inherits from Class::Accessor and thus provides individual accessor methods for every column in your subclass. It also overrides the get() and set() methods provided by Accessor to automagically handle database reading and writing. (Note that as it doesn't make sense to store a list of values in a column, set() takes a hash of column => value pairs, rather than the single key => values of Class::Accessor). the fundamental set() and get() methods $value = $obj->get($column_name); @values = $obj->get(@column_names); $obj->set($column_name => $value); $obj->set($col1 => $value1, $col2 => $value2 ... ); These methods are the fundamental entry points for getting and setting column values. The extra accessor methods automatically generated for each column of your table are simple wrappers that call these get() and set() methods. The set() method calls normalize_column_values() then validate_column_values() before storing the values. The "before_set_$column" trigger is invoked by validate_column_values(), checking any constraints that may have been set up. The "after_set_$column" trigger is invoked after the new value has been stored. It is possible for an object to not have all its column data in memory (due to lazy inflation). If the get() method is called for such a column then it will select the corresponding group of columns and then invoke the "select" trigger. Changing Your Column Accessor Method Names accessor_name_for / mutator_name_for It is possible to change the name of the accessor method created for a column either declaratively or programmatically. If, for example, you have a column with a name that clashes with a method otherwise created by Class::DBI, such as 'meta_info', you could create that Column explicitly with a different accessor (and/or mutator) when setting up your columns: my $meta_col = Class::DBI::Column->new(meta_info => { accessor => 'metadata', }); __PACKAGE__->columns(All => qw/id name/, $meta_col); If you want to change the name of all your accessors, or all that match a certain pattern, you need to provide an accessor_name_for($col) method, which will convert a column name to a method name. e.g: if your local database naming convention was to prepend the word 'customer' to each column in the 'customer' table, so that you had the columns 'customerid', 'customername' and 'customerage', but you wanted your methods to just be $customer->name and $customer->age rather than $customer->customername etc., you could create a sub accessor_name_for { my ($class, $column) = @_; $column =~ s/^customer//; return $column; } Similarly, if you wanted to have distinct accessor and mutator methods, you could provide a mutator_name_for($col) method which would return the name of the method to change the value: sub mutator_name_for { my ($class, $column) = @_; return "set_" . $column->accessor; } If you override the mutator name, then the accessor method will be enforced as read-only, and the mutator as write-only. update vs auto update There are two modes for the accessors to work in: manual update and autoupdate. When in autoupdate mode, every time one calls an accessor to make a change an UPDATE will immediately be sent to the database. Otherwise, if autoupdate is off, no changes will be written until update() is explicitly called. This is an example of manual updating: # The calls to NumExplodingSheep() and Rating() will only make the # changes in memory, not in the database. Once update() is called # it writes to the database in one swell foop. $gone->NumExplodingSheep(5); $gone->Rating('NC-17'); $gone->update; And of autoupdating: # Turn autoupdating on for this object. $gone->autoupdate(1); # Each accessor call causes the new value to immediately be written. $gone->NumExplodingSheep(5); $gone->Rating('NC-17'); Manual updating is probably more efficient than autoupdating and it provides the extra safety of a discard_changes() option to clear out all unsaved changes. Autoupdating can be more convenient for the programmer. Autoupdating is *off* by default. If changes are neither updated nor rolled back when the object is destroyed (falls out of scope or the program ends) then Class::DBI's DESTROY method will print a warning about unsaved changes. autoupdate __PACKAGE__->autoupdate($on_or_off); $update_style = Class->autoupdate; $obj->autoupdate($on_or_off); $update_style = $obj->autoupdate; This is an accessor to the current style of auto-updating. When called with no arguments it returns the current auto-updating state, true for on, false for off. When given an argument it turns auto-updating on and off: a true value turns it on, a false one off. When called as a class method it will control the updating style for every instance of the class. When called on an individual object it will control updating for just that object, overriding the choice for the class. __PACKAGE__->autoupdate(1); # Autoupdate is now on for the class. $obj = Class->retrieve('Aliens Cut My Hair'); $obj->autoupdate(0); # Shut off autoupdating for this object. The update setting for an object is not stored in the database. update $obj->update; If "autoupdate" is not enabled then changes you make to your object are not reflected in the database until you call update(). It is harmless to call update() if there are no changes to be saved. (If autoupdate is on there'll never be anything to save.) Note: If you have transactions turned on for your database (but see "TRANSACTIONS" below) you will also need to call dbi_commit(), as update() merely issues the UPDATE to the database). After the database update has been executed, the data for columns that have been updated are deleted from the object. If those columns are accessed again they'll simply be fetched as needed. This ensures that the data in the application is consistent with what the database *actually* stored. When update() is called the "before_update"($self) trigger is always invoked immediately. If any columns have been updated then the "after_update" trigger is invoked after the database update has executed and is passed: ($self, discard_columns => \@discard_columns) The trigger code can modify the discard_columns array to affect which columns are discarded. For example: Class->add_trigger(after_update => sub { my ($self, %args) = @_; my $discard_columns = $args{discard_columns}; # discard the md5_hash column if any field starting with 'foo' # has been updated - because the md5_hash will have been changed # by a trigger. push @$discard_columns, 'md5_hash' if grep { /^foo/ } @$discard_columns; }); Take care to not delete a primary key column unless you know what you're doing. The update() method returns the number of rows updated. If the object had not changed and thus did not need to issue an UPDATE statement, the update() call will have a return value of -1. If the record in the database has been deleted, or its primary key value changed, then the update will not affect any records and so the update() method will return 0. discard_changes $obj->discard_changes; Removes any changes you've made to this object since the last update. Currently this simply discards the column values from the object. If you're using autoupdate this method will throw an exception. is_changed my $changed = $obj->is_changed; my @changed_keys = $obj->is_changed; Indicates if the given $obj has changes since the last update. Returns a list of keys which have changed. (If autoupdate is on, this method will return an empty list, unless called inside a before_update or after_set_$column trigger) id $id = $obj->id; @id = $obj->id; Returns a unique identifier for this object based on the values in the database. It's the equivalent of $obj->get($self->columns('Primary')), with inflated values reduced to their ids. A warning will be generated if this method is used in scalar context on a table with a multi-column primary key. LOW-LEVEL DATA ACCESS On some occasions, such as when you're writing triggers or constraint routines, you'll want to manipulate data in a Class::DBI object without using the usual get() and set() accessors, which may themselves call triggers, fetch information from the database, etc. Rather than interacting directly with the data hash stored in a Class::DBI object (the exact implementation of which may change in future releases) you could use Class::DBI's low-level accessors. These appear 'private' to make you think carefully about using them - they should not be a common means of dealing with the object. The data within the object is modelled as a set of key-value pairs, where the keys are normalized column names (returned by find_column()), and the values are the data from the database row represented by the object. Access is via these functions: _attrs @values = $object->_attrs(@cols); Returns the values for one or more keys. _attribute_store $object->_attribute_store( { $col0 => $val0, $col1 => $val1 } ); $object->_attribute_store($col0, $val0, $col1, $val1); Stores values in the object. They key-value pairs may be passed in either as a simple list or as a hash reference. This only updates values in the object itself; changes will not be propagated to the database. _attribute_set $object->_attribute_set( { $col0 => $val0, $col1 => $val1 } ); $object->_attribute_set($col0, $val0, $col1, $val1); Updates values in the object via _attribute_store(), but also logs the changes so that they are propagated to the database with the next update. (Unlike set(), however, _attribute_set() will not trigger an update if autoupdate is turned on.) _attribute_delete @values = $object->_attribute_delete(@cols); Deletes values from the object, and returns the deleted values. _attribute_exists $bool = $object->_attribute_exists($col); Returns a true value if the object contains a value for the specified column, and a false value otherwise. By default, Class::DBI uses simple hash references to store object data, but all access is via these routines, so if you want to implement a different data model, just override these functions. OVERLOADED OPERATORS Class::DBI and its subclasses overload the perl builtin *stringify* and *bool* operators. This is a significant convenience. The perl builtin *bool* operator is overloaded so that a Class::DBI object reference is true so long as all its key columns have defined values. (This means an object with an id() of zero is not considered false.) When a Class::DBI object reference is used in a string context it will, by default, return the value of the primary key. (Composite primary key values will be separated by a slash). You can also specify the column(s) to be used for stringification via the special 'Stringify' column group. So, for example, if you're using an auto-incremented primary key, you could use this to provide a more meaningful display string: Widget->columns(Stringify => qw/name/); If you need to do anything more complex, you can provide an stringify_self() method which stringification will call: sub stringify_self { my $self = shift; return join ":", $self->id, $self->name; } This overloading behaviour can be useful for columns that have has_a() relationships. For example, consider a table that has price and currency fields: package Widget; use base 'My::Class::DBI'; Widget->table('widget'); Widget->columns(All => qw/widgetid name price currency_code/); $obj = Widget->retrieve($id); print $obj->price . " " . $obj->currency_code; The would print something like ""42.07 USD"". If the currency_code field is later changed to be a foreign key to a new currency table then $obj->currency_code will return an object reference instead of a plain string. Without overloading the stringify operator the example would now print something like ""42.07 Widget=HASH(0x1275}"" and the fix would be to change the code to add a call to id(): print $obj->price . " " . $obj->currency_code->id; However, with overloaded stringification, the original code continues to work as before, with no code changes needed. This makes it much simpler and safer to add relationships to existing applications, or remove them later. TABLE RELATIONSHIPS Databases are all about relationships. Thus Class::DBI provides a way for you to set up descriptions of your relationhips. Class::DBI provides three such relationships: 'has_a', 'has_many', and 'might_have'. Others are available from CPAN. has_a Music::CD->has_a(column => 'Foreign::Class'); Music::CD->has_a(artist => 'Music::Artist'); print $cd->artist->name; 'has_a' is most commonly used to supply lookup information for a foreign key. If a column is declared as storing the primary key of another table, then calling the method for that column does not return the id, but instead the relevant object from that foreign class. It is also possible to use has_a to inflate the column value to a non Class::DBI based. A common usage would be to inflate a date field to a date/time object: Music::CD->has_a(reldate => 'Date::Simple'); print $cd->reldate->format("%d %b, %Y"); Music::CD->has_a(reldate => 'Time::Piece', inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") }, deflate => 'ymd', ); print $cd->reldate->strftime("%d %b, %Y"); If the foreign class is another Class::DBI representation retrieve is called on that class with the column value. Any other object will be instantiated either by calling new($value) or using the given 'inflate' method. If the inflate method name is a subref, it will be executed, and will be passed the value and the Class::DBI object as arguments. When the object is being written to the database the object will be deflated either by calling the 'deflate' method (if given), or by attempting to stringify the object. If the deflate method is a subref, it will be passed the Class::DBI object as an argument. *NOTE* You should not attempt to make your primary key column inflate using has_a() as bad things will happen. If you have two tables which share a primary key, consider using might_have() instead. has_many Class->has_many(method_to_create => "Foreign::Class"); Music::CD->has_many(tracks => 'Music::Track'); my @tracks = $cd->tracks; my $track6 = $cd->add_to_tracks({ position => 6, title => 'Tomorrow', }); This method declares that another table is referencing us (i.e. storing our primary key in its table). It creates a named accessor method in our class which returns a list of all the matching Foreign::Class objects. In addition it creates another method which allows a new associated object to be constructed, taking care of the linking automatically. This method is the same as the accessor method with "add_to_" prepended. The add_to_tracks example above is exactly equivalent to: my $track6 = Music::Track->insert({ cd => $cd, position => 6, title => 'Tomorrow', }); When setting up the relationship the foreign class's has_a() declarations are examined to discover which of its columns reference our class. (Note that because this happens at compile time, if the foreign class is defined in the same file, the class with the has_a() must be defined earlier than the class with the has_many(). If the classes are in different files, Class::DBI should usually be able to do the right things, as long as all classes inherit Class::DBI before 'use'ing any other classes.) If the foreign class has no has_a() declarations linking to this class, it is assumed that the foreign key in that class is named after the moniker() of this class. If this is not true you can pass an additional third argument to the has_many() declaration stating which column of the foreign class is the foreign key to this class. Limiting Music::Artist->has_many(cds => 'Music::CD'); my @cds = $artist->cds(year => 1980); When calling the method created by has_many, you can also supply any additional key/value pairs for restricting the search. The above example will only return the CDs with a year of 1980. Ordering Music::CD->has_many(tracks => 'Music::Track', { order_by => 'playorder' }); has_many takes an optional final hashref of options. If an 'order_by' option is set, its value will be set in an ORDER BY clause in the SQL issued. This is passed through 'as is', enabling order_by clauses such as 'length DESC, position'. Mapping Music::CD->has_many(styles => [ 'Music::StyleRef' => 'style' ]); If the second argument to has_many is turned into a listref of the Classname and an additional method, then that method will be called in turn on each of the objects being returned. The above is exactly equivalent to: Music::CD->has_many(_style_refs => 'Music::StyleRef'); sub styles { my $self = shift; return map $_->style, $self->_style_refs; } For an example of where this is useful see "MANY TO MANY RELATIONSHIPS" below. Cascading Delete Music::Artist->has_many(cds => 'Music::CD', { cascade => 'Fail' }); It is also possible to control what happens to the 'child' objects when the 'parent' object is deleted. By default this is set to 'Delete' - so, for example, when you delete an artist, you also delete all their CDs, leaving no orphaned records. However you could also set this to 'None', which would leave all those orphaned records (although this generally isn't a good idea), or 'Fail', which will throw an exception when you try to delete an artist that still has any CDs. You can also write your own Cascade strategies by supplying a Class Name here. For example you could write a Class::DBI::Cascade::Plugin::Nullify which would set all related foreign keys to be NULL, and plug it into your relationship: Music::Artist->has_many(cds => 'Music::CD', { cascade => 'Class::DBI::Cascade::Plugin::Nullify' }); might_have Music::CD->might_have(method_name => Class => (@fields_to_import)); Music::CD->might_have(liner_notes => LinerNotes => qw/notes/); my $liner_notes_object = $cd->liner_notes; my $notes = $cd->notes; # equivalent to $cd->liner_notes->notes; might_have() is similar to has_many() for relationships that can have at most one associated objects. For example, if you have a CD database to which you want to add liner notes information, you might not want to add a 'liner_notes' column to your main CD table even though there is no multiplicity of relationship involved (each CD has at most one 'liner notes' field). So, you create another table with the same primary key as this one, with which you can cross-reference. But you don't want to have to keep writing methods to turn the the 'list' of liner_notes objects you'd get back from has_many into the single object you'd need. So, might_have() does this work for you. It creates an accessor to fetch the single object back if it exists, and it also allows you import any of its methods into your namespace. So, in the example above, the LinerNotes class can be mostly invisible - you can just call $cd->notes and it will call the notes method on the correct LinerNotes object transparently for you. Making sure you don't have namespace clashes is up to you, as is correctly creating the objects, but this may be made simpler in later versions. (Particularly if someone asks for this!) Notes has_a(), might_have() and has_many() check that the relevant class has already been loaded. If it hasn't then they try to load the module of the same name using require. If the require fails because it can't find the module then it will assume it's not a simple require (i.e., Foreign::Class isn't in Foreign/Class.pm) and that you will take care of it and ignore the warning. Any other error, such as a syntax error, triggers an exception. NOTE: The two classes in a relationship do not have to be in the same database, on the same machine, or even in the same type of database! It is quite acceptable for a table in a MySQL database to be connected to a different table in an Oracle database, and for cascading delete etc to work across these. This should assist greatly if you need to migrate a database gradually. MANY TO MANY RELATIONSHIPS Class::DBI does not currently support Many to Many relationships, per se. However, by combining the relationships that already exist it is possible to set these up. Consider the case of Films and Actors, with a linking Role table with a multi-column Primary Key. First of all set up the Role class: Role->table('role'); Role->columns(Primary => qw/film actor/); Role->has_a(film => 'Film'); Role->has_a(actor => 'Actor'); Then, set up the Film and Actor classes to use this linking table: Film->table('film'); Film->columns(All => qw/id title rating/); Film->has_many(stars => [ Role => 'actor' ]); Actor->table('actor'); Actor->columns(All => qw/id name/); Actor->has_many(films => [ Role => 'film' ]); In each case the 'mapping method' variation of has_many() is used to call the lookup method on the Role object returned. As these methods are the 'has_a' relationships on the Role, these will return the actual Actor and Film objects, providing a cheap many-to-many relationship. In the case of Film, this is equivalent to the more long-winded: Film->has_many(roles => "Role"); sub actors { my $self = shift; return map $_->actor, $self->roles } As this is almost exactly what is created internally, add_to_stars and add_to_films will generally do the right thing as they are actually doing the equivalent of add_to_roles: $film->add_to_actors({ actor => $actor }); Similarly a cascading delete will also do the right thing as it will only delete the relationship from the linking table. If the Role table were to contain extra information, such as the name of the character played, then you would usually need to skip these short-cuts and set up each of the relationships, and associated helper methods, manually. ADDING NEW RELATIONSHIP TYPES add_relationship_type The relationships described above are implemented through Class::DBI::Relationship subclasses. These are then plugged into Class::DBI through an add_relationship_type() call: __PACKAGE__->add_relationship_type( has_a => "Class::DBI::Relationship::HasA", has_many => "Class::DBI::Relationship::HasMany", might_have => "Class::DBI::Relationship::MightHave", ); If is thus possible to add new relationship types, or modify the behaviour of the existing types. See Class::DBI::Relationship for more information on what is required. DEFINING SQL STATEMENTS There are several main approaches to setting up your own SQL queries: For queries which could be used to create a list of matching objects you can create a constructor method associated with this SQL and let Class::DBI do the work for you, or just inline the entire query. For more complex queries you need to fall back on the underlying Ima::DBI query mechanism. (Caveat: since Ima::DBI uses sprintf-style interpolation, you need to be careful to double any "wildcard" % signs in your queries). add_constructor __PACKAGE__->add_constructor(method_name => 'SQL_where_clause'); The SQL can be of arbitrary complexity and will be turned into: SELECT (essential columns) FROM (table name) WHERE This will then create a method of the name you specify, which returns a list of objects as with any built in query. For example: Music::CD->add_constructor(new_music => 'year > 2000'); my @recent = Music::CD->new_music; You can also supply placeholders in your SQL, which must then be specified at query time: Music::CD->add_constructor(new_music => 'year > ?'); my @recent = Music::CD->new_music(2000); retrieve_from_sql On occasions where you want to execute arbitrary SQL, but don't want to go to the trouble of setting up a constructor method, you can inline the entire WHERE clause, and just get the objects back directly: my @cds = Music::CD->retrieve_from_sql(qq{ artist = 'Ozzy Osbourne' AND title like "%Crazy" AND year <= 1986 ORDER BY year LIMIT 2,3 }); Ima::DBI queries When you can't use 'add_constructor', e.g. when using aggregate functions, you can fall back on the fact that Class::DBI inherits from Ima::DBI and prefers to use its style of dealing with statements, via set_sql(). The Class::DBI set_sql() method defaults to using prepare_cached() unless the $cache parameter is defined and false (see Ima::DBI docs for more information). To assist with writing SQL that is inheritable into subclasses, several additional substitutions are available here: __TABLE__, __ESSENTIAL__ and __IDENTIFIER__. These represent the table name associated with the class, its essential columns, and the primary key of the current object, in the case of an instance method on it. For example, the SQL for the internal 'update' method is implemented as: __PACKAGE__->set_sql('update', <<""); UPDATE __TABLE__ SET %s WHERE __IDENTIFIER__ The 'longhand' version of the new_music constructor shown above would similarly be: Music::CD->set_sql(new_music => qq{ SELECT __ESSENTIAL__ FROM __TABLE__ WHERE year > ? }); For such 'SELECT' queries Ima::DBI's set_sql() method is extended to create a helper shortcut method, named by prefixing the name of the SQL fragment with 'search_'. Thus, the above call to set_sql() will automatically set up the method Music::CD->search_new_music(), which will execute this search and return the relevant objects or Iterator. (If there are placeholders in the query, you must pass the relevant arguments when calling your search method.) This does the equivalent of: sub search_new_music { my ($class, @args) = @_; my $sth = $class->sql_new_music; $sth->execute(@args); return $class->sth_to_objects($sth); } The $sth which is used to return the objects here is a normal DBI-style statement handle, so if the results can't be turned into objects easily, it is still possible to call $sth->fetchrow_array etc and return whatever data you choose. Of course, any query can be added via set_sql, including joins. So, to add a query that returns the 10 Artists with the most CDs, you could write (with MySQL): Music::Artist->set_sql(most_cds => qq{ SELECT artist.id, COUNT(cd.id) AS cds FROM artist, cd WHERE artist.id = cd.artist GROUP BY artist.id ORDER BY cds DESC LIMIT 10 }); my @artists = Music::Artist->search_most_cds(); If you also need to access the 'cds' value returned from this query, the best approach is to declare 'cds' to be a TEMP column. (See "Non-Persistent Fields" below). Class::DBI::AbstractSearch my @music = Music::CD->search_where( artist => [ 'Ozzy', 'Kelly' ], status => { '!=', 'outdated' }, ); The Class::DBI::AbstractSearch module, available from CPAN, is a plugin for Class::DBI that allows you to write arbitrarily complex searches using perl data structures, rather than SQL. Single Value SELECTs select_val Selects which only return a single value can couple Class::DBI's sql_single() SQL, with the $sth->select_val() call which we get from DBIx::ContextualFetch. __PACKAGE__->set_sql(count_all => "SELECT COUNT(*) FROM __TABLE__"); # .. then .. my $count = $class->sql_count_all->select_val; This can also take placeholders and/or do column interpolation if required: __PACKAGE__->set_sql(count_above => q{ SELECT COUNT(*) FROM __TABLE__ WHERE %s > ? }); # .. then .. my $count = $class->sql_count_above('year')->select_val(2001); sql_single Internally Class::DBI defines a very simple SQL fragment called 'single': "SELECT %s FROM __TABLE__". This is used to implement the above Class->count_all(): $class->sql_single("COUNT(*)")->select_val; This interpolates the COUNT(*) into the %s of the SQL, and then executes the query, returning a single value. Any SQL set up via set_sql() can of course be supplied here, and select_val can take arguments for any placeholders there. Internally several helper methods are defined using this approach: - count_all - maximum_value_of($column) - minimum_value_of($column) LAZY POPULATION In the tradition of Perl, Class::DBI is lazy about how it loads your objects. Often, you find yourself using only a small number of the available columns and it would be a waste of memory to load all of them just to get at two, especially if you're dealing with large numbers of objects simultaneously. You should therefore group together your columns by typical usage, as fetching one value from a group can also pre-fetch all the others in that group for you, for more efficient access. So for example, if we usually fetch the artist and title, but don't use the 'year' so much, then we could say the following: Music::CD->columns(Primary => qw/cdid/); Music::CD->columns(Essential => qw/artist title/); Music::CD->columns(Others => qw/year runlength/); Now when you fetch back a CD it will come pre-loaded with the 'cdid', 'artist' and 'title' fields. Fetching the 'year' will mean another visit to the database, but will bring back the 'runlength' whilst it's there. This can potentially increase performance. If you don't like this behavior, then just add all your columns to the Essential group, and Class::DBI will load everything at once. If you have a single column primary key you can do this all in one shot with one single column declaration: Music::CD->columns(Essential => qw/cdid artist title year runlength/); columns my @all_columns = $class->columns; my @columns = $class->columns($group); my @primary = $class->primary_columns; my $primary = $class->primary_column; my @essential = $class->_essential; There are four 'reserved' groups: 'All', 'Essential', 'Primary' and 'TEMP'. 'All' are all columns used by the class. If not set it will be created from all the other groups. 'Primary' is the primary key columns for this class. It *must* be set before objects can be used. If 'All' is given but not 'Primary' it will assume the first column in 'All' is the primary key. 'Essential' are the minimal set of columns needed to load and use the object. Only the columns in this group will be loaded when an object is retrieve()'d. It is typically used to save memory on a class that has a lot of columns but where only use a few of them are commonly used. It will automatically be set to 'Primary' if not explicitly set. The 'Primary' column is always part of the 'Essential' group. For simplicity primary_columns(), primary_column(), and _essential() methods are provided to return these. The primary_column() method should only be used for tables that have a single primary key column. Non-Persistent Fields Music::CD->columns(TEMP => qw/nonpersistent/); If you wish to have fields that act like columns in every other way, but that don't actually exist in the database (and thus will not persist), you can declare them as part of a column group of 'TEMP'. find_column Class->find_column($column); $obj->find_column($column); The columns of a class are stored as Class::DBI::Column objects. This method will return you the object for the given column, if it exists. This is most useful either in a boolean context to discover if the column exists, or to 'normalize' a user-entered column name to an actual Column. The interface of the Column object itself is still under development, so you shouldn't really rely on anything internal to it. TRANSACTIONS Class::DBI suffers from the usual problems when dealing with transactions. In particular, you should be very wary when committing your changes that you may actually be in a wider scope than expected and that your caller may not be expecting you to commit. However, as long as you are aware of this, and try to keep the scope of your transactions small, ideally always within the scope of a single method, you should be able to work with transactions with few problems. dbi_commit / dbi_rollback $obj->dbi_commit(); $obj->dbi_rollback(); These are thin aliases through to the DBI's commit() and rollback() commands to commit or rollback all changes to this object. Localised Transactions A nice idiom for turning on a transaction locally (with AutoCommit turned on globally) (courtesy of Dominic Mitchell) is: sub do_transaction { my $class = shift; my ( $code ) = @_; # Turn off AutoCommit for this scope. # A commit will occur at the exit of this block automatically, # when the local AutoCommit goes out of scope. local $class->db_Main->{ AutoCommit }; # Execute the required code inside the transaction. eval { $code->() }; if ( $@ ) { my $commit_error = $@; eval { $class->dbi_rollback }; # might also die! die $commit_error; } } And then you just call: Music::DBI->do_transaction( sub { my $artist = Music::Artist->insert({ name => 'Pink Floyd' }); my $cd = $artist->add_to_cds({ title => 'Dark Side Of The Moon', year => 1974, }); }); Now either both will get added, or the entire transaction will be rolled back. UNIQUENESS OF OBJECTS IN MEMORY Class::DBI supports uniqueness of objects in memory. In a given perl interpreter there will only be one instance of any given object at one time. Many variables may reference that object, but there can be only one. Here's an example to illustrate: my $artist1 = Music::Artist->insert({ artistid => 7, name => 'Polysics' }); my $artist2 = Music::Artist->retrieve(7); my $artist3 = Music::Artist->search( name => 'Polysics' )->first; Now $artist1, $artist2, and $artist3 all point to the same object. If you update a property on one of them, all of them will reflect the update. This is implemented using a simple object lookup index for all live objects in memory. It is not a traditional cache - when your objects go out of scope, they will be destroyed normally, and a future retrieve will instantiate an entirely new object. The ability to perform this magic for you replies on your perl having access to the Scalar::Util::weaken function. Although this is part of the core perl distribution, some vendors do not compile support for it. To find out if your perl has support for it, you can run this on the command line: perl -e 'use Scalar::Util qw(weaken)' If you get an error message about weak references not being implemented, Class::DBI will not maintain this lookup index, but give you a separate instances for each retrieve. A few new tools are offered for adjusting the behavior of the object index. These are still somewhat experimental and may change in a future release. remove_from_object_index $artist->remove_from_object_index(); This is an object method for removing a single object from the live objects index. You can use this if you want to have multiple distinct copies of the same object in memory. clear_object_index Music::DBI->clear_object_index(); You can call this method on any class or instance of Class::DBI, but the effect is universal: it removes all objects from the index. purge_object_index_every Music::Artist->purge_object_index_every(2000); Weak references are not removed from the index when an object goes out of scope. This means that over time the index will grow in memory. This is really only an issue for long-running environments like mod_perl, but every so often dead references are cleaned out to prevent this. By default, this happens every 1000 object loads, but you can change that default for your class by setting the 'purge_object_index_every' value. (Eventually this may handled in the DESTROY method instead.) As a final note, keep in mind that you can still have multiple distinct copies of an object in memory if you have multiple perl interpreters running. CGI, mod_perl, and many other common usage situations run multiple interpreters, meaning that each one of them may have an instance of an object representing the same data. However, this is no worse than it was before, and is entirely normal for database applications in multi-process environments. SUBCLASSING The preferred method of interacting with Class::DBI is for you to write a subclass for your database connection, with each table-class inheriting in turn from it. As well as encapsulating the connection information in one place, this also allows you to override default behaviour or add additional functionality across all of your classes. As the innards of Class::DBI are still in flux, you must exercise extreme caution in overriding private methods of Class::DBI (those starting with an underscore), unless they are explicitly mentioned in this documentation as being safe to override. If you find yourself needing to do this, then I would suggest that you ask on the mailing list about it, and we'll see if we can either come up with a better approach, or provide a new means to do whatever you need to do. CAVEATS Multi-Column Foreign Keys are not supported You can't currently add a relationship keyed on multiple columns. You could, however, write a Relationship plugin to do this, and the world would be eternally grateful... Don't change or inflate the value of your primary columns Altering your primary key column currently causes Bad Things to happen. I should really protect against this. SUPPORTED DATABASES Theoretically Class::DBI should work with almost any standard RDBMS. Of course, in the real world, we know that that's not true. It is known to work with MySQL, PostgreSQL, Oracle and SQLite, each of which have their own additional subclass on CPAN that you should explore if you're using them: L, L, L, L For the most part it's been reported to work with Sybase, although there are some issues with multi-case column/table names. Beyond that lies The Great Unknown(tm). If you have access to other databases, please give this a test run, and let me know the results. Ima::DBI (and hence Class::DBI) requires a database that supports table aliasing and a DBI driver that supports placeholders. This means it won't work with older releases of DBD::AnyData (and any releases of its predecessor DBD::RAM), and DBD::Sybase + FreeTDS may or may not work depending on your FreeTDS version. CURRENT AUTHOR Tony Bowden AUTHOR EMERITUS Michael G Schwern THANKS TO Tim Bunce, Tatsuhiko Miyagawa, Perrin Harkins, Alexander Karelas, Barry Hoggard, Bart Lateur, Boris Mouzykantskii, Brad Bowman, Brian Parker, Casey West, Charles Bailey, Christopher L. Everett Damian Conway, Dan Thill, Dave Cash, David Jack Olrik, Dominic Mitchell, Drew Taylor, Drew Wilson, Jay Strauss, Jesse Sheidlower, Jonathan Swartz, Marty Pauley, Michael Styer, Mike Lambert, Paul Makepeace, Phil Crow, Richard Piacentini, Simon Cozens, Simon Wilcox, Thomas Klausner, Tom Renfro, Uri Gutman, William McKee, the Class::DBI mailing list, the POOP group, and all the others who've helped, but that I've forgetten to mention. RELEASE PHILOSOPHY Class::DBI now uses a three-level versioning system. This release, for example, is version 3.0.14 The general approach to releases will be that users who like a degree of stability can hold off on upgrades until the major sub-version increases (e.g. 3.1.0). Those who like living more on the cutting edge can keep up to date with minor sub-version releases. Functionality which was introduced during a minor sub-version release may disappear without warning in a later minor sub-version release. I'll try to avoid doing this, and will aim to have a deprecation cycle of at least a few minor sub-versions, but you should keep a close eye on the CHANGES file, and have good tests in place. (This is good advice generally, of course.) Anything that is in a major sub-version release will go through a deprecation cycle of at least one further major sub-version before it is removed (and usually longer). Getting changes accepted There is an active Class::DBI community, however I am not part of it. I am not on the mailing list, and I don't follow the wiki. I also do not follow Perl Monks or CPAN reviews or annoCPAN or whatever the tool du jour happens to be. If you find a problem with Class::DBI, by all means discuss it in any of these places, but don't expect anything to happen unless you actually tell me about it. The preferred method for doing this is via the CPAN RT interface, which you can access at http://rt.cpan.org/ or by emailing bugs-Class-DBI@rt.cpan.org If you email me personally about Class::DBI issues, then I will probably bounce them on to there, unless you specifically ask me not to. Otherwise I can't keep track of what all needs fixed. (This of course means that if you ask me not to send your mail to RT, there's a much higher chance that nothing will every happen about your problem). Bug Reports If you're reporting a bug then it has a much higher chance of getting fixed quicker if you can include a failing test case. This should be a completely stand-alone test that could be added to the Class::DBI distribution. That is, it should use Test::Simple or Test::More, fail with the current code, but pass when I fix the problem. If it needs to have a working database to show the problem, then this should preferably use SQLite, and come with all the code to set this up. The nice people on the mailing list will probably help you out if you need assistance putting this together. You don't need to include code for actually fixing the problem, but of course it's often nice if you can. I may choose to fix it in a different way, however, so it's often better to ask first whether I'd like a patch, particularly before spending a lot of time hacking. Patches If you are sending patches, then please send either the entire code that is being changed or the output of 'diff -Bub'. Please also note what version the patch is against. I tend to apply all patches manually, so I'm more interested in being able to see what you're doing than in being able to apply the patch cleanly. Code formatting isn't an issue, as I automagically run perltidy against the source after any changes, so please format for clarity. Patches have a much better chance of being applied if they are small. People often think that it's better for me to get one patch with a bunch of fixes. It's not. I'd much rather get 100 small patches that can be applied one by one. A change that I can make and release in five minutes is always better than one that needs a couple of hours to ponder and work through. I often reject patches that I don't like. Please don't take it personally. I also like time to think about the wider implications of changes. Often a *lot* of time. Feel free to remind me about things that I may have forgotten about, but as long as they're on rt.cpan.org I will get around to them eventually. Feature Requests Wish-list requests are fine, although you should probably discuss them on the mailing list (or equivalent) with others first. There's quite often a plugin somewhere that already does what you want. In general I am much more open to discussion on how best to provide the flexibility for you to make your Cool New Feature(tm) a plugin rather than adding it to Class::DBI itself. For the most part the core of Class::DBI already has most of the functionality that I believe it will ever need (and some more besides, that will probably be split off at some point). Most other things are much better off as plugins, with a separate life on CPAN or elsewhere (and with me nowhere near the critical path). Most of the ongoing work on Class::DBI is about making life easier for people to write extensions - whether they're local to your own codebase or released for wider consumption. SUPPORT Support for Class::DBI is mostly via the mailing list. To join the list, or read the archives, visit http://lists.digitalcraftsmen.net/mailman/listinfo/classdbi There is also a Class::DBI wiki at http://www.class-dbi.com/ The wiki contains much information that should probably be in these docs but isn't yet. (See above if you want to help to rectify this.) As mentioned above, I don't follow the list or the wiki, so if you want to contact me individually, then you'll have to track me down personally. There are lots of 3rd party subclasses and plugins available. For a list of the ones on CPAN see: http://search.cpan.org/search?query=Class%3A%3ADBI&mode=module An article on Class::DBI was published on Perl.com a while ago. It's slightly out of date , but it's a good introduction: http://www.perl.com/pub/a/2002/11/27/classdbi.html The wiki has numerous references to other articles, presentations etc. http://poop.sourceforge.net/ provides a document comparing a variety of different approaches to database persistence, such as Class::DBI, Alazabo, Tangram, SPOPS etc. LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO Class::DBI is built on top of Ima::DBI, DBIx::ContextualFetch, Class::Accessor and Class::Data::Inheritable. The innards and much of the interface are easier to understand if you have an idea of how they all work as well. Class-DBI-v3.0.17/Changes0000644000175200017520000007031610701255214013500 0ustar tonytony 3.0.17 Oct 4, 2007 - Fix t/11 to cope with Class::Trigger no longer supporting multiple triggers in one shot 3.0.16 Nov 05, 2006 - Better error reporting from has_a setup failure 3.0.15 Aug 19 2006 - Fix ignorage with mutator_name and accessor_name (Ask Bjørn Hansen) 3.0.14 Jan 03 2006 - Fix breakage with mutator_name (Ask Bjørn Hansen) 3.0.13 Dec 15 2005 - Use DBI's last_insert_id() where available (David Steinbrunner) - Cope better with deleting through a might_have (Rob Brown) - Allow setting a false value or NULL in a might_have (Brad Bowman) 3.0.12 Nov 04 2005 - Use Clone instead of dclone for cloning meta info to reduce required perl version (Juan Camacho) and allow for closures (RT#15498) - Remove lots of old deprecations 3.0.11 Oct 23 2005 - search through a has_many can now take hash_ref - Fix documentation for SQL wildcards (RT#15145) 3.0.10 Oct 7 2005 - Set Storable::Deparse so that has_a subrefs can be cloned (Will Ross) - Use shorter version of mk_classdata - Include t/24 which was accidentally left out of MANIFEST in 3.0.9 3.0.9 Sep 23 2005 - Fixed bug with shared meta_info (Will Ross) - create() has been renamed to insert() to make it much clearer that it corresponds to an SQL INSERT rather than lots of different ideas as to what create() might mean. create() still (silently) works. It will give 'deprecated' warnings from 3.2.0 and will be removed no earlier than 3.4.0. The before/after create triggers have NOT been renamed yet as I'm rethinking some of that. We'll probably end up with more trigger points. Comments and suggestions welcome. 3.0.8 Sep 20 2005 - constraint exceptions now set their 'data' (Dan Collis Puro) - method created by has_many can now override method in parent class (reported by Christopher H. Laco) - factored out transform_sql for easier modification 3.0.7 Sep 17 2005 - Make Column responsible for accessor() and mutator() so they can be set up declaratively as well as programmatically (this means the second argument to accessor_name and mutator_name is now a Column object rather than its name, so you may need to check your case sensitivity) - Rename accessor/mutator_name to accessor/mutator_name_for - Document that order_by clauses in sort() are passed through - Make one-shot 'Essential' set up slightly more explicit in docs (Adam Kennedy) - Fix HasMany warning typo (argumemt) (Dan Friedman) - Remove obsolete SearchGenerator code which had leaked out 3.0.6 Sep 16 2005 - constrain_column can now take subref constraint - Document DBD::AnyData and FreeTDS issues (Matt Trout) - Factor out database error handling to _db_error() - Switch to Class::Accessor::Fast in Column and Relationship 3.0.5 Sep 14 2005 - has_many can take compile time constraints (Cees Hek) - has_many can take a cascading delete strategy (deprecating the old, undocumented, 'no_cascade_delete' option) - columns() can take Class::DBI::Column objects directly which can now in turn take options, thus allowing things like: __PACKAGE__->columns(dates => Class::DBI::Column->new( tdate => { placeholder => 'IF(1, CURDATE(), ?)' } ) 3.0.4 Sep 13 2005 Pre-Reqs - Note requirement for Scalar::Util 1.08+ (for refaddr) Refactorings - Move to pluggable Search interface (includes reworking of search approach per Tim Bunce) 3.0.3 Sep 11 2005 Bug Fixes - Ensure object is removed from index when delete()d (Tim Bunce) - clear_object_index when new relationship set up (Tim Bunce) - Fixed bug where PK values got auto-vivified (Tatsuhiko Miyagawa, Christopher L. Everett, Tim Bunce) - Removed 'AS' when aliasing tables; some databases don't like that - Properly return -1 from unchanged object updates (Kingsley Kerce) - Fixed problems with overloaded stringification of related classes (Tim Bunce) - Fixed bug where Essential might contain the PK twice Refactorings - Split live_object_key for easy subclassing (Tim Bunce) - Split out _as_hash() to return underlying data hash - Optimised _mk_column_accessors (Maurice Aubrey) - Don't hard-code relationship names (Peter Speltz) Internals - Changed error message when setting up has_a with incorrect column (Drew Taylor) Documentation - Fixed docs for after_update trigger and update (Kingsley Kerce) 3.0.2 Sep 11 2005 Code - No changes Pre-Reqs - Fixed code to explicitly need 5.6 (rather than just Makefile) - Require 'version' for new 3 part versions Tests - Fixed t/01 to check mutator_name better - Added NOT NULL to Primary in t/Blurb to avoid 0.95 regression - Added new Test base class Class::DBI::Test::SQLite - Changed all remaining uses of eq_set() to is_deeply() Documentation - Documented $obj->id() in list context (William McKee) - Documented cascading delete for might_have (Tom Hukins) - Documented MCFK better (plus fixed lots of typos etc) (Tom Hukins) - Documented DBIx::ContextualFetch better - select_val better (Dave Howorth) - Fixed misspelling of Perrin Harkins - Fixed documentation for the year constraint (Andy Lester) - Fixed set_sql documentation to explain when it creates a method - Fixed new_music documentation (Carl Johnstone) - Fixed docs for CD columns to show 'reldate' (Mark Thomas) - Fixed lots of other tiny doc issues - Fixed docs for Essential (defaults to Primary, rather than All) - Fixed docs for what gets passed to triggers (Ryan Tate) 3.0.1 Sep 11 2005 - Code is identical to 0.96 - New section added to documentation on Release Philosophy - Replace eq_set with is_deeply in t/04 to work around Test::More bug 3.0.0 UNRELEASED - IDENTICAL to 0.96. Only difference is version renumbering. 0.96 30 April 2004 New Functionality - Maintain live object index so subsequent requests for same row return the same object (Perrin Harkins) - connection() is now preferred over set_db() - New relationship architecture (see Class::DBI::Relationship) - meta_info now returns more information about relationships - search($column => undef) now does an ISNULL search (Bart Lateur, Drew Wilson, William McKee) - A slice of an iterator in scalar context now gives another iterator (Thomas Klausner) - Attribute methods can now take slices (Charles Bailey) - pass $self to inflation/deflation methods, allowing (amongst other things, cross-column processing in a custom method) (Charles Bailey) - deflation now happens at distinct trigger points that happen after normal before_create/update triggers (Dave Cash) - Columns may now set their placeholders: Foo->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)"); - Columns know if they have been constrained Documentation - add note about needing a RootClass (and fix tests for this) - Explain interaction of is_changed and auto-update (William McKee) - Better examples for select_val and sql_single (Paul Makepeace) - Add note about sprintf interpolation and wildcard searches in home-grown queries (Christopher L. Everett) - Mention the wiki Bug Fixes - Better error reporting from failed inflations [Tatsuhiko Miyagawa] - You can now have a column named 'first' [Tatsuhiko Miyagawa] - inflation and deflation handle edge cases better [Charles Bailey] - search_ methods are only generated for SELECT calls - add_constructor is now propery subclassable (Thomas Klausner) Deprecations - Class::DBI::Query is now deprecated. The SQL substitutions are a much better approach. - sort argument to has_many is now order_by to match search - __hasa_rels and __hasa_list are deprecated in favour of meta_info Other - construct() is no longer a protected method. - skip t/17 on error. There's a bug here I can't find, or fix, yet. 0.95 Fri Jan 9 2004 Pre-Requisites - Now requires Perl 5.6 or greater New Functionality - constrain_column() adds simple per-column constraints - has_many now attempts to work out the reference column by examining the foreign class's has_a() declarations, making the 3rd argument to has_many mostly obsolete. - __TABLE(Other::Class)__ now interpolates the table from the other class, allowing avoidance of hard-coding other table names. - __ESSENTIAL(alias)__ now prepends the table alias supplied to the start of each column name, for avoiding column name clashes. - __JOIN(alias alias)__ now inserts the SQL to join the two tables. - might_have now allows creating the remote object through a simple set of the accessor. [David Jack Olrik] - Iterators can now be reset() [Tatsuhiko Miyagawa] Documentation - count_all, maximum_value_of and minimum_value_of are now documented (along with how to implement similar methods) Bug Fixes - Allow retrieve() to take unnormalised columns, as with search [Connie] - Handle stringification before Primary Key(s) are filled - search() can take an overridden accessor name as a key - MultiColumn primary keys working better with ColumnGrouper [Perrin Harkins, Paul Makepeace, and Charles Bailey] Deprecations - _single_value_select and _single_row_select deprecated in favour of new select_val and select_row methods in Ima::DBI Other - Class::Accessor can no longer be used directly to add other attributes. TEMP columns should be used for this. - Ensure all croaks internally go through _croak() [Richard Piacentini] - deleted objects now blessed into Class::DBI::Object::Has::Been::Deleted - Lots of doc patches [Jesse Sheidlower, Paul Makepeace] - All internal attribute accesses now go through helper methods, as first step to changing how all this works. - set_sql now passes all arguments up to Ima::DBI (so you can turn off caching if required) [gfalck] - We now warn about column names clashing with any inherited methods, not just ones defined in Class::DBI itself [Dan Thill] - Silence some test warnings reported by Paul Makepeace 0.94 Wed Aug 27 2003 New Functionality - allow has_a() columns to hold NULL values (Dominic Mitchell) - cascading deletions can be turned off by passing argument to has_many setup: no_cascade_delete => 1 (undocumented/untested) [now implemented as a trigger] - classes and objects can be marked as read_only (experimental and undocumented, although tested) Documentation - no longer refer to Class::DBI::Join, which is dead - warn about inflating a primary key using has_a - rewrite of docs on transactions - numerous small tweaks from Jay Strauss, Alexander Karelas and Brad Bowman - redocument dbi_commit and dbi_rollback that have vanished... Bug Fixes - make sequences work again (Dominic Mitchell) [now with tests!] - interpolation of __TABLE__ etc now happens globally, rather than only once [Corion] - might_have now properly does a cascading delete - Fixed problem where we can't update an object which might_have a relationship, but doesn't. - might_have's tentative, but broken, support for MCPK has been removed. - Increase Class::Accessor pre-requisite to 0.18 to fix strange bug reported by Casey West. - Make sure we don't alter the hashref being passed to create() - The after_create() trigger is now called after the object is emptied, and will thus be able to see objects in has_a columns (by reloading from the DB) [If you were using this trigger to alter the columns to be cleaned out this can (for now) be done using the 'create' trigger, although that's deprecated. Let me know if you really need this ability. Deprecations - move() is deprecated. The concept is broken and will be removed unless someone convinces me to keep it. - normalize* are no longer necessary, due to the new Column objects, which store their normalized and unnormalize form. (Calling these will have no effect, other than a warning). - has_column deprecated in favour of find_column Other - init() now takes hash to instantiate with (Tim Bunce) - Rewrite of _require_class, with better short-circuiting and error message reporting (Tim Bunce) - new Class::DBI::Column to represent a column. Some functionality moved from ColumnGrouper to here. - mutator and accessor name overrides now stored in column, and not looked up every time. - attempt to trap and propogate all DBI failures 0.93 Wed Jul 2 2003 New Functionality - Multi-column primary keys are now supported. [with huge thanks to Tim Bunce] - New syntax for inbuilt SQL - classes can control stringification via as_string() and stringify_column(). - set_sql automatically translates __TABLE__, __ESSENTIAL__, and __IDENTIFIER__ Performance Improvements - use Storable's dclone() rather than Data::Dumper's deepcopy Documentation - document the order_by option to search() [Drew Taylor] - fix the documentation of the DBI connect string [Phil Crow] - document working with pre_create triggers - add a note on dynamically generating a database connection - avoid using (shift => $val) due to quoting issues! [Simon Wilcox] - refer to Class::DBI::Oracle for sequences [Jay Strauss] - give better explanation for construct() [Jay Strauss] - document get/set with multiple arguments [Jay Strauss] - more detailed description of arguments to has_a() Bug Fixes - Bug with setting driver defaults [Jay Strauss + Schwern] - Bug where selecting a column that was only in 'All' group also attempted to fetch any TEMP columns. [Dominic Mitchell] Removal of Functionality - Undocumented ordered_search method has been removed in favour of order_by option to search. - Undocumented make_filter method removed in favour of add_constructor - add_constructor no longer does (undocumented) %s substitutions - (undocumented) single_value_select() method no longer takes raw SQL fragments. 0.92 Sat Apr 12 2003 New Functionality - classes named after reserved SQL words can now supply a table_alias either directly, or as a second argument to table(). Deprecations - hasa() now calls has_a() with a warning. It will disappear completely in a forthcoming release. - issue warning on use of old hasa_list Bug Fixes - class data properly propagates (i.e. two classes can once again have has_a relationships of the same name) [Miyagawa + Marty] - only deflate columns that are changing on update. Other - croak if update() does not change exactly one row [Tim Bunce]. (Not yet live) - The Essential column group now defaults to Primary rather than All. 0.91 Sat Mar 8 2003 New Functionality - has_many can now take an extra set of search parameters at execution - has_many mapping method can now be a list - Class->delete(@search_args) deletes all results matching search criteria. - search can take a final hash of arguments. Currently the only one honoured is 'order_by' - searches deflate objects passed as search values as with has_a() - iterators can be slice()d - classes can provide their own iterators - columns in the TEMP column group will be non-persistent - set_sql automatically sets up a search_ method for that SQL - constraints can cross-check using new syntax, and per_column trigger points. - the after_update trigger can modify the list of changed columns to change refresh behaviour - Can delete via the iterator: $cd->artists->delete_all - New Class::DBI::Query module for dynamically constructing queries - Standardised exception handling (thanks to Tim Bunce) - on_failed_create no longer needed - overloading of objects - autoincrements work with SQLite Deprecations - commit() and autocommit() are now update() and autoupdate() - rollback() is now discard_changes() - hasa() now warns if used - trigger points create() and delete() warn when called - trigger point on_setting no longer exists Optimisation - has_a lazy inflates other Class::DBI instances - roll our own require rather than depending on UNIVERSAL::require (thanks to Tim Bunce) - Don't add __Changed = {} to every object on creation, just autovivify it on demand. (Tim) - Avoid calling $self->primary_column in a loop in create() (Tim) - Use fetchrow_arrayref instead of fetchrow_array. (Tim) - Return from _deflated_column earlier if value is not a ref. (Tim) - Use $sth->{NAME_lc} instead of $sth->{NAME}. (Tim) - Optmize _normalized and normalize. (Tim) - optimise various calls to columns() (Tim) - don't reflesh after an update - defer for lazy loading - Iterator no longer inherits from Class::DBI itself. Bug Fixes - has_many maps now work as iterators - columns only report as being in group 'All' if they're in no other columns (so lazy loading works in those cases!) - calling create with a primary key of zero no longer attempts to use auto_increment (Tim Bunce) Other - reference Class::DBI::AbstractSearch - retrieve_from_sql removes any leading 'WHERE' - inflate handles overloading better (thanks to Tim Bunce) - Avoid boolean test on object, use defined instead. - Tweak create() to prepare for possible caching of colmap info. - better documentation on transactions - test suite now uses DBD::SQLite instead of DBD::CSV - consolidated some test scripts 0.90 Wed Nov 27 GMT 2002 - hasa and associated_class merged (and deprecated) into has_a - has_many therefore no longer sets up reciprocal hasa - allow search() and search_like() to take multiple columns - added find_or_create() - add_constructor() is now preferred to make_filter() - added retrieve_from_sql() for inline SQL - documented running arbitrary SQL and using sth_to_objects to convert these to objects. (Making sth_to_objects public too) - has_many can now call a mapping method on the results (for simpler many-to-many joins, for example) - has_many adds an 'add_to_' method e.g. CD->has_many(tracks => Track); now adds not just 'tracks' method, but also 'add_to_tracks'. (thanks to Michael Styer) - try to guess table name if none given - speed up iterators (thanks to Tom Renfro) - added (undocumented) data_type method (thanks to Tatsuhiko Miyagawa) - renamed column_type() to associated_class() - added references to Class::DBI::SQLite, Class::DBI::Pg, and Class::Join - before_create trigger can now modify object itself - uses UNIVERSAL::require instead of rolling our own - marked primary_key(), is_column(), add_hook() as deprecated - changed _ids_to_objects to receieve listref, rather than list to cope with weird bug in 5.005_03 (thanks to Tatsuhiko Miyagawa) - warn if column name clashes with built-in method - third argument to has_many is now optional, defaulting to our 'class-name' (undocumented) - provide normalised method names if appropriate (i.e. a Film column will give us methods $obj->Film and $obj->film). This previously happened inconsistently. - split most of the column related code to Class::DBI::Columns - remove dependency on Class::Fields - reference the new Class::DBI mailing lists - Give better errors if no database connection set up (thanks to Simon Cozens) - A failed create now calls $class->on_failed_create, which by default dies, but can be made to do whatever you like. 0.89 Mon Jun 24 2002 - allow has_many to not have a relationship (Thanks to Brian Parker) - renamed (undocumented) min() and max() to minimum_value_of() and maximum_value_of() - croak() and carp() deprecated in favour of _croak() and _carp() - primary() and essential() deprecated in favour of primary_key() and _essential()/columns(essential); - normalize_one() deprecated in favour of _normalize_one - If a 'might-have' link points to nothing, don't give a 'Can't call method' error - better reporting on errors from create etc. - better reporting when you incorrectly set through hasa() - handle primary/foreign key value of zero better (reported by Jim O'Brien) - added (undocumented) 'column_type' based on ideas from Matthew Simon Cavalletto and Tatsuhiko Miyagawa. - brought delete triggers in line with documentation (reported by Barry Hoggard, fixed by Tatsuhiko Miyagawa) 0.88 Beltane 2000 - fix for hasa() and create() with modified accessor/mutator names (Thanks to Schwern) 0.87 Fri Mar 29 2002 * added might_have method - better MySQL autoincrement code (fixes occassional problems under mod_perl) [Thanks to Tatsuhiko Miyagawa] - fixed a test that was failing on 5.005 (but not 5.6.1) due to weird interaction between overloaded iterator and Test::More's ok() prototype [Thanks to Tatsuhiko Miyagawa] 0.86 Fri Mar 8 GMT 2002 * removed support for pseudo-hashes * hasa_list is now has_many (although has_many still exists for backwards compatability) + has_many auto-generates reciprocal hasa decalaration (unless called as hasa_list, or with { nohasa => 1 }) * searches now return iterators when used in scalar context - hooks are now called 'triggers' (using Class::Trigger) * new trigger for SELECT * added basic constraints + added support for filters on the same column (%s >= ? OR %s <= ?) + added 'between' filter which provides this - deal better with the case where the only column group is 'All' - much internal twiddly stuff 0.36 Wed Nov 28 2001 + tests no loner die horribly if you don't have MySQL installed - minor tweaks to some error messages - bugfixes for problems with auto-deleting objects - bugfix for mis-normalized accessor warning (thanks to Schwern) 0.35 Sun Oct 7 2001 + added hooks for create, update and delete - split commit() for easier subclassing 0.34 Sat Oct 6 2001 - Don't die if a value is a reference. (Ima::DBI does this for us, and better in case of overloaded objects) - fix minor problem with mutual hasa / hasa_list referencing - better diagnostics if hasa_list is miscalled 0.33 Sat Sep 15 2001 + Added create_filter(), and with it retrieve_all() + added docs on how to set-up many-to-many relationships + _cascade delete now split out to allow overriding + copy() and move() can now take multiple arguments to change (thanks to Jonathan Swartz) 0.32 Sun Sep 9 2001 + delete() now removes any foreign elements, to avoid orphans 0.31 Sun Sep 9 2001 + split out _column_placeholder (thanks to Jonathan Swartz) + added hasa() checks for orphaned rows 0.29 Wed Sep 5 10:24:54 BST 2001 + split docs into Class::DBI::Tutorial + renamed is_column to has_column (is_column still provided as alias) + added accessor_name and mutator_name form template methods - _load_class didn't work. Now fixed. - _next_in_sequence was broken, and would warn even if it wasn't. - better diagnostics when you call retrieve incorrectly 0.28 Wed Aug 29 20:02:28 BST 2001 + Tony Bowden took over maintenance * Added hasa_list - Fixed bug with inherited columns (reported by Boris Mouzykantskii) - move() and copy() were broken with auto_increments. Now fixed. - set() did bad things if you'd set up new fields with mk_accessors (reported by Boris Mouzykantskii). Now fixed. - Better errors when calling create() incorrectly - Split tests into distinct files (DBD::CSV now required) - General internal tidying 0.27 Mon Apr 23 09:04:51 BST 2001 * Class::DBI->new() deprecated in favor of create() - Fixed the 'Primary before All' bug reported by Tony Bowden 0.26 Mon Apr 9 14:32:17 BST 2001 - Class->columns('All', @cols) now assumes the first column to be your primary. - Class->columns('Essential', @cols) now automatically includes the primary column. * move() was broken. Works and tested. - Updated our base requirement to get at its bugfix - Updated our Ima::DBI requirement to get at commit() and rollback() * Documented construct() * Added docs about transactions * Added dbi_commit() and dbi_rollback() - Added docs about Class::DBI and mod_perl 0.25 Wed Jan 10 01:54:27 EST 2001 - The new ID is now optional for copy() * Added move() to move objects between classes/databases. - Updated PG's default attributes. - Made the way classes are loaded with hasa() safer 0.24 Thu Oct 5 19:07:21 EDT 2000 *UNRELEASED* - Fixed some $@ naughtiness. Errors should propigate properly. * Added default database attributes for Pg, MySQL, Oracle, DBD::CSV and DBD::RAM. Class::DBI should work out of the box with them now. 0.23 Tue Sep 12 00:33:38 EDT 2000 - rollback() needed to normalize its data (thanks to Greg Bartlett) 0.22 Sun Sep 10 05:36:51 GMT 2000 *UNRELEASED* - Added a warning if the primary column is not in the essential group 0.21 Sun Sep 10 01:03:01 EDT 2000 *UNRELEASED* - Now requiring Ima::DBI 0.24 - sequence() fixed, tested and working - Now working with DBD::Pg and PostgreSQL 7.0 0.20 Sun Sep 10 00:29:15 EDT 2000 *UNRELEASED* - *bug_fix* is_column() died if false. 0.19 Fri Sep 8 15:07:49 EDT 2000 - Forgot to update the Changes file. 0.18 Fri Sep 9 18:51:45 GMT 2000 * new() now accepts Class::DBI objects as values - hasa() is now inherited properly - normalize() will now take an empty array 0.17 Mon Sep 4 02:46:25 GMT 2000 *UNRELEASED* - Docs forgot to turn AutoCommit on in MySQL examples - Documented the behavior of new() and AUTO_INCREMENT - Added support for sequences. *Untested* - *bug fix* columns() can now be added after the class has been used - *bug fix* Columns added by hasa() had a chance of overwriting each other. 0.16 Sun Sep 3 17:49:08 GMT 2000 *UNRELEASED* * hasa() will now attempt to require the foreign class for you * hasa() will setup the necessary columns for you. 0.15 Sun Jul 16 23:14:20 PDT 2000 - Fixed minor bug in DESTROY message. * Added hasa() object relationships. 0.14 Sun Jul 9 05:25:53 EDT 2000 - Pseudohashes as objects now work and basicly tested - The rollback() mechanism changed to use less memory. - Expanded the TODO list 0.13 Wed May 24 02:45:43 EDT 2000 - Accessors were not being generated properly in certain cases. 0.12 Tue May 23 ish... * Unreleased* 0.11 - Aborted attempts to fix accessor misgeneration. 0.10 Thu May 18 00:59:34 EDT 2000 - new() was not working with objects which autogenerated primary keys 0.09 Tue May 2 00:42:06 EDT 2000 - README, INSTALL and Makefile.PL have been updated 0.08 Mon May 1 20:27:13 EDT 2000 - Documented lazy column population. 0.07 Mon May 1 02:18:20 EDT 2000 * Unreleased * * Added lazy population of columns. - columns('All') can now be autogenerated. 0.06 Mon May 1 00:56:52 EDT 2000 * Unreleased * * **API CHANGE** make_sql() is gone in favor of set_sql() * normalization has been added in all the right places. - retreive now handles autoincremented primary keys. - columns() internally normalizes column names. 0.05 Sat Apr 15 01:48:25 EDT 2000 * MAJOR BUG - simple subclasses of subclasses of Class::DBI would not work. This has been fixed. * Autoloader eliminated. * API CHANGE - columns must now be explictly declared, the class's public data members are not used. That was silly. * rollback() now works. - is_changed() now returns a list of changed columns 0.03 Mon Dec 20 10:04:23 EST 1999 * MAJOR BUG - commit() was not committing!!! * added is_changed() - columns('Essential') now autogenerated from columns('All') if not already present. - columns('Essential') is now prefered for most SELECT statements instead of just columns(). 0.02 * First working version * First version sent to CPAN Class-DBI-v3.0.17/MANIFEST.SKIP0000644000175200017520000000055410311003120014060 0ustar tonytony# Avoid version control files. \bRCS\b \bCVS\b ,v$ ,B$ ,D$ \B\.svn\b aegis.log$ \bconfig$ \bbuild$ # Avoid Makemaker generated and utility files. \bMakefile$ \bblib \bMakeMaker-\d \bpm_to_blib$ \bblibdirs$ # Avoid Module::Build generated and utility files. \bBuild$ \b_build # Avoid temp and backup files. ~$ \.gz$ \.old$ \.bak$ \.swp$ \.tdy$ \.ERR$ \#$ \b\.# Class-DBI-v3.0.17/Makefile.PL0000444000175200017520000000542310332622530014151 0ustar tonytony use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. $PACKAGE = 'Class::DBI'; ($PACKAGE_FILE) = $PACKAGE =~ /::([^:]+)/; $LAST_API_CHANGE = 0.93; require 5.006; eval "require $PACKAGE"; unless ($@) { # Make sure we did find the module. print <<"CHANGE_WARN" if ${$PACKAGE.'::VERSION'} < $LAST_API_CHANGE; NOTE: There have been API changes between this version and any older than version $LAST_API_CHANGE! Please check carefully if you are upgrading from a version older than $LAST_API_CHANGE. Significant changes: 0.95 - Breaking the encapsulation of an object (e.g. assuming that the value for the 'title' column will be stored internally in $object->{'title'} will stop working in a forthcoming release. Relying on this behaviour is a Bad Thing, and you should fix it now! (This also applies to before_create triggers, where previously it was the supported approach.) 0.93 - Undocumented ordered_search() method no longer exists - Undocumented make_filter() method no longer exists - Undocumented option for add_constructor to do %s subitutions removed - single_value_select() no longer takes raw SQL fragments 0.91 - on_setting() trigger point replaced by new individual column triggers (see documentation on constraints) - runtime database errors now throw exceptions - all errors standardised so on_failed_create no longer needed - objects now overload in string or boolean context 0.90 - hasa is now deprecated in favour of has_a. Therefore has_many no longer creates reciprocal hasa relationship. 0.85 - Class::DBI no longer supports pseudo-hash based objects - hasa_list is now deprecated in favour of has_many - has_many auto-creates a reciprocal hasa relationship 0.32 - delete() now removes any foreign elements, to avoid orphans CHANGE_WARN } sub MY::postamble { # DBD_PG_USER=tony make cover return <<'' cover: rm -rf cover_db PERL5OPT=-MDevel::Cover \$(MAKE) test || true cover cover_db -report html } WriteMakefile( NAME => $PACKAGE, VERSION_FROM => 'lib/Class/DBI.pm', PREREQ_PM => { 'Class::Accessor' => '0.18', 'Class::Data::Inheritable' => '0.02', 'Class::Trigger' => '0.07', 'File::Temp' => '0.12', 'Ima::DBI' => '0.33', 'List::Util' => '1.00', 'Scalar::Util' => '1.08', 'Clone' => 0, 'Test::More' => '0.47', 'UNIVERSAL::moniker' => '0.06', 'version' => 0, }, dist => { COMPRESS => 'gzip -9', SUFFIX => '.gz', DIST_DEFAULT => 'all tardist', }, ); Class-DBI-v3.0.17/META.yml0000644000175200017520000000134610701255372013460 0ustar tonytony# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Class-DBI version: v3.0.17 version_from: lib/Class/DBI.pm installdirs: site requires: Class::Accessor: 0.18 Class::Data::Inheritable: 0.02 Class::Trigger: 0.07 Clone: 0 File::Temp: 0.12 Ima::DBI: 0.33 List::Util: 1.00 Scalar::Util: 1.08 Test::More: 0.47 UNIVERSAL::moniker: 0.06 version: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01 Class-DBI-v3.0.17/MANIFEST0000644000175200017520000000254410471701444013341 0ustar tonytonyChanges lib/Class/DBI.pm lib/Class/DBI/Attribute.pm lib/Class/DBI/Cascade/Delete.pm lib/Class/DBI/Cascade/Fail.pm lib/Class/DBI/Cascade/None.pm lib/Class/DBI/Column.pm lib/Class/DBI/ColumnGrouper.pm lib/Class/DBI/Iterator.pm lib/Class/DBI/Query.pm lib/Class/DBI/Relationship.pm lib/Class/DBI/Relationship/HasA.pm lib/Class/DBI/Relationship/HasMany.pm lib/Class/DBI/Relationship/MightHave.pm lib/Class/DBI/Search/Basic.pm lib/Class/DBI/SQL/Transformer.pm lib/Class/DBI/Test/SQLite.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) README t/01-columns.t t/02-Film.t t/03-subclassing.t t/04-lazy.t t/05-Query.t t/06-hasa.t t/08-inheritcols.t t/09-has_many.t t/10-mysql.t t/11-triggers.t t/12-filter.t t/13-constraint.t t/14-might_have.t t/15-accessor.t t/16-reserved.t t/17-data_type.t t/18-has_a.t t/19-set_sql.t t/21-iterator.t t/22-deflate_order.t t/23-cascade.t t/24-meta_info.t t/25-closures_in_meta.t t/26-mutator.t t/27-mutator-old.t t/97-pod.t t/98-failure.t t/99-misc.t t/testlib/Actor.pm t/testlib/Binary.pm t/testlib/Blurb.pm t/testlib/CDBase.pm t/testlib/Director.pm t/testlib/Film.pm t/testlib/Lazy.pm t/testlib/Log.pm t/testlib/MyBase.pm t/testlib/MyFilm.pm t/testlib/MyFoo.pm t/testlib/MyStar.pm t/testlib/MyStarLink.pm t/testlib/MyStarLinkMCPK.pm t/testlib/Order.pm t/testlib/OtherFilm.pm t/testlib/PgBase.pm