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