X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=dffe6ada3a88d11fec0e4edac812c4830f1ff7e3;hb=f116ff4e8c8802234686405ad4ab44bff1a545f6;hp=e7ab22d80cf2d6de18987fe5627ab50c7c122f93;hpb=52416317a26986602098ffe2ea6aa64a05925b6f;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index e7ab22d..dffe6ad 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -7,16 +7,17 @@ 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 namespace::clean; use base qw/DBIx::Class/; __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns _columns _primaries _unique_constraints name resultset_attributes - schema from _relationships column_info_from_storage source_info + from _relationships column_info_from_storage source_info source_name sqlt_deploy_callback/); __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class @@ -365,7 +366,7 @@ sub column_info { if ( ! $self->_columns->{$column}{data_type} and ! $self->{_columns_info_loaded} and $self->column_info_from_storage - and $self->schema and my $stor = $self->storage ) + and my $stor = try { $self->storage } ) { $self->{_columns_info_loaded}++; @@ -426,7 +427,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 @@ -443,9 +444,7 @@ sub columns_info { and $self->column_info_from_storage and - $self->schema - and - my $stor = $self->storage + my $stor = try { $self->storage } ) { $self->{_columns_info_loaded}++; @@ -633,12 +632,11 @@ will be applied to the L of each L sub sequence { my ($self,$seq) = @_; - my $rsrc = $self->result_source; - my @pks = $rsrc->primary_columns - or next; + my @pks = $self->primary_columns + or return; $_->{sequence} = $seq - for values %{ $rsrc->columns_info (\@pks) }; + for values %{ $self->columns_info (\@pks) }; } @@ -1014,11 +1012,11 @@ sub resultset { 'call it on the schema instead.' ) if scalar @_; - return $self->resultset_class->new( + $self->resultset_class->new( $self, { + try { %{$self->schema->default_resultset_attributes} }, %{$self->{resultset_attributes}}, - %{$self->schema->default_resultset_attributes} }, ); } @@ -1065,7 +1063,7 @@ clause contents. =over 4 -=item Arguments: None +=item Arguments: $schema =item Return value: A schema object @@ -1073,8 +1071,29 @@ clause contents. my $schema = $source->schema(); -Returns the L object that this result source -belongs to. +Sets and/or returns the L object to which this +result source instance has been attached to. + +=cut + +sub schema { + if (@_ > 1) { + $_[0]->{schema} = $_[1]; + } + else { + $_[0]->{schema} || do { + my $name = $_[0]->{source_name} || '_unnamed_'; + my $err = 'Unable to perform storage-dependent operations with a detached result source ' + . "(source '$name' is not associated with a schema)."; + + $err .= ' You need to use $schema->thaw() or manually set' + . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.' + if $_[0]->{_detached_thaw}; + + DBIx::Class::Exception->throw($err); + }; + } +} =head2 storage @@ -1307,53 +1326,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) { - my $otherrel_info = $othertable->relationship_info($otherrel); + # columns are our foreign columns on $rel + foreach my $other_rel ($other_rsrc->relationships) { - my $back = $othertable->related_source($otherrel); - next unless $back->source_name eq $self->source_name; + # 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 - my @othertestconds; + # the schema may be partial + my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) } + or next; - if (ref $otherrel_info->{cond} eq 'HASH') { - @othertestconds = ($otherrel_info->{cond}); - } - elsif (ref $otherrel_info->{cond} eq 'ARRAY') { - @othertestconds = @{$otherrel_info->{cond}}; + 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; @@ -1362,36 +1402,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 @@ -1456,7 +1472,7 @@ sub _resolve_join { my $rel_src = $self->related_source($join); return [ { $as => $rel_src->from, - -source_handle => $rel_src->handle, + -rsrc => $rel_src, -join_type => $parent_force_left ? 'left' : $rel_info->{attrs}{join_type} @@ -1703,7 +1719,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 @@ -1730,16 +1757,90 @@ sub related_class { =head2 handle -Obtain a new handle to this source. Returns an instance of a -L. +=over 4 + +=item Arguments: None + +=item Return value: $source_handle + +=back + +Obtain a new L +for this source. Used as a serializable pointer to this resultsource, as it is not +easy (nor advisable) to serialize CODErefs which may very well be present in e.g. +relationship definitions. =cut sub handle { - return DBIx::Class::ResultSourceHandle->new({ - schema => $_[0]->schema, - source_moniker => $_[0]->source_name - }); + return DBIx::Class::ResultSourceHandle->new({ + source_moniker => $_[0]->source_name, + + # so that a detached thaw can be re-frozen + $_[0]->{_detached_thaw} + ? ( _detached_source => $_[0] ) + : ( schema => $_[0]->schema ) + , + }); +} + +{ + 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; + +###### +# !!! ACHTUNG !!!! +###### +# +# Under no circumstances shall $_[0] be stored anywhere else (like copied to +# a lexical variable, or shifted, or anything else). Doing so will mess up +# the refcount of this particular result source, and will allow the $schema +# 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 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 { Storable::nfreeze($_[0]->handle) } + +sub STORABLE_thaw { + my ($self, $cloning, $ice) = @_; + %$self = %{ (Storable::thaw($ice))->resolve }; } =head2 throw_exception @@ -1751,12 +1852,10 @@ See L. sub throw_exception { my $self = shift; - if (defined $self->schema) { - $self->schema->throw_exception(@_); - } - else { - DBIx::Class::Exception->throw(@_); - } + $self->{schema} + ? $self->{schema}->throw_exception(@_) + : DBIx::Class::Exception->throw(@_) + ; } =head2 source_info