From: Matt S Trout Date: Thu, 21 Jul 2005 12:31:03 +0000 (+0000) Subject: First of a two-parter :) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=510ca9120ab2fea50a0852ee4ed6a13735ed7ebc;p=dbsrgits%2FDBIx-Class-Historic.git First of a two-parter :) --- diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index 2380191..fc30d0a 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -4,13 +4,17 @@ use strict; use warnings; use base qw/DBIx::Class::CDBICompat::Convenience + DBIx::Class::CDBICompat::Triggers + DBIx::Class::CDBICompat::GetSet + DBIx::Class::CDBICompat::AttributeAPI DBIx::Class::CDBICompat::Stringify DBIx::Class::CDBICompat::ObjIndexStubs DBIx::Class::CDBICompat::DestroyWarning DBIx::Class::CDBICompat::Constructor - DBIx::Class::CDBICompat::AutoUpdate DBIx::Class::CDBICompat::AccessorMapping DBIx::Class::CDBICompat::ColumnCase + DBIx::Class::CDBICompat::LazyLoading + DBIx::Class::CDBICompat::AutoUpdate DBIx::Class::CDBICompat::ColumnGroups DBIx::Class::CDBICompat::ImaDBI/; diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index cdfd851..e5703c9 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -8,7 +8,7 @@ use NEXT; sub _mk_column_accessors { my ($class, @cols) = @_; unless ($class->can('accessor_name') || $class->can('mutator_name')) { - return $class->NEXT::_mk_column_accessors(@cols); + return $class->NEXT::_mk_column_accessors('column' => @cols); } foreach my $col (@cols) { my $ro_meth = ($class->can('accessor_name') @@ -18,10 +18,10 @@ sub _mk_column_accessors { ? $class->mutator_name($col) : $col); if ($ro_meth eq $wo_meth) { - $class->mk_accessors($col); + $class->mk_group_accessors('column' => $col); } else { - $class->mk_ro_accessors($ro_meth); - $class->mk_wo_accessors($wo_meth); + $class->mk_group_ro_accessors('column' => $ro_meth); + $class->mk_group_wo_accessors('column' => $wo_meth); } } } diff --git a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm index e61e167..f576276 100644 --- a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm +++ b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm @@ -7,10 +7,11 @@ use base qw/Class::Data::Inheritable/; __PACKAGE__->mk_classdata('__AutoCommit'); -sub set { +sub set_column { my $self = shift; - $self->NEXT::set(@_); + my $ret = $self->NEXT::set_column(@_); $self->update if ($self->autoupdate && $self->{_in_database}); + return $ret; } sub autoupdate { diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index fe9084a..e5c23d8 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -14,14 +14,19 @@ sub _register_columns { return $class->NEXT::_register_columns(map lc, @cols); } -sub get { +sub get_column { my ($class, $get, @rest) = @_; - return $class->NEXT::get(lc $get, @rest); + return $class->NEXT::get_column(lc $get, @rest); } -sub set { +sub set_column { my ($class, $set, @rest) = @_; - return $class->NEXT::set(lc $set, @rest); + return $class->NEXT::set_column(lc $set, @rest); +} + +sub store_column { + my ($class, $set, @rest) = @_; + return $class->NEXT::store_column(lc $set, @rest); } sub find_column { @@ -29,12 +34,12 @@ sub find_column { return $class->NEXT::find_column(lc $col); } -sub _mk_accessors { - my ($class, $type, @fields) = @_; +sub _mk_group_accessors { + my ($class, $type, $group, @fields) = @_; my %fields; $fields{$_} = 1 for @fields, map lc, grep { !defined &{"${class}::${_}"} } @fields; - return $class->NEXT::_mk_accessors($type, keys %fields); + return $class->NEXT::_mk_group_accessors($type, $group, keys %fields); } 1; diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 1c32842..ed5a967 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -8,47 +8,44 @@ use base qw/Class::Data::Inheritable/; __PACKAGE__->mk_classdata('_column_groups' => { }); -sub table { - shift->_table_name(@_); -} - sub columns { my $proto = shift; my $class = ref $proto || $proto; my $group = shift || "All"; - $class->_set_column_group($group => @_) if @_; + $class->_add_column_group($group => @_) if @_; return $class->all_columns if $group eq "All"; return $class->primary_column if $group eq "Primary"; return keys %{$class->_column_groups->{$group}}; } -sub _set_column_group { +sub _add_column_group { my ($class, $group, @cols) = @_; $class->_register_column_group($group => @cols); - #$class->_register_columns(@cols); - #$class->_mk_column_accessors(@cols); - $class->set_columns(@cols); + $class->add_columns(@cols); } sub _register_column_group { my ($class, $group, @cols) = @_; if ($group eq 'Primary') { - $class->set_primary(@cols); + $class->set_primary_key(@cols); } my $groups = { %{$class->_column_groups} }; if ($group eq 'All') { - unless ($class->_column_groups->{'Primary'}) { + unless (exists $class->_column_groups->{'Primary'}) { $groups->{'Primary'}{$cols[0]} = {}; - $class->_primaries({ $cols[0] => {} }); + $class->set_primary_key($cols[0]); } - unless ($class->_column_groups->{'Essential'}) { + unless (exists $class->_column_groups->{'Essential'}) { $groups->{'Essential'}{$cols[0]} = {}; } } $groups->{$group}{$_} ||= {} for @cols; + if ($group eq 'Essential') { + $groups->{$group}{$_} ||= {} for keys %{ $class->_primaries || {} }; + } $class->_column_groups($groups); } diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index ed08c93..36f66b0 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -29,10 +29,24 @@ sub set_sql { sub { my $sql = $sql; my $class = shift; - my $table = $class->_table_name; - $sql =~ s/__TABLE__/$table/; - return $class->_sql_to_sth(sprintf($sql, @_)); + return $class->_sql_to_sth($class->transform_sql($sql, @_)); }; + if ($sql =~ /select/i) { + my $meth = "sql_${name}"; + *{"${class}::search_${name}"} = + sub { + my ($class, @args) = @_; + $class->sth_to_objects($class->$meth, \@args); + }; + } +} + +sub transform_sql { + my ($class, $sql, @args) = @_; + my $table = $class->_table_name; + $sql =~ s/__TABLE__/$table/g; + $sql =~ s/__ESSENTIAL__/join(' ', $class->columns('Essential'))/eg; + return sprintf($sql, @args); } 1; diff --git a/lib/DBIx/Class/CDBICompat/Stringify.pm b/lib/DBIx/Class/CDBICompat/Stringify.pm index 6ba9310..7a7ea7b 100644 --- a/lib/DBIx/Class/CDBICompat/Stringify.pm +++ b/lib/DBIx/Class/CDBICompat/Stringify.pm @@ -15,7 +15,7 @@ sub stringify_self { my $self = shift; my @cols = $self->columns('Stringify'); @cols = $self->primary_column unless @cols; - my $ret = join "/", map { $self->get($_) } @cols; + my $ret = join "/", map { $self->get_column($_) } @cols; return $ret || ref $self; } diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 8855123..14b5367 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -6,6 +6,7 @@ use warnings; use base qw/DBIx::Class::PK DBIx::Class::Table DBIx::Class::SQL - DBIx::Class::DB/; + DBIx::Class::DB + DBIx::Class::AccessorGroup/; 1; diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index 1163725..2725ff9 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -17,7 +17,7 @@ sub _ident_values { return (map { $self->{_column_data}{$_} } keys %{$self->_primaries}); } -sub set_primary { +sub set_primary_key { my ($class, @cols) = @_; my %pri; $pri{$_} = {} for @cols; @@ -42,4 +42,10 @@ sub retrieve { return ($class->search($query))[0]; } +sub discard_changes { + my ($self) = @_; + delete $self->{_dirty_columns}; + $_[0] = $self->retrieve($self->id); +} + 1; diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm index 511f19b..9873ce4 100644 --- a/lib/DBIx/Class/Table.pm +++ b/lib/DBIx/Class/Table.pm @@ -3,7 +3,7 @@ package DBIx::Class::Table; use strict; use warnings; -use base qw/Class::Data::Inheritable Class::Accessor DBIx::Class::SQL/; +use base qw/Class::Data::Inheritable DBIx::Class::SQL/; __PACKAGE__->mk_classdata('_columns' => {}); @@ -16,10 +16,9 @@ sub new { if ($attrs) { die "attrs must be a hashref" unless ref($attrs) eq 'HASH'; while (my ($k, $v) = each %{$attrs}) { - $new->set($k => $v); + $new->store_column($k => $v); } } - $new->{_dirty_columns} = {}; return $new; } @@ -76,28 +75,26 @@ sub delete { return $self; } -sub discard_changes { - my ($self) = @_; - $_[0] = $self->retrieve($self->id); -} - -sub get { +sub get_column { my ($self, $column) = @_; die "Can't fetch data as class method" unless ref $self; - #die "No such column '${column}'" unless $self->_columns->{$column}; + die "No such column '${column}'" unless $self->_columns->{$column}; return $self->{_column_data}{$column} if $self->_columns->{$column}; - return shift->SUPER::get(@_); } -sub set { +sub set_column { + my $self = shift; + my ($column) = @_; + my $ret = $self->store_column(@_); + $self->{_dirty_columns}{$column} = 1; + return $ret; +} + +sub store_column { my ($self, $column, $value) = @_; - #die "No such column '${column}'" unless $self->_columns->{$column}; - #die "set_column called for ${column} without value" if @_ < 3; - if ($self->_columns->{$column}) { - $self->{_dirty_columns}{$column} = 1; - return $self->{_column_data}{$column} = $value; - } - return shift->SUPER::set(@_); + die "No such column '${column}'" unless $self->_columns->{$column}; + die "set_column called for ${column} without value" if @_ < 3; + return $self->{_column_data}{$column} = $value; } sub _register_columns { @@ -109,10 +106,10 @@ sub _register_columns { sub _mk_column_accessors { my ($class, @cols) = @_; - $class->mk_accessors(@cols); + $class->mk_group_accessors('column' => @cols); } -sub set_columns { +sub add_columns { my ($class, @cols) = @_; $class->_register_columns(@cols); $class->_mk_column_accessors(@cols); @@ -123,13 +120,18 @@ sub retrieve_from_sql { $cond =~ s/^\s*WHERE//i; my @cols = $class->_select_columns; my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond); - $sth->execute(@vals); + return $class->sth_to_objects($sth, \@vals, \@cols); +} + +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) { my $new = $class->new; - $new->set($_, shift @row) for @cols; + $new->store_column($_, shift @row) for @cols; $new->{_in_database} = 1; - $new->{_dirty_columns} = {}; push(@found, $new); } return @found; @@ -156,7 +158,7 @@ sub _select_columns { sub copy { my ($self, $changes) = @_; my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self); - $new->set($_ => $changes->{$_}) for keys %$changes; + $new->set_column($_ => $changes->{$_}) for keys %$changes; return $new->insert; } @@ -171,4 +173,8 @@ sub _where_from_hash { return ($cond, [ values %$query ]); } +sub table { + shift->_table_name(@_); +} + 1; diff --git a/t/01-columns.t b/t/01-columns.t index ca1040e..6b3346c 100644 --- a/t/01-columns.t +++ b/t/01-columns.t @@ -95,7 +95,7 @@ ok(!State->find_column('HGLAGAGlAG'), '!find_column HGLAGAGlAG'); my @grps = sort State->__grouper->groups_for(State->_find_columns(qw/rain capital/)); is @grps, 2, "Rain and Capital = 2 groups"; - my @grps = sort @grps; # Because DBIx::Class is hash-based + @grps = sort @grps; # Because DBIx::Class is hash-based is $grps[0], 'Other', " - Other"; is $grps[1], 'Weather', " - Weather"; } diff --git a/t/02-Film.t b/t/02-Film.t index 97505ba..bec54a2 100644 --- a/t/02-Film.t +++ b/t/02-Film.t @@ -238,6 +238,7 @@ is($btaste->Director, $orig_director, 'discard_changes()'); $btaste3->NumExplodingSheep(13); } is @warnings, 1, "DESTROY without update warns"; +print join("\n", @warnings); Film->autoupdate(0); } diff --git a/t/cdbi-t/03-subclassing.t b/t/cdbi-t/03-subclassing.t new file mode 100644 index 0000000..75b70d6 --- /dev/null +++ b/t/cdbi-t/03-subclassing.t @@ -0,0 +1,26 @@ +use 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()'; diff --git a/t/cdbi-t/04-lazy.t b/t/cdbi-t/04-lazy.t new file mode 100644 index 0000000..9db9e27 --- /dev/null +++ b/t/cdbi-t/04-lazy.t @@ -0,0 +1,75 @@ +use 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 ], [sort qw/things Essential Primary/], "this (@groups)"; +} + +{ + my @groups = Lazy->__grouper->groups_for(Lazy->find_column('that')); + is_deeply \@groups, [qw/things/], "that (@groups)"; +} + +Lazy->create({ 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->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50); +}; +ok($@, $@); + +eval { # False column + Lazy->create({ this => 10, that => 20, theother => 30 }); +}; +ok($@, $@); + +eval { # Multiple false columns + Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 }); +}; +ok($@, $@); + diff --git a/t/cdbi-t/08-inheritcols.t b/t/cdbi-t/08-inheritcols.t new file mode 100644 index 0000000..c23de9c --- /dev/null +++ b/t/cdbi-t/08-inheritcols.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 3; + +use DBIx::Class; + +package A; +@A::ISA = qw(DBIx::Class); +__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"; diff --git a/t/cdbi-t/11-triggers.t b/t/cdbi-t/11-triggers.t new file mode 100644 index 0000000..9e36c54 --- /dev/null +++ b/t/cdbi-t/11-triggers.t @@ -0,0 +1,63 @@ +use 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, + after_create => \&create_trigger2, + after_delete => \&delete_trigger, + before_update => \&pre_up_trigger, + after_update => \&pst_up_trigger, +); + +ok( + my $ver = Film->create({ + 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->create({director => "Me"}); +} diff --git a/t/cdbi-t/19-set_sql.t b/t/cdbi-t/19-set_sql.t new file mode 100644 index 0000000..bab8f51 --- /dev/null +++ b/t/cdbi-t/19-set_sql.t @@ -0,0 +1,106 @@ +use 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->create({ title => 'A', director => 'AA', rating => 'PG' }); +my $f2 = Film->create({ title => 'B', director => 'BA', rating => 'PG' }); +my $f3 = Film->create({ title => 'C', director => 'AA', rating => '15' }); +my $f4 = Film->create({ title => 'D', director => 'BA', rating => '18' }); +my $f5 = Film->create({ 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->create({ name => "A1", film => $f1 }); + my $a2 = Actor->create({ name => "A2", film => $f2 }); + my $a3 = Actor->create({ 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"; +} + diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm new file mode 100755 index 0000000..8203e60 --- /dev/null +++ b/t/lib/DBICTest.pm @@ -0,0 +1,169 @@ +package DBICTest; + +use strict; +use warnings; +use base qw/DBIx::Class::Core/; + +my $db_file = "t/var/DBIxClass.db"; + +unlink($db_file) if -e $db_file; +unlink($db_file . "-journal") if -e $db_file . "-journal"; +mkdir("t/var") unless -d "t/var"; + +__PACKAGE__->connection("dbi:SQLite:${db_file}"); + +my $dbh = __PACKAGE__->_get_dbh; + +my $sql = <do($_) for split(/\n\n/, $sql); + +package DBICTest::LinerNotes; + +use base 'DBICTest'; + +DBICTest::LinerNotes->table('liner_notes'); +DBICTest::LinerNotes->add_columns(qw/liner_id notes/); +DBICTest::LinerNotes->set_primary_key('liner_id'); + +package DBICTest::Tag; + +use base 'DBICTest'; + +DBICTest::Tag->table('tags'); +DBICTest::Tag->add_columns(qw/tagid cd tag/); +DBICTest::Tag->set_primary_key('tagid'); +#DBICTest::Tag->has_a(cd => 'SweetTest::CD'); + +package DBICTest::Track; + +use base 'DBICTest'; + +DBICTest::Track->table('track'); +DBICTest::Track->add_columns(qw/trackid cd position title/); +DBICTest::Track->set_primary_key('trackid'); +#DBICTest::Track->has_a(cd => 'SweetTest::CD'); + +package DBICTest::CD; + +use base 'DBICTest'; + +DBICTest::CD->table('cd'); +DBICTest::CD->add_columns(qw/cdid artist title year/); +DBICTest::CD->set_primary_key('trackid'); + +#DBICTest::CD->has_many(tracks => 'SweetTest::Track'); +#DBICTest::CD->has_many(tags => 'SweetTest::Tag'); +#DBICTest::CD->has_a(artist => 'SweetTest::Artist'); + +#DBICTest::CD->might_have(liner_notes => 'SweetTest::LinerNotes' => qw/notes/); + +package DBICTest::Artist; + +use base 'DBICTest'; + +DBICTest::Artist->table('artist'); +DBICTest::Artist->add_columns(qw/artistid name/); +DBICTest::Artist->set_primary_key('artistid'); +#DBICTest::Artist->has_many(cds => 'SweetTest::CD'); +#DBICTest::Artist->has_many(twokeys => 'SweetTest::TwoKeys'); +#DBICTest::Artist->has_many(onekeys => 'SweetTest::OneKey'); + +package DBICTest::TwoKeys; + +use base 'DBICTest'; + +DBICTest::TwoKeys->table('twokeys'); +DBICTest::TwoKeys->add_columns(qw/artist cd/); +DBICTest::TwoKeys->set_primary_key(qw/artist cd/); +#DBICTest::TwoKeys->has_a(artist => 'SweetTest::Artist'); +#DBICTest::TwoKeys->has_a(cd => 'SweetTest::CD'); + +package DBICTest::OneKey; + +use base 'DBICTest'; + +DBICTest::OneKey->table('onekey'); +DBICTest::OneKey->add_columns(qw/id artist cd/); +DBICTest::TwoKeys->set_primary_key('id'); + +1;