From: Matt S Trout Date: Sun, 31 Jul 2005 22:20:42 +0000 (+0000) Subject: Refactoring, basic cursor support, additional syntax supported by HasMany X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=95a70f01eae4b2c325a3a527a72cf8ae91796e8c;p=dbsrgits%2FDBIx-Class-Historic.git Refactoring, basic cursor support, additional syntax supported by HasMany --- diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index 1a2103b..aa88e4b 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -3,13 +3,11 @@ package DBIx::Class::CDBICompat; use strict; use warnings; -use base qw/DBIx::Class::CDBICompat::Convenience - DBIx::Class::CDBICompat::Triggers +use base qw/DBIx::Class::CDBICompat::Triggers DBIx::Class::CDBICompat::GetSet DBIx::Class::CDBICompat::LiveObjectIndex DBIx::Class::CDBICompat::AttributeAPI DBIx::Class::CDBICompat::Stringify - DBIx::Class::CDBICompat::ObjIndexStubs DBIx::Class::CDBICompat::DestroyWarning DBIx::Class::CDBICompat::Constructor DBIx::Class::CDBICompat::AccessorMapping @@ -21,6 +19,7 @@ use base qw/DBIx::Class::CDBICompat::Convenience DBIx::Class::CDBICompat::ColumnGroups DBIx::Class::CDBICompat::ImaDBI/; + #DBIx::Class::CDBICompat::ObjIndexStubs 1; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/Convenience.pm b/lib/DBIx/Class/CDBICompat/Convenience.pm deleted file mode 100644 index 23ff2ed..0000000 --- a/lib/DBIx/Class/CDBICompat/Convenience.pm +++ /dev/null @@ -1,18 +0,0 @@ -package DBIx::Class::CDBICompat::Convenience; - -use strict; -use warnings; - -sub find_or_create { - my $class = shift; - my $hash = ref $_[0] eq "HASH" ? shift: {@_}; - my ($exists) = $class->search($hash); - return defined($exists) ? $exists : $class->create($hash); -} - -sub retrieve_all { - my ($class) = @_; - return $class->retrieve_from_sql( '1' ); -} - -1; diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm index f96cf9c..4bf3449 100644 --- a/lib/DBIx/Class/CDBICompat/HasMany.pm +++ b/lib/DBIx/Class/CDBICompat/HasMany.pm @@ -5,28 +5,42 @@ use warnings; sub has_many { my ($class, $rel, $f_class, $f_key, $args) = @_; - #die "No such column ${col}" unless $class->_columns->{$col}; + + my $self_key; + + if (ref $f_class eq 'ARRAY') { + ($f_class, $self_key) = @$f_class; + } + + if (!$self_key || $self_key eq 'id') { + my ($pri, $too_many) = keys %{ $class->_primaries }; + die "has_many only works with a single primary key; ${class} has more" + if $too_many; + $self_key = $pri; + } + eval "require $f_class"; - my ($pri, $too_many) = keys %{ $class->_primaries }; - die "has_many only works with a single primary key; ${class} has more" - if $too_many; + if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; }; + #unless ($f_key) { Not selective enough. Removed pending fix. # ($f_rel) = grep { $_->{class} && $_->{class} eq $class } # $f_class->_relationships; #} + unless ($f_key) { #warn join(', ', %{ $f_class->_columns }); $class =~ /([^\:]+)$/; #warn $1; $f_key = lc $1 if $f_class->_columns->{lc $1}; } + die "Unable to resolve foreign key for has_many from ${class} to ${f_class}" unless $f_key; die "No such column ${f_key} on foreign class ${f_class}" unless $f_class->_columns->{$f_key}; $class->add_relationship($rel, $f_class, - { "foreign.${f_key}" => "self.${pri}" }, + { "foreign.${f_key}" => "self.${self_key}" }, { _type => 'has_many', %{$args || {}} } ); { no strict 'refs'; @@ -49,7 +63,9 @@ sub delete { my @hm = grep { $rels{$_}{attrs}{_type} && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels; foreach my $has_many (@hm) { - $_->delete for $self->search_related($has_many); + unless ($rels{$has_many}->{attrs}{no_cascade_delete}) { + $_->delete for $self->search_related($has_many) + } } return $ret; } diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index afaf27b..2134154 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -41,7 +41,7 @@ sub _populate_dbh { sub _dbi_connect { my ($class, @info) = @_; - return DBI->connect_cached(@info); + return DBI->connect(@info); } sub connection { diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index 08d499f..1ae5331 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Tie::IxHash; -use base qw/Class::Data::Inheritable DBIx::Class::SQL/; +use base qw/Class::Data::Inheritable/; __PACKAGE__->mk_classdata('_primaries' => {}); diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm index 80d3516..2c5adbf 100644 --- a/lib/DBIx/Class/SQL.pm +++ b/lib/DBIx/Class/SQL.pm @@ -46,7 +46,7 @@ sub _get_sql { sub _sql_to_sth { my ($class, $sql) = @_; - return $class->_get_dbh->prepare_cached($sql); + return $class->_get_dbh->prepare($sql); } sub _get_sth { diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm index aacbe0b..d7d67a8 100644 --- a/lib/DBIx/Class/Table.pm +++ b/lib/DBIx/Class/Table.pm @@ -3,7 +3,9 @@ package DBIx::Class::Table; use strict; use warnings; -use base qw/Class::Data::Inheritable DBIx::Class::SQL/; +use DBIx::Class::Cursor; + +use base qw/Class::Data::Inheritable/; __PACKAGE__->mk_classdata('_columns' => {}); @@ -11,6 +13,8 @@ __PACKAGE__->mk_classdata('_table_name'); __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do anything yet! +__PACKAGE__->mk_classdata('_cursor_class' => 'DBIx::Class::Cursor'); + =head1 NAME DBIx::Class::Table - Basic table methods @@ -164,13 +168,10 @@ sub retrieve_from_sql { sub sth_to_objects { my ($class, $sth, $args, $cols) = @_; my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} ); - $sth->execute(@$args); - my @found; - while (my @row = $sth->fetchrow_array) { - push(@found, $class->_row_to_object(\@cols, \@row)); - } - $sth->finish; - return @found; + my $cursor_class = $class->_cursor_class; + eval "use $cursor_class;"; + my $cursor = $cursor_class->new($class, $sth, $args, \@cols); + return (wantarray ? $cursor->all : $cursor); } sub _row_to_object { # WARNING: Destructive to @$row @@ -228,6 +229,18 @@ sub table { shift->_table_name(@_); } +sub find_or_create { + my $class = shift; + my $hash = ref $_[0] eq "HASH" ? shift: {@_}; + my ($exists) = $class->search($hash); + return defined($exists) ? $exists : $class->create($hash); +} + +sub retrieve_all { + my ($class) = @_; + return $class->retrieve_from_sql( '1' ); +} + 1; =back diff --git a/t/cdbi-t/12-filter.t b/t/cdbi-t/12-filter.t index a51d34d..bce6e6f 100644 --- a/t/cdbi-t/12-filter.t +++ b/t/cdbi-t/12-filter.t @@ -93,12 +93,11 @@ is $@, '', "No errors"; # Iterators #---------------------------------------------------------------------- -SKIP: { - skip "Compat layer doesn't have iterator support yet", 33; +my $it_class = 'DBIx::Class::Cursor'; sub test_normal_iterator { my $it = $film->actors; - isa_ok $it, "Class::DBI::Iterator"; + isa_ok $it, $it_class; is $it->count, 3, " - with 3 elements"; my $i = 0; while (my $film = $it->next) { @@ -112,7 +111,7 @@ test_normal_iterator; { Film->has_many(actor_ids => [ Actor => 'id' ]); my $it = $film->actor_ids; - isa_ok $it, "Class::DBI::Iterator"; + isa_ok $it, $it_class; is $it->count, 3, " - with 3 elements"; my $i = 0; while (my $film_id = $it->next) { @@ -125,6 +124,10 @@ test_normal_iterator; # make sure nothing gets clobbered; test_normal_iterator; +SKIP: { + skip "dbic iterators don't support slice yet", 12; + + { my @acts = $film->actors->slice(1, 2); is @acts, 2, "Slice gives 2 actor"; diff --git a/t/cdbi-t/21-iterator.t b/t/cdbi-t/21-iterator.t new file mode 100644 index 0000000..7a88f43 --- /dev/null +++ b/t/cdbi-t/21-iterator.t @@ -0,0 +1,83 @@ +use 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; + +my $it_class = "DBIx::Class::Cursor"; + +my @film = ( + Film->create({ Title => 'Film 1' }), + Film->create({ Title => 'Film 2' }), + Film->create({ Title => 'Film 3' }), + Film->create({ Title => 'Film 4' }), + Film->create({ Title => 'Film 5' }), + Film->create({ Title => 'Film 6' }), +); + +{ + my $it1 = Film->retrieve_all; + isa_ok $it1, $it_class; + + my $it2 = Film->retrieve_all; + isa_ok $it2, $it_class; + + 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"; +} + +SKIP: { + skip "Iterator doesn't yet have slice support", 19; + +{ + 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, $it_class, "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"; +} + +} # End SKIP