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