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 get_inflated_columns
 406
 407   my $inflated_data = $obj->get_inflated_columns;
 408
 409 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
 410
 411 =cut
 412
 413 sub get_inflated_columns {
 414   my $self = shift;
 415   return map {
 416     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 417     ($_ => $self->$accessor);
 418   } $self->columns;
 419 }
 420
 421 =head2 set_column
 422
 423   $obj->set_column($col => $val);
 424
 425 Sets a column value. If the new value is different from the old one,
 426 the column is marked as dirty for when you next call $obj->update.
 427
 428 =cut
 429
 430 sub set_column {
 431   my $self = shift;
 432   my ($column) = @_;
 433   $self->{_orig_ident} ||= $self->ident_condition;
 434   my $old = $self->get_column($column);
 435   my $ret = $self->store_column(@_);
 436   $self->{_dirty_columns}{$column} = 1
 437     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 438   return $ret;
 439 }
 440
 441 =head2 set_columns
 442
 443   my $copy = $orig->set_columns({ $col => $val, ... });
 444
 445 Sets more than one column value at once.
 446
 447 =cut
 448
 449 sub set_columns {
 450   my ($self,$data) = @_;
 451   foreach my $col (keys %$data) {
 452     $self->set_column($col,$data->{$col});
 453   }
 454   return $self;
 455 }
 456
 457 =head2 copy
 458
 459   my $copy = $orig->copy({ change => $to, ... });
 460
 461 Inserts a new row with the specified changes.
 462
 463 =cut
 464
 465 sub copy {
 466   my ($self, $changes) = @_;
 467   $changes ||= {};
 468   my $col_data = { %{$self->{_column_data}} };
 469   foreach my $col (keys %$col_data) {
 470     delete $col_data->{$col}
 471       if $self->result_source->column_info($col)->{is_auto_increment};
 472   }
 473
 474   my $new = { _column_data => $col_data };
 475   bless $new, ref $self;
 476
 477   $new->result_source($self->result_source);
 478   $new->set_columns($changes);
 479   $new->insert;
 480   foreach my $rel ($self->result_source->relationships) {
 481     my $rel_info = $self->result_source->relationship_info($rel);
 482     if ($rel_info->{attrs}{cascade_copy}) {
 483       my $resolved = $self->result_source->resolve_condition(
 484        $rel_info->{cond}, $rel, $new);
 485       foreach my $related ($self->search_related($rel)) {
 486         $related->copy($resolved);
 487       }
 488     }
 489   }
 490   return $new;
 491 }
 492
 493 =head2 store_column
 494
 495   $obj->store_column($col => $val);
 496
 497 Sets a column value without marking it as dirty.
 498
 499 =cut
 500
 501 sub store_column {
 502   my ($self, $column, $value) = @_;
 503   $self->throw_exception( "No such column '${column}'" )
 504     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 505   $self->throw_exception( "set_column called for ${column} without value" )
 506     if @_ < 3;
 507   return $self->{_column_data}{$column} = $value;
 508 }
 509
 510 =head2 inflate_result
 511
 512   Class->inflate_result($result_source, \%me, \%prefetch?)
 513
 514 Called by ResultSet to inflate a result from storage
 515
 516 =cut
 517
 518 sub inflate_result {
 519   my ($class, $source, $me, $prefetch) = @_;
 520
 521   my ($source_handle) = $source;
 522
 523   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 524       $source = $source_handle->resolve
 525   } else {
 526       $source_handle = $source->handle
 527   }
 528
 529   my $new = {
 530     _source_handle => $source_handle,
 531     _column_data => $me,
 532     _in_storage => 1
 533   };
 534   bless $new, (ref $class || $class);
 535
 536   my $schema;
 537   foreach my $pre (keys %{$prefetch||{}}) {
 538     my $pre_val = $prefetch->{$pre};
 539     my $pre_source = $source->related_source($pre);
 540     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 541       unless $pre_source;
 542     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 543       my @pre_objects;
 544       foreach my $pre_rec (@$pre_val) {
 545         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 546            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 547           next;
 548         }
 549         push(@pre_objects, $pre_source->result_class->inflate_result(
 550                              $pre_source, @{$pre_rec}));
 551       }
 552       $new->related_resultset($pre)->set_cache(\@pre_objects);
 553     } elsif (defined $pre_val->[0]) {
 554       my $fetched;
 555       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 556          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 557       {
 558         $fetched = $pre_source->result_class->inflate_result(
 559                       $pre_source, @{$pre_val});
 560       }
 561       $new->related_resultset($pre)->set_cache([ $fetched ]);
 562       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 563       $class->throw_exception("No accessor for prefetched $pre")
 564        unless defined $accessor;
 565       if ($accessor eq 'single') {
 566         $new->{_relationship_data}{$pre} = $fetched;
 567       } elsif ($accessor eq 'filter') {
 568         $new->{_inflated_column}{$pre} = $fetched;
 569       } else {
 570        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 571       }
 572     }
 573   }
 574   return $new;
 575 }
 576
 577 =head2 update_or_insert
 578
 579   $obj->update_or_insert
 580
 581 Updates the object if it's already in the db, else inserts it.
 582
 583 =head2 insert_or_update
 584
 585   $obj->insert_or_update
 586
 587 Alias for L</update_or_insert>
 588
 589 =cut
 590
 591 *insert_or_update = \&update_or_insert;
 592 sub update_or_insert {
 593   my $self = shift;
 594   return ($self->in_storage ? $self->update : $self->insert);
 595 }
 596
 597 =head2 is_changed
 598
 599   my @changed_col_names = $obj->is_changed();
 600   if ($obj->is_changed()) { ... }
 601
 602 In array context returns a list of columns with uncommited changes, or
 603 in scalar context returns a true value if there are uncommitted
 604 changes.
 605
 606 =cut
 607
 608 sub is_changed {
 609   return keys %{shift->{_dirty_columns} || {}};
 610 }
 611
 612 =head2 is_column_changed
 613
 614   if ($obj->is_column_changed('col')) { ... }
 615
 616 Returns a true value if the column has uncommitted changes.
 617
 618 =cut
 619
 620 sub is_column_changed {
 621   my( $self, $col ) = @_;
 622   return exists $self->{_dirty_columns}->{$col};
 623 }
 624
 625 =head2 result_source
 626
 627   my $resultsource = $object->result_source;
 628
 629 Accessor to the ResultSource this object was created from
 630
 631 =cut
 632
 633 sub result_source {
 634     my $self = shift;
 635
 636     if (@_) {
 637         $self->_source_handle($_[0]->handle);
 638     } else {
 639         $self->_source_handle->resolve;
 640     }
 641 }
 642
 643 =head2 register_column
 644
 645   $column_info = { .... };
 646   $class->register_column($column_name, $column_info);
 647
 648 Registers a column on the class. If the column_info has an 'accessor'
 649 key, creates an accessor named after the value if defined; if there is
 650 no such key, creates an accessor with the same name as the column
 651
 652 The column_info attributes are described in
 653 L<DBIx::Class::ResultSource/add_columns>
 654
 655 =cut
 656
 657 sub register_column {
 658   my ($class, $col, $info) = @_;
 659   my $acc = $col;
 660   if (exists $info->{accessor}) {
 661     return unless defined $info->{accessor};
 662     $acc = [ $info->{accessor}, $col ];
 663   }
 664   $class->mk_group_accessors('column' => $acc);
 665 }
 666
 667
 668 =head2 throw_exception
 669
 670 See Schema's throw_exception.
 671
 672 =cut
 673
 674 sub throw_exception {
 675   my $self=shift;
 676   if (ref $self && ref $self->result_source) {
 677     $self->result_source->schema->throw_exception(@_);
 678   } else {
 679     croak(@_);
 680   }
 681 }
 682
 683 1;
 684
 685 =head1 AUTHORS
 686
 687 Matt S. Trout <mst@shadowcatsystems.co.uk>
 688
 689 =head1 LICENSE
 690
 691 You may distribute this code under the same terms as Perl itself.
 692
 693 =cut