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