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