X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRow.pm;h=57f883f4f3d5e97c5086bddbcd6eb7699a7e2587;hb=096f421241;hp=85a70a80142aecdba5a4c5933bcfac7b389d68b3;hpb=64acc2bc801dcc1c982b16fe45434e9b82edcef6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 85a70a8..57f883f 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -10,7 +10,7 @@ __PACKAGE__->load_components(qw/AccessorGroup/); __PACKAGE__->mk_group_accessors('simple' => 'result_source'); -=head1 NAME +=head1 NAME DBIx::Class::Row - Basic row methods @@ -34,14 +34,23 @@ Creates a new row object from column => value mappings passed as a hash ref sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; - my $new = bless({ _column_data => { } }, $class); + + my $new = { _column_data => {} }; + bless $new, $class; + if ($attrs) { - $new->throw_exception("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; - while (my ($k, $v) = each %{$attrs}) { - $new->throw_exception("No such column $k on $class") unless $class->has_column($k); - $new->store_column($k => $v); + $new->throw_exception("attrs must be a hashref") + unless ref($attrs) eq 'HASH'; + if (my $source = delete $attrs->{-result_source}) { + $new->result_source($source); + } + foreach my $k (keys %$attrs) { + $new->throw_exception("No such column $k on $class") + unless $class->has_column($k); + $new->store_column($k => $attrs->{$k}); } } + return $new; } @@ -49,9 +58,11 @@ sub new { $obj->insert; -Inserts an object into the database if it isn't already in there. Returns -the object itself. Requires the object's result source to be set, or the -class to have a result_source_instance method. +Inserts an object into the database if it isn't already in +there. Returns the object itself. Requires the object's result source to +be set, or the class to have a result_source_instance method. To insert +an entirely new object into the database, use C (see +L). =cut @@ -61,7 +72,8 @@ sub insert { $self->{result_source} ||= $self->result_source_instance if $self->can('result_source_instance'); my $source = $self->{result_source}; - $self->throw_exception("No result_source set on this object; can't insert") unless $source; + $self->throw_exception("No result_source set on this object; can't insert") + unless $source; #use Data::Dumper; warn Dumper($self); $source->storage->insert($source->from, { $self->get_columns }); $self->in_storage(1); @@ -90,13 +102,15 @@ sub in_storage { $obj->update; Must be run on an object that is already in the database; issues an SQL -UPDATE query to commit any changes to the object to the db if required. +UPDATE query to commit any changes to the object to the database if +required. =cut sub update { my ($self, $upd) = @_; $self->throw_exception( "Not in database" ) unless $self->in_storage; + $self->set_columns($upd) if $upd; my %to_update = $self->get_dirty_columns; return $self unless keys %to_update; my $ident_cond = $self->ident_condition; @@ -118,9 +132,14 @@ sub update { $obj->delete -Deletes the object from the database. The object is still perfectly usable -accessor-wise etc. but ->in_storage will now return 0 and the object must -be re ->insert'ed before it can be ->update'ed +Deletes the object from the database. The object is still perfectly +usable, but C<-Ein_storage()> will now return 0 and the object must +reinserted using C<-Einsert()> before C<-E(update()> can be used +on it. If you delete an object in a class with a C +relationship, all the related objects will be deleted as well. To turn +this behavior off, pass C 0> in the C<$attr> +hashref. Any database-level cascade or restrict will take precedence +over a DBIx-Class-based cascading delete. See also L. =cut @@ -131,17 +150,18 @@ sub delete { my $ident_cond = $self->ident_condition; $self->throw_exception("Cannot safely delete a row in a PK-less table") if ! keys %$ident_cond; + foreach my $column (keys %$ident_cond) { + $self->throw_exception("Can't delete the object unless it has loaded the primary keys") + unless exists $self->{_column_data}{$column}; + } $self->result_source->storage->delete( $self->result_source->from, $ident_cond); $self->in_storage(undef); } else { $self->throw_exception("Can't do class delete without a ResultSource instance") unless $self->can('result_source_instance'); - my $attrs = { }; - if (@_ > 1 && ref $_[$#_] eq 'HASH') { - $attrs = { %{ pop(@_) } }; - } - my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_}); + my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; + my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->result_source_instance->resultset->search(@_)->delete; } return $self; @@ -160,12 +180,28 @@ the database and stored in the object. sub get_column { my ($self, $column) = @_; $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; - return $self->{_column_data}{$column} - if exists $self->{_column_data}{$column}; + return $self->{_column_data}{$column} if exists $self->{_column_data}{$column}; $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column); return undef; } +=head2 has_column_loaded + + if ( $obj->has_column_loaded($col) ) { + print "$col has been loaded from db"; + } + +Returns a true value if the column value has been loaded from the +database (or set locally). + +=cut + +sub has_column_loaded { + my ($self, $column) = @_; + $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self; + return exists $self->{_column_data}{$column}; +} + =head2 get_columns my %data = $obj->get_columns; @@ -222,8 +258,8 @@ Sets more than one column value at once. sub set_columns { my ($self,$data) = @_; - while (my ($col,$val) = each %$data) { - $self->set_column($col,$val); + foreach my $col (keys %$data) { + $self->set_column($col,$data->{$col}); } return $self; } @@ -244,8 +280,12 @@ sub copy { delete $col_data->{$col} if $self->result_source->column_info($col)->{is_auto_increment}; } - my $new = bless({ _column_data => $col_data }, ref $self); - $new->set_column($_ => $changes->{$_}) for keys %$changes; + + my $new = { _column_data => $col_data }; + bless $new, ref $self; + + $new->result_source($self->result_source); + $new->set_columns($changes); $new->insert; foreach my $rel ($self->result_source->relationships) { my $rel_info = $self->result_source->relationship_info($rel); @@ -257,7 +297,7 @@ sub copy { } } } - $new; + return $new; } =head2 store_column @@ -270,9 +310,9 @@ Sets a column value without marking it as dirty. sub store_column { my ($self, $column, $value) = @_; - $self->throw_exception( "No such column '${column}'" ) + $self->throw_exception( "No such column '${column}'" ) unless exists $self->{_column_data}{$column} || $self->has_column($column); - $self->throw_exception( "set_column called for ${column} without value" ) + $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; return $self->{_column_data}{$column} = $value; } @@ -288,28 +328,37 @@ Called by ResultSet to inflate a result from storage sub inflate_result { my ($class, $source, $me, $prefetch) = @_; #use Data::Dumper; print Dumper(@_); - my $new = bless({ result_source => $source, - _column_data => $me, - _in_storage => 1 - }, - ref $class || $class); + my $new = { + result_source => $source, + _column_data => $me, + _in_storage => 1 + }; + bless $new, (ref $class || $class); + my $schema; foreach my $pre (keys %{$prefetch||{}}) { my $pre_val = $prefetch->{$pre}; - # if first prefetch item is arrayref, assume this is a has_many prefetch - # and that objects are pre inflated (TODO: check arrayref contents using "ref" to make sure) - if( ref $pre_val->[0] eq 'ARRAY' ) { - $new->related_resultset($pre)->set_cache( $pre_val->[0] ); - } - else { - my $pre_source = $source->related_source($pre); - $class->throw_exception("Can't prefetch non-existent relationship ${pre}") unless $pre_source; + my $pre_source = $source->related_source($pre); + $class->throw_exception("Can't prefetch non-existent relationship ${pre}") + unless $pre_source; + if (ref($pre_val->[0]) eq 'ARRAY') { # multi + my @pre_objects; + foreach my $pre_rec (@$pre_val) { + unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_} + and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) { + next; + } + push(@pre_objects, $pre_source->result_class->inflate_result( + $pre_source, @{$pre_rec})); + } + $new->related_resultset($pre)->set_cache(\@pre_objects); + } elsif (defined $pre_val->[0]) { my $fetched; - unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_} - and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns) + unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_} + and !defined $pre_val->[0]{$_} } $pre_source->primary_columns) { $fetched = $pre_source->result_class->inflate_result( - $pre_source, @{$prefetch->{$pre}}); + $pre_source, @{$pre_val}); } my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; $class->throw_exception("No accessor for prefetched $pre") @@ -317,9 +366,7 @@ sub inflate_result { if ($accessor eq 'single') { $new->{_relationship_data}{$pre} = $fetched; } elsif ($accessor eq 'filter') { - $new->{_inflated_column}{$pre} = $fetched; - } elsif ($accessor eq 'multi') { - $class->throw_exception("Cache must be enabled for has_many prefetch '$pre'"); + $new->{_inflated_column}{$pre} = $fetched; } else { $class->throw_exception("Prefetch not supported with accessor '$accessor'"); } @@ -328,22 +375,34 @@ sub inflate_result { return $new; } +=head2 update_or_insert + + $obj->update_or_insert + +Updates the object if it's already in the db, else inserts it. + =head2 insert_or_update $obj->insert_or_update -Updates the object if it's already in the db, else inserts it. +Alias for L =cut -sub insert_or_update { +*insert_or_update = \&update_or_insert; +sub update_or_insert { my $self = shift; return ($self->in_storage ? $self->update : $self->insert); } =head2 is_changed - my @changed_col_names = $obj->is_changed + my @changed_col_names = $obj->is_changed(); + if ($obj->is_changed()) { ... } + +In array context returns a list of columns with uncommited changes, or +in scalar context returns a true value if there are uncommitted +changes. =cut @@ -351,15 +410,36 @@ sub is_changed { return keys %{shift->{_dirty_columns} || {}}; } +=head2 is_column_changed + + if ($obj->is_column_changed('col')) { ... } + +Returns a true value if the column has uncommitted changes. + +=cut + +sub is_column_changed { + my( $self, $col ) = @_; + return exists $self->{_dirty_columns}->{$col}; +} + =head2 result_source - Accessor to the ResultSource this object was created from + my $resultsource = $object->result_source; -=head2 register_column($column, $column_info) +Accessor to the ResultSource this object was created from - Registers a column on the class. If the column_info has an 'accessor' key, - creates an accessor named after the value if defined; if there is no such - key, creates an accessor with the same name as the column +=head2 register_column + + $column_info = { .... }; + $class->register_column($column_name, $column_info); + +Registers a column on the class. If the column_info has an 'accessor' +key, creates an accessor named after the value if defined; if there is +no such key, creates an accessor with the same name as the column + +The column_info attributes are described in +L =cut @@ -400,4 +480,3 @@ Matt S. Trout You may distribute this code under the same terms as Perl itself. =cut -