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