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