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