X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=228ade30c3cff25fd61db8d39472f17c4df13cc9;hb=7f3fd2621c5509873aa30e7a68b7dd670421cc86;hp=4e9408aea8934555d53b2b522bd0a4cc215ddfdd;hpb=abf8d91e24dae052a0af4b65ffee4e72044d54bb;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 4e9408a..228ade3 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -7,11 +7,10 @@ use DBIx::Class::ResultSet; use DBIx::Class::ResultSourceHandle; use DBIx::Class::Exception; -use Carp::Clan qw/^DBIx::Class/; +use DBIx::Class::Carp; use Try::Tiny; use List::Util 'first'; -use Scalar::Util qw/weaken isweak/; -use Storable qw/nfreeze thaw/; +use Scalar::Util qw/blessed weaken isweak/; use namespace::clean; use base qw/DBIx::Class/; @@ -32,18 +31,18 @@ DBIx::Class::ResultSource - Result source object # Create a table based result source, in a result class. - package MyDB::Schema::Result::Artist; + package MyApp::Schema::Result::Artist; use base qw/DBIx::Class::Core/; __PACKAGE__->table('artist'); __PACKAGE__->add_columns(qw/ artistid name /); __PACKAGE__->set_primary_key('artistid'); - __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD'); + __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD'); 1; # Create a query (view) based result source, in a result class - package MyDB::Schema::Result::Year2000CDs; + package MyApp::Schema::Result::Year2000CDs; use base qw/DBIx::Class::Core/; __PACKAGE__->load_components('InflateColumn::DateTime'); @@ -254,8 +253,20 @@ generate a new key value. If not specified, L will attempt to retrieve the name of the sequence from the database automatically. +=item retrieve_on_insert + + { retrieve_on_insert => 1 } + +For every column where this is set to true, DBIC will retrieve the RDBMS-side +value upon a new row insertion (normally only the autoincrement PK is +retrieved on insert). C is used automatically if +supported by the underlying storage, otherwise an extra SELECT statement is +executed to retrieve the missing data. + =item auto_nextval + { auto_nextval => 1 } + Set this to a true value for a column whose value is retrieved automatically from a sequence or function (if supported by your Storage driver.) For a sequence, if you do not use a trigger to get the nextval, you have to set the @@ -428,7 +439,7 @@ sub columns { my $columns_info = $source->columns_info; Like L but returns information for the requested columns. If -the optional column-list arrayref is ommitted it returns info on all columns +the optional column-list arrayref is omitted it returns info on all columns currently defined on the ResultSource via L. =cut @@ -634,7 +645,7 @@ sub sequence { my ($self,$seq) = @_; my @pks = $self->primary_columns - or next; + or return; $_->{sequence} = $seq for values %{ $self->columns_info (\@pks) }; @@ -875,12 +886,21 @@ sub unique_constraint_columns { =over -=item Arguments: $callback +=item Arguments: $callback_name | \&callback_code + +=item Return value: $callback_name | \&callback_code =back __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); + or + + __PACKAGE__->sqlt_deploy_callback(sub { + my ($source_instance, $sqlt_table) = @_; + ... + } ); + An accessor to set a callback to be called during deployment of the schema via L or L. @@ -888,7 +908,7 @@ L. The callback can be set as either a code reference or the name of a method in the current result class. -If not set, the L is called. +Defaults to L. Your callback will be passed the $source object representing the ResultSource instance being deployed, and the @@ -908,19 +928,13 @@ and call L. =head2 default_sqlt_deploy_hook -=over - -=item Arguments: $source, $sqlt_table - -=item Return value: undefined - -=back - -This is the sensible default for L. - -If a method named C exists in your Result class, it -will be called and passed the current C<$source> and the -C<$sqlt_table> being deployed. +This is the default deploy hook implementation which checks if your +current Result class has a C method, and if present +invokes it B. This is to preserve the +semantics of C which was originally designed to expect +the Result class name and the +L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being +deployed. =cut @@ -1327,56 +1341,74 @@ L. sub reverse_relationship_info { my ($self, $rel) = @_; - my $rel_info = $self->relationship_info($rel); + + my $rel_info = $self->relationship_info($rel) + or $self->throw_exception("No such relationship '$rel'"); + my $ret = {}; return $ret unless ((ref $rel_info->{cond}) eq 'HASH'); - my @cond = keys(%{$rel_info->{cond}}); - my @refkeys = map {/^\w+\.(\w+)$/} @cond; - my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond; + my $stripped_cond = $self->__strip_relcond ($rel_info->{cond}); + + my $rsrc_schema_moniker = $self->source_name + if try { $self->schema }; - # Get the related result source for this relationship - my $othertable = $self->related_source($rel); + # this may be a partial schema or something else equally esoteric + my $other_rsrc = try { $self->related_source($rel) } + or return $ret; # Get all the relationships for that source that related to this source # whose foreign column set are our self columns on $rel and whose self - # columns are our foreign columns on $rel. - my @otherrels = $othertable->relationships(); - my $otherrelationship; - foreach my $otherrel (@otherrels) { - # this may be a partial schema with the related source not being - # available at all - my $back = try { $othertable->related_source($otherrel) } or next; - - # did we get back to ourselves? - next unless $back->source_name eq $self->source_name; - - my $otherrel_info = $othertable->relationship_info($otherrel); - my @othertestconds; - - if (ref $otherrel_info->{cond} eq 'HASH') { - @othertestconds = ($otherrel_info->{cond}); - } - elsif (ref $otherrel_info->{cond} eq 'ARRAY') { - @othertestconds = @{$otherrel_info->{cond}}; + # columns are our foreign columns on $rel + foreach my $other_rel ($other_rsrc->relationships) { + + # only consider stuff that points back to us + # "us" here is tricky - if we are in a schema registration, we want + # to use the source_names, otherwise we will use the actual classes + + # the schema may be partial + my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) } + or next; + + if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) { + next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name; } else { - next; + next unless $self->result_class eq $roundtrip_rsrc->result_class; } - foreach my $othercond (@othertestconds) { - my @other_cond = keys(%$othercond); - my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond; - my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond; - next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) || - !$self->_compare_relationship_keys(\@other_refkeys, \@keys)); - $ret->{$otherrel} = $otherrel_info; - } + my $other_rel_info = $other_rsrc->relationship_info($other_rel); + + # this can happen when we have a self-referential class + next if $other_rel_info eq $rel_info; + + next unless ref $other_rel_info->{cond} eq 'HASH'; + my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond}); + + $ret->{$other_rel} = $other_rel_info if ( + $self->_compare_relationship_keys ( + [ keys %$stripped_cond ], [ values %$other_stripped_cond ] + ) + and + $self->_compare_relationship_keys ( + [ values %$stripped_cond ], [ keys %$other_stripped_cond ] + ) + ); } + return $ret; } +# all this does is removes the foreign/self prefix from a condition +sub __strip_relcond { + +{ + map + { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) } + keys %{$_[1]} + } +} + sub compare_relationship_keys { carp 'compare_relationship_keys is a private method, stop calling it'; my $self = shift; @@ -1385,36 +1417,12 @@ sub compare_relationship_keys { # Returns true if both sets of keynames are the same, false otherwise. sub _compare_relationship_keys { - my ($self, $keys1, $keys2) = @_; - - # Make sure every keys1 is in keys2 - my $found; - foreach my $key (@$keys1) { - $found = 0; - foreach my $prim (@$keys2) { - if ($prim eq $key) { - $found = 1; - last; - } - } - last unless $found; - } - - # Make sure every key2 is in key1 - if ($found) { - foreach my $prim (@$keys2) { - $found = 0; - foreach my $key (@$keys1) { - if ($prim eq $key) { - $found = 1; - last; - } - } - last unless $found; - } - } - - return $found; +# my ($self, $keys1, $keys2) = @_; + return + join ("\x00", sort @{$_[1]}) + eq + join ("\x00", sort @{$_[2]}) + ; } # Returns the {from} structure used to express JOIN conditions @@ -1493,7 +1501,8 @@ sub _resolve_join { -alias => $as, -relation_chain_depth => $seen->{-relation_chain_depth} || 0, }, - $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) ]; + $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) + ]; } } @@ -1545,38 +1554,89 @@ sub resolve_condition { $self->_resolve_condition (@_); } -# Resolves the passed condition to a concrete query fragment. If given an alias, -# returns a join condition; if given an object, inverts that object to produce -# a related conditional from that object. our $UNRESOLVABLE_CONDITION = \ '1 = 0'; +# Resolves the passed condition to a concrete query fragment and a flag +# indicating whether this is a cross-table condition. Also an optional +# list of non-triviail values (notmally conditions) returned as a part +# of a joinfree condition hash sub _resolve_condition { - my ($self, $cond, $as, $for, $rel) = @_; + my ($self, $cond, $as, $for, $relname) = @_; + + my $obj_rel = !!blessed $for; + if (ref $cond eq 'CODE') { + my $relalias = $obj_rel ? 'me' : $as; - # heuristic for the actual relname - if (! defined $rel) { - if (!ref $as) { - $rel = $as; + my ($crosstable_cond, $joinfree_cond) = $cond->({ + self_alias => $obj_rel ? $as : $for, + foreign_alias => $relalias, + self_resultsource => $self, + foreign_relname => $relname || ($obj_rel ? $as : $for), + self_rowobj => $obj_rel ? $for : undef + }); + + my $cond_cols; + if ($joinfree_cond) { + + # FIXME sanity check until things stabilize, remove at some point + $self->throw_exception ( + "A join-free condition returned for relationship '$relname' without a row-object to chain from" + ) unless $obj_rel; + + # FIXME another sanity check + if ( + ref $joinfree_cond ne 'HASH' + or + first { $_ !~ /^\Q$relalias.\E.+/ } keys %$joinfree_cond + ) { + $self->throw_exception ( + "The join-free condition returned for relationship '$relname' must be a hash " + .'reference with all keys being valid columns on the related result source' + ); } - elsif (!ref $for) { - $rel = $for; + + # normalize + for (values %$joinfree_cond) { + $_ = $_->{'='} if ( + ref $_ eq 'HASH' + and + keys %$_ == 1 + and + exists $_->{'='} + ); } - } - if (! defined $rel) { - $self->throw_exception ('Unable to determine relationship name for condition resolution'); - } + # see which parts of the joinfree cond are conditionals + my $relcol_list = { map { $_ => 1 } $self->related_source($relname)->columns }; - return $cond->({ - self_alias => ref $for ? $as : $for, - foreign_alias => ref $for ? $self->related_source($rel)->resultset->current_source_alias : $as, - self_resultsource => $self, - foreign_relname => $rel, - self_rowobj => ref $for ? $for : undef - }); + for my $c (keys %$joinfree_cond) { + my ($colname) = $c =~ /^ (?: \Q$relalias.\E )? (.+)/x; + + unless ($relcol_list->{$colname}) { + push @$cond_cols, $colname; + next; + } - } elsif (ref $cond eq 'HASH') { + if ( + ref $joinfree_cond->{$c} + and + ref $joinfree_cond->{$c} ne 'SCALAR' + and + ref $joinfree_cond->{$c} ne 'REF' + ) { + push @$cond_cols, $colname; + next; + } + } + + return wantarray ? ($joinfree_cond, 0, $cond_cols) : $joinfree_cond; + } + else { + return wantarray ? ($crosstable_cond, 1) : $crosstable_cond; + } + } + elsif (ref $cond eq 'HASH') { my %ret; foreach my $k (keys %{$cond}) { my $v = $cond->{$k}; @@ -1613,18 +1673,29 @@ sub _resolve_condition { } elsif (!defined $as) { # undef, i.e. "no reverse object" $ret{$v} = undef; } else { - $ret{"${as}.${k}"} = "${for}.${v}"; + $ret{"${as}.${k}"} = { -ident => "${for}.${v}" }; } } - return \%ret; - } elsif (ref $cond eq 'ARRAY') { - return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ]; - } else { - $self->throw_exception ("Can't handle condition $cond yet :("); + + return wantarray + ? ( \%ret, ($obj_rel || !defined $as || ref $as) ? 0 : 1 ) + : \%ret + ; + } + elsif (ref $cond eq 'ARRAY') { + my (@ret, $crosstable); + for (@$cond) { + my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $relname); + push @ret, $cond; + $crosstable ||= $crosstab; + } + return wantarray ? (\@ret, $crosstable) : \@ret; + } + else { + $self->throw_exception ("Can't handle condition $cond for relationship '$relname' yet :("); } } - # Accepts one or more relationships for the current source and returns an # array of column names for each of those relationships. Column names are # prefixed relative to the current source, in accordance with where they appear @@ -1752,7 +1823,18 @@ sub related_source { if( !$self->has_relationship( $rel ) ) { $self->throw_exception("No such relationship '$rel' on " . $self->source_name); } - return $self->schema->source($self->relationship_info($rel)->{source}); + + # if we are not registered with a schema - just use the prototype + # however if we do have a schema - ask for the source by name (and + # throw in the process if all fails) + if (my $schema = try { $self->schema }) { + $schema->source($self->relationship_info($rel)->{source}); + } + else { + my $class = $self->relationship_info($rel)->{class}; + $self->ensure_class_loaded($class); + $class->result_source_instance; + } } =head2 related_class @@ -1809,7 +1891,10 @@ sub handle { { my $global_phase_destroy; - END { $global_phase_destroy++ } + # SpeedyCGI runs END blocks every cycle but keeps object instances + # hence we have to disable the globaldestroy hatch, and rely on the + # eval trap below (which appears to work, but is risky done so late) + END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy } sub DESTROY { return if $global_phase_destroy; @@ -1832,23 +1917,34 @@ sub handle { ); # weaken our schema hold forcing the schema to find somewhere else to live - weaken $_[0]->{schema}; + # during global destruction (if we have not yet bailed out) this will throw + # which will serve as a signal to not try doing anything else + local $@; + eval { + weaken $_[0]->{schema}; + 1; + } or do { + $global_phase_destroy = 1; + return; + }; + - # if schema is still there reintroduce ourselves with strong refs back + # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { my $srcregs = $_[0]->{schema}->source_registrations; for (keys %$srcregs) { + next unless $srcregs->{$_}; $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; } } } } -sub STORABLE_freeze { nfreeze($_[0]->handle) } +sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) } sub STORABLE_thaw { my ($self, $cloning, $ice) = @_; - %$self = %{ (thaw $ice)->resolve }; + %$self = %{ (Storable::thaw($ice))->resolve }; } =head2 throw_exception