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