Add PK::Auto to Row/insert for now, could be prettier
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Row.pm
index bf4a526..dc1312d 100644 (file)
@@ -5,12 +5,11 @@ use warnings;
 
 use base qw/DBIx::Class/;
 use Carp::Clan qw/^DBIx::Class/;
+use Scalar::Util ();
 
-__PACKAGE__->load_components(qw/AccessorGroup/);
+__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
 
-__PACKAGE__->mk_group_accessors('simple' => 'result_source');
-
-=head1 NAME 
+=head1 NAME
 
 DBIx::Class::Row - Basic row methods
 
@@ -29,19 +28,91 @@ derived from L<DBIx::Class::ResultSource> objects.
 
 Creates a new row object from column => value mappings passed as a hash ref
 
+Passing an object, or an arrayref of objects as a value will call
+L<DBIx::Class::Relationship::Base/set_from_related> for you. When
+passed a hashref or an arrayref of hashrefs as the value, these will
+be turned into objects via new_related, and treated as if you had
+passed objects.
+
 =cut
 
+## NB (JER) - this assumes set_from_related can cope with multi-rels
+## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
+## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
+## When doing the later insert, we need to make sure the PKs are set.
+## using _relationship_data in new and funky ways..
+## check Relationship::CascadeActions and Relationship::Accessor for compat
+## tests!
+
 sub new {
-  my ($class, $attrs) = @_;
+  my ($class, $attrs, $source) = @_;
   $class = ref $class if ref $class;
-  my $new = bless({ _column_data => { } }, $class);
+
+  my $new = { _column_data => {} };
+  bless $new, $class;
+
+  $new->_source_handle($source) if $source;
+
   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';
+    
+    my ($related,$inflated);
+    foreach my $key (keys %$attrs) {
+      if (ref $attrs->{$key}) {
+        my $info = $class->relationship_info($key);
+        if ($info && $info->{attrs}{accessor}
+          && $info->{attrs}{accessor} eq 'single')
+        {
+          my $rel_obj = $attrs->{$key};
+          $new->{_rel_in_storage} = 1;
+          if(!Scalar::Util::blessed($rel_obj)) {
+            $rel_obj = $new->new_related($key, $rel_obj);
+            $new->{_rel_in_storage} = 0;
+          }
+          $new->set_from_related($key, $attrs->{$key});        
+          $related->{$key} = $attrs->{$key};
+          next;
+        } elsif ($info && $info->{attrs}{accessor}
+            && $info->{attrs}{accessor} eq 'multi'
+            && ref $attrs->{$key} eq 'ARRAY') {
+            my $others = delete $attrs->{$key};
+            $new->{_rel_in_storage} = 1;
+            foreach my $rel_obj (@$others) {
+              if(!Scalar::Util::blessed($rel_obj)) {
+                $rel_obj = $new->new_related($key, $rel_obj);
+                $new->{_rel_in_storage} = 0;
+              }
+            }
+#            $new->set_from_related($key, $others);
+            $related->{$key} = $others;
+            next;
+        } elsif ($class->has_column($key)
+          && exists $class->column_info($key)->{_inflate_info})
+        {
+          ## 'filter' should disappear and get merged in with 'single' above!
+          my $rel_obj = $attrs->{$key};
+          $new->{_rel_in_storage} = 1;
+          if(!Scalar::Util::blessed($rel_obj)) {
+            $rel_obj = $new->new_related($key, $rel_obj);
+            $new->{_rel_in_storage} = 0;
+          }
+          $inflated->{$key} = $rel_obj;
+          next;
+        }
+      }
+      $new->throw_exception("No such column $key on $class")
+        unless $class->has_column($key);
+      $new->store_column($key => $attrs->{$key});          
+    }
+    if (my $source = delete $attrs->{-result_source}) {
+      $new->result_source($source);
     }
+
+    $new->{_relationship_data} = $related if $related;
+    $new->{_inflated_column} = $inflated if $inflated;
   }
+
   return $new;
 }
 
