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