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