X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRow.pm;h=6d1b341012632c34c7634ffee58e493ad5f42d32;hb=f064a2abb15858bb39a141ad50391d4191988d2c;hp=9127c942ee672e4712857b3b9408a948f99c35f9;hpb=5ae153d7a25b664e5dc33824a7efd690ac9786b5;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 9127c94..6d1b341 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -6,10 +6,9 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util 'blessed'; -use List::Util 'first'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call ); use DBIx::Class::Carp; -use DBIx::Class::_Util 'is_literal_value'; +use SQL::Abstract qw( is_literal_value is_plain_value ); ### ### Internal method @@ -52,7 +51,7 @@ All "Row objects" derived from a Schema-attached L object (such as a typical C<< L-> L >> call) are actually Result instances, based on your application's -L. +L. L implements most of the row-based communication with the underlying storage, but a Result class B. @@ -126,26 +125,26 @@ with NULL as the default, and save yourself a SELECT. ## tests! sub __new_related_find_or_new_helper { - my ($self, $relname, $values) = @_; + my ($self, $rel_name, $values) = @_; my $rsrc = $self->result_source; # create a mock-object so all new/set_column component overrides will run: - my $rel_rs = $rsrc->related_source($relname)->resultset; + my $rel_rs = $rsrc->related_source($rel_name)->resultset; my $new_rel_obj = $rel_rs->new_result($values); my $proc_data = { $new_rel_obj->get_columns }; - if ($self->__their_pk_needs_us($relname)) { - MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via new_result\n"; + if ($self->__their_pk_needs_us($rel_name)) { + MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via new_result\n"; return $new_rel_obj; } - elsif ($rsrc->_pk_depends_on($relname, $proc_data )) { + elsif ($rsrc->_pk_depends_on($rel_name, $proc_data )) { if (! keys %$proc_data) { # there is nothing to search for - blind create - MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $relname\n"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $rel_name\n"; } else { - MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via find_or_new\n"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via find_or_new\n"; # this is not *really* find or new, as we don't want to double-new the # data (thus potentially double encoding or whatever) my $exists = $rel_rs->find ($proc_data); @@ -156,17 +155,17 @@ sub __new_related_find_or_new_helper { else { my $us = $rsrc->source_name; $self->throw_exception ( - "Unable to determine relationship '$relname' direction from '$us', " - . "possibly due to a missing reverse-relationship on '$relname' to '$us'." + "Unable to determine relationship '$rel_name' direction from '$us', " + . "possibly due to a missing reverse-relationship on '$rel_name' to '$us'." ); } } sub __their_pk_needs_us { # this should maybe be in resultsource. - my ($self, $relname) = @_; + my ($self, $rel_name) = @_; my $rsrc = $self->result_source; - my $reverse = $rsrc->reverse_relationship_info($relname); - my $rel_source = $rsrc->related_source($relname); + my $reverse = $rsrc->reverse_relationship_info($rel_name); + my $rel_source = $rsrc->related_source($rel_name); my $us = { $self->get_columns }; foreach my $key (keys %$reverse) { # if their primary key depends on us, then we have to @@ -200,7 +199,7 @@ sub new { my ($related,$inflated); foreach my $key (keys %$attrs) { - if (ref $attrs->{$key}) { + if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) { ## Can we extract this lot to use with update(_or .. ) ? $new->throw_exception("Can't do multi-create without result source") unless $rsrc; @@ -257,14 +256,16 @@ sub new { } $inflated->{$key} = $rel_obj; next; - } elsif ($class->has_column($key) - && $class->column_info($key)->{_inflate_info}) { + } + elsif ( + $rsrc->has_column($key) + and + $rsrc->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}); } @@ -342,7 +343,7 @@ sub insert { $self->throw_exception("No result_source set on this object; can't insert") unless $rsrc; - my $storage = $rsrc->storage; + my $storage = $rsrc->schema->storage; my $rollback_guard; @@ -352,27 +353,26 @@ sub insert { # insert what needs to be inserted before us my %pre_insert; - for my $relname (keys %related_stuff) { - my $rel_obj = $related_stuff{$relname}; + for my $rel_name (keys %related_stuff) { + my $rel_obj = $related_stuff{$rel_name}; - if (! $self->{_rel_in_storage}{$relname}) { + if (! $self->{_rel_in_storage}{$rel_name}) { next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row')); next unless $rsrc->_pk_depends_on( - $relname, { $rel_obj->get_columns } + $rel_name, { $rel_obj->get_columns } ); # The guard will save us if we blow out of this scope via die $rollback_guard ||= $storage->txn_scope_guard; - MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $relname $rel_obj\n"; + MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $rel_name $rel_obj\n"; my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns }; my $existing; # if there are no keys - nothing to search for - if (keys %$them and $existing = $self->result_source - ->related_source($relname) + if (keys %$them and $existing = $rsrc->related_source($rel_name) ->resultset ->find($them) ) { @@ -382,11 +382,11 @@ sub insert { $rel_obj->insert; } - $self->{_rel_in_storage}{$relname} = 1; + $self->{_rel_in_storage}{$rel_name} = 1; } - $self->set_from_related($relname, $rel_obj); - delete $related_stuff{$relname}; + $self->set_from_related($rel_name, $rel_obj); + delete $related_stuff{$rel_name}; } # start a transaction here if not started yet and there is more stuff @@ -417,7 +417,14 @@ sub insert { or (defined $current_rowdata{$_} xor defined $returned_cols->{$_}) or - (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_}) + ( + defined $current_rowdata{$_} + and + # one of the few spots doing forced-stringification + # needed to work around objects with defined stringification + # but *without* overloaded comparison (ugh!) + "$current_rowdata{$_}" ne "$returned_cols->{$_}" + ) ); } @@ -427,25 +434,25 @@ sub insert { $self->{_dirty_columns} = {}; $self->{related_resultsets} = {}; - foreach my $relname (keys %related_stuff) { - next unless $rsrc->has_relationship ($relname); + foreach my $rel_name (keys %related_stuff) { + next unless $rsrc->has_relationship ($rel_name); - my @cands = ref $related_stuff{$relname} eq 'ARRAY' - ? @{$related_stuff{$relname}} - : $related_stuff{$relname} + my @cands = ref $related_stuff{$rel_name} eq 'ARRAY' + ? @{$related_stuff{$rel_name}} + : $related_stuff{$rel_name} ; if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row') ) { - my $reverse = $rsrc->reverse_relationship_info($relname); + my $reverse = $rsrc->reverse_relationship_info($rel_name); foreach my $obj (@cands) { $obj->set_from_related($_, $self) for keys %$reverse; - if ($self->__their_pk_needs_us($relname)) { - if (exists $self->{_ignore_at_insert}{$relname}) { - MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $relname\n"; + if ($self->__their_pk_needs_us($rel_name)) { + if (exists $self->{_ignore_at_insert}{$rel_name}) { + MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $rel_name\n"; } else { - MULTICREATE_DEBUG and print STDERR "MC $self inserting $relname $obj\n"; + MULTICREATE_DEBUG and print STDERR "MC $self inserting $rel_name $obj\n"; $obj->insert; } } else { @@ -478,8 +485,8 @@ sub insert { Indicates whether the object exists as a row in the database or not. This is set to true when L, -L or L -are used. +L or L +are invoked. Creating a result object using L, or calling L on one, sets it to false. @@ -549,7 +556,7 @@ sub update { $self->throw_exception( "Not in database" ) unless $self->in_storage; - my $rows = $self->result_source->storage->update( + my $rows = $self->result_source->schema->storage->update( $self->result_source, \%to_update, $self->_storage_ident_condition ); if ($rows == 0) { @@ -611,7 +618,7 @@ sub delete { if (ref $self) { $self->throw_exception( "Not in database" ) unless $self->in_storage; - $self->result_source->storage->delete( + $self->result_source->schema->storage->delete( $self->result_source, $self->_storage_ident_condition ); @@ -619,7 +626,7 @@ sub delete { $self->in_storage(0); } else { - my $rsrc = try { $self->result_source_instance } + my $rsrc = dbic_internal_try { $self->result_source_instance } or $self->throw_exception("Can't do class delete without a ResultSource instance"); my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; @@ -673,8 +680,8 @@ sub get_column { )); } - $self->throw_exception( "No such column '${column}'" ) - unless $self->has_column($column); + $self->throw_exception( "No such column '${column}' on " . ref $self ) + unless $self->result_source->has_column($column); return undef; } @@ -801,8 +808,8 @@ really changed. sub make_column_dirty { my ($self, $column) = @_; - $self->throw_exception( "No such column '${column}'" ) - unless exists $self->{_column_data}{$column} || $self->has_column($column); + $self->throw_exception( "No such column '${column}' on " . ref $self ) + unless exists $self->{_column_data}{$column} || $self->result_source->has_column($column); # the entire clean/dirty code relies on exists, not on true/false return 1 if exists $self->{_dirty_columns}{$column}; @@ -844,9 +851,9 @@ See L for how to setup inflation. sub get_inflated_columns { my $self = shift; - my $loaded_colinfo = $self->columns_info ([ - grep { $self->has_column_loaded($_) } $self->columns - ]); + my $loaded_colinfo = $self->result_source->columns_info; + $self->has_column_loaded($_) or delete $loaded_colinfo->{$_} + for keys %$loaded_colinfo; my %cols_to_return = ( %{$self->{_column_data}}, %$loaded_colinfo ); @@ -888,14 +895,20 @@ sub get_inflated_columns { } sub _is_column_numeric { - my ($self, $column) = @_; - my $colinfo = $self->column_info ($column); + my ($self, $column) = @_; + + my $rsrc; + + return undef + unless ( $rsrc = $self->result_source )->has_column($column); + + my $colinfo = $rsrc->column_info ($column); # cache for speed (the object may *not* have a resultsource instance) if ( ! defined $colinfo->{is_numeric} and - my $storage = try { $self->result_source->schema->storage } + my $storage = dbic_internal_try { $rsrc->schema->storage } ) { $colinfo->{is_numeric} = $storage->is_datatype_numeric ($colinfo->{data_type}) @@ -940,9 +953,10 @@ sub set_column { my $dirty = $self->{_dirty_columns}{$column} || - $self->in_storage # no point tracking dirtyness on uninserted data + ( $self->in_storage # no point tracking dirtyness on uninserted data ? ! $self->_eq_column_values ($column, $old_value, $new_value) : 1 + ) ; if ($dirty) { @@ -953,20 +967,20 @@ sub set_column { # # FIXME - this is a quick *largely incorrect* hack, pending a more # serious rework during the merge of single and filter rels - my $relnames = $self->result_source->{_relationships}; - for my $relname (keys %$relnames) { + my $rel_names = $self->result_source->{_relationships}; + for my $rel_name (keys %$rel_names) { - my $acc = $relnames->{$relname}{attrs}{accessor} || ''; + my $acc = $rel_names->{$rel_name}{attrs}{accessor} || ''; - if ( $acc eq 'single' and $relnames->{$relname}{attrs}{fk_columns}{$column} ) { - delete $self->{related_resultsets}{$relname}; - delete $self->{_relationship_data}{$relname}; - #delete $self->{_inflated_column}{$relname}; + if ( $acc eq 'single' and $rel_names->{$rel_name}{attrs}{fk_columns}{$column} ) { + delete $self->{related_resultsets}{$rel_name}; + delete $self->{_relationship_data}{$rel_name}; + #delete $self->{_inflated_column}{$rel_name}; } - elsif ( $acc eq 'filter' and $relname eq $column) { - delete $self->{related_resultsets}{$relname}; - #delete $self->{_relationship_data}{$relname}; - delete $self->{_inflated_column}{$relname}; + elsif ( $acc eq 'filter' and $rel_name eq $column) { + delete $self->{related_resultsets}{$rel_name}; + #delete $self->{_relationship_data}{$rel_name}; + delete $self->{_inflated_column}{$rel_name}; } } @@ -1020,7 +1034,10 @@ sub _eq_column_values { # value tracked between column changes and commitment to storage sub _track_storage_value { my ($self, $col) = @_; - return defined first { $col eq $_ } ($self->primary_columns); + return scalar grep + { $col eq $_ } + $self->result_source->primary_columns + ; } =head2 set_columns @@ -1049,7 +1066,7 @@ sub set_columns { =head2 set_inflated_columns - $result->set_inflated_columns({ $col => $val, $relname => $obj, ... }); + $result->set_inflated_columns({ $col => $val, $rel_name => $obj, ... }); =over @@ -1082,9 +1099,11 @@ See also L. sub set_inflated_columns { my ( $self, $upd ) = @_; + my $rsrc; foreach my $key (keys %$upd) { if (ref $upd->{$key}) { - my $info = $self->relationship_info($key); + $rsrc ||= $self->result_source; + my $info = $rsrc->relationship_info($key); my $acc_type = $info->{attrs}{accessor} || ''; if ($acc_type eq 'single') { @@ -1097,7 +1116,11 @@ sub set_inflated_columns { "Recursive update is not supported over relationships of type '$acc_type' ($key)" ); } - elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) { + elsif ( + $rsrc->has_column($key) + and + exists $rsrc->column_info($key)->{_inflate_info} + ) { $self->set_inflated_column($key, delete $upd->{$key}); } } @@ -1135,43 +1158,48 @@ is set by default on C relationships and unset on all others. sub copy { my ($self, $changes) = @_; $changes ||= {}; - my $col_data = { %{$self->{_column_data}} }; + my $col_data = { $self->get_columns }; - my $colinfo = $self->columns_info([ keys %$col_data ]); + my $rsrc = $self->result_source; + + my $colinfo = $rsrc->columns_info; foreach my $col (keys %$col_data) { delete $col_data->{$col} - if $colinfo->{$col}{is_auto_increment}; + if ( ! $colinfo->{$col} or $colinfo->{$col}{is_auto_increment} ); } my $new = { _column_data => $col_data }; bless $new, ref $self; - $new->result_source($self->result_source); + $new->result_source($rsrc); $new->set_inflated_columns($changes); $new->insert; # Its possible we'll have 2 relations to the same Source. We need to make # sure we don't try to insert the same row twice else we'll violate unique # constraints - my $relnames_copied = {}; + my $rel_names_copied = {}; - foreach my $relname ($self->result_source->relationships) { - my $rel_info = $self->result_source->relationship_info($relname); + foreach my $rel_name ($rsrc->relationships) { + my $rel_info = $rsrc->relationship_info($rel_name); next unless $rel_info->{attrs}{cascade_copy}; - my $resolved = $self->result_source->_resolve_condition( - $rel_info->{cond}, $relname, $new, $relname - ); + my $foreign_vals; + my $copied = $rel_names_copied->{ $rel_info->{source} } ||= {}; - my $copied = $relnames_copied->{ $rel_info->{source} } ||= {}; - foreach my $related ($self->search_related($relname)->all) { - my $id_str = join("\0", $related->id); - next if $copied->{$id_str}; - $copied->{$id_str} = 1; - my $rel_copy = $related->copy($resolved); - } + $copied->{$_->ID}++ or $_->copy( + + $foreign_vals ||= $rsrc->_resolve_relationship_condition( + infer_values_based_on => {}, + rel_name => $rel_name, + self_result_object => $new, + + self_alias => "\xFE", # irrelevant + foreign_alias => "\xFF", # irrelevant, + )->{inferred_values} + ) for $self->related_resultset($rel_name)->all; } return $new; } @@ -1199,11 +1227,18 @@ extend this method to catch all data setting methods. sub store_column { my ($self, $column, $value) = @_; - $self->throw_exception( "No such column '${column}'" ) - unless exists $self->{_column_data}{$column} || $self->has_column($column); + $self->throw_exception( "No such column '${column}' on " . ref $self ) + unless exists $self->{_column_data}{$column} || $self->result_source->has_column($column); $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; - return $self->{_column_data}{$column} = $value; + + my $vref; + $self->{_column_data}{$column} = ( + # unpack potential { -value => "foo" } + ( length ref $value and $vref = is_plain_value( $value ) ) + ? $$vref + : $value + ); } =head2 inflate_result @@ -1241,56 +1276,56 @@ sub inflate_result { ; if ($prefetch) { - for my $relname ( keys %$prefetch ) { + for my $rel_name ( keys %$prefetch ) { - my $relinfo = $rsrc->relationship_info($relname) or do { + my $relinfo = $rsrc->relationship_info($rel_name) or do { my $err = sprintf "Inflation into non-existent relationship '%s' of '%s' requested", - $relname, + $rel_name, $rsrc->source_name, ; - if (my ($colname) = sort { length($a) <=> length ($b) } keys %{$prefetch->{$relname}[0] || {}} ) { + if (my ($colname) = sort { length($a) <=> length ($b) } keys %{$prefetch->{$rel_name}[0] || {}} ) { $err .= sprintf ", check the inflation specification (columns/as) ending in '...%s.%s'", - $relname, + $rel_name, $colname, } $rsrc->throw_exception($err); }; - $class->throw_exception("No accessor type declared for prefetched relationship '$relname'") + $class->throw_exception("No accessor type declared for prefetched relationship '$rel_name'") unless $relinfo->{attrs}{accessor}; - my $rel_rs = $new->related_resultset($relname); + my $rel_rs = $new->related_resultset($rel_name); my @rel_objects; if ( - @{ $prefetch->{$relname} || [] } + @{ $prefetch->{$rel_name} || [] } and - ref($prefetch->{$relname}) ne $DBIx::Class::ResultSource::RowParser::Util::null_branch_class + ref($prefetch->{$rel_name}) ne $DBIx::Class::ResultSource::RowParser::Util::null_branch_class ) { - if (ref $prefetch->{$relname}[0] eq 'ARRAY') { + if (ref $prefetch->{$rel_name}[0] eq 'ARRAY') { my $rel_rsrc = $rel_rs->result_source; my $rel_class = $rel_rs->result_class; my $rel_inflator = $rel_class->can('inflate_result'); @rel_objects = map { $rel_class->$rel_inflator ( $rel_rsrc, @$_ ) } - @{$prefetch->{$relname}} + @{$prefetch->{$rel_name}} ; } else { @rel_objects = $rel_rs->result_class->inflate_result( - $rel_rs->result_source, @{$prefetch->{$relname}} + $rel_rs->result_source, @{$prefetch->{$rel_name}} ); } } if ($relinfo->{attrs}{accessor} eq 'single') { - $new->{_relationship_data}{$relname} = $rel_objects[0]; + $new->{_relationship_data}{$rel_name} = $rel_objects[0]; } elsif ($relinfo->{attrs}{accessor} eq 'filter') { - $new->{_inflated_column}{$relname} = $rel_objects[0]; + $new->{_inflated_column}{$rel_name} = $rel_objects[0]; } $rel_rs->set_cache(\@rel_objects); @@ -1313,7 +1348,7 @@ sub inflate_result { =back -Ls the object if it's already in the database, according to +Ls the object if it's already in the database, according to L, else Ls it. =head2 insert_or_update @@ -1324,7 +1359,10 @@ Alias for L =cut -sub insert_or_update { shift->update_or_insert(@_) } +sub insert_or_update { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->update_or_insert(@_); +} sub update_or_insert { my $self = shift; @@ -1392,22 +1430,14 @@ Accessor to the L this object was created from. =cut sub result_source { - $_[0]->throw_exception( 'result_source can be called on instances only' ) - unless ref $_[0]; - - @_ > 1 - ? $_[0]->{_result_source} = $_[1] - - # note this is a || not a ||=, the difference is important - : $_[0]->{_result_source} || do { - my $class = ref $_[0]; - $_[0]->can('result_source_instance') - ? $_[0]->result_source_instance - : $_[0]->throw_exception( - "No result source instance registered for $class, did you forget to call $class->table(...) ?" - ) - } - ; + # this is essentially a `shift->result_source_instance(@_)` with handholding + &{ + $_[0]->can('result_source_instance') + || + $_[0]->throw_exception( + "No result source instance registered for '@{[ $_[0] ]}', did you forget to call @{[ ref $_[0] || $_[0] ]}->table(...) ?" + ) + }; } =head2 register_column @@ -1553,8 +1583,12 @@ See L. sub throw_exception { my $self=shift; - if (ref $self && ref $self->result_source ) { - $self->result_source->throw_exception(@_) + if ( + ! DBIx::Class::_Util::in_internal_try + and + my $rsrc = dbic_internal_try { $self->result_source } + ) { + $rsrc->throw_exception(@_) } else { DBIx::Class::Exception->throw(@_); @@ -1576,13 +1610,16 @@ sub throw_exception { Returns the primary key(s) for a row. Can't be called as a class method. Actually implemented in L -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -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