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
  10 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
  11
  12 =head1 NAME
  13
  14 DBIx::Class::Row - Basic row methods
  15
  16 =head1 SYNOPSIS
  17
  18 =head1 DESCRIPTION
  19
  20 This class is responsible for defining and doing basic operations on rows
  21 derived from L<DBIx::Class::ResultSource> objects.
  22
  23 =head1 METHODS
  24
  25 =head2 new
  26
  27   my $obj = My::Class->new($attrs);
  28
  29 Creates a new row object from column => value mappings passed as a hash ref
  30
  31 Passing an object, or an arrayref of objects as a value will call
  32 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
  33 passed a hashref or an arrayref of hashrefs as the value, these will
  34 be turned into objects via new_related, and treated as if you had
  35 passed objects.
  36
  37 =cut
  38
  39 ## 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().
  40 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
  41 ## When doing the later insert, we need to make sure the PKs are set.
  42 ## using _relationship_data in new and funky ways..
  43 ## check Relationship::CascadeActions and Relationship::Accessor for compat
  44 ## tests!
  45
  46 sub new {
  47   my ($class, $attrs) = @_;
  48   $class = ref $class if ref $class;
  49
  50   my $new = { _column_data => {} };
  51   bless $new, $class;
  52
  53   if (my $handle = delete $attrs->{-source_handle}) {
  54     $new->_source_handle($handle);
  55   }
  56   if (my $source = delete $attrs->{-result_source}) {
  57     $new->result_source($source);
  58   }
  59
  60   if ($attrs) {
  61     $new->throw_exception("attrs must be a hashref")
  62       unless ref($attrs) eq 'HASH';
  63
  64     my ($related,$inflated);
  65     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
  66     $new->{_rel_in_storage} = 1;
  67
  68     foreach my $key (keys %$attrs) {
  69       if (ref $attrs->{$key}) {
  70         ## Can we extract this lot to use with update(_or .. ) ?
  71         my $info = $class->relationship_info($key);
  72         if ($info && $info->{attrs}{accessor}
  73           && $info->{attrs}{accessor} eq 'single')
  74         {
  75           my $rel_obj = delete $attrs->{$key};
  76           if(!Scalar::Util::blessed($rel_obj)) {
  77             $rel_obj = $new->find_or_new_related($key, $rel_obj);
  78             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
  79           }
  80           $new->set_from_related($key, $rel_obj);
  81           $related->{$key} = $rel_obj;
  82           next;
  83         } elsif ($info && $info->{attrs}{accessor}
  84             && $info->{attrs}{accessor} eq 'multi'
  85             && ref $attrs->{$key} eq 'ARRAY') {
  86           my $others = delete $attrs->{$key};
  87           foreach my $rel_obj (@$others) {
  88             if(!Scalar::Util::blessed($rel_obj)) {
  89               $rel_obj = $new->new_related($key, $rel_obj);
  90               $new->{_rel_in_storage} = 0;
  91             }
  92           }
  93           $related->{$key} = $others;
  94           next;
  95         } elsif ($info && $info->{attrs}{accessor}
  96           && $info->{attrs}{accessor} eq 'filter')
  97         {
  98           ## 'filter' should disappear and get merged in with 'single' above!
  99           my $rel_obj = delete $attrs->{$key};
 100           if(!Scalar::Util::blessed($rel_obj)) {
 101             $rel_obj = $new->find_or_new_related($key, $rel_obj);
 102             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
 103           }
 104           $inflated->{$key} = $rel_obj;
 105           next;
 106         } elsif ($class->has_column($key)
 107             && $class->column_info($key)->{_inflate_info}) {
 108           $inflated->{$key} = $attrs->{$key};
 109           next;
 110         }
 111       }
 112       use Data::Dumper;
 113       $new->throw_exception("No such column $key on $class")
 114         unless $class->has_column($key);
 115       $new->store_column($key => $attrs->{$key});
 116     }
 117
 118     $new->{_relationship_data} = $related if $related;
 119     $new->{_inflated_column} = $inflated if $inflated;
 120   }
 121
 122   return $new;
 123 }
 124
 125 =head2 insert
 126
 127   $obj->insert;
 128
 129 Inserts an object into the database if it isn't already in
 130 there. Returns the object itself. Requires the object's result source to
 131 be set, or the class to have a result_source_instance method. To insert
 132 an entirely new object into the database, use C<create> (see
 133 L<DBIx::Class::ResultSet/create>).
 134
 135 =cut
 136
 137 sub insert {
 138   my ($self) = @_;
 139   return $self if $self->in_storage;
 140   my $source = $self->result_source;
 141   $source ||=  $self->result_source($self->result_source_instance)
 142     if $self->can('result_source_instance');
 143   $self->throw_exception("No result_source set on this object; can't insert")
 144     unless $source;
 145
 146   # Check if we stored uninserted relobjs here in new()
 147   my %related_stuff = (%{$self->{_relationship_data} || {}},
 148                        %{$self->{_inflated_column} || {}});
 149   if(!$self->{_rel_in_storage})
 150   {
 151     $source->storage->txn_begin;
 152
 153     ## Should all be in relationship_data, but we need to get rid of the
 154     ## 'filter' reltype..
 155     ## These are the FK rels, need their IDs for the insert.
 156     foreach my $relname (keys %related_stuff) {
 157       my $rel_obj = $related_stuff{$relname};
 158       if(Scalar::Util::blessed($rel_obj) && $rel_obj->isa('DBIx::Class::Row')) {
 159         $rel_obj->insert();
 160         $self->set_from_related($relname, $rel_obj);
 161       }
 162     }
 163   }
 164
 165   $source->storage->insert($source, { $self->get_columns });
 166
 167   ## PK::Auto
 168   my ($pri, $too_many) = grep { !defined $self->get_column($_) ||
 169                                     ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
 170   if(defined $pri) {
 171     $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
 172       if defined $too_many;
 173
 174     my $storage = $self->result_source->storage;
 175     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
 176       unless $storage->can('last_insert_id');
 177     my $id = $storage->last_insert_id($self->result_source,$pri);
 178     $self->throw_exception( "Can't get last insert id" ) unless $id;
 179     $self->store_column($pri => $id);
 180   }
 181
 182   if(!$self->{_rel_in_storage})
 183   {
 184     ## Now do the has_many rels, that need $selfs ID.
 185     foreach my $relname (keys %related_stuff) {
 186       my $relobj = $related_stuff{$relname};
 187       if(ref $relobj eq 'ARRAY') {
 188         foreach my $obj (@$relobj) {
 189           my $info = $self->relationship_info($relname);
 190           ## What about multi-col FKs ?
 191           my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
 192           $obj->set_from_related($key, $self);
 193           $obj->insert() if(!$obj->in_storage);
 194         }
 195       }
 196     }
 197     $source->storage->txn_commit;
 198   }
 199
 200   $self->in_storage(1);
 201   $self->{_dirty_columns} = {};
 202   $self->{related_resultsets} = {};
 203   undef $self->{_orig_ident};
 204   return $self;
 205 }
 206
 207 =head2 in_storage
 208
 209   $obj->in_storage; # Get value
 210   $obj->in_storage(1); # Set value
 211
 212 Indicated whether the object exists as a row in the database or not
 213
 214 =cut
 215
 216 sub in_storage {
 217   my ($self, $val) = @_;
 218   $self->{_in_storage} = $val if @_ > 1;
 219   return $self->{_in_storage};
 220 }
 221
 222 =head2 update
 223
 224   $obj->update \%columns?;
 225
 226 Must be run on an object that is already in the database; issues an SQL
 227 UPDATE query to commit any changes to the object to the database if
 228 required.
 229
 230 Also takes an options hashref of C<< column_name => value> pairs >> to update
 231 first. But be aware that this hashref might be edited in place, so dont rely on
 232 it being the same after a call to C<update>. If you need to preserve the hashref,
 233 it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
 234
 235 =cut
 236
 237 sub update {
 238   my ($self, $upd) = @_;
 239   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 240   my $ident_cond = $self->ident_condition;
 241   $self->throw_exception("Cannot safely update a row in a PK-less table")
 242     if ! keys %$ident_cond;
 243
 244   if ($upd) {
 245     foreach my $key (keys %$upd) {
 246       if (ref $upd->{$key}) {
 247         my $info = $self->relationship_info($key);
 248         if ($info && $info->{attrs}{accessor}
 249           && $info->{attrs}{accessor} eq 'single')
 250         {
 251           my $rel = delete $upd->{$key};
 252           $self->set_from_related($key => $rel);
 253           $self->{_relationship_data}{$key} = $rel;
 254         } elsif ($info && $info->{attrs}{accessor}
 255             && $info->{attrs}{accessor} eq 'multi'
 256             && ref $upd->{$key} eq 'ARRAY') {
 257             my $others = delete $upd->{$key};
 258             foreach my $rel_obj (@$others) {
 259               if(!Scalar::Util::blessed($rel_obj)) {
 260                 $rel_obj = $self->create_related($key, $rel_obj);
 261               }
 262             }
 263             $self->{_relationship_data}{$key} = $others;
 264 #            $related->{$key} = $others;
 265             next;
 266         }
 267         elsif ($self->has_column($key)
 268           && exists $self->column_info($key)->{_inflate_info})
 269         {
 270           $self->set_inflated_column($key, delete $upd->{$key});
 271         }
 272       }
 273     }
 274     $self->set_columns($upd);
 275   }
 276   my %to_update = $self->get_dirty_columns;
 277   return $self unless keys %to_update;
 278   my $rows = $self->result_source->storage->update(
 279                $self->result_source, \%to_update,
 280                $self->{_orig_ident} || $ident_cond
 281              );
 282   if ($rows == 0) {
 283     $self->throw_exception( "Can't update ${self}: row not found" );
 284   } elsif ($rows > 1) {
 285     $self->throw_exception("Can't update ${self}: updated more than one row");
 286   }
 287   $self->{_dirty_columns} = {};
 288   $self->{related_resultsets} = {};
 289   undef $self->{_orig_ident};
 290   return $self;
 291 }
 292
 293 =head2 delete
 294
 295   $obj->delete
 296
 297 Deletes the object from the database. The object is still perfectly
 298 usable, but C<< ->in_storage() >> will now return 0 and the object must
 299 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
 300 on it. If you delete an object in a class with a C<has_many>
 301 relationship, all the related objects will be deleted as well. To turn
 302 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
 303 hashref. Any database-level cascade or restrict will take precedence
 304 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 305
 306 =cut
 307
 308 sub delete {
 309   my $self = shift;
 310   if (ref $self) {
 311     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 312     my $ident_cond = $self->ident_condition;
 313     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 314       if ! keys %$ident_cond;
 315     foreach my $column (keys %$ident_cond) {
 316             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 317               unless exists $self->{_column_data}{$column};
 318     }
 319     $self->result_source->storage->delete(
 320       $self->result_source, $ident_cond);
 321     $self->in_storage(undef);
 322   } else {
 323     $self->throw_exception("Can't do class delete without a ResultSource instance")
 324       unless $self->can('result_source_instance');
 325     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 326     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 327     $self->result_source_instance->resultset->search(@_)->delete;
 328   }
 329   return $self;
 330 }
 331
 332 =head2 get_column
 333
 334   my $val = $obj->get_column($col);
 335
 336 Gets a column value from a row object. Does not do any queries; the column
 337 must have already been fetched from the database and stored in the object. If
 338 there is an inflated value stored that has not yet been deflated, it is deflated
 339 when the method is invoked.
 340
 341 =cut
 342
 343 sub get_column {
 344   my ($self, $column) = @_;
 345   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 346   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 347   if (exists $self->{_inflated_column}{$column}) {
 348     return $self->store_column($column,
 349       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 350   }
 351   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 352   return undef;
 353 }
 354
 355 =head2 has_column_loaded
 356
 357   if ( $obj->has_column_loaded($col) ) {
 358      print "$col has been loaded from db";
 359   }
 360
 361 Returns a true value if the column value has been loaded from the
 362 database (or set locally).
 363
 364 =cut
 365
 366 sub has_column_loaded {
 367   my ($self, $column) = @_;
 368   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 369   return 1 if exists $self->{_inflated_column}{$column};
 370   return exists $self->{_column_data}{$column};
 371 }
 372
 373 =head2 get_columns
 374
 375   my %data = $obj->get_columns;
 376
 377 Does C<get_column>, for all column values at once.
 378
 379 =cut
 380
 381 sub get_columns {
 382   my $self = shift;
 383   if (exists $self->{_inflated_column}) {
 384     foreach my $col (keys %{$self->{_inflated_column}}) {
 385       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 386         unless exists $self->{_column_data}{$col};
 387     }
 388   }
 389   return %{$self->{_column_data}};
 390 }
 391
 392 =head2 get_dirty_columns
 393
 394   my %data = $obj->get_dirty_columns;
 395
 396 Identical to get_columns but only returns those that have been changed.
 397
 398 =cut
 399
 400 sub get_dirty_columns {
 401   my $self = shift;
 402   return map { $_ => $self->{_column_data}{$_} }
 403            keys %{$self->{_dirty_columns}};
 404 }
 405
 406 =head2 get_inflated_columns
 407
 408   my $inflated_data = $obj->get_inflated_columns;
 409
 410 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
 411
 412 =cut
 413
 414 sub get_inflated_columns {
 415   my $self = shift;
 416   return map {
 417     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 418     ($_ => $self->$accessor);
 419   } $self->columns;
 420 }
 421
 422 =head2 set_column
 423
 424   $obj->set_column($col => $val);
 425
 426 Sets a column value. If the new value is different from the old one,
 427 the column is marked as dirty for when you next call $obj->update.
 428
 429 =cut
 430
 431 sub set_column {
 432   my $self = shift;
 433   my ($column) = @_;
 434   $self->{_orig_ident} ||= $self->ident_condition;
 435   my $old = $self->get_column($column);
 436   my $ret = $self->store_column(@_);
 437   $self->{_dirty_columns}{$column} = 1
 438     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 439   return $ret;
 440 }
 441
 442 =head2 set_columns
 443
 444   my $copy = $orig->set_columns({ $col => $val, ... });
 445
 446 Sets more than one column value at once.
 447
 448 =cut
 449
 450 sub set_columns {
 451   my ($self,$data) = @_;
 452   foreach my $col (keys %$data) {
 453     $self->set_column($col,$data->{$col});
 454   }
 455   return $self;
 456 }
 457
 458 =head2 copy
 459
 460   my $copy = $orig->copy({ change => $to, ... });
 461
 462 Inserts a new row with the specified changes.
 463
 464 =cut
 465
 466 sub copy {
 467   my ($self, $changes) = @_;
 468   $changes ||= {};
 469   my $col_data = { %{$self->{_column_data}} };
 470   foreach my $col (keys %$col_data) {
 471     delete $col_data->{$col}
 472       if $self->result_source->column_info($col)->{is_auto_increment};
 473   }
 474
 475   my $new = { _column_data => $col_data };
 476   bless $new, ref $self;
 477
 478   $new->result_source($self->result_source);
 479   $new->set_columns($changes);
 480   $new->insert;
 481   foreach my $rel ($self->result_source->relationships) {
 482     my $rel_info = $self->result_source->relationship_info($rel);
 483     if ($rel_info->{attrs}{cascade_copy}) {
 484       my $resolved = $self->result_source->resolve_condition(
 485        $rel_info->{cond}, $rel, $new);
 486       foreach my $related ($self->search_related($rel)) {
 487         $related->copy($resolved);
 488       }
 489     }
 490   }
 491   return $new;
 492 }
 493
 494 =head2 store_column
 495
 496   $obj->store_column($col => $val);
 497
 498 Sets a column value without marking it as dirty.
 499
 500 =cut
 501
 502 sub store_column {
 503   my ($self, $column, $value) = @_;
 504   $self->throw_exception( "No such column '${column}'" )
 505     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 506   $self->throw_exception( "set_column called for ${column} without value" )
 507     if @_ < 3;
 508   return $self->{_column_data}{$column} = $value;
 509 }
 510
 511 =head2 inflate_result
 512
 513   Class->inflate_result($result_source, \%me, \%prefetch?)
 514
 515 Called by ResultSet to inflate a result from storage
 516
 517 =cut
 518
 519 sub inflate_result {
 520   my ($class, $source, $me, $prefetch) = @_;
 521
 522   my ($source_handle) = $source;
 523
 524   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 525       $source = $source_handle->resolve
 526   } else {
 527       $source_handle = $source->handle
 528   }
 529
 530   my $new = {
 531     _source_handle => $source_handle,
 532     _column_data => $me,
 533     _in_storage => 1
 534   };
 535   bless $new, (ref $class || $class);
 536
 537   my $schema;
 538   foreach my $pre (keys %{$prefetch||{}}) {
 539     my $pre_val = $prefetch->{$pre};
 540     my $pre_source = $source->related_source($pre);
 541     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 542       unless $pre_source;
 543     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 544       my @pre_objects;
 545       foreach my $pre_rec (@$pre_val) {
 546         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 547            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 548           next;
 549         }
 550         push(@pre_objects, $pre_source->result_class->inflate_result(
 551                              $pre_source, @{$pre_rec}));
 552       }
 553       $new->related_resultset($pre)->set_cache(\@pre_objects);
 554     } elsif (defined $pre_val->[0]) {
 555       my $fetched;
 556       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 557          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 558       {
 559         $fetched = $pre_source->result_class->inflate_result(
 560                       $pre_source, @{$pre_val});
 561       }
 562       $new->related_resultset($pre)->set_cache([ $fetched ]);
 563       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 564       $class->throw_exception("No accessor for prefetched $pre")
 565        unless defined $accessor;
 566       if ($accessor eq 'single') {
 567         $new->{_relationship_data}{$pre} = $fetched;
 568       } elsif ($accessor eq 'filter') {
 569         $new->{_inflated_column}{$pre} = $fetched;
 570       } else {
 571        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 572       }
 573     }
 574   }
 575   return $new;
 576 }
 577
 578 =head2 update_or_insert
 579
 580   $obj->update_or_insert
 581
 582 Updates the object if it's already in the db, else inserts it.
 583
 584 =head2 insert_or_update
 585
 586   $obj->insert_or_update
 587
 588 Alias for L</update_or_insert>
 589
 590 =cut
 591
 592 *insert_or_update = \&update_or_insert;
 593 sub update_or_insert {
 594   my $self = shift;
 595   return ($self->in_storage ? $self->update : $self->insert);
 596 }
 597
 598 =head2 is_changed
 599
 600   my @changed_col_names = $obj->is_changed();
 601   if ($obj->is_changed()) { ... }
 602
 603 In array context returns a list of columns with uncommited changes, or
 604 in scalar context returns a true value if there are uncommitted
 605 changes.
 606
 607 =cut
 608
 609 sub is_changed {
 610   return keys %{shift->{_dirty_columns} || {}};
 611 }
 612
 613 =head2 is_column_changed
 614
 615   if ($obj->is_column_changed('col')) { ... }
 616
 617 Returns a true value if the column has uncommitted changes.
 618
 619 =cut
 620
 621 sub is_column_changed {
 622   my( $self, $col ) = @_;
 623   return exists $self->{_dirty_columns}->{$col};
 624 }
 625
 626 =head2 result_source
 627
 628   my $resultsource = $object->result_source;
 629
 630 Accessor to the ResultSource this object was created from
 631
 632 =cut
 633
 634 sub result_source {
 635     my $self = shift;
 636
 637     if (@_) {
 638         $self->_source_handle($_[0]->handle);
 639     } else {
 640         $self->_source_handle->resolve;
 641     }
 642 }
 643
 644 =head2 register_column
 645
 646   $column_info = { .... };
 647   $class->register_column($column_name, $column_info);
 648
 649 Registers a column on the class. If the column_info has an 'accessor'
 650 key, creates an accessor named after the value if defined; if there is
 651 no such key, creates an accessor with the same name as the column
 652
 653 The column_info attributes are described in
 654 L<DBIx::Class::ResultSource/add_columns>
 655
 656 =cut
 657
 658 sub register_column {
 659   my ($class, $col, $info) = @_;
 660   my $acc = $col;
 661   if (exists $info->{accessor}) {
 662     return unless defined $info->{accessor};
 663     $acc = [ $info->{accessor}, $col ];
 664   }
 665   $class->mk_group_accessors('column' => $acc);
 666 }
 667
 668
 669 =head2 throw_exception
 670
 671 See Schema's throw_exception.
 672
 673 =cut
 674
 675 sub throw_exception {
 676   my $self=shift;
 677   if (ref $self && ref $self->result_source) {
 678     $self->result_source->schema->throw_exception(@_);
 679   } else {
 680     croak(@_);
 681   }
 682 }
 683
 684 1;
 685
 686 =head1 AUTHORS
 687
 688 Matt S. Trout <mst@shadowcatsystems.co.uk>
 689
 690 =head1 LICENSE
 691
 692 You may distribute this code under the same terms as Perl itself.
 693
 694 =cut