@@ -49,23 +120,73 @@ 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<create> (see
+L<DBIx::Class::ResultSet/create>).
 
 =cut
 
 sub insert {
   my ($self) = @_;
   return $self if $self->in_storage;
-  $self->{result_source} ||= $self->result_source_instance
+  my $source = $self->result_source;
+  $source ||=  $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;
-  #use Data::Dumper; warn Dumper($self);
-  $source->storage->insert($source->from, { $self->get_columns });
+  $self->throw_exception("No result_source set on this object; can't insert")
+    unless $source;
+
+  # Check if we stored uninserted relobjs here in new()
+  $source->storage->txn_begin if(!$self->{_rel_in_storage});
+
+  my %related_stuff = (%{$self->{_relationship_data} || {}}, 
+                       %{$self->{_inflated_column} || {}});
+  ## Should all be in relationship_data, but we need to get rid of the
+  ## 'filter' reltype..
+  foreach my $relname (keys %related_stuff) {
+    my $relobj = $related_stuff{$relname};
+    if(ref $relobj ne 'ARRAY') {
+      $relobj->insert() if(!$relobj->in_storage);
+      $self->set_from_related($relname, $relobj);
+    }
+  }
+
+  $source->storage->insert($source, { $self->get_columns });
+
+  ## PK::Auto
+  my ($pri, $too_many) = grep { !defined $self->get_column($_) || 
+                                    ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
+  if(defined $pri) {
+    $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
+      if defined $too_many;
+
+    my $storage = $self->result_source->storage;
+    $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
+      unless $storage->can('last_insert_id');
+    my $id = $storage->last_insert_id($self->result_source,$pri);
+    $self->throw_exception( "Can't get last insert id" ) unless $id;
+    $self->store_column($pri => $id);
+  }
+
+  foreach my $relname (keys %related_stuff) {
+    my $relobj = $related_stuff{$relname};
+    if(ref $relobj eq 'ARRAY') {
+      foreach my $obj (@$relobj) {
+        my $info = $self->relationship_info($relname);
+        ## What about multi-col FKs ?
+        my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
+        $obj->set_from_related($key, $self);
+        $obj->insert() if(!$obj->in_storage);
+      }
+    }
+  }
+  $source->storage->txn_commit if(!$self->{_rel_in_storage});
+
   $self->in_storage(1);
   $self->{_dirty_columns} = {};
+  $self->{related_resultsets} = {};
+  undef $self->{_orig_ident};
   return $self;
 }
 
@@ -89,26 +210,52 @@ 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;
-  my %to_update = $self->get_dirty_columns;
-  return $self unless keys %to_update;
   my $ident_cond = $self->ident_condition;
   $self->throw_exception("Cannot safely update a row in a PK-less table")
     if ! keys %$ident_cond;
+
+  if ($upd) {
+    foreach my $key (keys %$upd) {
+      if (ref $upd->{$key}) {
+        my $info = $self->relationship_info($key);
+        if ($info && $info->{attrs}{accessor}
+          && $info->{attrs}{accessor} eq 'single')
+        {
+          my $rel = delete $upd->{$key};
+          $self->set_from_related($key => $rel);
+          $self->{_relationship_data}{$key} = $rel;          
+        } 
+        elsif ($self->has_column($key)
+          && exists $self->column_info($key)->{_inflate_info})
+        {
+          $self->set_inflated_column($key, delete $upd->{$key});          
+        }
+      }
+    }
+    $self->set_columns($upd);    
+  }
+  my %to_update = $self->get_dirty_columns;
+  return $self unless keys %to_update;
   my $rows = $self->result_source->storage->update(
-               $self->result_source->from, \%to_update, $ident_cond);
+               $self->result_source, \%to_update,
+               $self->{_orig_ident} || $ident_cond
+             );
   if ($rows == 0) {
     $self->throw_exception( "Can't update ${self}: row not found" );
   } elsif ($rows > 1) {
     $self->throw_exception("Can't update ${self}: updated more than one row");
   }
   $self->{_dirty_columns} = {};
+  $self->{related_resultsets} = {};
+  undef $self->{_orig_ident};
   return $self;
 }
 
@@ -116,9 +263,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<< ->in_storage() >> will now return 0 and the object must
+reinserted using C<< ->insert() >> before C<< ->update() >> can be used
+on it. If you delete an object in a class with a C<has_many>
+relationship, all the related objects will be deleted as well. To turn
+this behavior off, pass C<cascade_delete => 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<DBIx::Class::ResultSet/delete>.
 
 =cut
 
@@ -129,17 +281,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->result_source, $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;
@@ -149,21 +302,43 @@ sub delete {
 
   my $val = $obj->get_column($col);
 
-Gets a column value from a row object. Currently, does not do
-any queries; the column must have already been fetched from
-the database and stored in the object.
+Gets a column value from a row object. Does not do any queries; the column 
+must have already been fetched from the database and stored in the object. If 
+there is an inflated value stored that has not yet been deflated, it is deflated
+when the method is invoked.
 
 =cut
 
 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};
