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