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