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