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   }
 351
 352
 353   $self->{_dirty_columns} = {};
 354   $self->{related_resultsets} = {};
 355
 356   if(!$self->{_rel_in_storage}) {
 357     ## Now do the relationships that need our ID (has_many etc.)
 358     foreach my $relname (keys %related_stuff) {
 359       my $rel_obj = $related_stuff{$relname};
 360       my @cands;
 361       if (Scalar::Util::blessed($rel_obj)
 362           && $rel_obj->isa('DBIx::Class::Row')) {
 363         @cands = ($rel_obj);
 364       } elsif (ref $rel_obj eq 'ARRAY') {
 365         @cands = @$rel_obj;
 366       }
 367       if (@cands) {
 368         my $reverse = $source->reverse_relationship_info($relname);
 369         foreach my $obj (@cands) {
 370           $obj->set_from_related($_, $self) for keys %$reverse;
 371           my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
 372           if ($self->__their_pk_needs_us($relname, $them)) {
 373             if (exists $self->{_ignore_at_insert}{$relname}) {
 374               MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
 375             } else {
 376               MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
 377               my $re = $self->result_source
 378                             ->related_source($relname)
 379                             ->resultset
 380                             ->find_or_create($them);
 381               %{$obj} = %{$re};
 382               MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
 383             }
 384           } else {
 385             MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
 386             $obj->insert();
 387           }
 388         }
 389       }
 390     }
 391     delete $self->{_ignore_at_insert};
 392     $rollback_guard->commit;
 393   }
 394
 395   $self->in_storage(1);
 396   undef $self->{_orig_ident};
 397   return $self;
 398 }
 399
 400 =head2 in_storage
 401
 402   $row->in_storage; # Get value
 403   $row->in_storage(1); # Set value
 404
 405 =over
 406
 407 =item Arguments: none or 1|0
 408
 409 =item Returns: 1|0
 410
 411 =back
 412
 413 Indicates whether the object exists as a row in the database or
 414 not. This is set to true when L<DBIx::Class::ResultSet/find>,
 415 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
 416 are used.
 417
 418 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
 419 L</delete> on one, sets it to false.
 420
 421 =cut
 422
 423 sub in_storage {
 424   my ($self, $val) = @_;
 425   $self->{_in_storage} = $val if @_ > 1;
 426   return $self->{_in_storage};
 427 }
 428
 429 =head2 update
 430
 431   $row->update(\%columns?)
 432
 433 =over
 434
 435 =item Arguments: none or a hashref
 436
 437 =item Returns: The Row object
 438
 439 =back
 440
 441 Throws an exception if the row object is not yet in the database,
 442 according to L</in_storage>.
 443
 444 This method issues an SQL UPDATE query to commit any changes to the
 445 object to the database if required.
 446
 447 Also takes an optional hashref of C<< column_name => value> >> pairs
 448 to update on the object first. Be aware that the hashref will be
 449 passed to C<set_inflated_columns>, which might edit it in place, so
 450 don't rely on it being the same after a call to C<update>.  If you
 451 need to preserve the hashref, it is sufficient to pass a shallow copy
 452 to C<update>, e.g. ( { %{ $href } } )
 453
 454 If the values passed or any of the column values set on the object
 455 contain scalar references, eg:
 456
 457   $row->last_modified(\'NOW()');
 458   # OR
 459   $row->update({ last_modified => \'NOW()' });
 460
 461 The update will pass the values verbatim into SQL. (See
 462 L<SQL::Abstract> docs).  The values in your Row object will NOT change
 463 as a result of the update call, if you want the object to be updated
 464 with the actual values from the database, call L</discard_changes>
 465 after the update.
 466
 467   $row->update()->discard_changes();
 468
 469 To determine before calling this method, which column values have
 470 changed and will be updated, call L</get_dirty_columns>.
 471
 472 To check if any columns will be updated, call L</is_changed>.
 473
 474 To force a column to be updated, call L</make_column_dirty> before
 475 this method.
 476
 477 =cut
 478
 479 sub update {
 480   my ($self, $upd) = @_;
 481   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 482   my $ident_cond = $self->ident_condition;
 483   $self->throw_exception("Cannot safely update a row in a PK-less table")
 484     if ! keys %$ident_cond;
 485
 486   $self->set_inflated_columns($upd) if $upd;
 487   my %to_update = $self->get_dirty_columns;
 488   return $self unless keys %to_update;
 489   my $rows = $self->result_source->storage->update(
 490                $self->result_source, \%to_update,
 491                $self->{_orig_ident} || $ident_cond
 492              );
 493   if ($rows == 0) {
 494     $self->throw_exception( "Can't update ${self}: row not found" );
 495   } elsif ($rows > 1) {
 496     $self->throw_exception("Can't update ${self}: updated more than one row");
 497   }
 498   $self->{_dirty_columns} = {};
 499   $self->{related_resultsets} = {};
 500   undef $self->{_orig_ident};
 501   return $self;
 502 }
 503
 504 =head2 delete
 505
 506   $row->delete
 507
 508 =over
 509
 510 =item Arguments: none
 511
 512 =item Returns: The Row object
 513
 514 =back
 515
 516 Throws an exception if the object is not in the database according to
 517 L</in_storage>. Runs an SQL DELETE statement using the primary key
 518 values to locate the row.
 519
 520 The object is still perfectly usable, but L</in_storage> will
 521 now return 0 and the object must be reinserted using L</insert>
 522 before it can be used to L</update> the row again.
 523
 524 If you delete an object in a class with a C<has_many> relationship, an
 525 attempt is made to delete all the related objects as well. To turn
 526 this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
 527 hashref of the relationship, see L<DBIx::Class::Relationship>. Any
 528 database-level cascade or restrict will take precedence over a
 529 DBIx-Class-based cascading delete.
 530
 531 If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
 532 and the transaction subsequently fails, the row object will remain marked as
 533 not being in storage. If you know for a fact that the object is still in
 534 storage (i.e. by inspecting the cause of the transaction's failure), you can
 535 use C<< $obj->in_storage(1) >> to restore consistency between the object and
 536 the database. This would allow a subsequent C<< $obj->delete >> to work
 537 as expected.
 538
 539 See also L<DBIx::Class::ResultSet/delete>.
 540
 541 =cut
 542
 543 sub delete {
 544   my $self = shift;
 545   if (ref $self) {
 546     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 547     my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
 548     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 549       if ! keys %$ident_cond;
 550     foreach my $column (keys %$ident_cond) {
 551             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 552               unless exists $self->{_column_data}{$column};
 553     }
 554     $self->result_source->storage->delete(
 555       $self->result_source, $ident_cond);
 556     $self->in_storage(undef);
 557   } else {
 558     $self->throw_exception("Can't do class delete without a ResultSource instance")
 559       unless $self->can('result_source_instance');
 560     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 561     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 562     $self->result_source_instance->resultset->search(@_)->delete;
 563   }
 564   return $self;
 565 }
 566
 567 =head2 get_column
 568
 569   my $val = $row->get_column($col);
 570
 571 =over
 572
 573 =item Arguments: $columnname
 574
 575 =item Returns: The value of the column
 576
 577 =back
 578
 579 Throws an exception if the column name given doesn't exist according
 580 to L</has_column>.
 581
 582 Returns a raw column value from the row object, if it has already
 583 been fetched from the database or set by an accessor.
 584
 585 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
 586 will be deflated and returned.
 587
 588 Note that if you used the C<columns> or the C<select/as>
 589 L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
 590 which C<$row> was derived, and B<did not include> C<$columnname> in the list,
 591 this method will return C<undef> even if the database contains some value.
 592
 593 To retrieve all loaded column values as a hash, use L</get_columns>.
 594
 595 =cut
 596
 597 sub get_column {
 598   my ($self, $column) = @_;
 599   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 600   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 601   if (exists $self->{_inflated_column}{$column}) {
 602     return $self->store_column($column,
 603       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 604   }
 605   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 606   return undef;
 607 }
 608
 609 =head2 has_column_loaded
 610
 611   if ( $row->has_column_loaded($col) ) {
 612      print "$col has been loaded from db";
 613   }
 614
 615 =over
 616
 617 =item Arguments: $columnname
 618
 619 =item Returns: 0|1
 620
 621 =back
 622
 623 Returns a true value if the column value has been loaded from the
 624 database (or set locally).
 625
 626 =cut
 627
 628 sub has_column_loaded {
 629   my ($self, $column) = @_;
 630   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 631   return 1 if exists $self->{_inflated_column}{$column};
 632   return exists $self->{_column_data}{$column};
 633 }
 634
 635 =head2 get_columns
 636
 637   my %data = $row->get_columns;
 638
 639 =over
 640
 641 =item Arguments: none
 642
 643 =item Returns: A hash of columnname, value pairs.
 644
 645 =back
 646
 647 Returns all loaded column data as a hash, containing raw values. To
 648 get just one value for a particular column, use L</get_column>.
 649
 650 See L</get_inflated_columns> to get the inflated values.
 651
 652 =cut
 653
 654 sub get_columns {
 655   my $self = shift;
 656   if (exists $self->{_inflated_column}) {
 657     foreach my $col (keys %{$self->{_inflated_column}}) {
 658       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 659         unless exists $self->{_column_data}{$col};
 660     }
 661   }
 662   return %{$self->{_column_data}};
 663 }
 664
 665 =head2 get_dirty_columns
 666
 667   my %data = $row->get_dirty_columns;
 668
 669 =over
 670
 671 =item Arguments: none
 672
 673 =item Returns: A hash of column, value pairs
 674
 675 =back
 676
 677 Only returns the column, value pairs for those columns that have been
 678 changed on this object since the last L</update> or L</insert> call.
 679
 680 See L</get_columns> to fetch all column/value pairs.
 681
 682 =cut
 683
 684 sub get_dirty_columns {
 685   my $self = shift;
 686   return map { $_ => $self->{_column_data}{$_} }
 687            keys %{$self->{_dirty_columns}};
 688 }
 689
 690 =head2 make_column_dirty
 691
 692   $row->make_column_dirty($col)
 693
 694 =over
 695
 696 =item Arguments: $columnname
 697
 698 =item Returns: undefined
 699
 700 =back
 701
 702 Throws an exception if the column does not exist.
 703
 704 Marks a column as having been changed regardless of whether it has
 705 really changed.
 706
 707 =cut
 708 sub make_column_dirty {
 709   my ($self, $column) = @_;
 710
 711   $self->throw_exception( "No such column '${column}'" )
 712     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 713
 714   # the entire clean/dirty code relieas on exists, not on true/false
 715   return 1 if exists $self->{_dirty_columns}{$column};
 716
 717   $self->{_dirty_columns}{$column} = 1;
 718
 719   # if we are just now making the column dirty, and if there is an inflated
 720   # value, force it over the deflated one
 721   if (exists $self->{_inflated_column}{$column}) {
 722     $self->store_column($column,
 723       $self->_deflated_column(
 724         $column, $self->{_inflated_column}{$column}
 725       )
 726     );
 727   }
 728 }
 729
 730 =head2 get_inflated_columns
 731
 732   my %inflated_data = $obj->get_inflated_columns;
 733
 734 =over
 735
 736 =item Arguments: none
 737
 738 =item Returns: A hash of column, object|value pairs
 739
 740 =back
 741
 742 Returns a hash of all column keys and associated values. Values for any
 743 columns set to use inflation will be inflated and returns as objects.
 744
 745 See L</get_columns> to get the uninflated values.
 746
 747 See L<DBIx::Class::InflateColumn> for how to setup inflation.
 748
 749 =cut
 750
 751 sub get_inflated_columns {
 752   my $self = shift;
 753   return map {
 754     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 755     ($_ => $self->$accessor);
 756   } grep $self->has_column_loaded($_), $self->columns;
 757 }
 758
 759 =head2 set_column
 760
 761   $row->set_column($col => $val);
 762
 763 =over
 764
 765 =item Arguments: $columnname, $value
 766
 767 =item Returns: $value
 768
 769 =back
 770
 771 Sets a raw column value. If the new value is different from the old one,
 772 the column is marked as dirty for when you next call L</update>.
 773
 774 If passed an object or reference as a value, this method will happily
 775 attempt to store it, and a later L</insert> or L</update> will try and
 776 stringify/numify as appropriate. To set an object to be deflated
 777 instead, see L</set_inflated_columns>.
 778
 779 =cut
 780
 781 sub set_column {
 782   my ($self, $column, $new_value) = @_;
 783
 784   $self->{_orig_ident} ||= $self->ident_condition;
 785   my $old_value = $self->get_column($column);
 786
 787   $self->store_column($column, $new_value);
 788
 789   my $dirty;
 790   if (defined $old_value xor defined $new_value) {
 791     $dirty = 1;
 792   }
 793   elsif (not defined $old_value) {  # both undef
 794     $dirty = 0;
 795   }
 796   elsif ($old_value eq $new_value) {
 797     $dirty = 0;
 798   }
 799   else {  # do a numeric comparison if datatype allows it
 800     my $colinfo = $self->column_info ($column);
 801
 802     # cache for speed
 803     if (not defined $colinfo->{is_numeric}) {
 804       $colinfo->{is_numeric} =
 805         $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type})
 806           ? 1
 807           : 0
 808         ;
 809     }
 810
 811     if ($colinfo->{is_numeric}) {
 812       $dirty = $old_value != $new_value;
 813     }
 814     else {
 815       $dirty = 1;
 816     }
 817   }
 818
 819   # sadly the update code just checks for keys, not for their value
 820   $self->{_dirty_columns}{$column} = 1 if $dirty;
 821
 822   # XXX clear out the relation cache for this column
 823   delete $self->{related_resultsets}{$column};
 824
 825   return $new_value;
 826 }
 827
 828 =head2 set_columns
 829
 830   $row->set_columns({ $col => $val, ... });
 831
 832 =over
 833
 834 =item Arguments: \%columndata
 835
 836 =item Returns: The Row object
 837
 838 =back
 839
 840 Sets multiple column, raw value pairs at once.
 841
 842 Works as L</set_column>.
 843
 844 =cut
 845
 846 sub set_columns {
 847   my ($self,$data) = @_;
 848   foreach my $col (keys %$data) {
 849     $self->set_column($col,$data->{$col});
 850   }
 851   return $self;
 852 }
 853
 854 =head2 set_inflated_columns
 855
 856   $row->set_inflated_columns({ $col => $val, $relname => $obj, ... });
 857
 858 =over
 859
 860 =item Arguments: \%columndata
 861
 862 =item Returns: The Row object
 863
 864 =back
 865
 866 Sets more than one column value at once. Any inflated values are
 867 deflated and the raw values stored.
 868
 869 Any related values passed as Row objects, using the relation name as a
 870 key, are reduced to the appropriate foreign key values and stored. If
 871 instead of related row objects, a hashref of column, value data is
 872 passed, will create the related object first then store.
 873
 874 Will even accept arrayrefs of data as a value to a
 875 L<DBIx::Class::Relationship/has_many> key, and create the related
 876 objects if necessary.
 877
 878 Be aware that the input hashref might be edited in place, so dont rely
 879 on it being the same after a call to C<set_inflated_columns>. If you
 880 need to preserve the hashref, it is sufficient to pass a shallow copy
 881 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
 882
 883 See also L<DBIx::Class::Relationship::Base/set_from_related>.
 884
 885 =cut
 886
 887 sub set_inflated_columns {
 888   my ( $self, $upd ) = @_;
 889   foreach my $key (keys %$upd) {
 890     if (ref $upd->{$key}) {
 891       my $info = $self->relationship_info($key);
 892       if ($info && $info->{attrs}{accessor}
 893         && $info->{attrs}{accessor} eq 'single')
 894       {
 895         my $rel = delete $upd->{$key};
 896         $self->set_from_related($key => $rel);
 897         $self->{_relationship_data}{$key} = $rel;
 898       } elsif ($info && $info->{attrs}{accessor}
 899         && $info->{attrs}{accessor} eq 'multi') {
 900           $self->throw_exception(
 901             "Recursive update is not supported over relationships of type multi ($key)"
 902           );
 903       }
 904       elsif ($self->has_column($key)
 905         && exists $self->column_info($key)->{_inflate_info})
 906       {
 907         $self->set_inflated_column($key, delete $upd->{$key});
 908       }
 909     }
 910   }
 911   $self->set_columns($upd);
 912 }
 913
 914 =head2 copy
 915
 916   my $copy = $orig->copy({ change => $to, ... });
 917
 918 =over
 919
 920 =item Arguments: \%replacementdata
 921
 922 =item Returns: The Row object copy
 923
 924 =back
 925
 926 Inserts a new row into the database, as a copy of the original
 927 object. If a hashref of replacement data is supplied, these will take
 928 precedence over data in the original. Also any columns which have
 929 the L<column info attribute|DBIx::Class::ResultSource/add_columns>
 930 C<< is_auto_increment => 1 >> are explicitly removed before the copy,
 931 so that the database can insert its own autoincremented values into
 932 the new object.
 933
 934 Relationships will be followed by the copy procedure B<only> if the
 935 relationship specifes a true value for its
 936 L<cascade_copy|DBIx::Class::Relationship::Base> attribute. C<cascade_copy>
 937 is set by default on C<has_many> relationships and unset on all others.
 938
 939 =cut
 940
 941 sub copy {
 942   my ($self, $changes) = @_;
 943   $changes ||= {};
 944   my $col_data = { %{$self->{_column_data}} };
 945   foreach my $col (keys %$col_data) {
 946     delete $col_data->{$col}
 947       if $self->result_source->column_info($col)->{is_auto_increment};
 948   }
 949
 950   my $new = { _column_data => $col_data };
 951   bless $new, ref $self;
 952
 953   $new->result_source($self->result_source);
 954   $new->set_inflated_columns($changes);
 955   $new->insert;
 956
 957   # Its possible we'll have 2 relations to the same Source. We need to make
 958   # sure we don't try to insert the same row twice esle we'll violate unique
 959   # constraints
 960   my $rels_copied = {};
 961
 962   foreach my $rel ($self->result_source->relationships) {
 963     my $rel_info = $self->result_source->relationship_info($rel);
 964
 965     next unless $rel_info->{attrs}{cascade_copy};
 966
 967     my $resolved = $self->result_source->_resolve_condition(
 968       $rel_info->{cond}, $rel, $new
 969     );
 970
 971     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 972     foreach my $related ($self->search_related($rel)) {
 973       my $id_str = join("\0", $related->id);
 974       next if $copied->{$id_str};
 975       $copied->{$id_str} = 1;
 976       my $rel_copy = $related->copy($resolved);
 977     }
 978
 979   }
 980   return $new;
 981 }
 982
 983 =head2 store_column
 984
 985   $row->store_column($col => $val);
 986
 987 =over
 988
 989 =item Arguments: $columnname, $value
 990
 991 =item Returns: The value sent to storage
 992
 993 =back
 994
 995 Set a raw value for a column without marking it as changed. This
 996 method is used internally by L</set_column> which you should probably
 997 be using.
 998
 999 This is the lowest level at which data is set on a row object,
