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