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
   9 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
  10
  11 =head1 NAME
  12
  13 DBIx::Class::Row - Basic row methods
  14
  15 =head1 SYNOPSIS
  16
  17 =head1 DESCRIPTION
  18
  19 This class is responsible for defining and doing basic operations on rows
  20 derived from L<DBIx::Class::ResultSource> objects.
  21
  22 =head1 METHODS
  23
  24 =head2 new
  25
  26   my $obj = My::Class->new($attrs);
  27
  28 Creates a new row object from column => value mappings passed as a hash ref
  29
  30 =cut
  31
  32 sub new {
  33   my ($class, $attrs) = @_;
  34   $class = ref $class if ref $class;
  35
  36   my $new = { _column_data => {} };
  37   bless $new, $class;
  38
  39   if (my $handle = delete $attrs->{-source_handle}) {
  40     $new->_source_handle($handle);
  41   }
  42   if (my $source = delete $attrs->{-result_source}) {
  43     $new->result_source($source);
  44   }
  45
  46   if ($attrs) {
  47     $new->throw_exception("attrs must be a hashref")
  48       unless ref($attrs) eq 'HASH';
  49
  50     my ($related,$inflated);
  51     foreach my $key (keys %$attrs) {
  52       if (ref $attrs->{$key}) {
  53         my $info = $class->relationship_info($key);
  54         if ($info && $info->{attrs}{accessor}
  55           && $info->{attrs}{accessor} eq 'single')
  56         {
  57           $new->set_from_related($key, $attrs->{$key});
  58           $related->{$key} = $attrs->{$key};
  59           next;
  60         }
  61         elsif ($class->has_column($key)
  62           && exists $class->column_info($key)->{_inflate_info})
  63         {
  64           $inflated->{$key} = $attrs->{$key};
  65           next;
  66         }
  67       }
  68       $new->throw_exception("No such column $key on $class")
  69         unless $class->has_column($key);
  70       $new->store_column($key => $attrs->{$key});
  71     }
  72
  73     $new->{_relationship_data} = $related if $related;
  74     $new->{_inflated_column} = $inflated if $inflated;
  75   }
  76
  77   return $new;
  78 }
  79
  80 =head2 insert
  81
  82   $obj->insert;
  83
  84 Inserts an object into the database if it isn't already in
  85 there. Returns the object itself. Requires the object's result source to
  86 be set, or the class to have a result_source_instance method. To insert
  87 an entirely new object into the database, use C<create> (see
  88 L<DBIx::Class::ResultSet/create>).
  89
  90 =cut
  91
  92 sub insert {
  93   my ($self) = @_;
  94   return $self if $self->in_storage;
  95   my $source = $self->result_source;
  96   $source ||=  $self->result_source($self->result_source_instance)
  97     if $self->can('result_source_instance');
  98   $self->throw_exception("No result_source set on this object; can't insert")
  99     unless $source;
 100
 101   $source->storage->insert($source, { $self->get_columns });
 102   $self->in_storage(1);
 103   $self->{_dirty_columns} = {};
 104   $self->{related_resultsets} = {};
 105   undef $self->{_orig_ident};
 106   return $self;
 107 }
 108
 109 =head2 in_storage
 110
 111   $obj->in_storage; # Get value
 112   $obj->in_storage(1); # Set value
 113
 114 Indicated whether the object exists as a row in the database or not
 115
 116 =cut
 117
 118 sub in_storage {
 119   my ($self, $val) = @_;
 120   $self->{_in_storage} = $val if @_ > 1;
 121   return $self->{_in_storage};
 122 }
 123
 124 =head2 update
 125
 126   $obj->update \%columns?;
 127
 128 Must be run on an object that is already in the database; issues an SQL
 129 UPDATE query to commit any changes to the object to the database if
 130 required.
 131
 132 Also takes an options hashref of C<< column_name => value> pairs >> to update
 133 first. But be aware that this hashref might be edited in place, so dont rely on
 134 it being the same after a call to C<update>.
 135
 136 =cut
 137
 138 sub update {
 139   my ($self, $upd) = @_;
 140   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 141   my $ident_cond = $self->ident_condition;
 142   $self->throw_exception("Cannot safely update a row in a PK-less table")
 143     if ! keys %$ident_cond;
 144
 145   if ($upd) {
 146     foreach my $key (keys %$upd) {
 147       if (ref $upd->{$key}) {
 148         my $info = $self->relationship_info($key);
 149         if ($info && $info->{attrs}{accessor}
 150           && $info->{attrs}{accessor} eq 'single')
 151         {
 152           my $rel = delete $upd->{$key};
 153           $self->set_from_related($key => $rel);
 154           $self->{_relationship_data}{$key} = $rel;
 155         }
 156         elsif ($self->has_column($key)
 157           && exists $self->column_info($key)->{_inflate_info})
 158         {
 159           $self->set_inflated_column($key, delete $upd->{$key});
 160         }
 161       }
 162     }
 163     $self->set_columns($upd);
 164   }
 165   my %to_update = $self->get_dirty_columns;
 166   return $self unless keys %to_update;
 167   my $rows = $self->result_source->storage->update(
 168                $self->result_source, \%to_update,
 169                $self->{_orig_ident} || $ident_cond
 170              );
 171   if ($rows == 0) {
 172     $self->throw_exception( "Can't update ${self}: row not found" );
 173   } elsif ($rows > 1) {
 174     $self->throw_exception("Can't update ${self}: updated more than one row");
 175   }
 176   $self->{_dirty_columns} = {};
 177   $self->{related_resultsets} = {};
 178   undef $self->{_orig_ident};
 179   return $self;
 180 }
 181
 182 =head2 delete
 183
 184   $obj->delete
 185
 186 Deletes the object from the database. The object is still perfectly
 187 usable, but C<< ->in_storage() >> will now return 0 and the object must
 188 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
 189 on it. If you delete an object in a class with a C<has_many>
 190 relationship, all the related objects will be deleted as well. To turn
 191 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
 192 hashref. Any database-level cascade or restrict will take precedence
 193 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 194
 195 =cut
 196
 197 sub delete {
 198   my $self = shift;
 199   if (ref $self) {
 200     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 201     my $ident_cond = $self->ident_condition;
 202     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 203       if ! keys %$ident_cond;
 204     foreach my $column (keys %$ident_cond) {
 205             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 206               unless exists $self->{_column_data}{$column};
 207     }
 208     $self->result_source->storage->delete(
 209       $self->result_source, $ident_cond);
 210     $self->in_storage(undef);
 211   } else {
 212     $self->throw_exception("Can't do class delete without a ResultSource instance")
 213       unless $self->can('result_source_instance');
 214     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 215     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 216     $self->result_source_instance->resultset->search(@_)->delete;
 217   }
 218   return $self;
 219 }
 220
 221 =head2 get_column
 222
 223   my $val = $obj->get_column($col);
 224
 225 Gets a column value from a row object. Does not do any queries; the column
 226 must have already been fetched from the database and stored in the object. If
 227 there is an inflated value stored that has not yet been deflated, it is deflated
 228 when the method is invoked.
 229
 230 =cut
 231
 232 sub get_column {
 233   my ($self, $column) = @_;
 234   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 235   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 236   if (exists $self->{_inflated_column}{$column}) {
 237     return $self->store_column($column,
 238       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
 239   }
 240   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 241   return undef;
 242 }
 243
 244 =head2 has_column_loaded
 245
 246   if ( $obj->has_column_loaded($col) ) {
 247      print "$col has been loaded from db";
 248   }
 249
 250 Returns a true value if the column value has been loaded from the
 251 database (or set locally).
 252
 253 =cut
 254
 255 sub has_column_loaded {
 256   my ($self, $column) = @_;
 257   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 258   return 1 if exists $self->{_inflated_column}{$column};
 259   return exists $self->{_column_data}{$column};
 260 }
 261
 262 =head2 get_columns
 263
 264   my %data = $obj->get_columns;
 265
 266 Does C<get_column>, for all column values at once.
 267
 268 =cut
 269
 270 sub get_columns {
 271   my $self = shift;
 272   if (exists $self->{_inflated_column}) {
 273     foreach my $col (keys %{$self->{_inflated_column}}) {
 274       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
 275         unless exists $self->{_column_data}{$col};
 276     }
 277   }
 278   return %{$self->{_column_data}};
 279 }
 280
 281 =head2 get_dirty_columns
 282
 283   my %data = $obj->get_dirty_columns;
 284
 285 Identical to get_columns but only returns those that have been changed.
 286
 287 =cut
 288
 289 sub get_dirty_columns {
 290   my $self = shift;
 291   return map { $_ => $self->{_column_data}{$_} }
 292            keys %{$self->{_dirty_columns}};
 293 }
 294
 295 =head2 get_inflated_columns
 296
 297   my $inflated_data = $obj->get_inflated_columns;
 298
 299 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
 300
 301 =cut
 302
 303 sub get_inflated_columns {
 304   my $self = shift;
 305   return map {
 306     my $accessor = $self->column_info($_)->{'accessor'} || $_;
 307     ($_ => $self->$accessor);
 308   } $self->columns;
 309 }
 310
 311 =head2 set_column
 312
 313   $obj->set_column($col => $val);
 314
 315 Sets a column value. If the new value is different from the old one,
 316 the column is marked as dirty for when you next call $obj->update.
 317
 318 =cut
 319
 320 sub set_column {
 321   my $self = shift;
 322   my ($column) = @_;
 323   $self->{_orig_ident} ||= $self->ident_condition;
 324   my $old = $self->get_column($column);
 325   my $ret = $self->store_column(@_);
 326   $self->{_dirty_columns}{$column} = 1
 327     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 328   return $ret;
 329 }
 330
 331 =head2 set_columns
 332
 333   my $copy = $orig->set_columns({ $col => $val, ... });
 334
 335 Sets more than one column value at once.
 336
 337 =cut
 338
 339 sub set_columns {
 340   my ($self,$data) = @_;
 341   foreach my $col (keys %$data) {
 342     $self->set_column($col,$data->{$col});
 343   }
 344   return $self;
 345 }
 346
 347 =head2 copy
 348
 349   my $copy = $orig->copy({ change => $to, ... });
 350
 351 Inserts a new row with the specified changes.
 352
 353 =cut
 354
 355 sub copy {
 356   my ($self, $changes) = @_;
 357   $changes ||= {};
 358   my $col_data = { %{$self->{_column_data}} };
 359   foreach my $col (keys %$col_data) {
 360     delete $col_data->{$col}
 361       if $self->result_source->column_info($col)->{is_auto_increment};
 362   }
 363
 364   my $new = { _column_data => $col_data };
 365   bless $new, ref $self;
 366
 367   $new->result_source($self->result_source);
 368   $new->set_columns($changes);
 369   $new->insert;
 370   foreach my $rel ($self->result_source->relationships) {
 371     my $rel_info = $self->result_source->relationship_info($rel);
 372     if ($rel_info->{attrs}{cascade_copy}) {
 373       my $resolved = $self->result_source->resolve_condition(
 374        $rel_info->{cond}, $rel, $new);
 375       foreach my $related ($self->search_related($rel)) {
 376         $related->copy($resolved);
 377       }
 378     }
 379   }
 380   return $new;
 381 }
 382
 383 =head2 store_column
 384
 385   $obj->store_column($col => $val);
 386
 387 Sets a column value without marking it as dirty.
 388
 389 =cut
 390
 391 sub store_column {
 392   my ($self, $column, $value) = @_;
 393   $self->throw_exception( "No such column '${column}'" )
 394     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 395   $self->throw_exception( "set_column called for ${column} without value" )
 396     if @_ < 3;
 397   return $self->{_column_data}{$column} = $value;
 398 }
 399
 400 =head2 inflate_result
 401
 402   Class->inflate_result($result_source, \%me, \%prefetch?)
 403
 404 Called by ResultSet to inflate a result from storage
 405
 406 =cut
 407
 408 sub inflate_result {
 409   my ($class, $source, $me, $prefetch) = @_;
 410
 411   my ($source_handle) = $source;
 412
 413   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 414       $source = $source_handle->resolve
 415   } else {
 416       $source_handle = $source->handle
 417   }
 418
 419   my $new = {
 420     _source_handle => $source_handle,
 421     _column_data => $me,
 422     _in_storage => 1
 423   };
 424   bless $new, (ref $class || $class);
 425
 426   my $schema;
 427   foreach my $pre (keys %{$prefetch||{}}) {
 428     my $pre_val = $prefetch->{$pre};
 429     my $pre_source = $source->related_source($pre);
 430     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 431       unless $pre_source;
 432     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 433       my @pre_objects;
 434       foreach my $pre_rec (@$pre_val) {
 435         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 436            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 437           next;
 438         }
 439         push(@pre_objects, $pre_source->result_class->inflate_result(
 440                              $pre_source, @{$pre_rec}));
 441       }
 442       $new->related_resultset($pre)->set_cache(\@pre_objects);
 443     } elsif (defined $pre_val->[0]) {
 444       my $fetched;
 445       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 446          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 447       {
 448         $fetched = $pre_source->result_class->inflate_result(
 449                       $pre_source, @{$pre_val});
 450       }
 451       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 452       $class->throw_exception("No accessor for prefetched $pre")
 453        unless defined $accessor;
 454       if ($accessor eq 'single') {
 455         $new->{_relationship_data}{$pre} = $fetched;
 456       } elsif ($accessor eq 'filter') {
 457         $new->{_inflated_column}{$pre} = $fetched;
 458       } else {
 459        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 460       }
 461     }
 462   }
 463   return $new;
 464 }
 465
 466 =head2 update_or_insert
 467
 468   $obj->update_or_insert
 469
 470 Updates the object if it's already in the db, else inserts it.
 471
 472 =head2 insert_or_update
 473
 474   $obj->insert_or_update
 475
 476 Alias for L</update_or_insert>
 477
 478 =cut
 479
 480 *insert_or_update = \&update_or_insert;
 481 sub update_or_insert {
 482   my $self = shift;
 483   return ($self->in_storage ? $self->update : $self->insert);
 484 }
 485
 486 =head2 is_changed
 487
 488   my @changed_col_names = $obj->is_changed();
 489   if ($obj->is_changed()) { ... }
 490
 491 In array context returns a list of columns with uncommited changes, or
 492 in scalar context returns a true value if there are uncommitted
 493 changes.
 494
 495 =cut
 496
 497 sub is_changed {
 498   return keys %{shift->{_dirty_columns} || {}};
 499 }
 500
 501 =head2 is_column_changed
 502
 503   if ($obj->is_column_changed('col')) { ... }
 504
 505 Returns a true value if the column has uncommitted changes.
 506
 507 =cut
 508
 509 sub is_column_changed {
 510   my( $self, $col ) = @_;
 511   return exists $self->{_dirty_columns}->{$col};
 512 }
 513
 514 =head2 result_source
 515
 516   my $resultsource = $object->result_source;
 517
 518 Accessor to the ResultSource this object was created from
 519
 520 =cut
 521
 522 sub result_source {
 523     my $self = shift;
 524
 525     if (@_) {
 526         $self->_source_handle($_[0]->handle);
 527     } else {
 528         $self->_source_handle->resolve;
 529     }
 530 }
 531
 532 =head2 register_column
 533
 534   $column_info = { .... };
 535   $class->register_column($column_name, $column_info);
 536
 537 Registers a column on the class. If the column_info has an 'accessor'
 538 key, creates an accessor named after the value if defined; if there is
 539 no such key, creates an accessor with the same name as the column
 540
 541 The column_info attributes are described in
 542 L<DBIx::Class::ResultSource/add_columns>
 543
 544 =cut
 545
 546 sub register_column {
 547   my ($class, $col, $info) = @_;
 548   my $acc = $col;
 549   if (exists $info->{accessor}) {
 550     return unless defined $info->{accessor};
 551     $acc = [ $info->{accessor}, $col ];
 552   }
 553   $class->mk_group_accessors('column' => $acc);
 554 }
 555
 556
 557 =head2 throw_exception
 558
 559 See Schema's throw_exception.
 560
 561 =cut
 562
 563 sub throw_exception {
 564   my $self=shift;
 565   if (ref $self && ref $self->result_source) {
 566     $self->result_source->schema->throw_exception(@_);
 567   } else {
 568     croak(@_);
 569   }
 570 }
 571
 572 1;
 573
 574 =head1 AUTHORS
 575
 576 Matt S. Trout <mst@shadowcatsystems.co.uk>
 577
 578 =head1 LICENSE
 579
 580 You may distribute this code under the same terms as Perl itself.
 581
 582 =cut