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