These accessors no longer automatically require the classes when
set.
+0.07004
+ - fix find_related-based queries to correctly grep the unique key
+
0.07003 2006-11-16 11:52:00
- fix for rt.cpan.org #22740 (use $^X instead of hardcoded "perl")
- Tweaks to resultset to allow inflate_result to return an array
sub _deflated_column {
my ($self, $col, $value) = @_;
- return $value unless ref $value; # If it's not an object, don't touch it
+ return $value unless ref $value && blessed($value); # If it's not an object, don't touch it
my $info = $self->column_info($col) or
$self->throw_exception("No column info for $col");
return $value unless exists $info->{_inflate_info};
return $self->{_inflated_column}{$col} = $obj;
}
-=head2 get_column
-
-Gets a column value in the same way as L<DBIx::Class::Row/get_column>. If there
-is an inflated value stored that has not yet been deflated, it is deflated
-when the method is invoked.
-
-=cut
-
-sub get_column {
- my ($self, $col) = @_;
- if (exists $self->{_inflated_column}{$col}
- && !exists $self->{_column_data}{$col}) {
- $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}));
- }
- return $self->next::method($col);
-}
-
-=head2 get_columns
-
-Returns the get_column info for all columns as a hash,
-just like L<DBIx::Class::Row/get_columns>. Handles inflation just
-like L</get_column>.
-
-=cut
-
-sub get_columns {
- my $self = shift;
- if (exists $self->{_inflated_column}) {
- foreach my $col (keys %{$self->{_inflated_column}}) {
- $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
- unless exists $self->{_column_data}{$col};
- }
- }
- return $self->next::method;
-}
-
-=head2 has_column_loaded
-
-Like L<DBIx::Class::Row/has_column_loaded>, but also returns true if there
-is an inflated value stored.
-
-=cut
-
-sub has_column_loaded {
- my ($self, $col) = @_;
- return 1 if exists $self->{_inflated_column}{$col};
- return $self->next::method($col);
-}
-
-=head2 update
-
-Updates a row in the same way as L<DBIx::Class::Row/update>, handling
-inflation and deflation of columns appropriately.
-
-=cut
-
-sub update {
- my ($class, $attrs, @rest) = @_;
- foreach my $key (keys %{$attrs||{}}) {
- if (ref $attrs->{$key} && $class->has_column($key)
- && exists $class->column_info($key)->{_inflate_info}) {
- $class->set_inflated_column($key, delete $attrs->{$key});
- }
- }
- return $class->next::method($attrs, @rest);
-}
-
-=head2 new
-
-Creates a row in the same way as L<DBIx::Class::Row/new>, handling
-inflation and deflation of columns appropriately.
-
-=cut
-
-sub new {
- my ($class, $attrs, @rest) = @_;
- my $inflated;
- foreach my $key (keys %{$attrs||{}}) {
- $inflated->{$key} = delete $attrs->{$key}
- if ref $attrs->{$key} && $class->has_column($key)
- && exists $class->column_info($key)->{_inflate_info};
- }
- my $obj = $class->next::method($attrs, @rest);
- $obj->{_inflated_column} = $inflated if $inflated;
- return $obj;
-}
-
=head1 SEE ALSO
=over 4
}
}
-sub new {
- my ($class, $attrs, @rest) = @_;
- my ($related, $info);
- foreach my $key (keys %{$attrs||{}}) {
- next unless $info = $class->relationship_info($key);
- $related->{$key} = delete $attrs->{$key}
- if ref $attrs->{$key}
- && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single';
- }
- my $obj = $class->next::method($attrs, @rest);
- if ($related) {
- $obj->{_relationship_data} = $related;
- foreach my $rel (keys %$related) {
- $obj->set_from_related($rel, $related->{$rel});
- }
- }
- return $obj;
-}
-
-sub update {
- my ($obj, $attrs, @rest) = @_;
- my $info;
- foreach my $key (keys %{$attrs||{}}) {
- next unless $info = $obj->relationship_info($key);
- if (ref $attrs->{$key} && $info->{attrs}{accessor}
- && $info->{attrs}{accessor} eq 'single') {
- my $rel = delete $attrs->{$key};
- $obj->set_from_related($key => $rel);
- $obj->{_relationship_data}{$key} = $rel;
- }
- }
- return $obj->next::method($attrs, @rest);
-}
-
1;
"${class} has more"
) if $too_many;
+ $class->throw_exception(
+ "has_many needs a primary key to infer a join; ".
+ "${class} has none"
+ ) if !defined $pri && (!defined $cond || !length $cond);
+
my ($f_key,$guess);
if (defined $cond && length $cond) {
$f_key = $cond;
unless (ref $cond) {
$class->ensure_class_loaded($f_class);
my ($pri, $too_many) = $class->primary_columns;
+
$class->throw_exception(
"might_have/has_one can only infer join for a single primary key; ".
"${class} has more"
) if $too_many;
+
+ $class->throw_exception(
+ "might_have/has_one needs a primary key to infer a join; ".
+ "${class} has none"
+ ) if !defined $pri && (!defined $cond || !length $cond);
+
my $f_class_loaded = eval { $f_class->columns };
my ($f_key,$guess);
if (defined $cond && length $cond) {
sub many_to_many {
my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
+
+ $class->throw_exception(
+ "missing relation in many-to-many"
+ ) unless $rel;
+
+ $class->throw_exception(
+ "missing foreign relation in many-to-many"
+ ) unless $f_rel;
+
{
no strict 'refs';
no warnings 'redefine';
? ($attrs->{key})
: $self->result_source->unique_constraint_names;
+ my $where = $self->_collapse_cond($self->{attrs}{where} || {});
+ my $num_where = scalar keys %$where;
+
my @unique_queries;
foreach my $name (@constraint_names) {
my @unique_cols = $self->result_source->unique_constraint_columns($name);
my $unique_query = $self->_build_unique_query($query, \@unique_cols);
+ my $num_cols = scalar @unique_cols;
my $num_query = scalar keys %$unique_query;
- next unless $num_query;
- # XXX: Assuming quite a bit about $self->{attrs}{where}
- my $num_cols = scalar @unique_cols;
- my $num_where = exists $self->{attrs}{where}
- ? scalar keys %{ $self->{attrs}{where} }
- : 0;
- push @unique_queries, $unique_query
- if $num_query + $num_where == $num_cols;
+ my $total = $num_query + $num_where;
+ if ($num_query && ($num_query == $num_cols || $total == $num_cols)) {
+ # The query is either unique on its own or is unique in combination with
+ # the existing where clause
+ push @unique_queries, $unique_query;
+ }
}
return @unique_queries;
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
-
- foreach my $k (keys %$attrs) {
- $new->throw_exception("No such column $k on $class")
- unless $class->has_column($k);
- $new->store_column($k => $attrs->{$k});
+
+ my ($related,$inflated);
+ foreach my $key (keys %$attrs) {
+ if (ref $attrs->{$key}) {
+ my $info = $class->relationship_info($key);
+ if ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'single')
+ {
+ $new->set_from_related($key, $attrs->{$key});
+ $related->{$key} = $attrs->{$key};
+ next;
+ }
+ elsif ($class->has_column($key)
+ && exists $class->column_info($key)->{_inflate_info})
+ {
+ $inflated->{$key} = $attrs->{$key};
+ next;
+ }
+ }
+ $new->throw_exception("No such column $key on $class")
+ unless $class->has_column($key);
+ $new->store_column($key => $attrs->{$key});
}
+ if (my $source = delete $attrs->{-result_source}) {
+ $new->result_source($source);
+ }
+
+ $new->{_relationship_data} = $related if $related;
+ $new->{_inflated_column} = $inflated if $inflated;
}
return $new;
$self->in_storage(1);
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
+ undef $self->{_orig_ident};
return $self;
}
my $ident_cond = $self->ident_condition;
$self->throw_exception("Cannot safely update a row in a PK-less table")
if ! keys %$ident_cond;
- $self->set_columns($upd) if $upd;
+ if ($upd) {
+ foreach my $key (keys %$upd) {
+ if (ref $upd->{$key}) {
+ my $info = $self->relationship_info($key);
+ if ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'single')
+ {
+ my $rel = delete $upd->{$key};
+ $self->set_from_related($key => $rel);
+ $self->{_relationship_data}{$key} = $rel;
+ }
+ elsif ($self->has_column($key)
+ && exists $self->column_info($key)->{_inflate_info})
+ {
+ $self->set_inflated_column($key, delete $upd->{$key});
+ }
+ }
+ }
+ $self->set_columns($upd);
+ }
my %to_update = $self->get_dirty_columns;
return $self unless keys %to_update;
my $rows = $self->result_source->storage->update(
- $self->result_source->from, \%to_update, $ident_cond);
+ $self->result_source->from, \%to_update, $self->{_orig_ident} || $ident_cond);
if ($rows == 0) {
$self->throw_exception( "Can't update ${self}: row not found" );
} elsif ($rows > 1) {
}
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
+ undef $self->{_orig_ident};
return $self;
}
$obj->delete
Deletes the object from the database. The object is still perfectly
-usable, but C<-E<gt>in_storage()> will now return 0 and the object must
-reinserted using C<-E<gt>insert()> before C<-E(<gt>update()> can be used
+usable, but C<< ->in_storage() >> will now return 0 and the object must
+reinserted using C<< ->insert() >> before C<< ->update() >> can be used
on it. If you delete an object in a class with a C<has_many>
relationship, all the related objects will be deleted as well. To turn
this behavior off, pass C<cascade_delete => 0> in the C<$attr>
my $val = $obj->get_column($col);
-Gets a column value from a row object. Currently, does not do
-any queries; the column must have already been fetched from
-the database and stored in the object.
+Gets a column value from a row object. Does not do any queries; the column
+must have already been fetched from the database and stored in the object. If
+there is an inflated value stored that has not yet been deflated, it is deflated
+when the method is invoked.
=cut
my ($self, $column) = @_;
$self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
+ if (exists $self->{_inflated_column}{$column}) {
+ return $self->store_column($column,
+ $self->_deflated_column($column, $self->{_inflated_column}{$column}));
+ }
$self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
return undef;
}
sub has_column_loaded {
my ($self, $column) = @_;
$self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
+ return 1 if exists $self->{_inflated_column}{$column};
return exists $self->{_column_data}{$column};
}
sub get_columns {
my $self = shift;
+ if (exists $self->{_inflated_column}) {
+ foreach my $col (keys %{$self->{_inflated_column}}) {
+ $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
+ unless exists $self->{_column_data}{$col};
+ }
+ }
return %{$self->{_column_data}};
}
sub set_column {
my $self = shift;
my ($column) = @_;
+ $self->{_orig_ident} ||= $self->ident_condition;
my $old = $self->get_column($column);
my $ret = $self->store_column(@_);
$self->{_dirty_columns}{$column} = 1
Attempts to deploy the schema to the current storage using L<SQL::Translator>.
Note that this feature is currently EXPERIMENTAL and may not work correctly
-across all databases, or fully handle complex relationships.
+across all databases, or fully handle complex relationships. Saying that, it
+has been used successfully by many people, including the core dev team.
See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
produced include a DROP TABLE statement for each table created.
+Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
+ref or an array ref, containing a list of source to deploy. If present, then
+only the sources listed will get deployed.
+
=cut
sub deploy {
if (ref $cond eq 'HASH') {
my %j;
for (keys %$cond) {
- my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
+ my $v = $cond->{$_};
+ if (ref $v) {
+ # XXX no throw_exception() in this package and croak() fails with strange results
+ Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
+ if ref($v) ne 'SCALAR';
+ $j{$_} = $v;
+ }
+ else {
+ my $x = '= '.$self->_quote($v); $j{$_} = \$x;
+ }
};
- return $self->_recurse_where(\%j);
+ return scalar($self->_recurse_where(\%j));
} elsif (ref $cond eq 'ARRAY') {
return join(' OR ', map { $self->_join_condition($_) } @$cond);
} else {
$self->throw_exception($@) if $@;
eval "use SQL::Translator::Producer::${type};";
$self->throw_exception($@) if $@;
+
+ # sources needs to be a parser arg, but for simplicty allow at top level
+ # coming in
+ $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
+ if exists $sqltargs->{sources};
+
my $tr = SQL::Translator->new(%$sqltargs);
SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
sub last_insert_id {
my ($self,$source,$col) = @_;
my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
+ $self->throw_exception("could not fetch primary key for " . $source->name . ", could not "
+ . "get autoinc sequence for $col (check that table and column specifications are correct "
+ . "and in the correct case)") unless defined $seq;
$self->dbh_do($self->can('_dbh_last_insert_id'), $seq);
}
# We're working with DBIx::Class Schemas, not data streams.
# -------------------------------------------------------------------
sub parse {
- my ($tr, $data) = @_;
- my $args = $tr->parser_args;
- my $dbixschema = $args->{'DBIx::Schema'} || $data;
- $dbixschema ||= $args->{'package'};
+ my ($tr, $data) = @_;
+ my $args = $tr->parser_args;
+ my $dbixschema = $args->{'DBIx::Schema'} || $data;
+ $dbixschema ||= $args->{'package'};
+ my $limit_sources = $args->{'sources'};
die 'No DBIx::Schema' unless ($dbixschema);
if (!ref $dbixschema) {
my %seen_tables;
- foreach my $moniker ($dbixschema->sources)
+ my @monikers = $dbixschema->sources;
+ if ($limit_sources) {
+ my $ref = ref $limit_sources || '';
+ die "'sources' parameter must be an array or hash ref" unless $ref eq 'ARRAY' || ref eq 'HASH';
+
+ # limit monikers to those specified in
+ my $sources;
+ if ($ref eq 'ARRAY') {
+ $sources->{$_} = 1 for (@$limit_sources);
+ } else {
+ $sources = $limit_sources;
+ }
+ @monikers = grep { $sources->{$_} } @monikers;
+ }
+
+
+ foreach my $moniker (@monikers)
{
#eval "use $tableclass";
#print("Can't load $tableclass"), next if($@);
}
my @rels = $source->relationships();
+
+ my %created_FK_rels;
+
foreach my $rel (@rels)
{
my $rel_info = $source->relationship_info($rel);
$on_update = $otherrelationship->{'attrs'}->{cascade_copy} ? 'CASCADE' : '';
}
+ # Make sure we dont create the same foreign key constraint twice
+ my $key_test = join("\x00", @keys);
+
#Decide if this is a foreign key based on whether the self
#items are our primary columns.
# If the sets are different, then we assume it's a foreign key from
# us to another table.
- if (!$source->compare_relationship_keys(\@keys, \@primary)) {
+ # OR: If is_foreign_key attr is explicity set on one the local columns
+ if ( ! exists $created_FK_rels{$rel_table}->{$key_test}
+ &&
+ ( !$source->compare_relationship_keys(\@keys, \@primary) ||
+ grep { $source->column_info($_)->{is_foreign_key} } @keys
+ )
+ ) {
+ $created_FK_rels{$rel_table}->{$key_test} = 1;
$table->add_constraint(
type => 'foreign_key',
name => "fk_$keys[0]",
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
}
my $art = $schema->resultset("Artist")->find(1);
ok($art->update({ artistid => 100 }), 'update allows pk mutation');
is($art->artistid, 100, 'pk mutation applied');
+
+my $art_100 = $schema->resultset("Artist")->find(100);
+$art_100->artistid(101);
+ok($art_100->update(), 'update allows pk mutation via column accessor');
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 50 );
+ : ( tests => 53 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
;
is( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok');
+my @j5 = (
+ { child => 'person' },
+ [ { father => 'person' }, { 'father.person_id' => \'!= child.father_id' }, ],
+ [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
+);
+$match = 'person child JOIN person father ON ( father.person_id != '
+ . 'child.father_id ) JOIN person mother ON ( mother.person_id '
+ . '= child.mother_id )'
+ ;
+is( $sa->_recurse_from(@j5), $match, 'join 5 (SCALAR reference for ON statement) ok' );
+
+my @j6 = (
+ { child => 'person' },
+ [ { father => 'person' }, { 'father.person_id' => { '!=', '42' } }, ],
+ [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
+);
+$match = qr/^\QHASH reference arguments are not supported in JOINS - try using \"..." instead\E/;
+eval { $sa->_recurse_from(@j6) };
+like( $@, $match, 'join 6 (HASH reference for ON statement dies) ok' );
+
my $rs = $schema->resultset("CD")->search(
{ 'year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ from => [ { 'me' => 'cd' },
$schema->storage->debug($orig_debug);
$schema->storage->debugobj->callback(undef);
+$rs = $schema->resultset('Artist');
+$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
+$rs->create({ artistid => 5, name => 'Emo 4ever' });
+@artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' });
+is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok');
+
# -------------
#
# Tests for multilevel has_many prefetch
my $schema = DBICTest->init_schema();
-plan tests => 43;
+plan tests => 45;
# Check the defined unique constraints
is_deeply(
is($cd8->title, $cd1->title, 'title is correct');
is($cd8->year, $cd1->year, 'year is correct');
-my $cd9 = $artist->update_or_create_related('cds',
+my $cd9 = $artist->cds->update_or_create(
{
+ cdid => $cd1->cdid,
title => $title,
year => 2021,
},
},
{ key => 'foo_bar' }
);
+
ok(! $row->is_changed, 'update_or_create on table without primary key: row is clean');
is($row->foo, 1, 'foo is correct');
is($row->bar, 2, 'bar is correct');
is($row->baz, 3, 'baz is correct');
+
+# Test a unique condition with extra information in the where attr
+{
+ my $artist = $schema->resultset('Artist')->find({ artistid => 1 });
+ my $cd = $artist->cds->find_or_new(
+ {
+ cdid => 1,
+ title => 'Not The Real Title',
+ year => 3000,
+ },
+ { key => 'primary' }
+ );
+
+ ok($cd->in_storage, 'find correctly grepped the key across a relationship');
+ is($cd->cdid, 1, 'cdid is correct');
+}
my $schema = DBICTest->init_schema;
-plan tests => 53;
+plan tests => 54;
my $translator = SQL::Translator->new(
parser_args => {
my $output = $translator->translate();
+
+ok($output, "SQLT produced someoutput")
+ or diag($translator->error);
+
# Note that the constraints listed here are the only ones that are tested -- if
# more exist in the Schema than are listed here and all listed constraints are
# correct, the test will still pass. If you add a class with UNIQUE or FOREIGN
my $schema = DBICTest->init_schema();
-plan tests => 5;
+plan tests => 10;
my $old_artistid = 1;
my $new_artistid = $schema->resultset("Artist")->get_column('artistid')->max + 1;
ok(defined $artist, 'found an artist with the new PK');
is($artist->artistid, $new_artistid, 'artist ID matches');
}
+
+# Do it all over again, using a different methodology:
+$old_artistid = $new_artistid;
+$new_artistid++;
+
+# Update the PK
+{
+ my $artist = $schema->resultset("Artist")->find($old_artistid);
+ ok(defined $artist, 'found an artist with the new PK');
+
+ $artist->artistid($new_artistid);
+ $artist->update;
+ is($artist->artistid, $new_artistid, 'artist ID matches');
+}
+
+# Look for the old PK
+{
+ my $artist = $schema->resultset("Artist")->find($old_artistid);
+ ok(!defined $artist, 'no artist found with the old PK');
+}
+
+# Look for the new PK
+{
+ my $artist = $schema->resultset("Artist")->find($new_artistid);
+ ok(defined $artist, 'found an artist with the new PK');
+ is($artist->artistid, $new_artistid, 'artist ID matches');
+}
__PACKAGE__->set_primary_key(qw/foo bar hello goodbye/);
__PACKAGE__->has_many(
- 'fourkeys_to_twokeys', '__PACKAGE___to_TwoKeys', {
+ 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
'foreign.f_foo' => 'self.foo',
'foreign.f_bar' => 'self.bar',
'foreign.f_hello' => 'self.hello',
projects / dbsrgits/DBIx-Class.git / commitdiff