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>.
 233
 234 =cut
 235
 236 sub update {
 237   my ($self, $upd) = @_;
 238   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 239   my $ident_cond = $self->ident_condition;
 240   $self->throw_exception("Cannot safely update a row in a PK-less table")
 241     if ! keys %$ident_cond;
 242
 243   if ($upd) {
 244     foreach my $key (keys %$upd) {
 245       if (ref $upd->{$key}) {
 246         my $info = $self->relationship_info($key);
 247         if ($info && $info->{attrs}{accessor}
 248           && $info->{attrs}{accessor} eq 'single')
 249         {
 250           my $rel = delete $upd->{$key};
 251           $self->set_from_related($key => $rel);
 252           $self->{_relationship_data}{$key} = $rel;
 253         } elsif ($info && $info->{attrs}{accessor}
 254             && $info->{attrs}{accessor} eq 'multi'
 255             && ref $upd->{$key} eq 'ARRAY') {
 256             my $others = delete $upd->{$key};
 257             foreach my $rel_obj (@$others) {
 258               if(!Scalar::Util::blessed($rel_obj)) {
 259                 $rel_obj = $self->create_related($key, $rel_obj);
 260               }
 261             }
 262             $self->{_relationship_data}{$key} = $others;
 263 #            $related->{$key} = $others;
 264             next;
 265         }
 266         elsif ($self->has_column($key)
 267           && exists $self->column_info($key)->{_inflate_info})
 268         {
 269           $self->set_inflated_column($key, delete $upd->{$key});
 270         }
 271       }
 272     }
 273     $self->set_columns($upd);
 274   }
 275   my %to_update = $self->get_dirty_columns;
 276   return $self unless keys %to_update;
 277   my $rows = $self->result_source->storage->update(
 278                $self->result_source, \%to_update,
 279                $self->{_orig_ident} || $ident_cond
 280              );
 281   if ($rows == 0) {
 282     $self->throw_exception( "Can't update ${self}: row not found" );
 283   } elsif ($rows > 1) {
 284     $self->throw_exception("Can't update ${self}: updated more than one row");
 285   }
 286   $self->{_dirty_columns} = {};
 287   $self->{related_resultsets} = {};
 288   undef $self->{_orig_ident};
 289   return $self;
 290 }
 291
 292 =head2 delete
 293
 294   $obj->delete
 295
 296 Deletes the object from the database. The object is still perfectly
 297 usable, but C<< ->in_storage() >> will now return 0 and the object must
 298 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
 299 on it. If you delete an object in a class with a C<has_many>
 300 relationship, all the related objects will be deleted as well. To turn
 301 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
 302 hashref. Any database-level cascade or restrict will take precedence
 303 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 304
 305 =cut
 306
 307 sub delete {
 308   my $self = shift;
 309   if (ref $self) {
 310     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 311     my $ident_cond = $self->ident_condition;
 312     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 313       if ! keys %$ident_cond;
 314     foreach my $column (keys %$ident_cond) {
 315             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 316               unless exists $self->{_column_data}{$column};
 317     }
 318     $self->result_source->storage->delete(
 319       $self->result_source, $ident_cond);
 320     $self->in_storage(undef);
 321   } else {
 322     $self->throw_exception("Can't do class delete without a ResultSource instance")
 323       unless $self->can('result_source_instance');
 324     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 325     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 326     $self->result_source_instance->resultset->search(@_)->delete;
 327   }
 328   return $self;
 329 }
 330
 331 =head2 get_column
 332
 333   my $val = $obj->get_column($col);
 334
 335 Gets a column value from a row object. Does not do any queries; the column
 336 must have already been fetched from the database and stored in the object. If
 337 there is an inflated value stored that has not yet been deflated, it is deflated
 338 when the method is invoked.
 339
 340 =cut
 341
 342 sub get_column {
 343   my ($self, $column) = @_;
 344   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 345   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 346   if (exists $self->{_inflated_column}{$column}) {
 347     return $self->store_column($column,
 348       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 349   }
 350   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 351   return undef;
 352 }
 353
 354 =head2 has_column_loaded
 355
 356   if ( $obj->has_column_loaded($col) ) {
 357      print "$col has been loaded from db";
 358   }
 359
 360 Returns a true value if the column value has been loaded from the
 361 database (or set locally).
 362
 363 =cut
 364
 365 sub has_column_loaded {
 366   my ($self, $column) = @_;
 367   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 368   return 1 if exists $self->{_inflated_column}{$column};
 369   return exists $self->{_column_data}{$column};
 370 }
 371
 372 =head2 get_columns
 373
 374   my %data = $obj->get_columns;
 375
 376 Does C<get_column>, for all column values at once.
 377
 378 =cut
 379
 380 sub get_columns {
 381   my $self = shift;
 382   if (exists $self->{_inflated_column}) {
 383     foreach my $col (keys %{$self->{_inflated_column}}) {
 384       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 385         unless exists $self->{_column_data}{$col};
 386     }
 387   }
 388   return %{$self->{_column_data}};
 389 }
 390
 391 =head2 get_dirty_columns
 392
 393   my %data = $obj->get_dirty_columns;
 394
 395 Identical to get_columns but only returns those that have been changed.
 396
 397 =cut
 398
 399 sub get_dirty_columns {
 400   my $self = shift;
 401   return map { $_ => $self->{_column_data}{$_} }
 402            keys %{$self->{_dirty_columns}};
 403 }
 404
 405 =head2 set_column
 406
 407   $obj->set_column($col => $val);
 408
 409 Sets a column value. If the new value is different from the old one,
 410 the column is marked as dirty for when you next call $obj->update.
 411
 412 =cut
 413
 414 sub set_column {
 415   my $self = shift;
 416   my ($column) = @_;
 417   $self->{_orig_ident} ||= $self->ident_condition;
 418   my $old = $self->get_column($column);
 419   my $ret = $self->store_column(@_);
 420   $self->{_dirty_columns}{$column} = 1
 421     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 422   return $ret;
 423 }
 424
 425 =head2 set_columns
 426
 427   my $copy = $orig->set_columns({ $col => $val, ... });
 428
 429 Sets more than one column value at once.
 430
 431 =cut
 432
 433 sub set_columns {
 434   my ($self,$data) = @_;
 435   foreach my $col (keys %$data) {
 436     $self->set_column($col,$data->{$col});
 437   }
 438   return $self;
 439 }
 440
 441 =head2 copy
 442
 443   my $copy = $orig->copy({ change => $to, ... });
 444
 445 Inserts a new row with the specified changes.
 446
 447 =cut
 448
 449 sub copy {
 450   my ($self, $changes) = @_;
 451   $changes ||= {};
 452   my $col_data = { %{$self->{_column_data}} };
 453   foreach my $col (keys %$col_data) {
 454     delete $col_data->{$col}
 455       if $self->result_source->column_info($col)->{is_auto_increment};
 456   }
 457
 458   my $new = { _column_data => $col_data };
 459   bless $new, ref $self;
 460
 461   $new->result_source($self->result_source);
 462   $new->set_columns($changes);
 463   $new->insert;
 464   foreach my $rel ($self->result_source->relationships) {
 465     my $rel_info = $self->result_source->relationship_info($rel);
 466     if ($rel_info->{attrs}{cascade_copy}) {
 467       my $resolved = $self->result_source->resolve_condition(
 468        $rel_info->{cond}, $rel, $new);
 469       foreach my $related ($self->search_related($rel)) {
 470         $related->copy($resolved);
 471       }
 472     }
 473   }
 474   return $new;
 475 }
 476
 477 =head2 store_column
 478
 479   $obj->store_column($col => $val);
 480
 481 Sets a column value without marking it as dirty.
 482
 483 =cut
 484
 485 sub store_column {
 486   my ($self, $column, $value) = @_;
 487   $self->throw_exception( "No such column '${column}'" )
 488     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 489   $self->throw_exception( "set_column called for ${column} without value" )
 490     if @_ < 3;
 491   return $self->{_column_data}{$column} = $value;
 492 }
 493
 494 =head2 inflate_result
 495
 496   Class->inflate_result($result_source, \%me, \%prefetch?)
 497
 498 Called by ResultSet to inflate a result from storage
 499
 500 =cut
 501
 502 sub inflate_result {
 503   my ($class, $source, $me, $prefetch) = @_;
 504
 505   my ($source_handle) = $source;
 506
 507   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 508       $source = $source_handle->resolve
 509   } else {
 510       $source_handle = $source->handle
 511   }
 512
 513   my $new = {
 514     _source_handle => $source_handle,
 515     _column_data => $me,
 516     _in_storage => 1
 517   };
 518   bless $new, (ref $class || $class);
 519
 520   my $schema;
 521   foreach my $pre (keys %{$prefetch||{}}) {
 522     my $pre_val = $prefetch->{$pre};
 523     my $pre_source = $source->related_source($pre);
 524     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 525       unless $pre_source;
 526     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 527       my @pre_objects;
 528       foreach my $pre_rec (@$pre_val) {
 529         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 530            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 531           next;
 532         }
 533         push(@pre_objects, $pre_source->result_class->inflate_result(
 534                              $pre_source, @{$pre_rec}));
 535       }
 536       $new->related_resultset($pre)->set_cache(\@pre_objects);
 537     } elsif (defined $pre_val->[0]) {
 538       my $fetched;
 539       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 540          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 541       {
 542         $fetched = $pre_source->result_class->inflate_result(
 543                       $pre_source, @{$pre_val});
 544       }
 545       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 546       $class->throw_exception("No accessor for prefetched $pre")
 547        unless defined $accessor;
 548       if ($accessor eq 'single') {
 549         $new->{_relationship_data}{$pre} = $fetched;
 550       } elsif ($accessor eq 'filter') {
 551         $new->{_inflated_column}{$pre} = $fetched;
 552       } else {
 553        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 554       }
 555     }
 556   }
 557   return $new;
 558 }
 559
 560 =head2 update_or_insert
 561
 562   $obj->update_or_insert
 563
 564 Updates the object if it's already in the db, else inserts it.
 565
 566 =head2 insert_or_update
 567
 568   $obj->insert_or_update
 569
 570 Alias for L</update_or_insert>
 571
 572 =cut
 573
 574 *insert_or_update = \&update_or_insert;
 575 sub update_or_insert {
 576   my $self = shift;
 577   return ($self->in_storage ? $self->update : $self->insert);
 578 }
 579
 580 =head2 is_changed
 581
 582   my @changed_col_names = $obj->is_changed();
 583   if ($obj->is_changed()) { ... }
 584
 585 In array context returns a list of columns with uncommited changes, or
 586 in scalar context returns a true value if there are uncommitted
 587 changes.
 588
 589 =cut
 590
 591 sub is_changed {
 592   return keys %{shift->{_dirty_columns} || {}};
 593 }
 594
 595 =head2 is_column_changed
 596
 597   if ($obj->is_column_changed('col')) { ... }
 598
 599 Returns a true value if the column has uncommitted changes.
 600
 601 =cut
 602
 603 sub is_column_changed {
 604   my( $self, $col ) = @_;
 605   return exists $self->{_dirty_columns}->{$col};
 606 }
 607
 608 =head2 result_source
 609
 610   my $resultsource = $object->result_source;
 611
 612 Accessor to the ResultSource this object was created from
 613
 614 =cut
 615
 616 sub result_source {
 617     my $self = shift;
 618
 619     if (@_) {
 620         $self->_source_handle($_[0]->handle);
 621     } else {
 622         $self->_source_handle->resolve;
 623     }
 624 }
 625
 626 =head2 register_column
 627
 628   $column_info = { .... };
 629   $class->register_column($column_name, $column_info);
 630
 631 Registers a column on the class. If the column_info has an 'accessor'
 632 key, creates an accessor named after the value if defined; if there is
 633 no such key, creates an accessor with the same name as the column
 634
 635 The column_info attributes are described in
 636 L<DBIx::Class::ResultSource/add_columns>
 637
 638 =cut
 639
 640 sub register_column {
 641   my ($class, $col, $info) = @_;
 642   my $acc = $col;
 643   if (exists $info->{accessor}) {
 644     return unless defined $info->{accessor};
 645     $acc = [ $info->{accessor}, $col ];
 646   }
 647   $class->mk_group_accessors('column' => $acc);
 648 }
 649
 650
 651 =head2 throw_exception
 652
 653 See Schema's throw_exception.
 654
 655 =cut
 656
 657 sub throw_exception {
 658   my $self=shift;
 659   if (ref $self && ref $self->result_source) {
 660     $self->result_source->schema->throw_exception(@_);
 661   } else {
 662     croak(@_);
 663   }
 664 }
 665
 666 1;
 667
 668 =head1 AUTHORS
 669
 670 Matt S. Trout <mst@shadowcatsystems.co.uk>
 671
 672 =head1 LICENSE
 673
 674 You may distribute this code under the same terms as Perl itself.
 675
 676 =cut