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 set_column
 296
 297   $obj->set_column($col => $val);
 298
 299 Sets a column value. If the new value is different from the old one,
 300 the column is marked as dirty for when you next call $obj->update.
 301
 302 =cut
 303
 304 sub set_column {
 305   my $self = shift;
 306   my ($column) = @_;
 307   $self->{_orig_ident} ||= $self->ident_condition;
 308   my $old = $self->get_column($column);
 309   my $ret = $self->store_column(@_);
 310   $self->{_dirty_columns}{$column} = 1
 311     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 312   return $ret;
 313 }
 314
 315 =head2 set_columns
 316
 317   my $copy = $orig->set_columns({ $col => $val, ... });
 318
 319 Sets more than one column value at once.
 320
 321 =cut
 322
 323 sub set_columns {
 324   my ($self,$data) = @_;
 325   foreach my $col (keys %$data) {
 326     $self->set_column($col,$data->{$col});
 327   }
 328   return $self;
 329 }
 330
 331 =head2 copy
 332
 333   my $copy = $orig->copy({ change => $to, ... });
 334
 335 Inserts a new row with the specified changes.
 336
 337 =cut
 338
 339 sub copy {
 340   my ($self, $changes) = @_;
 341   $changes ||= {};
 342   my $col_data = { %{$self->{_column_data}} };
 343   foreach my $col (keys %$col_data) {
 344     delete $col_data->{$col}
 345       if $self->result_source->column_info($col)->{is_auto_increment};
 346   }
 347
 348   my $new = { _column_data => $col_data };
 349   bless $new, ref $self;
 350
 351   $new->result_source($self->result_source);
 352   $new->set_columns($changes);
 353   $new->insert;
 354   foreach my $rel ($self->result_source->relationships) {
 355     my $rel_info = $self->result_source->relationship_info($rel);
 356     if ($rel_info->{attrs}{cascade_copy}) {
 357       my $resolved = $self->result_source->resolve_condition(
 358        $rel_info->{cond}, $rel, $new);
 359       foreach my $related ($self->search_related($rel)) {
 360         $related->copy($resolved);
 361       }
 362     }
 363   }
 364   return $new;
 365 }
 366
 367 =head2 store_column
 368
 369   $obj->store_column($col => $val);
 370
 371 Sets a column value without marking it as dirty.
 372
 373 =cut
 374
 375 sub store_column {
 376   my ($self, $column, $value) = @_;
 377   $self->throw_exception( "No such column '${column}'" )
 378     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 379   $self->throw_exception( "set_column called for ${column} without value" )
 380     if @_ < 3;
 381   return $self->{_column_data}{$column} = $value;
 382 }
 383
 384 =head2 inflate_result
 385
 386   Class->inflate_result($result_source, \%me, \%prefetch?)
 387
 388 Called by ResultSet to inflate a result from storage
 389
 390 =cut
 391
 392 sub inflate_result {
 393   my ($class, $source, $me, $prefetch) = @_;
 394
 395   my ($source_handle) = $source;
 396
 397   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 398       $source = $source_handle->resolve
 399   } else {
 400       $source_handle = $source->handle
 401   }
 402
 403   my $new = {
 404     _source_handle => $source_handle,
 405     _column_data => $me,
 406     _in_storage => 1
 407   };
 408   bless $new, (ref $class || $class);
 409
 410   my $schema;
 411   foreach my $pre (keys %{$prefetch||{}}) {
 412     my $pre_val = $prefetch->{$pre};
 413     my $pre_source = $source->related_source($pre);
 414     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 415       unless $pre_source;
 416     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 417       my @pre_objects;
 418       foreach my $pre_rec (@$pre_val) {
 419         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 420            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 421           next;
 422         }
 423         push(@pre_objects, $pre_source->result_class->inflate_result(
 424                              $pre_source, @{$pre_rec}));
 425       }
 426       $new->related_resultset($pre)->set_cache(\@pre_objects);
 427     } elsif (defined $pre_val->[0]) {
 428       my $fetched;
 429       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 430          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 431       {
 432         $fetched = $pre_source->result_class->inflate_result(
 433                       $pre_source, @{$pre_val});
 434       }
 435       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 436       $class->throw_exception("No accessor for prefetched $pre")
 437        unless defined $accessor;
 438       if ($accessor eq 'single') {
 439         $new->{_relationship_data}{$pre} = $fetched;
 440       } elsif ($accessor eq 'filter') {
 441         $new->{_inflated_column}{$pre} = $fetched;
 442       } else {
 443        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 444       }
 445     }
 446   }
 447   return $new;
 448 }
 449
 450 =head2 update_or_insert
 451
 452   $obj->update_or_insert
 453
 454 Updates the object if it's already in the db, else inserts it.
 455
 456 =head2 insert_or_update
 457
 458   $obj->insert_or_update
 459
 460 Alias for L</update_or_insert>
 461
 462 =cut
 463
 464 *insert_or_update = \&update_or_insert;
 465 sub update_or_insert {
 466   my $self = shift;
 467   return ($self->in_storage ? $self->update : $self->insert);
 468 }
 469
 470 =head2 is_changed
 471
 472   my @changed_col_names = $obj->is_changed();
 473   if ($obj->is_changed()) { ... }
 474
 475 In array context returns a list of columns with uncommited changes, or
 476 in scalar context returns a true value if there are uncommitted
 477 changes.
 478
 479 =cut
 480
 481 sub is_changed {
 482   return keys %{shift->{_dirty_columns} || {}};
 483 }
 484
 485 =head2 is_column_changed
 486
 487   if ($obj->is_column_changed('col')) { ... }
 488
 489 Returns a true value if the column has uncommitted changes.
 490
 491 =cut
 492
 493 sub is_column_changed {
 494   my( $self, $col ) = @_;
 495   return exists $self->{_dirty_columns}->{$col};
 496 }
 497
 498 =head2 result_source
 499
 500   my $resultsource = $object->result_source;
 501
 502 Accessor to the ResultSource this object was created from
 503
 504 =cut
 505
 506 sub result_source {
 507     my $self = shift;
 508
 509     if (@_) {
 510         $self->_source_handle($_[0]->handle);
 511     } else {
 512         $self->_source_handle->resolve;
 513     }
 514 }
 515
 516 =head2 register_column
 517
 518   $column_info = { .... };
 519   $class->register_column($column_name, $column_info);
 520
 521 Registers a column on the class. If the column_info has an 'accessor'
 522 key, creates an accessor named after the value if defined; if there is
 523 no such key, creates an accessor with the same name as the column
 524
 525 The column_info attributes are described in
 526 L<DBIx::Class::ResultSource/add_columns>
 527
 528 =cut
 529
 530 sub register_column {
 531   my ($class, $col, $info) = @_;
 532   my $acc = $col;
 533   if (exists $info->{accessor}) {
 534     return unless defined $info->{accessor};
 535     $acc = [ $info->{accessor}, $col ];
 536   }
 537   $class->mk_group_accessors('column' => $acc);
 538 }
 539
 540
 541 =head2 throw_exception
 542
 543 See Schema's throw_exception.
 544
 545 =cut
 546
 547 sub throw_exception {
 548   my $self=shift;
 549   if (ref $self && ref $self->result_source) {
 550     $self->result_source->schema->throw_exception(@_);
 551   } else {
 552     croak(@_);
 553   }
 554 }
 555
 556 1;
 557
 558 =head1 AUTHORS
 559
 560 Matt S. Trout <mst@shadowcatsystems.co.uk>
 561
 562 =head1 LICENSE
 563
 564 You may distribute this code under the same terms as Perl itself.
 565
 566 =cut