+  if (exists $self->{_inflated_column}{$column}) {
+    return $self->store_column($column,
+      $self->_deflated_column($column, $self->{_inflated_column}{$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 1 if exists $self->{_inflated_column}{$column};
+  return exists $self->{_column_data}{$column};
+}
+
 =head2 get_columns
 
   my %data = $obj->get_columns;
@@ -174,6 +349,12 @@ Does C<get_column>, for all column values at once.
 
 sub get_columns {
   my $self = shift;
+  if (exists $self->{_inflated_column}) {
+    foreach my $col (keys %{$self->{_inflated_column}}) {
+      $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
+        unless exists $self->{_column_data}{$col};
+    }
+  }
   return %{$self->{_column_data}};
 }
 
@@ -203,6 +384,7 @@ the column is marked as dirty for when you next call $obj->update.
 sub set_column {
   my $self = shift;
   my ($column) = @_;
+  $self->{_orig_ident} ||= $self->ident_condition;
   my $old = $self->get_column($column);
   my $ret = $self->store_column(@_);
   $self->{_dirty_columns}{$column} = 1
@@ -220,8 +402,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;
 }
@@ -236,9 +418,30 @@ Inserts a new row with the specified changes.
 
 sub copy {
   my ($self, $changes) = @_;
-  my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
-  $new->set_column($_ => $changes->{$_}) for keys %$changes;
-  return $new->insert;
+  $changes ||= {};
+  my $col_data = { %{$self->{_column_data}} };
+  foreach my $col (keys %$col_data) {
+    delete $col_data->{$col}
+      if $self->result_source->column_info($col)->{is_auto_increment};
+  }
+
+  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);
+    if ($rel_info->{attrs}{cascade_copy}) {
+      my $resolved = $self->result_source->resolve_condition(
+       $rel_info->{cond}, $rel, $new);
+      foreach my $related ($self->search_related($rel)) {
+        $related->copy($resolved);
+      }
+    }
+  }
+  return $new;
 }
 
 =head2 store_column
@@ -251,9 +454,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;
 }
@@ -268,53 +471,90 @@ 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 ($source_handle) = $source;
+
+  if ($source->isa('DBIx::Class::ResultSourceHandle')) {
+      $source = $source_handle->resolve
+  } else {
+      $source_handle = $source->handle
+  }
+
+  my $new = {
+    _source_handle => $source_handle,
+    _column_data => $me,
+    _in_storage => 1
+  };
+  bless $new, (ref $class || $class);
+
   my $schema;
-  PRE: foreach my $pre (keys %{$prefetch||{}}) {
+  foreach my $pre (keys %{$prefetch||{}}) {
+    my $pre_val = $prefetch->{$pre};
     my $pre_source = $source->related_source($pre);
-    $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source;
-    my $fetched;
-    unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_} 
-       and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns)
-    {
-      $fetched = $pre_source->result_class->inflate_result(
-                      $pre_source, @{$prefetch->{$pre}});      
-    }
-    my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
-    $class->throw_exception("No accessor for prefetched $pre")
-      unless defined $accessor;
-    if ($accessor eq 'single') {
-      $new->{_relationship_data}{$pre} = $fetched;
-    } elsif ($accessor eq 'filter') {
-      $new->{_inflated_column}{$pre} = $fetched;
-    } else {
-      $class->throw_exception("Don't know how to store prefetched $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 $pre_val->[0]{$_}
+         and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
+      {
+        $fetched = $pre_source->result_class->inflate_result(
+                      $pre_source, @{$pre_val});
+      }
+      my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
+      $class->throw_exception("No accessor for prefetched $pre")
+       unless defined $accessor;
+      if ($accessor eq 'single') {
+        $new->{_relationship_data}{$pre} = $fetched;
+      } elsif ($accessor eq 'filter') {
+        $new->{_inflated_column}{$pre} = $fetched;
+      } else {
+       $class->throw_exception("Prefetch not supported with accessor '$accessor'");
+      }
     }
   }
   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</update_or_insert>
 
 =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
 
@@ -322,15 +562,48 @@ 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;
+
+Accessor to the ResultSource this object was created from
+
+=cut
+
+sub result_source {
+    my $self = shift;
 
-=head2 register_column($column, $column_info)
+    if (@_) {
+        $self->_source_handle($_[0]->handle);
+    } else {
+        $self->_source_handle->resolve;
+    }
+}
 
-  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<DBIx::Class::ResultSource/add_columns>
 
 =cut
 
@@ -371,4 +644,3 @@ Matt S. Trout <mst@shadowcatsystems.co.uk>
 You may distribute this code under the same terms as Perl itself.
 
 =cut
-