From: Matt S Trout Date: Sat, 23 Jul 2005 02:52:38 +0000 (+0000) Subject: Extra files for relationships, has_many support X-Git-Tag: v0.03001~131 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b8e1e21f0fcd55e6e3ce987e57601b279a75b666;p=dbsrgits%2FDBIx-Class.git Extra files for relationships, has_many support --- diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 7a2da2c..bfaef4d 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -32,12 +32,16 @@ sub mk_group_accessors { "'$class' is unwise."); } + my $name = $field; + + ($name, $field) = @$field if ref $field; + my $accessor = $self->$maker($group, $field); - my $alias = "_${field}_accessor"; + my $alias = "_${name}_accessor"; #warn "$class $group $field $alias"; - *{$class."\:\:$field"} = $accessor; + *{$class."\:\:$name"} = $accessor; #unless defined &{$class."\:\:$field"} *{$class."\:\:$alias"} = $accessor; diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index c5e2634..4f77c5a 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -13,6 +13,7 @@ use base qw/DBIx::Class::CDBICompat::Convenience DBIx::Class::CDBICompat::Constructor DBIx::Class::CDBICompat::AccessorMapping DBIx::Class::CDBICompat::ColumnCase + DBIx::Class::CDBICompat::HasMany DBIx::Class::CDBICompat::HasA DBIx::Class::CDBICompat::LazyLoading DBIx::Class::CDBICompat::AutoUpdate diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index e5703c9..07e72ac 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -5,10 +5,10 @@ use warnings; use NEXT; -sub _mk_column_accessors { - my ($class, @cols) = @_; +sub mk_group_accessors { + my ($class, $group, @cols) = @_; unless ($class->can('accessor_name') || $class->can('mutator_name')) { - return $class->NEXT::_mk_column_accessors('column' => @cols); + return $class->NEXT::mk_group_accessors($group => @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_group_accessors('column' => $col); + $class->mk_group_accessors($group => [ $ro_meth => $col ]); } else { - $class->mk_group_ro_accessors('column' => $ro_meth); - $class->mk_group_wo_accessors('column' => $wo_meth); + $class->mk_group_ro_accessors($group => [ $ro_meth => $col ]); + $class->mk_group_wo_accessors($group => [ $wo_meth => $col ]); } } } diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index d6f527c..2e6225d 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -22,6 +22,11 @@ sub has_a { return 1; } +sub has_many { + my ($class, $rel, $f_class, $f_key, @rest) = @_; + return $class->NEXT::ACTUAL::has_many($rel, $f_class, lc($f_key), @rest); +} + sub get_has_a { my ($class, $get, @rest) = @_; return $class->NEXT::ACTUAL::get_has_a(lc($get), @rest); @@ -59,10 +64,15 @@ sub find_column { sub _mk_group_accessors { my ($class, $type, $group, @fields) = @_; - my %fields; - $fields{$_} = 1 for @fields, - map lc, grep { !defined &{"${class}::${_}"} } @fields; - return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group, keys %fields); + #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields); + my @extra; + foreach (@fields) { + my ($acc, $field) = ref $_ ? @$_ : ($_, $_); + next if defined &{"${class}::${acc}"}; + push(@extra, [ lc $acc => $field ]); + } + return $class->NEXT::ACTUAL::_mk_group_accessors($type, $group, + @fields, @extra); } sub _cond_key { diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index ed5a967..4c0b148 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -26,26 +26,31 @@ sub _add_column_group { sub _register_column_group { my ($class, $group, @cols) = @_; + + my $groups = { %{$class->_column_groups} }; + if ($group eq 'Primary') { $class->set_primary_key(@cols); + $groups->{'Essential'}{$_} ||= {} for @cols; } - my $groups = { %{$class->_column_groups} }; - if ($group eq 'All') { unless (exists $class->_column_groups->{'Primary'}) { $groups->{'Primary'}{$cols[0]} = {}; $class->set_primary_key($cols[0]); } unless (exists $class->_column_groups->{'Essential'}) { + #$class->_register_column_group('Essential' => $cols[0]); $groups->{'Essential'}{$cols[0]} = {}; + #$groups->{'Essential'}{$_} ||= {} for keys %{ $class->_primaries || {} }; } } $groups->{$group}{$_} ||= {} for @cols; - if ($group eq 'Essential') { - $groups->{$group}{$_} ||= {} for keys %{ $class->_primaries || {} }; - } + #if ($group eq 'Essential') { + # $groups->{$group}{$_} ||= {} for keys %{ $class->_primaries || {} }; + #} + $class->_column_groups($groups); } diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm new file mode 100644 index 0000000..e5c2cf0 --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/HasA.pm @@ -0,0 +1,84 @@ +package DBIx::Class::CDBICompat::HasA; + +use strict; +use warnings; + +sub has_a { + my ($self, $col, $f_class) = @_; + die "No such column ${col}" unless $self->_columns->{$col}; + eval "require $f_class"; + my ($pri, $too_many) = keys %{ $f_class->_primaries }; + die "has_a only works with a single primary key; ${f_class} has more" + if $too_many; + $self->add_relationship($col, $f_class, + { "foreign.${pri}" => "self.${col}" }, + { _type => 'has_a' } ); + $self->delete_accessor($col); + $self->mk_group_accessors('has_a' => $col); + return 1; +} + +sub get_has_a { + my ($self, $rel) = @_; + #warn $rel; + #warn join(', ', %{$self->{_column_data}}); + return $self->{_relationship_data}{$rel} + if $self->{_relationship_data}{$rel}; + return undef unless $self->get_column($rel); + #my ($pri) = (keys %{$self->_relationships->{$rel}{class}->_primaries})[0]; + return $self->{_relationship_data}{$rel} = + ($self->search_related($rel, {}, {}))[0] + || do { + my $f_class = $self->_relationships->{$rel}{class}; + my ($pri) = keys %{$f_class->_primaries}; + $f_class->new({ $pri => $self->get_column($rel) }); }; +} + +sub set_has_a { + my ($self, $rel, @rest) = @_; + my $ret = $self->store_has_a($rel, @rest); + $self->{_dirty_columns}{$rel} = 1; + return $ret; +} + +sub store_has_a { + my ($self, $rel, $obj) = @_; + return $self->set_column($rel, $obj) unless ref $obj; + my $rel_obj = $self->_relationships->{$rel}; + die "Can't set $rel: object $obj is not of class ".$rel_obj->{class} + unless $obj->isa($rel_obj->{class}); + $self->{_relationship_data}{$rel} = $obj; + $self->set_column($rel, ($obj->_ident_values)[0]); + return $obj; +} + +sub new { + my ($class, $attrs, @rest) = @_; + my %hasa; + foreach my $key (keys %$attrs) { + my $rt = $class->_relationships->{$key}{attrs}{_type}; + next unless $rt && $rt eq 'has_a' && ref $attrs->{$key}; + $hasa{$key} = delete $attrs->{$key}; + } + my $new = $class->NEXT::ACTUAL::new($attrs, @rest); + foreach my $key (keys %hasa) { + $new->store_has_a($key, $hasa{$key}); + } + return $new; +} + +sub _cond_value { + my ($self, $attrs, $key, $value) = @_; + if ( my $rel_obj = $self->_relationships->{$key} ) { + my $rel_type = $rel_obj->{attrs}{_type} || ''; + if ($rel_type eq 'has_a' && ref $value) { + die "Object $value is not of class ".$rel_obj->{class} + unless $value->isa($rel_obj->{class}); + $value = ($value->_ident_values)[0]; + #warn $value; + } + } + return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value); +} + +1; diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm new file mode 100644 index 0000000..ad1cf66 --- /dev/null +++ b/lib/DBIx/Class/CDBICompat/HasMany.pm @@ -0,0 +1,50 @@ +package DBIx::Class::CDBICompat::HasMany; + +use strict; +use warnings; + +sub has_many { + my ($class, $rel, $f_class, $f_key, $args) = @_; + #die "No such column ${col}" unless $class->_columns->{$col}; + 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) { + ($f_key) = grep { $f_class && $_->{class} eq $class } + $f_class->_relationships; + } + 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}" }, + { _type => 'has_many', %{$args || {}} } ); + { + no strict 'refs'; + *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); }; + *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); }; + } + return 1; +} + +sub delete { + my ($self, @rest) = @_; + return $self->NEXT::ACTUAL::delete(@rest) unless ref $self; + # I'm just ignoring this for class deletes because hell, the db should + # be handling this anyway. Assuming we have joins we probably actually + # *could* do them, but I'd rather not. + + my $ret = $self->NEXT::ACTUAL::delete(@rest); + + my %rels = %{ $self->_relationships }; + 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); + } + return $ret; +} +1; diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm index e991cc0..d15345a 100644 --- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm +++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm @@ -20,10 +20,10 @@ sub get_column { sub _flesh { my ($self, @groups) = @_; + @groups = ('All') unless @groups; my %want; $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups; if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) { - #warn "@want"; my $sth = $self->_get_sth('select', \@want, $self->_table_name, $self->_ident_cond); $sth->execute($self->_ident_values); diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index fb412cc..7b005a0 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -4,6 +4,7 @@ use strict; use warnings; use base qw/DBIx::Class::Relationship + DBIx::Class::SQL::OrderBy DBIx::Class::SQL::Abstract DBIx::Class::PK DBIx::Class::Table diff --git a/lib/DBIx/Class/PK/Auto.pm b/lib/DBIx/Class/PK/Auto.pm new file mode 100644 index 0000000..b9507a8 --- /dev/null +++ b/lib/DBIx/Class/PK/Auto.pm @@ -0,0 +1,25 @@ +package DBIx::Class::PK::Auto; + +use strict; +use warnings; + +sub insert { + my ($self, @rest) = @_; + my $ret = $self->NEXT::ACTUAL::insert(@rest); + my ($pri, $too_many) = + (grep { $self->_primaries->{$_}{'auto_increment'} } + keys %{ $self->_primaries }) + || (keys %{ $self->_primaries }); + die "More than one possible key found for auto-inc on ".ref $self + if $too_many; + unless (exists $self->{_column_data}{$pri}) { + die "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method" + unless $self->can('_last_insert_id'); + my $id = $self->_last_insert_id; + die "Can't get last insert id" unless $id; + $self->store_column($pri => $id); + } + return $ret; +} + +1; diff --git a/lib/DBIx/Class/PK/Auto/SQLite.pm b/lib/DBIx/Class/PK/Auto/SQLite.pm new file mode 100644 index 0000000..98d1c07 --- /dev/null +++ b/lib/DBIx/Class/PK/Auto/SQLite.pm @@ -0,0 +1,10 @@ +package DBIx::Class::PK::Auto::SQLite; + +use strict; +use warnings; + +sub _last_insert_id { + return $_[0]->_get_dbh->func('last_insert_rowid'); +} + +1; diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm new file mode 100644 index 0000000..3fef7a3 --- /dev/null +++ b/lib/DBIx/Class/Relationship.pm @@ -0,0 +1,103 @@ +package DBIx::Class::Relationship; + +use strict; +use warnings; + +use base qw/Class::Data::Inheritable/; + +__PACKAGE__->mk_classdata('_relationships', { } ); + +sub add_relationship { + my ($class, $rel, $f_class, $cond, $attrs) = @_; + my %rels = %{ $class->_relationships }; + $rels{$rel} = { class => $f_class, + cond => $cond, + attrs => $attrs }; + $class->_relationships(\%rels); +} + +sub _cond_key { + my ($self, $attrs, $key) = @_; + my $action = $attrs->{_action} || ''; + if ($action eq 'convert') { + unless ($key =~ s/^foreign\.//) { + die "Unable to convert relationship to WHERE clause: invalid key ${key}"; + } + return $key; + } elsif ($action eq 'join') { + my ($type, $field) = split(/\./, $key); + if ($attrs->{_aliases}{$type}) { + return join('.', $attrs->{_aliases}{$type}, $field); + } else { + die "Unable to resolve type ${type}: only have aliases for ". + join(', ', keys %{$attrs->{_aliases}{$type} || {}}); + } + } + return $self->NEXT::ACTUAL::_cond_key($attrs, $key); +} + +sub _cond_value { + my ($self, $attrs, $key, $value) = @_; + my $action = $attrs->{_action} || ''; + if ($action eq 'convert') { + unless ($value =~ s/^self\.//) { + die "Unable to convert relationship to WHERE clause: invalid value ${value}"; + } + unless ($self->can($value)) { + die "Unable to convert relationship to WHERE clause: no such accessor ${value}"; + } + push(@{$attrs->{bind}}, $self->get_column($value)); + return '?'; + } elsif ($action eq 'join') { + my ($type, $field) = split(/\./, $value); + if ($attrs->{_aliases}{$type}) { + return join('.', $attrs->{_aliases}{$type}, $field); + } else { + die "Unable to resolve type ${type}: only have aliases for ". + join(', ', keys %{$attrs->{_aliases}{$type} || {}}); + } + } + + return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value) +} + +sub search_related { + my $self = shift; + my $rel = shift; + my $attrs = { }; + if (@_ > 1 && ref $_[$#_] eq 'HASH') { + $attrs = { %{ pop(@_) } }; + } + my $rel_obj = $self->_relationships->{$rel}; + die "No such relationship ${rel}" unless $rel; + $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}} }; + my $s_cond; + if (@_) { + die "Invalid query: @_" if (@_ > 1 && (@_ % 2 == 1)); + my $query = ((@_ > 1) ? {@_} : shift); + $s_cond = $self->_cond_resolve($query, $attrs); + } + $attrs->{_action} = 'convert'; + my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs); + $cond = "${s_cond} AND ${cond}" if $s_cond; + return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || {}}); +} + +sub create_related { + my ($self, $rel, $values, $attrs) = @_; + die "Can't call create_related as class method" unless ref $self; + die "create_related needs a hash" unless (ref $values eq 'HASH'); + my $rel_obj = $self->_relationships->{$rel}; + die "No such relationship ${rel}" unless $rel; + die "Can't abstract implicit create for ${rel}, condition not a hash" + unless ref $rel_obj->{cond} eq 'HASH'; + $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' }; + my %fields = %$values; + while (my ($k, $v) = each %{$rel_obj->{cond}}) { + $self->_cond_value($attrs, $k => $v); + $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0]; + } + return $rel_obj->{class}->create(\%fields); +} + +1; diff --git a/lib/DBIx/Class/SQL.pm b/lib/DBIx/Class/SQL.pm index a06062e..53b7692 100644 --- a/lib/DBIx/Class/SQL.pm +++ b/lib/DBIx/Class/SQL.pm @@ -26,7 +26,6 @@ __PACKAGE__->mk_classdata('_sql_statements', sub _get_sql { my ($class, $name, $cols, $from, $cond) = @_; my $sql = $class->_sql_statements->{$name}->($cols, $from, $cond); - #warn $sql; return $sql; } diff --git a/lib/DBIx/Class/SQL/Abstract.pm b/lib/DBIx/Class/SQL/Abstract.pm new file mode 100644 index 0000000..2286931 --- /dev/null +++ b/lib/DBIx/Class/SQL/Abstract.pm @@ -0,0 +1,142 @@ +package DBIx::Class::SQL::Abstract; + +# Many thanks to SQL::Abstract, from which I stole most of this + +sub _debug { } + +sub _cond_resolve { + my ($self, $cond, $attrs, $join) = @_; + my $ref = ref $cond || ''; + $join ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND'); + my $cmp = uc($attrs->{cmp}) || '='; + + # For assembling SQL fields and values + my(@sqlf) = (); + + # If an arrayref, then we join each element + if ($ref eq 'ARRAY') { + # need to use while() so can shift() for arrays + while (my $el = shift @$cond) { + my $subjoin = 'OR'; + + # skip empty elements, otherwise get invalid trailing AND stuff + if (my $ref2 = ref $el) { + if ($ref2 eq 'ARRAY') { + next unless @$el; + } elsif ($ref2 eq 'HASH') { + next unless %$el; + $subjoin = 'AND'; + } elsif ($ref2 eq 'SCALAR') { + # literal SQL + push @sqlf, $$el; + next; + } + $self->_debug("$ref2(*top) means join with $subjoin"); + } else { + # top-level arrayref with scalars, recurse in pairs + $self->_debug("NOREF(*top) means join with $subjoin"); + $el = {$el => shift(@$cond)}; + } + push @sqlf, scalar $self->_cond_resolve($el, $attrs, $subjoin); + } + } + elsif ($ref eq 'HASH') { + # Note: during recursion, the last element will always be a hashref, + # since it needs to point a column => value. So this be the end. + for my $k (sort keys %$cond) { + my $v = $cond->{$k}; + if (! defined($v)) { + # undef = null + $self->_debug("UNDEF($k) means IS NULL"); + push @sqlf, $k . ' IS NULL' + } elsif (ref $v eq 'ARRAY') { + # multiple elements: multiple options + $self->_debug("ARRAY($k) means multiple elements: [ @$v ]"); + + # map into an array of hashrefs and recurse + my @w = (); + push @w, { $k => $_ } for @$v; + push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR'); + + } elsif (ref $v eq 'HASH') { + # modified operator { '!=', 'completed' } + for my $f (sort keys %$v) { + my $x = $v->{$f}; + $self->_debug("HASH($k) means modified operator: { $f }"); + + # check for the operator being "IN" or "BETWEEN" or whatever + if ($f =~ /^([\s\w]+)$/i && ref $x eq 'ARRAY') { + my $u = uc($1); + if ($u =~ /BETWEEN/) { + # SQL sucks + die "BETWEEN must have exactly two arguments" unless @$x == 2; + push @sqlf, join ' ', + $self->_cond_key($attrs => $k), $u, + $self->_cond_value($attrs => $k => $x->[0]), + 'AND', + $self->_cond_value($attrs => $k => $x->[1]); + } else { + push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(', + join(', ', + map { $self->_cond_value($attrs, $k, $_) } @$x), + ')'; + } + } elsif (ref $x eq 'ARRAY') { + # multiple elements: multiple options + $self->_debug("ARRAY($x) means multiple elements: [ @$x ]"); + + # map into an array of hashrefs and recurse + my @w = (); + push @w, { $k => { $f => $_ } } for @$x; + push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR'); + + } elsif (! defined($x)) { + # undef = NOT null + my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : ''; + push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL"; + } else { + # regular ol' value + push @sqlf, join ' ', $self->_cond_key($attrs => $k), $f, + $self->_cond_value($attrs => $k => $x); + } + } + } elsif (ref $v eq 'SCALAR') { + # literal SQL + $self->_debug("SCALAR($k) means literal SQL: $$v"); + push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v; + } else { + # standard key => val + $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v"); + push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp, + $self->_cond_value($attrs => $k => $v); + } + } + } + elsif ($ref eq 'SCALAR') { + # literal sql + $self->_debug("SCALAR(*top) means literal SQL: $$cond"); + push @sqlf, $$cond; + } + elsif (defined $cond) { + # literal sql + $self->_debug("NOREF(*top) means literal SQL: $cond"); + push @sqlf, $cond; + } + + # assemble and return sql + my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : ''; + return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql; +} + +sub _cond_key { + my ($self, $attrs, $key) = @_; + return $key; +} + +sub _cond_value { + my ($self, $attrs, $key, $value) = @_; + push(@{$attrs->{bind}}, $value); + return '?'; +} + +1; diff --git a/lib/DBIx/Class/SQL/OrderBy.pm b/lib/DBIx/Class/SQL/OrderBy.pm new file mode 100644 index 0000000..e64123b --- /dev/null +++ b/lib/DBIx/Class/SQL/OrderBy.pm @@ -0,0 +1,19 @@ +package DBIx::Class::SQL::OrderBy; + +use strict; +use warnings; + +sub _cond_resolve { + my ($self, $cond, $attrs, @rest) = @_; + return $self->NEXT::ACTUAL::_cond_resolve($cond, $attrs, @rest) + unless wantarray; + my ($sql, @bind) = $self->NEXT::ACTUAL::_cond_resolve($cond, $attrs, @rest); + if ($attrs->{order_by}) { + $sql .= " ORDER BY ".join(', ', (ref $attrs->{order_by} eq 'ARRAY' + ? @{$attrs->{order_by}} + : $attrs->{order_by})); + } + return ($sql, @bind); +} + +1; diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm index eabc9e7..78a97bd 100644 --- a/lib/DBIx/Class/Table.pm +++ b/lib/DBIx/Class/Table.pm @@ -60,6 +60,7 @@ sub update { sub delete { my $self = shift; if (ref $self) { + #warn $self->_ident_cond.' '.join(', ', $self->_ident_values); my $sth = $self->_get_sth('delete', undef, $self->_table_name, $self->_ident_cond); $sth->execute($self->_ident_values); @@ -124,6 +125,7 @@ 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); + #warn "$cond @vals"; return $class->sth_to_objects($sth, \@vals, \@cols); } diff --git a/lib/DBIx/Class/Test/SQLite.pm b/lib/DBIx/Class/Test/SQLite.pm index d23b6bd..e20bdb8 100644 --- a/lib/DBIx/Class/Test/SQLite.pm +++ b/lib/DBIx/Class/Test/SQLite.pm @@ -2,7 +2,7 @@ package DBIx::Class::Test::SQLite; =head1 NAME -DBIx::Class::Test::SQLite - Base class for DBIx::Class tests, shamelessly ripped from Class::DBI::Test::SQLite +DBIx::Class::Test::SQLite - Base class for running Class::DBI tests against DBIx::Class compat layer, shamelessly ripped from Class::DBI::Test::SQLite =head1 SYNOPSIS @@ -32,7 +32,7 @@ tie it to the class. use strict; -use base 'DBIx::Class'; +use base qw/DBIx::Class::PK::Auto::SQLite DBIx::Class::PK::Auto DBIx::Class/; use File::Temp qw/tempfile/; my (undef, $DB) = tempfile(); END { unlink $DB if -e $DB } diff --git a/t/cdbi-t/09-has_many.t b/t/cdbi-t/09-has_many.t new file mode 100644 index 0000000..2ff2633 --- /dev/null +++ b/t/cdbi-t/09-has_many.t @@ -0,0 +1,109 @@ +use strict; +use Test::More; + +BEGIN { + eval "use DBD::SQLite"; + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 30); +} + + +use lib 't/testlib'; +use Film; +use Actor; +Film->has_many(actors => Actor => 'Film', { order_by => 'name' }); +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->create( + { + Name => 'Peter Vere-Jones', + Film => undef, + Salary => '30_000', # For a voice! + } + ), + 'create 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->create( + { + 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"); +