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         && ref $upd->{$key} eq 'ARRAY') {
 778         my $others = delete $upd->{$key};
 779         foreach my $rel_obj (@$others) {
 780           if(!Scalar::Util::blessed($rel_obj)) {
 781             $rel_obj = $self->create_related($key, $rel_obj);
 782           }
 783         }
 784         $self->{_relationship_data}{$key} = $others;
 785 #            $related->{$key} = $others;
 786         next;
 787       }
 788       elsif ($self->has_column($key)
 789         && exists $self->column_info($key)->{_inflate_info})
 790       {
 791         $self->set_inflated_column($key, delete $upd->{$key});
 792       }
 793     }
 794   }
 795   $self->set_columns($upd);
 796 }
 797
 798 =head2 copy
 799
 800   my $copy = $orig->copy({ change => $to, ... });
 801
 802 =over
 803
 804 =item Arguments: \%replacementdata
 805
 806 =item Returns: The Row object copy
 807
 808 =back
 809
 810 Inserts a new row into the database, as a copy of the original
 811 object. If a hashref of replacement data is supplied, these will take
 812 precedence over data in the original.
 813
 814 If the row has related objects in a
 815 L<DBIx::Class::Relationship/has_many> then those objects may be copied
 816 too depending on the L<cascade_copy|DBIx::Class::Relationship>
 817 relationship attribute.
 818
 819 =cut
 820
 821 sub copy {
 822   my ($self, $changes) = @_;
 823   $changes ||= {};
 824   my $col_data = { %{$self->{_column_data}} };
 825   foreach my $col (keys %$col_data) {
 826     delete $col_data->{$col}
 827       if $self->result_source->column_info($col)->{is_auto_increment};
 828   }
 829
 830   my $new = { _column_data => $col_data };
 831   bless $new, ref $self;
 832
 833   $new->result_source($self->result_source);
 834   $new->set_inflated_columns($changes);
 835   $new->insert;
 836
 837   # Its possible we'll have 2 relations to the same Source. We need to make
 838   # sure we don't try to insert the same row twice esle we'll violate unique
 839   # constraints
 840   my $rels_copied = {};
 841
 842   foreach my $rel ($self->result_source->relationships) {
 843     my $rel_info = $self->result_source->relationship_info($rel);
 844
 845     next unless $rel_info->{attrs}{cascade_copy};
 846
 847     my $resolved = $self->result_source->resolve_condition(
 848       $rel_info->{cond}, $rel, $new
 849     );
 850
 851     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 852     foreach my $related ($self->search_related($rel)) {
 853       my $id_str = join("\0", $related->id);
 854       next if $copied->{$id_str};
 855       $copied->{$id_str} = 1;
 856       my $rel_copy = $related->copy($resolved);
 857     }
 858
 859   }
 860   return $new;
 861 }
 862
 863 =head2 store_column
 864
 865   $row->store_column($col => $val);
 866
 867 =over
 868
 869 =item Arguments: $columnname, $value
 870
 871 =item Returns: The value sent to storage
 872
 873 =back
 874
 875 Set a raw value for a column without marking it as changed. This
 876 method is used internally by L</set_column> which you should probably
 877 be using.
 878
 879 This is the lowest level at which data is set on a row object,
 880 extend this method to catch all data setting methods.
 881
 882 =cut
 883
 884 sub store_column {
 885   my ($self, $column, $value) = @_;
 886   $self->throw_exception( "No such column '${column}'" )
 887     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 888   $self->throw_exception( "set_column called for ${column} without value" )
 889     if @_ < 3;
 890   return $self->{_column_data}{$column} = $value;
 891 }
 892
 893 =head2 inflate_result
 894
 895   Class->inflate_result($result_source, \%me, \%prefetch?)
 896
 897 =over
 898
 899 =item Arguments: $result_source, \%columndata, \%prefetcheddata
 900
 901 =item Returns: A Row object
 902
 903 =back
 904
 905 All L<DBIx::Class::ResultSet> methods that retrieve data from the
 906 database and turn it into row objects call this method.
 907
 908 Extend this method in your Result classes to hook into this process,
 909 for example to rebless the result into a different class.
 910
 911 Reblessing can also be done more easily by setting C<result_class> in
 912 your Result class. See L<DBIx::Class::ResultSource/result_class>.
 913
 914 =cut
 915
 916 sub inflate_result {
 917   my ($class, $source, $me, $prefetch) = @_;
 918
 919   my ($source_handle) = $source;
 920
 921   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 922       $source = $source_handle->resolve
 923   } else {
 924       $source_handle = $source->handle
 925   }
 926
 927   my $new = {
 928     _source_handle => $source_handle,
 929     _column_data => $me,
 930     _in_storage => 1
 931   };
 932   bless $new, (ref $class || $class);
 933
 934   my $schema;
 935   foreach my $pre (keys %{$prefetch||{}}) {
 936     my $pre_val = $prefetch->{$pre};
 937     my $pre_source = $source->related_source($pre);
 938     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 939       unless $pre_source;
 940     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 941       my @pre_objects;
 942       foreach my $pre_rec (@$pre_val) {
 943         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 944            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 945           next;
 946         }
 947         push(@pre_objects, $pre_source->result_class->inflate_result(
 948                              $pre_source, @{$pre_rec}));
 949       }
 950       $new->related_resultset($pre)->set_cache(\@pre_objects);
 951     } elsif (defined $pre_val->[0]) {
 952       my $fetched;
 953       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 954          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 955       {
 956         $fetched = $pre_source->result_class->inflate_result(
 957                       $pre_source, @{$pre_val});
 958       }
 959       $new->related_resultset($pre)->set_cache([ $fetched ]);
 960       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 961       $class->throw_exception("No accessor for prefetched $pre")
 962        unless defined $accessor;
 963       if ($accessor eq 'single') {
 964         $new->{_relationship_data}{$pre} = $fetched;
 965       } elsif ($accessor eq 'filter') {
 966         $new->{_inflated_column}{$pre} = $fetched;
 967       } else {
 968        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 969       }
 970     }
 971   }
 972   return $new;
 973 }
 974
 975 =head2 update_or_insert
 976
 977   $row->update_or_insert
 978
 979 =over
 980
 981 =item Arguments: none
 982
 983 =item Returns: Result of update or insert operation
 984
 985 =back
 986
 987 L</Update>s the object if it's already in the database, according to
 988 L</in_storage>, else L</insert>s it.
 989
 990 =head2 insert_or_update
 991
 992   $obj->insert_or_update
 993
 994 Alias for L</update_or_insert>
 995
 996 =cut
 997
 998 sub insert_or_update { shift->update_or_insert(@_) }
 999
1000 sub update_or_insert {
1001   my $self = shift;
1002   return ($self->in_storage ? $self->update : $self->insert);
1003 }
1004
1005 =head2 is_changed
1006
1007   my @changed_col_names = $row->is_changed();
1008   if ($row->is_changed()) { ... }
1009
1010 =over
1011
1012 =item Arguments: none
1013
1014 =item Returns: 0|1 or @columnnames
1015
1016 =back
1017
1018 In list context returns a list of columns with uncommited changes, or
1019 in scalar context returns a true value if there are uncommitted
1020 changes.
1021
1022 =cut
1023
1024 sub is_changed {
1025   return keys %{shift->{_dirty_columns} || {}};
1026 }
1027
1028 =head2 is_column_changed
1029
1030   if ($row->is_column_changed('col')) { ... }
1031
1032 =over
1033
1034 =item Arguments: $columname
1035
1036 =item Returns: 0|1
1037
1038 =back
1039
1040 Returns a true value if the column has uncommitted changes.
1041
1042 =cut
1043
1044 sub is_column_changed {
1045   my( $self, $col ) = @_;
1046   return exists $self->{_dirty_columns}->{$col};
1047 }
1048
1049 =head2 result_source
1050
1051   my $resultsource = $row->result_source;
1052
1053 =over
1054
1055 =item Arguments: none
1056
1057 =item Returns: a ResultSource instance
1058
1059 =back
1060
1061 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1062
1063 =cut
1064
1065 sub result_source {
1066     my $self = shift;
1067
1068     if (@_) {
1069         $self->_source_handle($_[0]->handle);
1070     } else {
1071         $self->_source_handle->resolve;
1072     }
1073 }
1074
1075 =head2 register_column
1076
1077   $column_info = { .... };
1078   $class->register_column($column_name, $column_info);
1079
1080 =over
1081
1082 =item Arguments: $columnname, \%columninfo
1083
1084 =item Returns: undefined
1085
1086 =back
1087
1088 Registers a column on the class. If the column_info has an 'accessor'
1089 key, creates an accessor named after the value if defined; if there is
1090 no such key, creates an accessor with the same name as the column
1091
1092 The column_info attributes are described in
1093 L<DBIx::Class::ResultSource/add_columns>
1094
1095 =cut
1096
1097 sub register_column {
1098   my ($class, $col, $info) = @_;
1099   my $acc = $col;
1100   if (exists $info->{accessor}) {
1101     return unless defined $info->{accessor};
1102     $acc = [ $info->{accessor}, $col ];
1103   }
1104   $class->mk_group_accessors('column' => $acc);
1105 }
1106
1107 =head2 get_from_storage
1108
1109   my $copy = $row->get_from_storage($attrs)
1110
1111 =over
1112
1113 =item Arguments: \%attrs
1114
1115 =item Returns: A Row object
1116
1117 =back
1118
1119 Fetches a fresh copy of the Row object from the database and returns it.
1120
1121 If passed the \%attrs argument, will first apply these attributes to
1122 the resultset used to find the row.
1123
1124 This copy can then be used to compare to an existing row object, to
1125 determine if any changes have been made in the database since it was
1126 created.
1127
1128 To just update your Row object with any latest changes from the
1129 database, use L</discard_changes> instead.
1130
1131 The \%attrs argument should be compatible with
1132 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1133
1134 =cut
1135
1136 sub get_from_storage {
1137     my $self = shift @_;
1138     my $attrs = shift @_;
1139     my $resultset = $self->result_source->resultset;
1140
1141     if(defined $attrs) {
1142         $resultset = $resultset->search(undef, $attrs);
1143     }
1144
1145     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1146 }
1147
1148 =head2 throw_exception
1149
1150 See L<DBIx::Class::Schema/throw_exception>.
1151
1152 =cut
1153
1154 sub throw_exception {
1155   my $self=shift;
1156   if (ref $self && ref $self->result_source && $self->result_source->schema) {
1157     $self->result_source->schema->throw_exception(@_);
1158   } else {
1159     croak(@_);
1160   }
1161 }
1162
1163 =head2 id
1164
1165   my @pk = $row->id;
1166
1167 =over
1168
1169 =item Arguments: none
1170
1171 =item Returns: A list of primary key values
1172
1173 =back
1174
1175 Returns the primary key(s) for a row. Can't be called as a class method.
1176 Actually implemented in L<DBIx::Class::PK>
1177
1178 =head2 discard_changes
1179
1180   $row->discard_changes
1181
1182 =over
1183
1184 =item Arguments: none
1185
1186 =item Returns: nothing (updates object in-place)
1187
1188 =back
1189
1190 Retrieves and sets the row object data from the database, losing any
1191 local changes made.
1192
1193 This method can also be used to refresh from storage, retrieving any
1194 changes made since the row was last read from storage. Actually
1195 implemented in L<DBIx::Class::PK>
1196
1197 =cut
1198
1199 1;
1200
1201 =head1 AUTHORS
1202
1203 Matt S. Trout <mst@shadowcatsystems.co.uk>
1204
1205 =head1 LICENSE
1206
1207 You may distribute this code under the same terms as Perl itself.
1208
1209 =cut