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