X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=f45ea2fddf1b5cfd411d8666ecdfe690a89c00d0;hb=76031e147d6f0d80ab3ec73a12d373962ade1252;hp=58eed49fe52f98777df4b5c8345a049273beea1f;hpb=fed15b9163bcb281a3a654643949a9cd1f9a3928;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 58eed49..f45ea2f 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -3,25 +3,33 @@ package DBIx::Class::ResultSource; use strict; use warnings; +use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; + use DBIx::Class::ResultSet; use DBIx::Class::ResultSourceHandle; use DBIx::Class::Exception; use DBIx::Class::Carp; +use DBIx::Class::GlobalDestruction; use Try::Tiny; use List::Util 'first'; use Scalar::Util qw/blessed weaken isweak/; + use namespace::clean; -use base qw/DBIx::Class/; +__PACKAGE__->mk_group_accessors(simple => qw/ + source_name name source_info + _ordered_columns _columns _primaries _unique_constraints + _relationships resultset_attributes + column_info_from_storage +/); -__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns - _columns _primaries _unique_constraints name resultset_attributes - from _relationships column_info_from_storage source_info - source_name sqlt_deploy_callback/); +__PACKAGE__->mk_group_accessors(component_class => qw/ + resultset_class + result_class +/); -__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class - result_class/); +__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); =head1 NAME @@ -115,7 +123,6 @@ sub new { $new->{_relationships} = { %{$new->{_relationships}||{}} }; $new->{name} ||= "!!NAME NOT SET!!"; $new->{_columns_info_loaded} ||= 0; - $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook"; return $new; } @@ -886,12 +893,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. @@ -899,7 +915,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 @@ -919,19 +935,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 @@ -940,8 +950,8 @@ sub default_sqlt_deploy_hook { my $class = $self->result_class; - if ($class and my $hook = $class->can('sqlt_deploy_hook')) { - $self->$hook(@_); + if ($class and $class->can('sqlt_deploy_hook')) { + $class->sqlt_deploy_hook(@_); } } @@ -1033,6 +1043,20 @@ sub resultset { ); } +=head2 name + +=over 4 + +=item Arguments: None + +=item Result value: $name + +=back + +Returns the name of the result source, which will typically be the table +name. This may be a scalar reference if the result source has a non-standard +name. + =head2 source_name =over 4 @@ -1071,6 +1095,10 @@ Returns an expression of the source to be supplied to storage to specify retrieval from this source. In the case of a database, the required FROM clause contents. +=cut + +sub from { die 'Virtual method!' } + =head2 schema =over 4 @@ -1422,6 +1450,32 @@ sub _compare_relationship_keys { ; } +# optionally takes either an arrayref of column names, or a hashref of already +# retrieved colinfos +# returns an arrayref of column names of the shortest unique constraint +# (matching some of the input if any), giving preference to the PK +sub _identifying_column_set { + my ($self, $cols) = @_; + + my %unique = $self->unique_constraints; + my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||()); + + # always prefer the PK first, and then shortest constraints first + USET: + for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) { + next unless $set && @$set; + + for (@$set) { + next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} ); + } + + # copy so we can mangle it at will + return [ @$set ]; + } + + return undef; +} + # Returns the {from} structure used to express JOIN conditions sub _resolve_join { my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_; @@ -1435,7 +1489,7 @@ sub _resolve_join { $jpath = [@$jpath]; # copy - if (not defined $join) { + if (not defined $join or not length $join) { return (); } elsif (ref $join eq 'ARRAY') { @@ -1491,14 +1545,14 @@ sub _resolve_join { , -join_path => [@$jpath, { $join => $as } ], -is_single => ( - $rel_info->{attrs}{accessor} - && + (! $rel_info->{attrs}{accessor}) + or first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) ), -alias => $as, -relation_chain_depth => $seen->{-relation_chain_depth} || 0, }, - $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) + scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) ]; } } @@ -1578,7 +1632,7 @@ sub _resolve_condition { # FIXME sanity check until things stabilize, remove at some point $self->throw_exception ( - "A join-free condition returned for relationship '$relname' whithout a row-object to chain from" + "A join-free condition returned for relationship '$relname' without a row-object to chain from" ) unless $obj_rel; # FIXME another sanity check @@ -1693,114 +1747,6 @@ sub _resolve_condition { } } -# 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 -# in the supplied relationships. - -sub _resolve_prefetch { - my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_; - $pref_path ||= []; - - if (not defined $pre) { - return (); - } - elsif( ref $pre eq 'ARRAY' ) { - return - map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) } - @$pre; - } - elsif( ref $pre eq 'HASH' ) { - my @ret = - map { - $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ), - $self->related_source($_)->_resolve_prefetch( - $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] ) - } keys %$pre; - return @ret; - } - elsif( ref $pre ) { - $self->throw_exception( - "don't know how to resolve prefetch reftype ".ref($pre)); - } - else { - my $p = $alias_map; - $p = $p->{$_} for (@$pref_path, $pre); - - $self->throw_exception ( - "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: " - . join (' -> ', @$pref_path, $pre) - ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} ); - - my $as = shift @{$p->{-join_aliases}}; - - my $rel_info = $self->relationship_info( $pre ); - $self->throw_exception( $self->source_name . " has no such relationship '$pre'" ) - unless $rel_info; - my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : ''); - my $rel_source = $self->related_source($pre); - - if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') { - $self->throw_exception( - "Can't prefetch has_many ${pre} (join cond too complex)") - unless ref($rel_info->{cond}) eq 'HASH'; - my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}" - - if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots } - keys %{$collapse}) { - my ($last) = ($fail =~ /([^\.]+)$/); - carp ( - "Prefetching multiple has_many rels ${last} and ${pre} " - .(length($as_prefix) - ? "at the same level (${as_prefix}) " - : "at top level " - ) - . 'will explode the number of row objects retrievable via ->next or ->all. ' - . 'Use at your own risk.' - ); - } - - #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); } - # values %{$rel_info->{cond}}; - $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ]; - # action at a distance. prepending the '.' allows simpler code - # in ResultSet->_collapse_result - my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); } - keys %{$rel_info->{cond}}; - push @$order, map { "${as}.$_" } @key; - - if (my $rel_order = $rel_info->{attrs}{order_by}) { - # this is kludgy and incomplete, I am well aware - # but the parent method is going away entirely anyway - # so sod it - my $sql_maker = $self->storage->sql_maker; - my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars; - my $sep = $sql_maker->name_sep; - - # install our own quoter, so we can catch unqualified stuff - local $sql_maker->{quote_char} = ["\x00", "\xFF"]; - - my $quoted_prefix = "\x00${as}\xFF"; - - for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) { - my @bind; - ($chunk, @bind) = @$chunk if ref $chunk; - - $chunk = "${quoted_prefix}${sep}${chunk}" - unless $chunk =~ /\Q$sep/; - - $chunk =~ s/\x00/$orig_ql/g; - $chunk =~ s/\xFF/$orig_qr/g; - push @$order, \[$chunk, @bind]; - } - } - } - - return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] } - $rel_source->columns; - } -} - =head2 related_source =over 4 @@ -1885,16 +1831,9 @@ sub handle { }); } -{ - my $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; +my $global_phase_destroy; +sub DESTROY { + return if $global_phase_destroy ||= in_global_destruction; ###### # !!! ACHTUNG !!!! @@ -1906,25 +1845,21 @@ sub handle { # we are trying to save to reattach back to the source we are destroying. # The relevant code checking refcounts is in ::Schema::DESTROY() - # if we are not a schema instance holder - we don't matter - return if( - ! ref $_[0]->{schema} - or - isweak $_[0]->{schema} - ); - - # weaken our schema hold forcing the schema to find somewhere else to live - # 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 we are not a schema instance holder - we don't matter + return if( + ! ref $_[0]->{schema} + or + isweak $_[0]->{schema} + ); + # weaken our schema hold forcing the schema to find somewhere else to live + # 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 + # however beware - on older perls the exception seems randomly untrappable + # due to some weird race condition during thread joining :((( + local $@; + eval { + weaken $_[0]->{schema}; # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { @@ -1934,7 +1869,13 @@ sub handle { $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; } } - } + + 1; + } or do { + $global_phase_destroy = 1; + }; + + return; } sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }