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