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