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     foreach my $k (keys %$attrs) {
  46       $new->throw_exception("No such column $k on $class")
  47         unless $class->has_column($k);
  48       $new->store_column($k => $attrs->{$k});
  49     }
  50   }
  51
  52   return $new;
  53 }
  54
  55 =head2 insert
  56
  57   $obj->insert;
  58
  59 Inserts an object into the database if it isn't already in
  60 there. Returns the object itself. Requires the object's result source to
  61 be set, or the class to have a result_source_instance method. To insert
  62 an entirely new object into the database, use C<create> (see
  63 L<DBIx::Class::ResultSet/create>).
  64
  65 =cut
  66
  67 sub insert {
  68   my ($self) = @_;
  69   return $self if $self->in_storage;
  70   my $source = $self->result_source;
  71   $source ||=  $self->result_source($self->result_source_instance)
  72     if $self->can('result_source_instance');
  73   $self->throw_exception("No result_source set on this object; can't insert")
  74     unless $source;
  75   #use Data::Dumper; warn Dumper($self);
  76   $source->storage->insert($source->from, { $self->get_columns });
  77   $self->in_storage(1);
  78   $self->{_dirty_columns} = {};
  79   $self->{related_resultsets} = {};
  80   return $self;
  81 }
  82
  83 =head2 in_storage
  84
  85   $obj->in_storage; # Get value
  86   $obj->in_storage(1); # Set value
  87
  88 Indicated whether the object exists as a row in the database or not
  89
  90 =cut
  91
  92 sub in_storage {
  93   my ($self, $val) = @_;
  94   $self->{_in_storage} = $val if @_ > 1;
  95   return $self->{_in_storage};
  96 }
  97
  98 =head2 update
  99
 100   $obj->update;
 101
 102 Must be run on an object that is already in the database; issues an SQL
 103 UPDATE query to commit any changes to the object to the database if
 104 required.
 105
 106 =cut
 107
 108 sub update {
 109   my ($self, $upd) = @_;
 110   $self->throw_exception( "Not in database" ) unless $self->in_storage;
 111   my $ident_cond = $self->ident_condition;
 112   $self->throw_exception("Cannot safely update a row in a PK-less table")
 113     if ! keys %$ident_cond;
 114   $self->set_columns($upd) if $upd;
 115   my %to_update = $self->get_dirty_columns;
 116   return $self unless keys %to_update;
 117   my $rows = $self->result_source->storage->update(
 118                $self->result_source->from, \%to_update, $ident_cond);
 119   if ($rows == 0) {
 120     $self->throw_exception( "Can't update ${self}: row not found" );
 121   } elsif ($rows > 1) {
 122     $self->throw_exception("Can't update ${self}: updated more than one row");
 123   }
 124   $self->{_dirty_columns} = {};
 125   $self->{related_resultsets} = {};
 126   return $self;
 127 }
 128
 129 =head2 delete
 130
 131   $obj->delete
 132
 133 Deletes the object from the database. The object is still perfectly
 134 usable, but C<-E<gt>in_storage()> will now return 0 and the object must
 135 reinserted using C<-E<gt>insert()> before C<-E(<gt>update()> can be used
 136 on it. If you delete an object in a class with a C<has_many>
 137 relationship, all the related objects will be deleted as well. To turn
 138 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
 139 hashref. Any database-level cascade or restrict will take precedence
 140 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
 141
 142 =cut
 143
 144 sub delete {
 145   my $self = shift;
 146   if (ref $self) {
 147     $self->throw_exception( "Not in database" ) unless $self->in_storage;
 148     my $ident_cond = $self->ident_condition;
 149     $self->throw_exception("Cannot safely delete a row in a PK-less table")
 150       if ! keys %$ident_cond;
 151     foreach my $column (keys %$ident_cond) {
 152             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
 153               unless exists $self->{_column_data}{$column};
 154     }
 155     $self->result_source->storage->delete(
 156       $self->result_source->from, $ident_cond);
 157     $self->in_storage(undef);
 158   } else {
 159     $self->throw_exception("Can't do class delete without a ResultSource instance")
 160       unless $self->can('result_source_instance');
 161     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
 162     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
 163     $self->result_source_instance->resultset->search(@_)->delete;
 164   }
 165   return $self;
 166 }
 167
 168 =head2 get_column
 169
 170   my $val = $obj->get_column($col);
 171
 172 Gets a column value from a row object. Currently, does not do
 173 any queries; the column must have already been fetched from
 174 the database and stored in the object.
 175
 176 =cut
 177
 178 sub get_column {
 179   my ($self, $column) = @_;
 180   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
 181   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
 182   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
 183   return undef;
 184 }
 185
 186 =head2 has_column_loaded
 187
 188   if ( $obj->has_column_loaded($col) ) {
 189      print "$col has been loaded from db";
 190   }
 191
 192 Returns a true value if the column value has been loaded from the
 193 database (or set locally).
 194
 195 =cut
 196
 197 sub has_column_loaded {
 198   my ($self, $column) = @_;
 199   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 200   return exists $self->{_column_data}{$column};
 201 }
 202
 203 =head2 get_columns
 204
 205   my %data = $obj->get_columns;
 206
 207 Does C<get_column>, for all column values at once.
 208
 209 =cut
 210
 211 sub get_columns {
 212   my $self = shift;
 213   return %{$self->{_column_data}};
 214 }
 215
 216 =head2 get_dirty_columns
 217
 218   my %data = $obj->get_dirty_columns;
 219
 220 Identical to get_columns but only returns those that have been changed.
 221
 222 =cut
 223
 224 sub get_dirty_columns {
 225   my $self = shift;
 226   return map { $_ => $self->{_column_data}{$_} }
 227            keys %{$self->{_dirty_columns}};
 228 }
 229
 230 =head2 set_column
 231
 232   $obj->set_column($col => $val);
 233
 234 Sets a column value. If the new value is different from the old one,
 235 the column is marked as dirty for when you next call $obj->update.
 236
 237 =cut
 238
 239 sub set_column {
 240   my $self = shift;
 241   my ($column) = @_;
 242   my $old = $self->get_column($column);
 243   my $ret = $self->store_column(@_);
 244   $self->{_dirty_columns}{$column} = 1
 245     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 246   return $ret;
 247 }
 248
 249 =head2 set_columns
 250
 251   my $copy = $orig->set_columns({ $col => $val, ... });
 252
 253 Sets more than one column value at once.
 254
 255 =cut
 256
 257 sub set_columns {
 258   my ($self,$data) = @_;
 259   foreach my $col (keys %$data) {
 260     $self->set_column($col,$data->{$col});
 261   }
 262   return $self;
 263 }
 264
 265 =head2 copy
 266
 267   my $copy = $orig->copy({ change => $to, ... });
 268
 269 Inserts a new row with the specified changes.
 270
 271 =cut
 272
 273 sub copy {
 274   my ($self, $changes) = @_;
 275   $changes ||= {};
 276   my $col_data = { %{$self->{_column_data}} };
 277   foreach my $col (keys %$col_data) {
 278     delete $col_data->{$col}
 279       if $self->result_source->column_info($col)->{is_auto_increment};
 280   }
 281
 282   my $new = { _column_data => $col_data };
 283   bless $new, ref $self;
 284
 285   $new->result_source($self->result_source);
 286   $new->set_columns($changes);
 287   $new->insert;
 288   foreach my $rel ($self->result_source->relationships) {
 289     my $rel_info = $self->result_source->relationship_info($rel);
 290     if ($rel_info->{attrs}{cascade_copy}) {
 291       my $resolved = $self->result_source->resolve_condition(
 292        $rel_info->{cond}, $rel, $new);
 293       foreach my $related ($self->search_related($rel)) {
 294         $related->copy($resolved);
 295       }
 296     }
 297   }
 298   return $new;
 299 }
 300
 301 =head2 store_column
 302
 303   $obj->store_column($col => $val);
 304
 305 Sets a column value without marking it as dirty.
 306
 307 =cut
 308
 309 sub store_column {
 310   my ($self, $column, $value) = @_;
 311   $self->throw_exception( "No such column '${column}'" )
 312     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 313   $self->throw_exception( "set_column called for ${column} without value" )
 314     if @_ < 3;
 315   return $self->{_column_data}{$column} = $value;
 316 }
 317
 318 =head2 inflate_result
 319
 320   Class->inflate_result($result_source, \%me, \%prefetch?)
 321
 322 Called by ResultSet to inflate a result from storage
 323
 324 =cut
 325
 326 sub inflate_result {
 327   my ($class, $source, $me, $prefetch) = @_;
 328
 329   my ($source_handle) = $source;
 330
 331   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
 332       $source = $source_handle->resolve
 333   } else {
 334       $source_handle = $source->handle
 335   }
 336
 337   my $new = {
 338     _source_handle => $source_handle,
 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 =cut
 439
 440 sub result_source {
 441     my $self = shift;
 442
 443     if (@_) {
 444         $self->_source_handle($_[0]->handle);
 445     } else {
 446         $self->_source_handle->resolve;
 447     }
 448 }
 449
 450 =head2 register_column
 451
 452   $column_info = { .... };
 453   $class->register_column($column_name, $column_info);
 454
 455 Registers a column on the class. If the column_info has an 'accessor'
 456 key, creates an accessor named after the value if defined; if there is
 457 no such key, creates an accessor with the same name as the column
 458
 459 The column_info attributes are described in
 460 L<DBIx::Class::ResultSource/add_columns>
 461
 462 =cut
 463
 464 sub register_column {
 465   my ($class, $col, $info) = @_;
 466   my $acc = $col;
 467   if (exists $info->{accessor}) {
 468     return unless defined $info->{accessor};
 469     $acc = [ $info->{accessor}, $col ];
 470   }
 471   $class->mk_group_accessors('column' => $acc);
 472 }
 473
 474
 475 =head2 throw_exception
 476
 477 See Schema's throw_exception.
 478
 479 =cut
 480
 481 sub throw_exception {
 482   my $self=shift;
 483   if (ref $self && ref $self->result_source) {
 484     $self->result_source->schema->throw_exception(@_);
 485   } else {
 486     croak(@_);
 487   }
 488 }
 489
 490 1;
 491
 492 =head1 AUTHORS
 493
 494 Matt S. Trout <mst@shadowcatsystems.co.uk>
 495
 496 =head1 LICENSE
 497
 498 You may distribute this code under the same terms as Perl itself.
 499
 500 =cut