lib/DBIx/Class/Row.pm

   1 package DBIx::Class::Row;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class/;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use Scalar::Util ();
   9 use Scope::Guard;
  10
  11 ###
  12 ### Internal method
  13 ### Do not use
  14 ###
  15 BEGIN {
  16   *MULTICREATE_DEBUG =
  17     $ENV{DBIC_MULTICREATE_DEBUG}
  18       ? sub () { 1 }
  19       : sub () { 0 };
  20 }
  21
  22 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
  23
  24 =head1 NAME
  25
  26 DBIx::Class::Row - Basic row methods
  27
  28 =head1 SYNOPSIS
  29
  30 =head1 DESCRIPTION
  31
  32 This class is responsible for defining and doing basic operations on rows
  33 derived from L<DBIx::Class::ResultSource> objects.
  34
  35 Row objects are returned from L<DBIx::Class::ResultSet>s using the
  36 L<create|DBIx::Class::ResultSet/create>, L<find|DBIx::Class::ResultSet/find>,
  37 L<next|DBIx::Class::ResultSet/next> and L<all|DBIx::Class::ResultSet/all> methods,
  38 as well as invocations of 'single' (
  39 L<belongs_to|DBIx::Class::Relationship/belongs_to>,
  40 L<has_one|DBIx::Class::Relationship/has_one> or
  41 L<might_have|DBIx::Class::Relationship/might_have>)
  42 relationship accessors of L<DBIx::Class::Row> objects.
  43
  44 =head1 METHODS
  45
  46 =head2 new
  47
  48   my $row = My::Class->new(\%attrs);
  49
  50   my $row = $schema->resultset('MySource')->new(\%colsandvalues);
  51
  52 =over
  53
  54 =item Arguments: \%attrs or \%colsandvalues
  55
  56 =item Returns: A Row object
  57
  58 =back
  59
  60 While you can create a new row object by calling C<new> directly on
  61 this class, you are better off calling it on a
  62 L<DBIx::Class::ResultSet> object.
  63
  64 When calling it directly, you will not get a complete, usable row
  65 object until you pass or set the C<source_handle> attribute, to a
  66 L<DBIx::Class::ResultSource> instance that is attached to a
  67 L<DBIx::Class::Schema> with a valid connection.
  68
  69 C<$attrs> is a hashref of column name, value data. It can also contain
  70 some other attributes such as the C<source_handle>.
  71
  72 Passing an object, or an arrayref of objects as a value will call
  73 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
  74 passed a hashref or an arrayref of hashrefs as the value, these will
  75 be turned into objects via new_related, and treated as if you had
  76 passed objects.
  77
  78 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
  79
  80 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->{-from_resultset}) {
 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         confess "Can't do multi-create without result source" unless $source;
 172         my $info = $source->relationship_info($key);
 173         if ($info && $info->{attrs}{accessor}
 174           && $info->{attrs}{accessor} eq 'single')
 175         {
 176           my $rel_obj = delete $attrs->{$key};
 177           if(!Scalar::Util::blessed($rel_obj)) {
 178             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 179           }
 180
 181           if ($rel_obj->in_storage) {
 182             $new->{_rel_in_storage}{$key} = 1;
 183             $new->set_from_related($key, $rel_obj);
 184           } else {
 185             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
 186           }
 187
 188           $related->{$key} = $rel_obj;
 189           next;
 190         } elsif ($info && $info->{attrs}{accessor}
 191             && $info->{attrs}{accessor} eq 'multi'
 192             && ref $attrs->{$key} eq 'ARRAY') {
 193           my $others = delete $attrs->{$key};
 194           my $total = @$others;
 195           my @objects;
 196           foreach my $idx (0 .. $#$others) {
 197             my $rel_obj = $others->[$idx];
 198             if(!Scalar::Util::blessed($rel_obj)) {
 199               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 200             }
 201
 202             if ($rel_obj->in_storage) {
 203               $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong');
 204             } else {
 205               MULTICREATE_DEBUG and
 206                 warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
 207             }
 208             push(@objects, $rel_obj);
 209           }
 210           $related->{$key} = \@objects;
 211           next;
 212         } elsif ($info && $info->{attrs}{accessor}
 213           && $info->{attrs}{accessor} eq 'filter')
 214         {
 215           ## 'filter' should disappear and get merged in with 'single' above!
 216           my $rel_obj = delete $attrs->{$key};
 217           if(!Scalar::Util::blessed($rel_obj)) {
 218             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
 219           }
 220           if ($rel_obj->in_storage) {
 221             $new->{_rel_in_storage}{$key} = 1;
 222           }
 223           else {
 224             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
 225           }
 226           $inflated->{$key} = $rel_obj;
 227           next;
 228         } elsif ($class->has_column($key)
 229             && $class->column_info($key)->{_inflate_info}) {
 230           $inflated->{$key} = $attrs->{$key};
 231           next;
 232         }
 233       }
 234       $new->throw_exception("No such column $key on $class")
 235         unless $class->has_column($key);
 236       $new->store_column($key => $attrs->{$key});
 237     }
 238
 239     $new->{_relationship_data} = $related if $related;
 240     $new->{_inflated_column} = $inflated if $inflated;
 241   }
 242
 243   return $new;
 244 }
 245
 246 =head2 insert
 247
 248   $row->insert;
 249
 250 =over
 251
 252 =item Arguments: none
 253
 254 =item Returns: The Row object
 255
 256 =back
 257
 258 Inserts an object previously created by L</new> into the database if
 259 it isn't already in there. Returns the object itself. Requires the
 260 object's result source to be set, or the class to have a
 261 result_source_instance method. To insert an entirely new row into
 262 the database, use C<create> (see L<DBIx::Class::ResultSet/create>).
 263
 264 To fetch an uninserted row object, call
 265 L<new|DBIx::Class::ResultSet/new> on a resultset.
 266
 267 This will also insert any uninserted, related objects held inside this
 268 one, see L<DBIx::Class::ResultSet/create> for more details.
 269
 270 =cut
 271
 272 sub insert {
 273   my ($self) = @_;
 274   return $self if $self->in_storage;
 275   my $source = $self->result_source;
 276   $source ||=  $self->result_source($self->result_source_instance)
 277     if $self->can('result_source_instance');
 278   $self->throw_exception("No result_source set on this object; can't insert")
 279     unless $source;
 280
 281   my $rollback_guard;
 282
 283   # Check if we stored uninserted relobjs here in new()
 284   my %related_stuff = (%{$self->{_relationship_data} || {}},
 285                        %{$self->{_inflated_column} || {}});
 286
 287   # insert what needs to be inserted before us
 288   my %pre_insert;
 289   for my $relname (keys %related_stuff) {
 290     my $rel_obj = $related_stuff{$relname};
 291
 292     if (! $self->{_rel_in_storage}{$relname}) {
 293       next unless (Scalar::Util::blessed($rel_obj)
 294                     && $rel_obj->isa('DBIx::Class::Row'));
 295
 296       next unless $source->_pk_depends_on(
 297                     $relname, { $rel_obj->get_columns }
 298                   );
 299
 300       # The guard will save us if we blow out of this scope via die
 301       $rollback_guard ||= $source->storage->txn_scope_guard;
 302
 303       MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
 304
 305       my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
 306       my $re = $self->result_source
 307                     ->related_source($relname)
 308                     ->resultset
 309                     ->find_or_create($them);
 310
 311       %{$rel_obj} = %{$re};
 312       $self->{_rel_in_storage}{$relname} = 1;
 313     }
 314
 315     $self->set_from_related($relname, $rel_obj);
 316     delete $related_stuff{$relname};
 317   }
 318
 319   # start a transaction here if not started yet and there is more stuff
 320   # to insert after us
 321   if (keys %related_stuff) {
 322     $rollback_guard ||= $source->storage->txn_scope_guard
 323   }
 324
 325   MULTICREATE_DEBUG and do {
 326     no warnings 'uninitialized';
 327     warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
 328   };
 329   my $updated_cols = $source->storage->insert($source, { $self->get_columns });
 330   foreach my $col (keys %$updated_cols) {
 331     $self->store_column($col, $updated_cols->{$col});
 332   }
 333
 334   ## PK::Auto
 335   my @auto_pri = grep {
 336                   (not defined $self->get_column($_))
 337                     ||
 338                   (ref($self->get_column($_)) eq 'SCALAR')
 339                  } $self->primary_columns;
 340
 341   if (@auto_pri) {
 342     MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\n";
 343     my $storage = $self->result_source->storage;
 344     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
 345       unless $storage->can('last_insert_id');
 346     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
 347     $self->throw_exception( "Can't get last insert id" )
 348       unless (@ids == @auto_pri);
 349     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
 350   }
 351
 352
 353   $self->{_dirty_columns} = {};
 354   $self->{related_resultsets} = {};
 355
 356   foreach my $relname (keys %related_stuff) {
 357     my $rel_obj = $related_stuff{$relname};
 358     my @cands;
 359     if (Scalar::Util::blessed($rel_obj)
 360           && $rel_obj->isa('DBIx::Class::Row'))
 361     {
 362       @cands = ($rel_obj);
 363     }
 364     elsif (ref $rel_obj eq 'ARRAY') {
 365       @cands = @$rel_obj;
 366     }
 367
 368     if (@cands) {
 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};
 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.
 447
 448 Also takes an optional hashref of C<< column_name => value> >> pairs
 449 to update on the object first. Be aware that the hashref will be
 450 passed to C<set_inflated_columns>, which might edit it in place, so
 451 don't rely on it being the same after a call to C<update>.  If you
 452 need to preserve the hashref, it is sufficient to pass a shallow copy
 453 to C<update>, e.g. ( { %{ $href } } )
 454
 455 If the values passed or any of the column values set on the object
 456 contain scalar references, eg:
 457
 458   $row->last_modified(\'NOW()');
 459   # OR
 460   $row->update({ last_modified => \'NOW()' });
 461
 462 The update will pass the values verbatim into SQL. (See
 463 L<SQL::Abstract> docs).  The values in your Row object will NOT change
 464 as a result of the update call, if you want the object to be updated
 465 with the actual values from the database, call L</discard_changes>
 466 after the update.
 467
 468   $row->update()->discard_changes();
 469
 470 To determine before calling this method, which column values have
 471 changed and will be updated, call L</get_dirty_columns>.
 472
 473 To check if any columns will be updated, call L</is_changed>.
 474
 475 To force a column to be updated, call L</make_column_dirty> before
 476 this method.
 477
 478 =cut
 479
 480 sub update {
 481   my ($self, $upd) = @_;
 482   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 483   my $ident_cond = $self->ident_condition;
 484   $self->throw_exception("Cannot safely update a row in a PK-less table")
 485     if ! keys %$ident_cond;
 486
 487   $self->set_inflated_columns($upd) if $upd;
 488   my %to_update = $self->get_dirty_columns;
 489   return $self unless keys %to_update;
 490   my $rows = $self->result_source->storage->update(
 491                $self->result_source, \%to_update,
 492                $self->{_orig_ident} || $ident_cond
 493              );
 494   if ($rows == 0) {
 495     $self->throw_exception( "Can't update ${self}: row not found" );
 496   } elsif ($rows > 1) {
 497     $self->throw_exception("Can't update ${self}: updated more than one row");
 498   }
 499   $self->{_dirty_columns} = {};
 500   $self->{related_resultsets} = {};
 501   undef $self->{_orig_ident};
 502   return $self;
 503 }
 504
 505 =head2 delete
 506
 507   $row->delete
 508
 509 =over
 510
 511 =item Arguments: none
 512
 513 =item Returns: The Row object
 514
 515 =back
 516
 517 Throws an exception if the object is not in the database according to
 518 L</in_storage>. Runs an SQL DELETE statement using the primary key
 519 values to locate the row.
 520
 521 The object is still perfectly usable, but L</in_storage> will
 522 now return 0 and the object must be reinserted using L</insert>
 523 before it can be used to L</update> the row again.
 524
 525 If you delete an object in a class with a C<has_many> relationship, an
 526 attempt is made to delete all the related objects as well. To turn
 527 this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
 528 hashref of the relationship, see L<DBIx::Class::Relationship>. Any
 529 database-level cascade or restrict will take precedence over a
 530 DBIx-Class-based cascading delete.
 531
 532 If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
 533 and the transaction subsequently fails, the row object will remain marked as
 534 not being in storage. If you know for a fact that the object is still in
 535 storage (i.e. by inspecting the cause of the transaction's failure), you can
 536 use C<< $obj->in_storage(1) >> to restore consistency between the object and
 537 the database. This would allow a subsequent C<< $obj->delete >> to work
 538 as expected.
 539
 540 See also L<DBIx::Class::ResultSet/delete>.
 541
 542 =cut
 543
 544 sub delete {
 545   my $self = shift;
 546   if (ref $self) {
 547     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 548     my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
 549     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 550       if ! keys %$ident_cond;
 551     foreach my $column (keys %$ident_cond) {
 552             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 553               unless exists $self->{_column_data}{$column};
 554     }
 555     $self->result_source->storage->delete(
 556       $self->result_source, $ident_cond);
 557     $self->in_storage(undef);
 558   } else {
 559     $self->throw_exception("Can't do class delete without a ResultSource instance")
 560       unless $self->can('result_source_instance');
 561     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 562     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 563     $self->result_source_instance->resultset->search(@_)->delete;
 564   }
 565   return $self;
 566 }
 567
 568 =head2 get_column
 569
 570   my $val = $row->get_column($col);
 571
 572 =over
 573
 574 =item Arguments: $columnname
 575
 576 =item Returns: The value of the column
 577
 578 =back
 579
 580 Throws an exception if the column name given doesn't exist according
 581 to L</has_column>.
 582
 583 Returns a raw column value from the row object, if it has already
 584 been fetched from the database or set by an accessor.
 585
 586 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
 587 will be deflated and returned.
 588
 589 Note that if you used the C<columns> or the C<select/as>
 590 L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
 591 which C<$row> was derived, and B<did not include> C<$columnname> in the list,
 592 this method will return C<undef> even if the database contains some value.
 593
 594 To retrieve all loaded column values as a hash, use L</get_columns>.
 595
 596 =cut
 597
 598 sub get_column {
 599   my ($self, $column) = @_;
 600   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 601   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 602   if (exists $self->{_inflated_column}{$column}) {
 603     return $self->store_column($column,
 604       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 605   }
 606   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 607   return undef;
 608 }
 609
 610 =head2 has_column_loaded
 611
 612   if ( $row->has_column_loaded($col) ) {
 613      print "$col has been loaded from db";
 614   }
 615
 616 =over
 617
 618 =item Arguments: $columnname
 619
 620 =item Returns: 0|1
 621
 622 =back
 623
 624 Returns a true value if the column value has been loaded from the
 625 database (or set locally).
 626
 627 =cut
 628
 629 sub has_column_loaded {
 630   my ($self, $column) = @_;
 631   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 632   return 1 if exists $self->{_inflated_column}{$column};
 633   return exists $self->{_column_data}{$column};
 634 }
 635
 636 =head2 get_columns
 637
 638   my %data = $row->get_columns;
 639
 640 =over
 641
 642 =item Arguments: none
 643
 644 =item Returns: A hash of columnname, value pairs.
 645
 646 =back
 647
 648 Returns all loaded column data as a hash, containing raw values. To
 649 get just one value for a particular column, use L</get_column>.
 650
 651 See L</get_inflated_columns> to get the inflated values.
 652
 653 =cut
 654
 655 sub get_columns {
 656   my $self = shift;
 657   if (exists $self->{_inflated_column}) {
 658     foreach my $col (keys %{$self->{_inflated_column}}) {
 659       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 660         unless exists $self->{_column_data}{$col};
 661     }
 662   }
 663   return %{$self->{_column_data}};
 664 }
 665
 666 =head2 get_dirty_columns
 667
 668   my %data = $row->get_dirty_columns;
 669
 670 =over
 671
 672 =item Arguments: none
 673
 674 =item Returns: A hash of column, value pairs
 675
 676 =back
 677
 678 Only returns the column, value pairs for those columns that have been
 679 changed on this object since the last L</update> or L</insert> call.
 680
 681 See L</get_columns> to fetch all column/value pairs.
 682
 683 =cut
 684
 685 sub get_dirty_columns {
 686   my $self = shift;
 687   return map { $_ => $self->{_column_data}{$_} }
 688            keys %{$self->{_dirty_columns}};
 689 }
 690
 691 =head2 make_column_dirty
 692
 693   $row->make_column_dirty($col)
 694
 695 =over
 696
 697 =item Arguments: $columnname
 698
 699 =item Returns: undefined
 700
 701 =back
 702
 703 Throws an exception if the column does not exist.
 704
 705 Marks a column as having been changed regardless of whether it has
 706 really changed.
 707
 708 =cut
 709 sub make_column_dirty {
 710   my ($self, $column) = @_;
 711
 712   $self->throw_exception( "No such column '${column}'" )
 713     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 714
 715   # the entire clean/dirty code relies on exists, not on true/false
 716   return 1 if exists $self->{_dirty_columns}{$column};
 717
 718   $self->{_dirty_columns}{$column} = 1;
 719
 720   # if we are just now making the column dirty, and if there is an inflated
 721   # value, force it over the deflated one
 722   if (exists $self->{_inflated_column}{$column}) {
 723     $self->store_column($column,
 724       $self->_deflated_column(
 725         $column, $self->{_inflated_column}{$column}
 726       )
 727     );
 728   }
 729 }
 730
 731 =head2 get_inflated_columns
 732
 733   my %inflated_data = $obj->get_inflated_columns;
 734
 735 =over
 736
 737 =item Arguments: none
 738
 739 =item Returns: A hash of column, object|value pairs
 740
 741 =back
 742
 743 Returns a hash of all column keys and associated values. Values for any
 744 columns set to use inflation will be inflated and returns as objects.
 745
 746 See L</get_columns> to get the uninflated values.
 747
 748 See L<DBIx::Class::InflateColumn> for how to setup inflation.
 749
 750 =cut
 751
 752 sub get_inflated_columns {
 753   my $self = shift;
 754   return map {
 755     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 756     ($_ => $self->$accessor);
 757   } grep $self->has_column_loaded($_), $self->columns;
 758 }
 759
 760 =head2 set_column
 761
 762   $row->set_column($col => $val);
 763
 764 =over
 765
 766 =item Arguments: $columnname, $value
 767
 768 =item Returns: $value
 769
 770 =back
 771
 772 Sets a raw column value. If the new value is different from the old one,
 773 the column is marked as dirty for when you next call L</update>.
 774
 775 If passed an object or reference as a value, this method will happily
 776 attempt to store it, and a later L</insert> or L</update> will try and
 777 stringify/numify as appropriate. To set an object to be deflated
 778 instead, see L</set_inflated_columns>.
 779
 780 =cut
 781
 782 sub set_column {
 783   my ($self, $column, $new_value) = @_;
 784
 785   $self->{_orig_ident} ||= $self->ident_condition;
 786   my $old_value = $self->get_column($column);
 787
 788   $self->store_column($column, $new_value);
 789
 790   my $dirty;
 791   if (!$self->in_storage) { # no point tracking dirtyness on uninserted data
 792     $dirty = 1;
 793   }
 794   elsif (defined $old_value xor defined $new_value) {
 795     $dirty = 1;
 796   }
 797   elsif (not defined $old_value) {  # both undef
 798     $dirty = 0;
 799   }
 800   elsif ($old_value eq $new_value) {
 801     $dirty = 0;
 802   }
 803   else {  # do a numeric comparison if datatype allows it
 804     my $colinfo = $self->column_info ($column);
 805
 806     # cache for speed (the object may *not* have a resultsource instance)
 807     if (not defined $colinfo->{is_numeric} && $self->_source_handle) {
 808       $colinfo->{is_numeric} =
 809         $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type})
 810           ? 1
 811           : 0
 812         ;
 813     }
 814
 815     if ($colinfo->{is_numeric}) {
 816       $dirty = $old_value != $new_value;
 817     }
 818     else {
 819       $dirty = 1;
 820     }
 821   }
 822
 823   # sadly the update code just checks for keys, not for their value
 824   $self->{_dirty_columns}{$column} = 1 if $dirty;
 825
 826   # XXX clear out the relation cache for this column
 827   delete $self->{related_resultsets}{$column};
 828
 829   return $new_value;
 830 }
 831
 832 =head2 set_columns
 833
 834   $row->set_columns({ $col => $val, ... });
 835
 836 =over
 837
 838 =item Arguments: \%columndata
 839
 840 =item Returns: The Row object
 841
 842 =back
 843
 844 Sets multiple column, raw value pairs at once.
 845
 846 Works as L</set_column>.
 847
 848 =cut
 849
 850 sub set_columns {
 851   my ($self,$data) = @_;
 852   foreach my $col (keys %$data) {
 853     $self->set_column($col,$data->{$col});
 854   }
 855   return $self;
 856 }
 857
 858 =head2 set_inflated_columns
 859
 860   $row->set_inflated_columns({ $col => $val, $relname => $obj, ... });
 861
 862 =over
 863
 864 =item Arguments: \%columndata
 865
 866 =item Returns: The Row object
 867
 868 =back
 869
 870 Sets more than one column value at once. Any inflated values are
 871 deflated and the raw values stored.
 872
 873 Any related values passed as Row objects, using the relation name as a
 874 key, are reduced to the appropriate foreign key values and stored. If
 875 instead of related row objects, a hashref of column, value data is
 876 passed, will create the related object first then store.
 877
 878 Will even accept arrayrefs of data as a value to a
 879 L<DBIx::Class::Relationship/has_many> key, and create the related
 880 objects if necessary.
 881
 882 Be aware that the input hashref might be edited in place, so dont rely
 883 on it being the same after a call to C<set_inflated_columns>. If you
 884 need to preserve the hashref, it is sufficient to pass a shallow copy
 885 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
 886
 887 See also L<DBIx::Class::Relationship::Base/set_from_related>.
 888
 889 =cut
 890
 891 sub set_inflated_columns {
 892   my ( $self, $upd ) = @_;
 893   foreach my $key (keys %$upd) {
 894     if (ref $upd->{$key}) {
 895       my $info = $self->relationship_info($key);
 896       if ($info && $info->{attrs}{accessor}
 897         && $info->{attrs}{accessor} eq 'single')
 898       {
 899         my $rel = delete $upd->{$key};
 900         $self->set_from_related($key => $rel);
 901         $self->{_relationship_data}{$key} = $rel;
 902       } elsif ($info && $info->{attrs}{accessor}
 903         && $info->{attrs}{accessor} eq 'multi') {
 904           $self->throw_exception(
 905             "Recursive update is not supported over relationships of type multi ($key)"
 906           );
 907       }
 908       elsif ($self->has_column($key)
 909         && exists $self->column_info($key)->{_inflate_info})
 910       {
 911         $self->set_inflated_column($key, delete $upd->{$key});
 912       }
 913     }
 914   }
 915   $self->set_columns($upd);
 916 }
 917
 918 =head2 copy
 919
 920   my $copy = $orig->copy({ change => $to, ... });
 921
 922 =over
 923
 924 =item Arguments: \%replacementdata
 925
 926 =item Returns: The Row object copy
 927
 928 =back
 929
 930 Inserts a new row into the database, as a copy of the original
 931 object. If a hashref of replacement data is supplied, these will take
 932 precedence over data in the original. Also any columns which have
 933 the L<column info attribute|DBIx::Class::ResultSource/add_columns>
 934 C<< is_auto_increment => 1 >> are explicitly removed before the copy,
 935 so that the database can insert its own autoincremented values into
 936 the new object.
 937
 938 Relationships will be followed by the copy procedure B<only> if the
 939 relationship specifes a true value for its
 940 L<cascade_copy|DBIx::Class::Relationship::Base> attribute. C<cascade_copy>
 941 is set by default on C<has_many> relationships and unset on all others.
 942
 943 =cut
 944
 945 sub copy {
 946   my ($self, $changes) = @_;
 947   $changes ||= {};
 948   my $col_data = { %{$self->{_column_data}} };
 949   foreach my $col (keys %$col_data) {
 950     delete $col_data->{$col}
 951       if $self->result_source->column_info($col)->{is_auto_increment};
 952   }
 953
 954   my $new = { _column_data => $col_data };
 955   bless $new, ref $self;
 956
 957   $new->result_source($self->result_source);
 958   $new->set_inflated_columns($changes);
 959   $new->insert;
 960
 961   # Its possible we'll have 2 relations to the same Source. We need to make
 962   # sure we don't try to insert the same row twice esle we'll violate unique
 963   # constraints
 964   my $rels_copied = {};
 965
 966   foreach my $rel ($self->result_source->relationships) {
 967     my $rel_info = $self->result_source->relationship_info($rel);
 968
 969     next unless $rel_info->{attrs}{cascade_copy};
 970
 971     my $resolved = $self->result_source->_resolve_condition(
 972       $rel_info->{cond}, $rel, $new
 973     );
 974
 975     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
 976     foreach my $related ($self->search_related($rel)) {
 977       my $id_str = join("\0", $related->id);
 978       next if $copied->{$id_str};
 979       $copied->{$id_str} = 1;
 980       my $rel_copy = $related->copy($resolved);
 981     }
 982
 983   }
 984   return $new;
 985 }
 986
 987 =head2 store_column
 988
 989   $row->store_column($col => $val);
 990
 991 =over
 992
 993 =item Arguments: $columnname, $value
 994
 995 =item Returns: The value sent to storage
 996
 997 =back
 998
 999 Set a raw value for a column without marking it as changed. This
1000 method is used internally by L</set_column> which you should probably
1001 be using.
1002
1003 This is the lowest level at which data is set on a row object,
1004 extend this method to catch all data setting methods.
1005
1006 =cut
1007
1008 sub store_column {
1009   my ($self, $column, $value) = @_;
1010   $self->throw_exception( "No such column '${column}'" )
1011     unless exists $self->{_column_data}{$column} || $self->has_column($column);
1012   $self->throw_exception( "set_column called for ${column} without value" )
1013     if @_ < 3;
1014   return $self->{_column_data}{$column} = $value;
1015 }
1016
1017 =head2 inflate_result
1018
1019   Class->inflate_result($result_source, \%me, \%prefetch?)
1020
1021 =over
1022
1023 =item Arguments: $result_source, \%columndata, \%prefetcheddata
1024
1025 =item Returns: A Row object
1026
1027 =back
1028
1029 All L<DBIx::Class::ResultSet> methods that retrieve data from the
1030 database and turn it into row objects call this method.
1031
1032 Extend this method in your Result classes to hook into this process,
1033 for example to rebless the result into a different class.
1034
1035 Reblessing can also be done more easily by setting C<result_class> in
1036 your Result class. See L<DBIx::Class::ResultSource/result_class>.
1037
1038 Different types of results can also be created from a particular
1039 L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/result_class>.
1040
1041 =cut
1042
1043 sub inflate_result {
1044   my ($class, $source, $me, $prefetch) = @_;
1045
1046   my ($source_handle) = $source;
1047
1048   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
1049       $source = $source_handle->resolve
1050   } else {
1051       $source_handle = $source->handle
1052   }
1053
1054   my $new = {
1055     _source_handle => $source_handle,
1056     _column_data => $me,
1057   };
1058   bless $new, (ref $class || $class);
1059
1060   my $schema;
1061   foreach my $pre (keys %{$prefetch||{}}) {
1062     my $pre_val = $prefetch->{$pre};
1063     my $pre_source = $source->related_source($pre);
1064     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
1065       unless $pre_source;
1066     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
1067       my @pre_objects;
1068
1069       for my $me_pref (@$pre_val) {
1070
1071         # the collapser currently *could* return bogus elements with all
1072         # columns set to undef
1073         my $has_def;
1074         for (values %{$me_pref->[0]}) {
1075           if (defined $_) {
1076             $has_def++;
1077             last;
1078           }
1079         }
1080         next unless $has_def;
1081
1082         push @pre_objects, $pre_source->result_class->inflate_result(
1083           $pre_source, @$me_pref
1084         );
1085       }
1086
1087       $new->related_resultset($pre)->set_cache(\@pre_objects);
1088     } elsif (defined $pre_val->[0]) {
1089       my $fetched;
1090       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
1091          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
1092       {
1093         $fetched = $pre_source->result_class->inflate_result(
1094                       $pre_source, @{$pre_val});
1095       }
1096       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
1097       $class->throw_exception("No accessor for prefetched $pre")
1098        unless defined $accessor;
1099       if ($accessor eq 'single') {
1100         $new->{_relationship_data}{$pre} = $fetched;
1101       } elsif ($accessor eq 'filter') {
1102         $new->{_inflated_column}{$pre} = $fetched;
1103       } else {
1104        $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor '$accessor'");
1105       }
1106       $new->related_resultset($pre)->set_cache([ $fetched ]);
1107     }
1108   }
1109
1110   $new->in_storage (1);
1111   return $new;
1112 }
1113
1114 =head2 update_or_insert
1115
1116   $row->update_or_insert
1117
1118 =over
1119
1120 =item Arguments: none
1121
1122 =item Returns: Result of update or insert operation
1123
1124 =back
1125
1126 L</Update>s the object if it's already in the database, according to
1127 L</in_storage>, else L</insert>s it.
1128
1129 =head2 insert_or_update
1130
1131   $obj->insert_or_update
1132
1133 Alias for L</update_or_insert>
1134
1135 =cut
1136
1137 sub insert_or_update { shift->update_or_insert(@_) }
1138
1139 sub update_or_insert {
1140   my $self = shift;
1141   return ($self->in_storage ? $self->update : $self->insert);
1142 }
1143
1144 =head2 is_changed
1145
1146   my @changed_col_names = $row->is_changed();
1147   if ($row->is_changed()) { ... }
1148
1149 =over
1150
1151 =item Arguments: none
1152
1153 =item Returns: 0|1 or @columnnames
1154
1155 =back
1156
1157 In list context returns a list of columns with uncommited changes, or
1158 in scalar context returns a true value if there are uncommitted
1159 changes.
1160
1161 =cut
1162
1163 sub is_changed {
1164   return keys %{shift->{_dirty_columns} || {}};
1165 }
1166
1167 =head2 is_column_changed
1168
1169   if ($row->is_column_changed('col')) { ... }
1170
1171 =over
1172
1173 =item Arguments: $columname
1174
1175 =item Returns: 0|1
1176
1177 =back
1178
1179 Returns a true value if the column has uncommitted changes.
1180
1181 =cut
1182
1183 sub is_column_changed {
1184   my( $self, $col ) = @_;
1185   return exists $self->{_dirty_columns}->{$col};
1186 }
1187
1188 =head2 result_source
1189
1190   my $resultsource = $row->result_source;
1191
1192 =over
1193
1194 =item Arguments: none
1195
1196 =item Returns: a ResultSource instance
1197
1198 =back
1199
1200 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1201
1202 =cut
1203
1204 sub result_source {
1205     my $self = shift;
1206
1207     if (@_) {
1208         $self->_source_handle($_[0]->handle);
1209     } else {
1210         $self->_source_handle->resolve;
1211     }
1212 }
1213
1214 =head2 register_column
1215
1216   $column_info = { .... };
1217   $class->register_column($column_name, $column_info);
1218
1219 =over
1220
1221 =item Arguments: $columnname, \%columninfo
1222
1223 =item Returns: undefined
1224
1225 =back
1226
1227 Registers a column on the class. If the column_info has an 'accessor'
1228 key, creates an accessor named after the value if defined; if there is
1229 no such key, creates an accessor with the same name as the column
1230
1231 The column_info attributes are described in
1232 L<DBIx::Class::ResultSource/add_columns>
1233
1234 =cut
1235
1236 sub register_column {
1237   my ($class, $col, $info) = @_;
1238   my $acc = $col;
1239   if (exists $info->{accessor}) {
1240     return unless defined $info->{accessor};
1241     $acc = [ $info->{accessor}, $col ];
1242   }
1243   $class->mk_group_accessors('column' => $acc);
1244 }
1245
1246 =head2 get_from_storage
1247
1248   my $copy = $row->get_from_storage($attrs)
1249
1250 =over
1251
1252 =item Arguments: \%attrs
1253
1254 =item Returns: A Row object
1255
1256 =back
1257
1258 Fetches a fresh copy of the Row object from the database and returns it.
1259
1260 If passed the \%attrs argument, will first apply these attributes to
1261 the resultset used to find the row.
1262
1263 This copy can then be used to compare to an existing row object, to
1264 determine if any changes have been made in the database since it was
1265 created.
1266
1267 To just update your Row object with any latest changes from the
1268 database, use L</discard_changes> instead.
1269
1270 The \%attrs argument should be compatible with
1271 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1272
1273 =cut
1274
1275 sub get_from_storage {
1276     my $self = shift @_;
1277     my $attrs = shift @_;
1278     my $resultset = $self->result_source->resultset;
1279
1280     if(defined $attrs) {
1281         $resultset = $resultset->search(undef, $attrs);
1282     }
1283
1284     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1285 }
1286
1287 =head2 throw_exception
1288
1289 See L<DBIx::Class::Schema/throw_exception>.
1290
1291 =cut
1292
1293 sub throw_exception {
1294   my $self=shift;
1295   if (ref $self && ref $self->result_source && $self->result_source->schema) {
1296     $self->result_source->schema->throw_exception(@_);
1297   } else {
1298     croak(@_);
1299   }
1300 }
1301
1302 =head2 id
1303
1304   my @pk = $row->id;
1305
1306 =over
1307
1308 =item Arguments: none
1309
1310 =item Returns: A list of primary key values
1311
1312 =back
1313
1314 Returns the primary key(s) for a row. Can't be called as a class method.
1315 Actually implemented in L<DBIx::Class::PK>
1316
1317 =head2 discard_changes
1318
1319   $row->discard_changes
1320
1321 =over
1322
1323 =item Arguments: none
1324
1325 =item Returns: nothing (updates object in-place)
1326
1327 =back
1328
1329 Retrieves and sets the row object data from the database, losing any
1330 local changes made.
1331
1332 This method can also be used to refresh from storage, retrieving any
1333 changes made since the row was last read from storage. Actually
1334 implemented in L<DBIx::Class::PK>
1335
1336 Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
1337 storage, please kept in mind that if you L</discard_changes> on a row that you
1338 just updated or created, you should wrap the entire bit inside a transaction.
1339 Otherwise you run the risk that you insert or update to the master database
1340 but read from a replicant database that has not yet been updated from the
1341 master.  This will result in unexpected results.
1342
1343 =cut
1344
1345 1;
1346
1347 =head1 AUTHORS
1348
1349 Matt S. Trout <mst@shadowcatsystems.co.uk>
1350
1351 =head1 LICENSE
1352
1353 You may distribute this code under the same terms as Perl itself.
1354
1355 =cut