1000 extend this method to catch all data setting methods.
1001
1002 =cut
1003
1004 sub store_column {
1005   my ($self, $column, $value) = @_;
1006   $self->throw_exception( "No such column '${column}'" )
1007     unless exists $self->{_column_data}{$column} || $self->has_column($column);
1008   $self->throw_exception( "set_column called for ${column} without value" )
1009     if @_ < 3;
1010   return $self->{_column_data}{$column} = $value;
1011 }
1012
1013 =head2 inflate_result
1014
1015   Class->inflate_result($result_source, \%me, \%prefetch?)
1016
1017 =over
1018
1019 =item Arguments: $result_source, \%columndata, \%prefetcheddata
1020
1021 =item Returns: A Row object
1022
1023 =back
1024
1025 All L<DBIx::Class::ResultSet> methods that retrieve data from the
1026 database and turn it into row objects call this method.
1027
1028 Extend this method in your Result classes to hook into this process,
1029 for example to rebless the result into a different class.
1030
1031 Reblessing can also be done more easily by setting C<result_class> in
1032 your Result class. See L<DBIx::Class::ResultSource/result_class>.
1033
1034 Different types of results can also be created from a particular
1035 L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/result_class>.
1036
1037 =cut
1038
1039 sub inflate_result {
1040   my ($class, $source, $me, $prefetch) = @_;
1041
1042   my ($source_handle) = $source;
1043
1044   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
1045       $source = $source_handle->resolve
1046   } else {
1047       $source_handle = $source->handle
1048   }
1049
1050   my $new = {
1051     _source_handle => $source_handle,
1052     _column_data => $me,
1053     _in_storage => 1
1054   };
1055   bless $new, (ref $class || $class);
1056
1057   my $schema;
1058   foreach my $pre (keys %{$prefetch||{}}) {
1059     my $pre_val = $prefetch->{$pre};
1060     my $pre_source = $source->related_source($pre);
1061     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
1062       unless $pre_source;
1063     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
1064       my @pre_objects;
1065       foreach my $pre_rec (@$pre_val) {
1066         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
1067            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
1068           next;
1069         }
1070         push(@pre_objects, $pre_source->result_class->inflate_result(
1071                              $pre_source, @{$pre_rec}));
1072       }
1073       $new->related_resultset($pre)->set_cache(\@pre_objects);
1074     } elsif (defined $pre_val->[0]) {
1075       my $fetched;
1076       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
1077          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
1078       {
1079         $fetched = $pre_source->result_class->inflate_result(
1080                       $pre_source, @{$pre_val});
1081       }
1082       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
1083       $class->throw_exception("No accessor for prefetched $pre")
1084        unless defined $accessor;
1085       if ($accessor eq 'single') {
1086         $new->{_relationship_data}{$pre} = $fetched;
1087       } elsif ($accessor eq 'filter') {
1088         $new->{_inflated_column}{$pre} = $fetched;
1089       } else {
1090        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
1091       }
1092       $new->related_resultset($pre)->set_cache([ $fetched ]);
1093     }
1094   }
1095   return $new;
1096 }
1097
1098 =head2 update_or_insert
1099
1100   $row->update_or_insert
1101
1102 =over
1103
1104 =item Arguments: none
1105
1106 =item Returns: Result of update or insert operation
1107
1108 =back
1109
1110 L</Update>s the object if it's already in the database, according to
1111 L</in_storage>, else L</insert>s it.
1112
1113 =head2 insert_or_update
1114
1115   $obj->insert_or_update
1116
1117 Alias for L</update_or_insert>
1118
1119 =cut
1120
1121 sub insert_or_update { shift->update_or_insert(@_) }
1122
1123 sub update_or_insert {
1124   my $self = shift;
1125   return ($self->in_storage ? $self->update : $self->insert);
1126 }
1127
1128 =head2 is_changed
1129
1130   my @changed_col_names = $row->is_changed();
1131   if ($row->is_changed()) { ... }
1132
1133 =over
1134
1135 =item Arguments: none
1136
1137 =item Returns: 0|1 or @columnnames
1138
1139 =back
1140
1141 In list context returns a list of columns with uncommited changes, or
1142 in scalar context returns a true value if there are uncommitted
1143 changes.
1144
1145 =cut
1146
1147 sub is_changed {
1148   return keys %{shift->{_dirty_columns} || {}};
1149 }
1150
1151 =head2 is_column_changed
1152
1153   if ($row->is_column_changed('col')) { ... }
1154
1155 =over
1156
1157 =item Arguments: $columname
1158
1159 =item Returns: 0|1
1160
1161 =back
1162
1163 Returns a true value if the column has uncommitted changes.
1164
1165 =cut
1166
1167 sub is_column_changed {
1168   my( $self, $col ) = @_;
1169   return exists $self->{_dirty_columns}->{$col};
1170 }
1171
1172 =head2 result_source
1173
1174   my $resultsource = $row->result_source;
1175
1176 =over
1177
1178 =item Arguments: none
1179
1180 =item Returns: a ResultSource instance
1181
1182 =back
1183
1184 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1185
1186 =cut
1187
1188 sub result_source {
1189     my $self = shift;
1190
1191     if (@_) {
1192         $self->_source_handle($_[0]->handle);
1193     } else {
1194         $self->_source_handle->resolve;
1195     }
1196 }
1197
1198 =head2 register_column
1199
1200   $column_info = { .... };
1201   $class->register_column($column_name, $column_info);
1202
1203 =over
1204
1205 =item Arguments: $columnname, \%columninfo
1206
1207 =item Returns: undefined
1208
1209 =back
1210
1211 Registers a column on the class. If the column_info has an 'accessor'
1212 key, creates an accessor named after the value if defined; if there is
1213 no such key, creates an accessor with the same name as the column
1214
1215 The column_info attributes are described in
1216 L<DBIx::Class::ResultSource/add_columns>
1217
1218 =cut
1219
1220 sub register_column {
1221   my ($class, $col, $info) = @_;
1222   my $acc = $col;
1223   if (exists $info->{accessor}) {
1224     return unless defined $info->{accessor};
1225     $acc = [ $info->{accessor}, $col ];
1226   }
1227   $class->mk_group_accessors('column' => $acc);
1228 }
1229
1230 =head2 get_from_storage
1231
1232   my $copy = $row->get_from_storage($attrs)
1233
1234 =over
1235
1236 =item Arguments: \%attrs
1237
1238 =item Returns: A Row object
1239
1240 =back
1241
1242 Fetches a fresh copy of the Row object from the database and returns it.
1243
1244 If passed the \%attrs argument, will first apply these attributes to
1245 the resultset used to find the row.
1246
1247 This copy can then be used to compare to an existing row object, to
1248 determine if any changes have been made in the database since it was
1249 created.
1250
1251 To just update your Row object with any latest changes from the
1252 database, use L</discard_changes> instead.
1253
1254 The \%attrs argument should be compatible with
1255 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1256
1257 =cut
1258
1259 sub get_from_storage {
1260     my $self = shift @_;
1261     my $attrs = shift @_;
1262     my $resultset = $self->result_source->resultset;
1263
1264     if(defined $attrs) {
1265         $resultset = $resultset->search(undef, $attrs);
1266     }
1267
1268     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1269 }
1270
1271 =head2 throw_exception
1272
1273 See L<DBIx::Class::Schema/throw_exception>.
1274
1275 =cut
1276
1277 sub throw_exception {
1278   my $self=shift;
1279   if (ref $self && ref $self->result_source && $self->result_source->schema) {
1280     $self->result_source->schema->throw_exception(@_);
1281   } else {
1282     croak(@_);
1283   }
1284 }
1285
1286 =head2 id
1287
1288   my @pk = $row->id;
1289
1290 =over
1291
1292 =item Arguments: none
1293
1294 =item Returns: A list of primary key values
1295
1296 =back
1297
1298 Returns the primary key(s) for a row. Can't be called as a class method.
1299 Actually implemented in L<DBIx::Class::PK>
1300
1301 =head2 discard_changes
1302
1303   $row->discard_changes
1304
1305 =over
1306
1307 =item Arguments: none
1308
1309 =item Returns: nothing (updates object in-place)
1310
1311 =back
1312
1313 Retrieves and sets the row object data from the database, losing any
1314 local changes made.
1315
1316 This method can also be used to refresh from storage, retrieving any
1317 changes made since the row was last read from storage. Actually
1318 implemented in L<DBIx::Class::PK>
1319
1320 =cut
1321
1322 1;
1323
1324 =head1 AUTHORS
1325
1326 Matt S. Trout <mst@shadowcatsystems.co.uk>
1327
1328 =head1 LICENSE
1329
1330 You may distribute this code under the same terms as Perl itself.
1331
1332 =cut