lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class/;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use Scalar::Util ();
   9 use Scope::Guard;
  10
  11 ###
  12 ### Internal method
  13 ### Do not use
  14 ###
  15 BEGIN {
  16   *MULTICREATE_DEBUG =
  17     $ENV{DBIC_MULTICREATE_DEBUG}
  18       ? sub () { 1 }
  19       : sub () { 0 };
  20 }
  21
  22 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
  23
  24 =head1 NAME
  25
  26 DBIx::Class::Row - Basic row methods
  27
  28 =head1 SYNOPSIS
  29
  30 =head1 DESCRIPTION
  31
  32 This class is responsible for defining and doing basic operations on rows
  33 derived from L<DBIx::Class::ResultSource> objects.
  34
  35 Row objects are returned from L<DBIx::Class::ResultSet>s using the
  36 L<create|DBIx::Class::ResultSet/create>, L<find|DBIx::Class::ResultSet/find>,
  37 L<next|DBIx::Class::ResultSet/next> and L<all|DBIx::Class::ResultSet/all> methods,
  38 as well as invocations of 'single' (
  39 L<belongs_to|DBIx::Class::Relationship/belongs_to>,
  40 L<has_one|DBIx::Class::Relationship/has_one> or
  41 L<might_have|DBIx::Class::Relationship/might_have>)
  42 relationship accessors of L<DBIx::Class::Row> objects.
  43
  44 =head1 METHODS
  45
  46 =head2 new
  47
  48   my $row = My::Class->new(\%attrs);
  49
  50   my $row = $schema->resultset('MySource')->new(\%colsandvalues);
  51
  52 =over
  53
  54 =item Arguments: \%attrs or \%colsandvalues
  55
  56 =item Returns: A Row object
  57
  58 =back
  59
  60 While you can create a new row object by calling C<new> directly on
  61 this class, you are better off calling it on a
  62 L<DBIx::Class::ResultSet> object.
  63
  64 When calling it directly, you will not get a complete, usable row
  65 object until you pass or set the C<source_handle> attribute, to a
  66 L<DBIx::Class::ResultSource> instance that is attached to a
  67 L<DBIx::Class::Schema> with a valid connection.
  68
  69 C<$attrs> is a hashref of column name, value data. It can also contain
  70 some other attributes such as the C<source_handle>.
  71
  72 Passing an object, or an arrayref of objects as a value will call
  73 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
  74 passed a hashref or an arrayref of hashrefs as the value, these will
  75 be turned into objects via new_related, and treated as if you had
  76 passed objects.
  77
  78 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
  79
  80 Please note that if a value is not passed to new, no value will be sent
  81 in the SQL INSERT call, and the column will therefore assume whatever
  82 default value was specified in your database. While DBIC will retrieve the
  83 value of autoincrement columns, it will never make an explicit database
  84 trip to retrieve default values assigned by the RDBMS. You can explicitly
  85 request that all values be fetched back from the database by calling
  86 L</discard_changes>, or you can supply an explicit C<undef> to columns
  87 with NULL as the default, and save yourself a SELECT.
  88
  89  CAVEAT:
  90
  91  The behavior described above will backfire if you use a foreign key column
  92  with a database-defined default. If you call the relationship accessor on
  93  an object that doesn't have a set value for the FK column, DBIC will throw
  94  an exception, as it has no way of knowing the PK of the related object (if
  95  there is one).
  96
  97 =cut
  98
  99 ## 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().
 100 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
 101 ## When doing the later insert, we need to make sure the PKs are set.
 102 ## using _relationship_data in new and funky ways..
 103 ## check Relationship::CascadeActions and Relationship::Accessor for compat
 104 ## tests!
 105
 106 sub __new_related_find_or_new_helper {
 107   my ($self, $relname, $data) = @_;
 108   if ($self->__their_pk_needs_us($relname, $data)) {
 109     MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
 110     return $self->result_source
 111                 ->related_source($relname)
 112                 ->resultset
 113                 ->new_result($data);
 114   }
 115   if ($self->result_source->pk_depends_on($relname, $data)) {
 116     MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
 117     return $self->result_source
 118                 ->related_source($relname)
 119                 ->resultset
 120                 ->find_or_new($data);
 121   }
 122   MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new_related";
 123   return $self->find_or_new_related($relname, $data);
 124 }
 125
 126 sub __their_pk_needs_us { # this should maybe be in resultsource.
 127   my ($self, $relname, $data) = @_;
 128   my $source = $self->result_source;
 129   my $reverse = $source->reverse_relationship_info($relname);
 130   my $rel_source = $source->related_source($relname);
 131   my $us = { $self->get_columns };
 132   foreach my $key (keys %$reverse) {
 133     # if their primary key depends on us, then we have to
 134     # just create a result and we'll fill it out afterwards
 135     return 1 if $rel_source->pk_depends_on($key, $us);
 136   }
 137   return 0;
 138 }
 139
 140 sub new {
 141   my ($class, $attrs) = @_;
 142   $class = ref $class if ref $class;
 143
 144   my $new = {
 145       _column_data          => {},
 146   };
 147   bless $new, $class;
 148
 149   if (my $handle = delete $attrs->{-source_handle}) {
 150     $new->_source_handle($handle);
 151   }
 152
 153   my $source;
 154   if ($source = delete $attrs->{-result_source}) {
 155     $new->result_source($source);
 156   }
 157
 158   if (my $related = delete $attrs->{-from_resultset}) {
 159     @{$new->{_ignore_at_insert}={}}{@$related} = ();
 160   }
 161
 162   if ($attrs) {
 163     $new->throw_exception("attrs must be a hashref")
 164       unless ref($attrs) eq 'HASH';
 165
 166     my ($related,$inflated);
 167     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
 168     $new->{_rel_in_storage} = 1;
 169
 170     foreach my $key (keys %$attrs) {
 171       if (ref $attrs->{$key}) {
 172         ## Can we extract this lot to use with update(_or .. ) ?
 173         confess "Can't do multi-create without result source" unless $source;
 174         my $info = $source->relationship_info($key);
 175         if ($info && $info->{attrs}{accessor}
 176           && $info->{attrs}{accessor} eq 'single')
 177         {
 178           my $rel_obj = delete $attrs->{$key};
 179           if(!Scalar::Util::blessed($rel_obj)) {
 180             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 181           }
 182
 183           if ($rel_obj->in_storage) {
 184             $new->set_from_related($key, $rel_obj);
 185           } else {
 186             $new->{_rel_in_storage} = 0;
 187             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
 188           }
 189
 190           $related->{$key} = $rel_obj;
 191           next;
 192         } elsif ($info && $info->{attrs}{accessor}
 193             && $info->{attrs}{accessor} eq 'multi'
 194             && ref $attrs->{$key} eq 'ARRAY') {
 195           my $others = delete $attrs->{$key};
 196           my $total = @$others;
 197           my @objects;
 198           foreach my $idx (0 .. $#$others) {
 199             my $rel_obj = $others->[$idx];
 200             if(!Scalar::Util::blessed($rel_obj)) {
 201               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 202             }
 203
 204             if ($rel_obj->in_storage) {
 205               $new->set_from_related($key, $rel_obj);
 206             } else {
 207               $new->{_rel_in_storage} = 0;
 208               MULTICREATE_DEBUG and
 209                 warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
 210             }
 211             $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
 212             push(@objects, $rel_obj);
 213           }
 214           $related->{$key} = \@objects;
 215           next;
 216         } elsif ($info && $info->{attrs}{accessor}
 217           && $info->{attrs}{accessor} eq 'filter')
 218         {
 219           ## 'filter' should disappear and get merged in with 'single' above!
 220           my $rel_obj = delete $attrs->{$key};
 221           if(!Scalar::Util::blessed($rel_obj)) {
 222             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 223           }
 224           unless ($rel_obj->in_storage) {
 225             $new->{_rel_in_storage} = 0;
 226             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
 227           }
 228           $inflated->{$key} = $rel_obj;
 229           next;
 230         } elsif ($class->has_column($key)
 231             && $class->column_info($key)->{_inflate_info}) {
 232           $inflated->{$key} = $attrs->{$key};
 233           next;
 234         }
 235       }
 236       $new->throw_exception("No such column $key on $class")
 237         unless $class->has_column($key);
 238       $new->store_column($key => $attrs->{$key});
 239     }
 240
 241     $new->{_relationship_data} = $related if $related;
 242     $new->{_inflated_column} = $inflated if $inflated;
 243   }
 244
 245   return $new;
 246 }
 247
 248 =head2 insert
 249
 250   $row->insert;
 251
 252 =over
 253
 254 =item Arguments: none
 255
 256 =item Returns: The Row object
 257
 258 =back
 259
 260 Inserts an object previously created by L</new> into the database if
 261 it isn't already in there. Returns the object itself. Requires the
 262 object's result source to be set, or the class to have a
 263 result_source_instance method. To insert an entirely new row into
 264 the database, use C<create> (see L<DBIx::Class::ResultSet/create>).
 265
 266 To fetch an uninserted row object, call
 267 L<new|DBIx::Class::ResultSet/new> on a resultset.
 268
 269 This will also insert any uninserted, related objects held inside this
 270 one, see L<DBIx::Class::ResultSet/create> for more details.
 271
 272 =cut
 273
 274 sub insert {
 275   my ($self) = @_;
 276   return $self if $self->in_storage;
 277   my $source = $self->result_source;
 278   $source ||=  $self->result_source($self->result_source_instance)
 279     if $self->can('result_source_instance');
 280   $self->throw_exception("No result_source set on this object; can't insert")
 281     unless $source;
 282
 283   my $rollback_guard;
 284
 285   # Check if we stored uninserted relobjs here in new()
 286   my %related_stuff = (%{$self->{_relationship_data} || {}},
 287                        %{$self->{_inflated_column} || {}});
 288
 289   if(!$self->{_rel_in_storage}) {
 290
 291     # The guard will save us if we blow out of this scope via die
 292     $rollback_guard = $source->storage->txn_scope_guard;
 293
 294     ## Should all be in relationship_data, but we need to get rid of the
 295     ## 'filter' reltype..
 296     ## These are the FK rels, need their IDs for the insert.
 297
 298     my @pri = $self->primary_columns;
 299
 300     REL: foreach my $relname (keys %related_stuff) {
 301
 302       my $rel_obj = $related_stuff{$relname};
 303
 304       next REL unless (Scalar::Util::blessed($rel_obj)
 305                        && $rel_obj->isa('DBIx::Class::Row'));
 306
 307       next REL unless $source->pk_depends_on(
 308                         $relname, { $rel_obj->get_columns }
 309                       );
 310
 311       MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
 312
 313       my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
 314       my $re = $self->result_source
 315                     ->related_source($relname)
 316                     ->resultset
 317                     ->find_or_create($them);
 318       %{$rel_obj} = %{$re};
 319       $self->set_from_related($relname, $rel_obj);
 320       delete $related_stuff{$relname};
 321     }
 322   }
 323
 324   MULTICREATE_DEBUG and do {
 325     no warnings 'uninitialized';
 326     warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
 327   };
 328   my $updated_cols = $source->storage->insert($source, { $self->get_columns });
 329   foreach my $col (keys %$updated_cols) {
 330     $self->store_column($col, $updated_cols->{$col});
 331   }
 332
 333   ## PK::Auto
 334   my @auto_pri = grep {
 335                    !defined $self->get_column($_) ||
 336                    ref($self->get_column($_)) eq 'SCALAR'
 337                  } $self->primary_columns;
 338
 339   if (@auto_pri) {
 340     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
 341     #  if defined $too_many;
 342     MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\n";
 343     my $storage = $self->result_source->storage;
 344     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
 345       unless $storage->can('last_insert_id');
 346     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
 347     $self->throw_exception( "Can't get last insert id" )
 348       unless (@ids == @auto_pri);
 349     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
 350 #use Data::Dumper; warn Dumper($self);
 351   }
 352
 353
 354   $self->{_dirty_columns} = {};
 355   $self->{related_resultsets} = {};
 356
 357   if(!$self->{_rel_in_storage}) {
 358     ## Now do the relationships that need our ID (has_many etc.)
 359     foreach my $relname (keys %related_stuff) {
 360       my $rel_obj = $related_stuff{$relname};
 361       my @cands;
 362       if (Scalar::Util::blessed($rel_obj)
 363           && $rel_obj->isa('DBIx::Class::Row')) {
 364         @cands = ($rel_obj);
 365       } elsif (ref $rel_obj eq 'ARRAY') {
 366         @cands = @$rel_obj;
 367       }
 368       if (@cands) {
 369         my $reverse = $source->reverse_relationship_info($relname);
 370         foreach my $obj (@cands) {
 371           $obj->set_from_related($_, $self) for keys %$reverse;
 372           my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
 373           if ($self->__their_pk_needs_us($relname, $them)) {
 374             if (exists $self->{_ignore_at_insert}{$relname}) {
 375               MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
 376             } else {
 377               MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
 378               my $re = $self->result_source
 379                             ->related_source($relname)
 380                             ->resultset
 381                             ->find_or_create($them);
 382               %{$obj} = %{$re};
 383               MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
 384             }
 385           } else {
 386             MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
 387             $obj->insert();
 388           }
 389         }
 390       }
 391     }
 392     delete $self->{_ignore_at_insert};
 393     $rollback_guard->commit;
 394   }
 395
 396   $self->in_storage(1);
 397   undef $self->{_orig_ident};
 398   return $self;
 399 }
 400
 401 =head2 in_storage
 402
 403   $row->in_storage; # Get value
 404   $row->in_storage(1); # Set value
 405
 406 =over
 407
 408 =item Arguments: none or 1|0
 409
 410 =item Returns: 1|0
 411
 412 =back
 413
 414 Indicates whether the object exists as a row in the database or
 415 not. This is set to true when L<DBIx::Class::ResultSet/find>,
 416 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
 417 are used.
 418
 419 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
 420 L</delete> on one, sets it to false.
 421
 422 =cut
 423
 424 sub in_storage {
 425   my ($self, $val) = @_;
 426   $self->{_in_storage} = $val if @_ > 1;
 427   return $self->{_in_storage};
 428 }
 429
 430 =head2 update
 431
 432   $row->update(\%columns?)
 433
 434 =over
 435
 436 =item Arguments: none or a hashref
 437
 438 =item Returns: The Row object
 439
 440 =back
 441
 442 Throws an exception if the row object is not yet in the database,
 443 according to L</in_storage>.
 444
 445 This method issues an SQL UPDATE query to commit any changes to the
 446 object to the database if required.
 447
 448 Also takes an optional hashref of C<< column_name => value> >> pairs
 449 to update on the object first. Be aware that the hashref will be
 450 passed to C<set_inflated_columns>, which might edit it in place, so
 451 don't rely on it being the same after a call to C<update>.  If you
 452 need to preserve the hashref, it is sufficient to pass a shallow copy
 453 to C<update>, e.g. ( { %{ $href } } )
 454
 455 If the values passed or any of the column values set on the object
 456 contain scalar references, eg:
 457
 458   $row->last_modified(\'NOW()');
 459   # OR
 460   $row->update({ last_modified => \'NOW()' });
 461
 462 The update will pass the values verbatim into SQL. (See
 463 L<SQL::Abstract> docs).  The values in your Row object will NOT change
 464 as a result of the update call, if you want the object to be updated
 465 with the actual values from the database, call L</discard_changes>
 466 after the update.
 467
 468   $row->update()->discard_changes();
 469
 470 To determine before calling this method, which column values have
 471 changed and will be updated, call L</get_dirty_columns>.
 472
 473 To check if any columns will be updated, call L</is_changed>.
 474
 475 To force a column to be updated, call L</make_column_dirty> before
 476 this method.
 477
 478 =cut
 479
 480 sub update {
 481   my ($self, $upd) = @_;
 482   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 483   my $ident_cond = $self->ident_condition;
 484   $self->throw_exception("Cannot safely update a row in a PK-less table")
 485     if ! keys %$ident_cond;
 486
 487   $self->set_inflated_columns($upd) if $upd;
 488   my %to_update = $self->get_dirty_columns;
 489   return $self unless keys %to_update;
 490   my $rows = $self->result_source->storage->update(
 491                $self->result_source, \%to_update,
 492                $self->{_orig_ident} || $ident_cond
 493              );
 494   if ($rows == 0) {
 495     $self->throw_exception( "Can't update ${self}: row not found" );
 496   } elsif ($rows > 1) {
 497     $self->throw_exception("Can't update ${self}: updated more than one row");
 498   }
 499   $self->{_dirty_columns} = {};
 500   $self->{related_resultsets} = {};
 501   undef $self->{_orig_ident};
 502   return $self;
 503 }
 504
 505 =head2 delete
 506
 507   $row->delete
 508
 509 =over
 510
 511 =item Arguments: none
 512
 513 =item Returns: The Row object
 514
 515 =back
 516
 517 Throws an exception if the object is not in the database according to
 518 L</in_storage>. Runs an SQL DELETE statement using the primary key
 519 values to locate the row.
 520
 521 The object is still perfectly usable, but L</in_storage> will
 522 now return 0 and the object must be reinserted using L</insert>
 523 before it can be used to L</update> the row again.
 524
 525 If you delete an object in a class with a C<has_many> relationship, an
 526 attempt is made to delete all the related objects as well. To turn
 527 this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
 528 hashref of the relationship, see L<DBIx::Class::Relationship>. Any
 529 database-level cascade or restrict will take precedence over a
 530 DBIx-Class-based cascading delete.
 531
 532 If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
 533 and the transaction subsequently fails, the row object will remain marked as
 534 not being in storage. If you know for a fact that the object is still in
 535 storage (i.e. by inspecting the cause of the transaction's failure), you can
 536 use C<< $obj->in_storage(1) >> to restore consistency between the object and
 537 the database. This would allow a subsequent C<< $obj->delete >> to work
 538 as expected.
 539
 540 See also L<DBIx::Class::ResultSet/delete>.
 541
 542 =cut
 543
 544 sub delete {
 545   my $self = shift;
 546   if (ref $self) {
 547     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 548     my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
 549     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 550       if ! keys %$ident_cond;
 551     foreach my $column (keys %$ident_cond) {
 552             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 553               unless exists $self->{_column_data}{$column};
 554     }
 555     $self->result_source->storage->delete(
 556       $self->result_source, $ident_cond);
 557     $self->in_storage(undef);
 558   } else {
 559     $self->throw_exception("Can't do class delete without a ResultSource instance")
 560       unless $self->can('result_source_instance');
 561     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 562     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 563     $self->result_source_instance->resultset->search(@_)->delete;
 564   }
 565   return $self;
 566 }
 567
 568 =head2 get_column
 569
 570   my $val = $row->get_column($col);
 571
 572 =over
 573
 574 =item Arguments: $columnname
 575
 576 =item Returns: The value of the column
 577
 578 =back
 579
 580 Throws an exception if the column name given doesn't exist according
 581 to L</has_column>.
 582
 583 Returns a raw column value from the row object, if it has already
 584 been fetched from the database or set by an accessor.
 585
 586 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
 587 will be deflated and returned.
 588
 589 Note that if you used the C<columns> or the C<select/as>
 590 L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
 591 which C<$row> was derived, and B<did not include> C<$columnname> in the list,
 592 this method will return C<undef> even if the database contains some value.
 593
 594 To retrieve all loaded column values as a hash, use L</get_columns>.
 595
 596 =cut
 597
 598 sub get_column {
 599   my ($self, $column) = @_;
 600   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 601   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 602   if (exists $self->{_inflated_column}{$column}) {
 603     return $self->store_column($column,
 604       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 605   }
 606   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 607   return undef;
 608 }
 609
 610 =head2 has_column_loaded
 611
 612   if ( $row->has_column_loaded($col) ) {
 613      print "$col has been loaded from db";
 614   }
 615
 616 =over
 617
 618 =item Arguments: $columnname
 619
 620 =item Returns: 0|1
 621
 622 =back
 623
 624 Returns a true value if the column value has been loaded from the
 625 database (or set locally).
 626
 627 =cut
 628
 629 sub has_column_loaded {
 630   my ($self, $column) = @_;
 631   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 632   return 1 if exists $self->{_inflated_column}{$column};
 633   return exists $self->{_column_data}{$column};
 634 }
 635
 636 =head2 get_columns
 637
 638   my %data = $row->get_columns;
 639
 640 =over
 641
 642 =item Arguments: none
 643
 644 =item Returns: A hash of columnname, value pairs.
 645
 646 =back
 647
 648 Returns all loaded column data as a hash, containing raw values. To
 649 get just one value for a particular column, use L</get_column>.
 650
 651 =cut
 652
 653 sub get_columns {
 654   my $self = shift;
 655   if (exists $self->{_inflated_column}) {
 656     foreach my $col (keys %{$self->{_inflated_column}}) {
 657       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 658         unless exists $self->{_column_data}{$col};
 659     }
 660   }
 661   return %{$self->{_column_data}};
 662 }
 663
 664 =head2 get_dirty_columns
 665
 666   my %data = $row->get_dirty_columns;
 667
 668 =over
 669
 670 =item Arguments: none
 671
 672 =item Returns: A hash of column, value pairs
 673
 674 =back
 675
 676 Only returns the column, value pairs for those columns that have been
 677 changed on this object since the last L</update> or L</insert> call.
 678
 679 See L</get_columns> to fetch all column/value pairs.
 680
 681 =cut
 682
 683 sub get_dirty_columns {
 684   my $self = shift;
 685   return map { $_ => $self->{_column_data}{$_} }
 686            keys %{$self->{_dirty_columns}};
 687 }
 688
 689 =head2 make_column_dirty
 690
 691   $row->make_column_dirty($col)
 692
 693 =over
 694
 695 =item Arguments: $columnname
 696
 697 =item Returns: undefined
 698
 699 =back
 700
 701 Throws an exception if the column does not exist.
 702
 703 Marks a column as having been changed regardless of whether it has
 704 really changed.
 705
 706 =cut
 707 sub make_column_dirty {
 708   my ($self, $column) = @_;
 709
 710   $self->throw_exception( "No such column '${column}'" )
 711     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 712   $self->{_dirty_columns}{$column} = 1;
 713 }
 714
 715 =head2 get_inflated_columns
 716
 717   my %inflated_data = $obj->get_inflated_columns;
 718
 719 =over
 720
 721 =item Arguments: none
 722
 723 =item Returns: A hash of column, object|value pairs
 724
 725 =back
 726
 727 Returns a hash of all column keys and associated values. Values for any
 728 columns set to use inflation will be inflated and returns as objects.
 729
 730 See L</get_columns> to get the uninflated values.
 731
 732 See L<DBIx::Class::InflateColumn> for how to setup inflation.
 733
 734 =cut
 735
 736 sub get_inflated_columns {
 737   my $self = shift;
 738   return map {
 739     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 740     ($_ => $self->$accessor);
 741   } grep $self->has_column_loaded($_), $self->columns;
 742 }
 743
 744 =head2 set_column
 745
 746   $row->set_column($col => $val);
 747
 748 =over
 749
 750 =item Arguments: $columnname, $value
 751
 752 =item Returns: $value
 753
 754 =back
 755
 756 Sets a raw column value. If the new value is different from the old one,
 757 the column is marked as dirty for when you next call L</update>.
 758
 759 If passed an object or reference as a value, this method will happily
 760 attempt to store it, and a later L</insert> or L</update> will try and
 761 stringify/numify as appropriate. To set an object to be deflated
 762 instead, see L</set_inflated_columns>.
 763
 764 =cut
 765
 766 sub set_column {
 767   my ($self, $column, $new_value) = @_;
 768
 769   $self->{_orig_ident} ||= $self->ident_condition;
 770   my $old_value = $self->get_column($column);
 771
 772   $self->store_column($column, $new_value);
 773   $self->{_dirty_columns}{$column} = 1
 774     if (defined $old_value xor defined $new_value) || (defined $old_value && $old_value ne $new_value);
 775
 776   # XXX clear out the relation cache for this column
 777   delete $self->{related_resultsets}{$column};
 778
 779   return $new_value;
 780 }
 781
 782 =head2 set_columns
 783
 784   $row->set_columns({ $col => $val, ... });
 785
 786 =over
 787
 788 =item Arguments: \%columndata
 789
 790 =item Returns: The Row object
 791
 792 =back
 793
 794 Sets multiple column, raw value pairs at once.
 795
 796 Works as L</set_column>.
 797
 798 =cut
 799
 800 sub set_columns {
 801   my ($self,$data) = @_;
 802   foreach my $col (keys %$data) {
 803     $self->set_column($col,$data->{$col});
 804   }
 805   return $self;
 806 }
 807
 808 =head2 set_inflated_columns
 809
 810   $row->set_inflated_columns({ $col => $val, $relname => $obj, ... });
 811
 812 =over
 813
 814 =item Arguments: \%columndata
 815
 816 =item Returns: The Row object
 817
 818 =back
 819
 820 Sets more than one column value at once. Any inflated values are
 821 deflated and the raw values stored.
 822
 823 Any related values passed as Row objects, using the relation name as a
 824 key, are reduced to the appropriate foreign key values and stored. If
 825 instead of related row objects, a hashref of column, value data is
 826 passed, will create the related object first then store.
 827
 828 Will even accept arrayrefs of data as a value to a
 829 L<DBIx::Class::Relationship/has_many> key, and create the related
 830 objects if necessary.
 831
 832 Be aware that the input hashref might be edited in place, so dont rely
 833 on it being the same after a call to C<set_inflated_columns>. If you
 834 need to preserve the hashref, it is sufficient to pass a shallow copy
 835 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
 836
 837 See also L<DBIx::Class::Relationship::Base/set_from_related>.
 838
 839 =cut
 840
 841 sub set_inflated_columns {
 842   my ( $self, $upd ) = @_;
 843   foreach my $key (keys %$upd) {
 844     if (ref $upd->{$key}) {
 845       my $info = $self->relationship_info($key);
 846       if ($info && $info->{attrs}{accessor}
 847         && $info->{attrs}{accessor} eq 'single')
 848       {
 849         my $rel = delete $upd->{$key};
 850         $self->set_from_related($key => $rel);
 851         $self->{_relationship_data}{$key} = $rel;
 852       } elsif ($info && $info->{attrs}{accessor}
 853         && $info->{attrs}{accessor} eq 'multi') {
 854           $self->throw_exception(
 855             "Recursive update is not supported over relationships of type multi ($key)"
 856           );
 857       }
 858       elsif ($self->has_column($key)
 859         && exists $self->column_info($key)->{_inflate_info})
 860       {
 861         $self->set_inflated_column($key, delete $upd->{$key});
 862       }
 863     }
 864   }
 865   $self->set_columns($upd);
 866 }
 867
 868 =head2 copy
 869
 870   my $copy = $orig->copy({ change => $to, ... });
 871
 872 =over
 873
 874 =item Arguments: \%replacementdata
 875
 876 =item Returns: The Row object copy
 877
 878 =back
 879
 880 Inserts a new row into the database, as a copy of the original
 881 object. If a hashref of replacement data is supplied, these will take
 882 precedence over data in the original.
 883
 884 If the row has related objects in a
 885 L<DBIx::Class::Relationship/has_many> then those objects may be copied
 886 too depending on the L<cascade_copy|DBIx::Class::Relationship>
 887 relationship attribute.
 888
 889 =cut
 890
 891 sub copy {
 892   my ($self, $changes) = @_;
 893   $changes ||= {};
 894   my $col_data = { %{$self->{_column_data}} };
 895   foreach my $col (keys %$col_data) {
 896     delete $col_data->{$col}
 897       if $self->result_source->column_info($col)->{is_auto_increment};
 898   }
 899
 900   my $new = { _column_data => $col_data };
 901   bless $new, ref $self;
 902
 903   $new->result_source($self->result_source);
 904   $new->set_inflated_columns($changes);
 905   $new->insert;
 906
 907   # Its possible we'll have 2 relations to the same Source. We need to make
 908   # sure we don't try to insert the same row twice esle we'll violate unique
 909   # constraints
 910   my $rels_copied = {};
 911
 912   foreach my $rel ($self->result_source->relationships) {
 913     my $rel_info = $self->result_source->relationship_info($rel);
 914
 915     next unless $rel_info->{attrs}{cascade_copy};
 916
 917     my $resolved = $self->result_source->resolve_condition(
 918       $rel_info->{cond}, $rel, $new
 919     );
 920
 921     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 922     foreach my $related ($self->search_related($rel)) {
 923       my $id_str = join("\0", $related->id);
 924       next if $copied->{$id_str};
 925       $copied->{$id_str} = 1;
 926       my $rel_copy = $related->copy($resolved);
 927     }
 928
 929   }
 930   return $new;
 931 }
 932
 933 =head2 store_column
 934
 935   $row->store_column($col => $val);
 936
 937 =over
 938
 939 =item Arguments: $columnname, $value
 940
 941 =item Returns: The value sent to storage
 942
 943 =back
 944
 945 Set a raw value for a column without marking it as changed. This
 946 method is used internally by L</set_column> which you should probably
 947 be using.
 948
 949 This is the lowest level at which data is set on a row object,
 950 extend this method to catch all data setting methods.
 951
 952 =cut
 953
 954 sub store_column {
 955   my ($self, $column, $value) = @_;
 956   $self->throw_exception( "No such column '${column}'" )
 957     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 958   $self->throw_exception( "set_column called for ${column} without value" )
 959     if @_ < 3;
 960   return $self->{_column_data}{$column} = $value;
 961 }
 962
 963 =head2 inflate_result
 964
 965   Class->inflate_result($result_source, \%me, \%prefetch?)
 966
 967 =over
 968
 969 =item Arguments: $result_source, \%columndata, \%prefetcheddata
 970
 971 =item Returns: A Row object
 972
 973 =back
 974
 975 All L<DBIx::Class::ResultSet> methods that retrieve data from the
 976 database and turn it into row objects call this method.
 977
 978 Extend this method in your Result classes to hook into this process,
 979 for example to rebless the result into a different class.
 980
 981 Reblessing can also be done more easily by setting C<result_class> in
 982 your Result class. See L<DBIx::Class::ResultSource/result_class>.
 983
 984 =cut
 985
 986 sub inflate_result {
 987   my ($class, $source, $me, $prefetch) = @_;
 988
 989   my ($source_handle) = $source;
 990
 991   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 992       $source = $source_handle->resolve
 993   } else {
 994       $source_handle = $source->handle
 995   }
 996
 997   my $new = {
 998     _source_handle => $source_handle,
 999     _column_data => $me,
1000     _in_storage => 1
1001   };
1002   bless $new, (ref $class || $class);
1003
1004   my $schema;
1005   foreach my $pre (keys %{$prefetch||{}}) {
1006     my $pre_val = $prefetch->{$pre};
1007     my $pre_source = $source->related_source($pre);
1008     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
1009       unless $pre_source;
1010     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
1011       my @pre_objects;
1012       foreach my $pre_rec (@$pre_val) {
1013         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
1014            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
1015           next;
1016         }
1017         push(@pre_objects, $pre_source->result_class->inflate_result(
1018                              $pre_source, @{$pre_rec}));
1019       }
1020       $new->related_resultset($pre)->set_cache(\@pre_objects);
1021     } elsif (defined $pre_val->[0]) {
1022       my $fetched;
1023       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
1024          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
1025       {
1026         $fetched = $pre_source->result_class->inflate_result(
1027                       $pre_source, @{$pre_val});
1028       }
1029       $new->related_resultset($pre)->set_cache([ $fetched ]);
1030       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
1031       $class->throw_exception("No accessor for prefetched $pre")
1032        unless defined $accessor;
1033       if ($accessor eq 'single') {
1034         $new->{_relationship_data}{$pre} = $fetched;
1035       } elsif ($accessor eq 'filter') {
1036         $new->{_inflated_column}{$pre} = $fetched;
1037       } else {
1038        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
1039       }
1040     }
1041   }
1042   return $new;
1043 }
1044
1045 =head2 update_or_insert
1046
1047   $row->update_or_insert
1048
1049 =over
1050
1051 =item Arguments: none
1052
1053 =item Returns: Result of update or insert operation
1054
1055 =back
1056
1057 L</Update>s the object if it's already in the database, according to
1058 L</in_storage>, else L</insert>s it.
1059
1060 =head2 insert_or_update
1061
1062   $obj->insert_or_update
1063
1064 Alias for L</update_or_insert>
1065
1066 =cut
1067
1068 sub insert_or_update { shift->update_or_insert(@_) }
1069
1070 sub update_or_insert {
1071   my $self = shift;
1072   return ($self->in_storage ? $self->update : $self->insert);
1073 }
1074
1075 =head2 is_changed
1076
1077   my @changed_col_names = $row->is_changed();
1078   if ($row->is_changed()) { ... }
1079
1080 =over
1081
1082 =item Arguments: none
1083
1084 =item Returns: 0|1 or @columnnames
1085
1086 =back
1087
1088 In list context returns a list of columns with uncommited changes, or
1089 in scalar context returns a true value if there are uncommitted
1090 changes.
1091
1092 =cut
1093
1094 sub is_changed {
1095   return keys %{shift->{_dirty_columns} || {}};
1096 }
1097
1098 =head2 is_column_changed
1099
1100   if ($row->is_column_changed('col')) { ... }
1101
1102 =over
1103
1104 =item Arguments: $columname
1105
1106 =item Returns: 0|1
1107
1108 =back
1109
1110 Returns a true value if the column has uncommitted changes.
1111
1112 =cut
1113
1114 sub is_column_changed {
1115   my( $self, $col ) = @_;
1116   return exists $self->{_dirty_columns}->{$col};
1117 }
1118
1119 =head2 result_source
1120
1121   my $resultsource = $row->result_source;
1122
1123 =over
1124
1125 =item Arguments: none
1126
1127 =item Returns: a ResultSource instance
1128
1129 =back
1130
1131 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1132
1133 =cut
1134
1135 sub result_source {
1136     my $self = shift;
1137
1138     if (@_) {
1139         $self->_source_handle($_[0]->handle);
1140     } else {
1141         $self->_source_handle->resolve;
1142     }
1143 }
1144
1145 =head2 register_column
1146
1147   $column_info = { .... };
1148   $class->register_column($column_name, $column_info);
1149
1150 =over
1151
1152 =item Arguments: $columnname, \%columninfo
1153
1154 =item Returns: undefined
1155
1156 =back
1157
1158 Registers a column on the class. If the column_info has an 'accessor'
1159 key, creates an accessor named after the value if defined; if there is
1160 no such key, creates an accessor with the same name as the column
1161
1162 The column_info attributes are described in
1163 L<DBIx::Class::ResultSource/add_columns>
1164
1165 =cut
1166
1167 sub register_column {
1168   my ($class, $col, $info) = @_;
1169   my $acc = $col;
1170   if (exists $info->{accessor}) {
1171     return unless defined $info->{accessor};
1172     $acc = [ $info->{accessor}, $col ];
1173   }
1174   $class->mk_group_accessors('column' => $acc);
1175 }
1176
1177 =head2 get_from_storage
1178
1179   my $copy = $row->get_from_storage($attrs)
1180
1181 =over
1182
1183 =item Arguments: \%attrs
1184
1185 =item Returns: A Row object
1186
1187 =back
1188
1189 Fetches a fresh copy of the Row object from the database and returns it.
1190
1191 If passed the \%attrs argument, will first apply these attributes to
1192 the resultset used to find the row.
1193
1194 This copy can then be used to compare to an existing row object, to
1195 determine if any changes have been made in the database since it was
1196 created.
1197
1198 To just update your Row object with any latest changes from the
1199 database, use L</discard_changes> instead.
1200
1201 The \%attrs argument should be compatible with
1202 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1203
1204 =cut
1205
1206 sub get_from_storage {
1207     my $self = shift @_;
1208     my $attrs = shift @_;
1209     my $resultset = $self->result_source->resultset;
1210
1211     if(defined $attrs) {
1212         $resultset = $resultset->search(undef, $attrs);
1213     }
1214
1215     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1216 }
1217
1218 =head2 throw_exception
1219
1220 See L<DBIx::Class::Schema/throw_exception>.
1221
1222 =cut
1223
1224 sub throw_exception {
1225   my $self=shift;
1226   if (ref $self && ref $self->result_source && $self->result_source->schema) {
1227     $self->result_source->schema->throw_exception(@_);
1228   } else {
1229     croak(@_);
1230   }
1231 }
1232
1233 =head2 id
1234
1235   my @pk = $row->id;
1236
1237 =over
1238
1239 =item Arguments: none
1240
1241 =item Returns: A list of primary key values
1242
1243 =back
1244
1245 Returns the primary key(s) for a row. Can't be called as a class method.
1246 Actually implemented in L<DBIx::Class::PK>
1247
1248 =head2 discard_changes
1249
1250   $row->discard_changes
1251
1252 =over
1253
1254 =item Arguments: none
1255
1256 =item Returns: nothing (updates object in-place)
1257
1258 =back
1259
1260 Retrieves and sets the row object data from the database, losing any
1261 local changes made.
1262
1263 This method can also be used to refresh from storage, retrieving any
1264 changes made since the row was last read from storage. Actually
1265 implemented in L<DBIx::Class::PK>
1266
1267 =cut
1268
1269 1;
1270
1271 =head1 AUTHORS
1272
1273 Matt S. Trout <mst@shadowcatsystems.co.uk>
1274
1275 =head1 LICENSE
1276
1277 You may distribute this code under the same terms as Perl itself.
1278
1279 =cut