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