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