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