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