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