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