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