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