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