X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=d2cc10f6a615ee9e54d9afdaba923853daf76484;hb=d009cb7d393292037eff527a9f8bab93860224fb;hp=34f26e9de030d812da5cc4827db86a6803864bb1;hpb=21621fe4565697ead298e6829425dc0e9e5ba816;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 34f26e9..d2cc10f 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -3,17 +3,15 @@ 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 base 'DBIx::Class'; +__PACKAGE__->load_components(qw( + ResultSource::RowParser +)); use DBIx::Class::Carp; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; -use Try::Tiny; -use List::Util 'first'; use Scalar::Util qw/blessed weaken isweak/; use namespace::clean; @@ -77,7 +75,7 @@ More specifically, the L base class pulls in the L component, which defines the L method. When called, C creates and stores an instance of -L. Luckily, to use tables as result +L. Luckily, to use tables as result sources, you don't need to remember any of this. Result sources representing select queries, or views, can also be @@ -86,7 +84,8 @@ created, see L for full details. =head2 Finding result source objects As mentioned above, a result source instance is created and stored for -you when you define a L. +you when you define a +L. You can retrieve the result source at runtime in the following ways: @@ -108,7 +107,13 @@ You can retrieve the result source at runtime in the following ways: =head1 METHODS -=pod +=head2 new + + $class->new(); + + $class->new({attribute_name => value}); + +Creates a new ResultSource object. Not normally called directly by end users. =cut @@ -204,6 +209,12 @@ The length of your column, if it is a column type that can have a size restriction. This is currently only used to create tables from your schema, see L. + { size => [ 9, 6 ] } + +For decimal or float values you can specify an ArrayRef in order to +control precision, assuming your database's +L supports it. + =item is_nullable { is_nullable => 1 } @@ -391,12 +402,12 @@ sub column_info { if ( ! $self->_columns->{$column}{data_type} and ! $self->{_columns_info_loaded} and $self->column_info_from_storage - and my $stor = try { $self->storage } ) + and my $stor = dbic_internal_try { $self->storage } ) { $self->{_columns_info_loaded}++; # try for the case of storage without table - try { + dbic_internal_try { my $info = $stor->columns_info_for( $self->from ); my $lc_info = { map { (lc $_) => $info->{$_} } @@ -463,18 +474,18 @@ sub columns_info { my $colinfo = $self->_columns; if ( - first { ! $_->{data_type} } values %$colinfo - and ! $self->{_columns_info_loaded} and $self->column_info_from_storage and - my $stor = try { $self->storage } + grep { ! $_->{data_type} } values %$colinfo + and + my $stor = dbic_internal_try { $self->storage } ) { $self->{_columns_info_loaded}++; # try for the case of storage without table - try { + dbic_internal_try { my $info = $stor->columns_info_for( $self->from ); my $lc_info = { map { (lc $_) => $info->{$_} } @@ -582,7 +593,7 @@ sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB Defines one or more columns as primary key for this source. Must be called after L. -Additionally, defines a L +Additionally, defines a L named C. Note: you normally do want to define a primary key on your sources @@ -790,7 +801,7 @@ sub add_unique_constraints { my $self = shift; my @constraints = @_; - if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) { + if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) { # with constraint name while (my ($name, $constraint) = splice @constraints, 0, 2) { $self->add_unique_constraint($name => $constraint); @@ -1118,7 +1129,7 @@ sub resultset { $self->resultset_class->new( $self, { - try { %{$self->schema->default_resultset_attributes} }, + ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ), %{$self->{resultset_attributes}}, }, ); @@ -1180,6 +1191,17 @@ clause contents. sub from { die 'Virtual method!' } +=head2 source_info + +Stores a hashref of per-source metadata. No specific key names +have yet been standardized, the examples below are purely hypothetical +and don't actually accomplish anything on their own: + + __PACKAGE__->source_info({ + "_tablespace" => 'fast_disk_array_3', + "_engine" => 'InnoDB', + }); + =head2 schema =over 4 @@ -1331,35 +1353,11 @@ sub add_relationship { my %rels = %{ $self->_relationships }; $rels{$rel} = { class => $f_source_name, source => $f_source_name, - _original_name => $rel, cond => $cond, attrs => $attrs }; $self->_relationships(\%rels); return $self; - -# XXX disabled. doesn't work properly currently. skip in tests. - - my $f_source = $self->schema->source($f_source_name); - unless ($f_source) { - $self->ensure_class_loaded($f_source_name); - $f_source = $f_source_name->result_source; - #my $s_class = ref($self->schema); - #$f_source_name =~ m/^${s_class}::(.*)$/; - #$self->schema->register_class(($1 || $f_source_name), $f_source_name); - #$f_source = $self->schema->source($f_source_name); - } - return unless $f_source; # Can't test rel without f_source - - try { $self->_resolve_join($rel, 'me', {}, []) } - catch { - # If the resolve failed, back out and re-throw the error - delete $rels{$rel}; - $self->_relationships(\%rels); - $self->throw_exception("Error creating relationship $rel: $_"); - }; - - 1; } =head2 relationships @@ -1472,7 +1470,7 @@ sub reverse_relationship_info { # 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) } + my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) } or next; if ($registered_source_name) { @@ -1685,14 +1683,20 @@ sub _resolve_join { , -join_path => [@$jpath, { $join => $as } ], -is_single => ( - (! $rel_info->{attrs}{accessor}) + ! $rel_info->{attrs}{accessor} + or + $rel_info->{attrs}{accessor} eq 'single' or - first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) + $rel_info->{attrs}{accessor} eq 'filter' ), -alias => $as, -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, }, - scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) + $self->_resolve_relationship_condition( + rel_name => $join, + self_alias => $alias, + foreign_alias => $as, + )->{condition}, ]; } } @@ -1787,8 +1791,6 @@ sub _resolve_condition { } my $args = { - condition => $cond, - # where-is-waldo block guesses relname, then further down we override it if available ( $is_objlike[1] ? ( rel_name => $res_args[0], self_alias => $res_args[0], foreign_alias => 'me', self_result_object => $res_args[1] ) @@ -1798,6 +1800,12 @@ sub _resolve_condition { ( $rel_name ? ( rel_name => $rel_name ) : () ), }; + + # Allowing passing relconds different than the relationshup itself is cute, + # but likely dangerous. Remove that from the (still unofficial) API of + # _resolve_relationship_condition, and instead make it "hard on purpose" + local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond; + ####################### # now it's fucking easy isn't it?! @@ -1841,7 +1849,6 @@ Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); # self_result_object => (either not supplied or a result object) # require_join_free_condition => (boolean, throws on failure to construct a JF-cond) # infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition) -# condition => (sqla cond struct, optional, defeaults to from $self->rel_info(rel_name)->{cond}) # ## returns a hash # condition => (a valid *likely fully qualified* sqla cond structure) @@ -1865,12 +1872,17 @@ sub _resolve_relationship_condition { $self->throw_exception("Arguments 'self_alias' and 'foreign_alias' may not be identical") if $args->{self_alias} eq $args->{foreign_alias}; +# TEMP + my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'"; + my $rel_info = $self->relationship_info($args->{rel_name}) # TEMP # or $self->throw_exception( "No such $exception_rel_id" ); or carp_unique("Requesting resolution on non-existent relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}': fix your code *soon*, as it will break with the next major version"); - my $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'"; +# TEMP + $exception_rel_id = "relationship '$rel_info->{_original_name}' on source '@{[ $self->source_name ]}'" + if $rel_info and exists $rel_info->{_original_name}; $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures") if exists $args->{self_result_object} and exists $args->{foreign_values}; @@ -1880,20 +1892,24 @@ sub _resolve_relationship_condition { $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; - $args->{condition} ||= $rel_info->{cond}; - - $self->throw_exception( "Argument 'self_result_object' must be an object of class '@{[ $self->result_class ]}'" ) + $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) if ( exists $args->{self_result_object} and - ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa($self->result_class) ) + ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) ) ; my $rel_rsrc = $self->related_source($args->{rel_name}); + my $storage = $self->schema->storage; if (exists $args->{foreign_values}) { - if (defined blessed $args->{foreign_values}) { + + if (! defined $args->{foreign_values} ) { + # fallback: undef => {} + $args->{foreign_values} = {}; + } + elsif (defined blessed $args->{foreign_values}) { $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) unless $args->{foreign_values}->isa('DBIx::Class::Row'); @@ -1906,11 +1922,41 @@ sub _resolve_relationship_condition { $args->{foreign_values} = { $args->{foreign_values}->get_columns }; } - elsif (! defined $args->{foreign_values} or ref $args->{foreign_values} eq 'HASH') { - my $ci = $rel_rsrc->columns_info; - ! exists $ci->{$_} and $self->throw_exception( - "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" - ) for keys %{ $args->{foreign_values} ||= {} }; + elsif ( ref $args->{foreign_values} eq 'HASH' ) { + + # re-build {foreign_values} excluding identically named rels + if( keys %{$args->{foreign_values}} ) { + + my ($col_idx, $rel_idx) = map + { { map { $_ => 1 } $rel_rsrc->$_ } } + qw( columns relationships ) + ; + + my $equivalencies = $storage->_extract_fixed_condition_columns( + $args->{foreign_values}, + 'consider nulls', + ); + + $args->{foreign_values} = { map { + # skip if relationship *and* a non-literal ref + # this means a multicreate stub was passed in + ( + $rel_idx->{$_} + and + length ref $args->{foreign_values}{$_} + and + ! is_literal_value($args->{foreign_values}{$_}) + ) + ? () + : ( $_ => ( + ! $col_idx->{$_} + ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" ) + : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION ) + ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" ) + : $args->{foreign_values}{$_} + )) + } keys %{$args->{foreign_values}} }; + } } else { $self->throw_exception( @@ -1922,7 +1968,7 @@ sub _resolve_relationship_condition { my $ret; - if (ref $args->{condition} eq 'CODE') { + if (ref $rel_info->{cond} eq 'CODE') { my $cref_args = { rel_name => $args->{rel_name}, @@ -1941,7 +1987,7 @@ sub _resolve_relationship_condition { $cref_args->{self_rowobj} = $cref_args->{self_result_object} if exists $cref_args->{self_result_object}; - ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $args->{condition}->($cref_args); + ($ret->{condition}, $ret->{join_free_condition}, my @extra) = $rel_info->{cond}->($cref_args); # sanity check $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra") @@ -1976,7 +2022,7 @@ sub _resolve_relationship_condition { exists $fq_col_list->{$_} or $self->throw_exception ( "The join-free condition returned for $exception_rel_id may only " . 'contain keys that are fully qualified column names of the corresponding source ' - . "(it returned '$_')" + . "'$joinfree_alias' (instead it returned '$_')" ) for keys %$jfc; ( @@ -1995,14 +2041,14 @@ sub _resolve_relationship_condition { } } - elsif (ref $args->{condition} eq 'HASH') { + elsif (ref $rel_info->{cond} eq 'HASH') { # the condition is static - use parallel arrays # for a "pivot" depending on which side of the # rel did we get as an object my (@f_cols, @l_cols); - for my $fc (keys %{$args->{condition}}) { - my $lc = $args->{condition}{$fc}; + for my $fc (keys %{ $rel_info->{cond} }) { + my $lc = $rel_info->{cond}{$fc}; # FIXME STRICTMODE should probably check these are valid columns $fc =~ s/^foreign\.// || @@ -2050,48 +2096,60 @@ sub _resolve_relationship_condition { } } } - elsif (ref $args->{condition} eq 'ARRAY') { - if (@{$args->{condition}} == 0) { + elsif (ref $rel_info->{cond} eq 'ARRAY') { + if (@{ $rel_info->{cond} } == 0) { $ret = { condition => UNRESOLVABLE_CONDITION, join_free_condition => UNRESOLVABLE_CONDITION, }; } - elsif (@{$args->{condition}} == 1) { - $ret = $self->_resolve_relationship_condition({ - %$args, - condition => $args->{condition}[0], - }); - } else { - # we are discarding inferred values here... likely incorrect... - # then again - the entire thing is an OR, so we *can't* use them anyway - for my $subcond ( map - { $self->_resolve_relationship_condition({ %$args, condition => $_ }) } - @{$args->{condition}} - ) { - $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') - if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); + my @subconds = map { + local $rel_info->{cond} = $_; + $self->_resolve_relationship_condition( $args ); + } @{ $rel_info->{cond} }; + + if( @{ $rel_info->{cond} } == 1 ) { + $ret = $subconds[0]; + } + else { + # we are discarding inferred values here... likely incorrect... + # then again - the entire thing is an OR, so we *can't* use them anyway + for my $subcond ( @subconds ) { + $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') + if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); - $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); + $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); + } } } } else { - $self->throw_exception ("Can't handle condition $args->{condition} for $exception_rel_id yet :("); + $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :("); } - $self->throw_exception(ucfirst "$exception_rel_id does not resolve to a join-free condition fragment") if ( + if ( $args->{require_join_free_condition} and ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) - ); - - my $storage = $self->schema->storage; + ) { + $self->throw_exception( + ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment", + exists $args->{foreign_values} + ? "'foreign_values'-based reversed-" + : '' + ); + } # we got something back - sanity check and infer values if we can my @nonvalues; - if ( my $jfc = $ret->{join_free_condition} and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION ) { + if ( + $ret->{join_free_condition} + and + $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION + and + my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} ) + ) { my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); @@ -2163,10 +2221,28 @@ sub _resolve_relationship_condition { ; } } + elsif ( + $col_eqs->{$lhs} =~ /^ ( \Q$args->{self_alias}\E \. .+ ) /x + and + ($colinfos->{$1}||{})->{-result_source} == $rel_rsrc + ) { + my ($lcol, $rcol) = map + { $colinfos->{$_}{-colname} } + ( $lhs, $1 ) + ; + carp_unique( + "The $exception_rel_id specifies equality of column '$lcol' and the " + . "*VALUE* '$rcol' (you did not use the { -ident => ... } operator)" + ); + } } } - $ret + # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition + $ret->{condition} = { -and => [ $ret->{condition} ] } + unless $ret->{condition} eq UNRESOLVABLE_CONDITION; + + $ret; } =head2 related_source @@ -2192,7 +2268,7 @@ sub related_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 }) { + if (my $schema = dbic_internal_try { $self->schema }) { $schema->source($self->relationship_info($rel)->{source}); } else { @@ -2242,6 +2318,7 @@ relationship definitions. =cut sub handle { + require DBIx::Class::ResultSourceHandle; return DBIx::Class::ResultSourceHandle->new({ source_moniker => $_[0]->source_name, @@ -2255,6 +2332,9 @@ sub handle { my $global_phase_destroy; sub DESTROY { + ### NO detected_reinvoked_destructor check + ### This code very much relies on being called multuple times + return if $global_phase_destroy ||= in_global_destruction; ###### @@ -2279,6 +2359,7 @@ sub DESTROY { # 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 $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { weaken $_[0]->{schema}; @@ -2286,10 +2367,15 @@ sub DESTROY { # 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]; - } + + defined $srcregs->{$_} + and + $srcregs->{$_} == $_[0] + and + $srcregs->{$_} = $_[0] + and + last + for keys %$srcregs; } 1; @@ -2297,7 +2383,10 @@ sub DESTROY { $global_phase_destroy = 1; }; - return; + # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage + # collected before leaving this scope. Depending on the code above, this + # may very well be just a preventive measure guarding future modifications + undef; } sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) } @@ -2322,25 +2411,6 @@ sub throw_exception { ; } -=head2 source_info - -Stores a hashref of per-source metadata. No specific key names -have yet been standardized, the examples below are purely hypothetical -and don't actually accomplish anything on their own: - - __PACKAGE__->source_info({ - "_tablespace" => 'fast_disk_array_3', - "_engine" => 'InnoDB', - }); - -=head2 new - - $class->new(); - - $class->new({attribute_name => value}); - -Creates a new ResultSource object. Not normally called directly by end users. - =head2 column_info_from_storage =over @@ -2357,14 +2427,16 @@ Enables the on-demand automatic loading of the above column metadata from storage as necessary. This is *deprecated*, and should not be used. It will be removed before 1.0. +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut