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   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   $self->set_columns($upd) if $upd;
 117   my %to_update = $self->get_dirty_columns;
 118   return $self unless keys %to_update;
 119   my $rows = $self->result_source->storage->update(
 120                $self->result_source->from, \%to_update, $self->{_orig_ident} || $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
 246   # save our original ident condition if
 247   #  they modify any part of the PK
 248   if(!$self->{_orig_ident}) {
 249     foreach ($self->primary_columns) {
 250        if($_ eq $column) {
 251            $self->{_orig_ident} = $self->ident_condition;
 252            last;
 253        }
 254     }
 255   }
 256
 257   my $ret = $self->store_column(@_);
 258   $self->{_dirty_columns}{$column} = 1
 259     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 260   return $ret;
 261 }
 262
 263 =head2 set_columns
 264
 265   my $copy = $orig->set_columns({ $col => $val, ... });
 266
 267 Sets more than one column value at once.
 268
 269 =cut
 270
 271 sub set_columns {
 272   my ($self,$data) = @_;
 273   foreach my $col (keys %$data) {
 274     $self->set_column($col,$data->{$col});
 275   }
 276   return $self;
 277 }
 278
 279 =head2 copy
 280
 281   my $copy = $orig->copy({ change => $to, ... });
 282
 283 Inserts a new row with the specified changes.
 284
 285 =cut
 286
 287 sub copy {
 288   my ($self, $changes) = @_;
 289   $changes ||= {};
 290   my $col_data = { %{$self->{_column_data}} };
 291   foreach my $col (keys %$col_data) {
 292     delete $col_data->{$col}
 293       if $self->result_source->column_info($col)->{is_auto_increment};
 294   }
 295
 296   my $new = { _column_data => $col_data };
 297   bless $new, ref $self;
 298
 299   $new->result_source($self->result_source);
 300   $new->set_columns($changes);
 301   $new->insert;
 302   foreach my $rel ($self->result_source->relationships) {
 303     my $rel_info = $self->result_source->relationship_info($rel);
 304     if ($rel_info->{attrs}{cascade_copy}) {
 305       my $resolved = $self->result_source->resolve_condition(
 306        $rel_info->{cond}, $rel, $new);
 307       foreach my $related ($self->search_related($rel)) {
 308         $related->copy($resolved);
 309       }
 310     }
 311   }
 312   return $new;
 313 }
 314
 315 =head2 store_column
 316
 317   $obj->store_column($col => $val);
 318
 319 Sets a column value without marking it as dirty.
 320
 321 =cut
 322
 323 sub store_column {
 324   my ($self, $column, $value) = @_;
 325   $self->throw_exception( "No such column '${column}'" )
 326     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 327   $self->throw_exception( "set_column called for ${column} without value" )
 328     if @_ < 3;
 329   return $self->{_column_data}{$column} = $value;
 330 }
 331
 332 =head2 inflate_result
 333
 334   Class->inflate_result($result_source, \%me, \%prefetch?)
 335
 336 Called by ResultSet to inflate a result from storage
 337
 338 =cut
 339
 340 sub inflate_result {
 341   my ($class, $source, $me, $prefetch) = @_;
 342   #use Data::Dumper; print Dumper(@_);
 343   my $new = {
 344     result_source => $source,
 345     _column_data => $me,
 346     _in_storage => 1
 347   };
 348   bless $new, (ref $class || $class);
 349
 350   my $schema;
 351   foreach my $pre (keys %{$prefetch||{}}) {
 352     my $pre_val = $prefetch->{$pre};
 353     my $pre_source = $source->related_source($pre);
 354     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 355       unless $pre_source;
 356     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 357       my @pre_objects;
 358       foreach my $pre_rec (@$pre_val) {
 359         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 360            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 361           next;
 362         }
 363         push(@pre_objects, $pre_source->result_class->inflate_result(
 364                              $pre_source, @{$pre_rec}));
 365       }
 366       $new->related_resultset($pre)->set_cache(\@pre_objects);
 367     } elsif (defined $pre_val->[0]) {
 368       my $fetched;
 369       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 370          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 371       {
 372         $fetched = $pre_source->result_class->inflate_result(
 373                       $pre_source, @{$pre_val});
 374       }
 375       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 376       $class->throw_exception("No accessor for prefetched $pre")
 377        unless defined $accessor;
 378       if ($accessor eq 'single') {
 379         $new->{_relationship_data}{$pre} = $fetched;
 380       } elsif ($accessor eq 'filter') {
 381         $new->{_inflated_column}{$pre} = $fetched;
 382       } else {
 383        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 384       }
 385     }
 386   }
 387   return $new;
 388 }
 389
 390 =head2 update_or_insert
 391
 392   $obj->update_or_insert
 393
 394 Updates the object if it's already in the db, else inserts it.
 395
 396 =head2 insert_or_update
 397
 398   $obj->insert_or_update
 399
 400 Alias for L</update_or_insert>
 401
 402 =cut
 403
 404 *insert_or_update = \&update_or_insert;
 405 sub update_or_insert {
 406   my $self = shift;
 407   return ($self->in_storage ? $self->update : $self->insert);
 408 }
 409
 410 =head2 is_changed
 411
 412   my @changed_col_names = $obj->is_changed();
 413   if ($obj->is_changed()) { ... }
 414
 415 In array context returns a list of columns with uncommited changes, or
 416 in scalar context returns a true value if there are uncommitted
 417 changes.
 418
 419 =cut
 420
 421 sub is_changed {
 422   return keys %{shift->{_dirty_columns} || {}};
 423 }
 424
 425 =head2 is_column_changed
 426
 427   if ($obj->is_column_changed('col')) { ... }
 428
 429 Returns a true value if the column has uncommitted changes.
 430
 431 =cut
 432
 433 sub is_column_changed {
 434   my( $self, $col ) = @_;
 435   return exists $self->{_dirty_columns}->{$col};
 436 }
 437
 438 =head2 result_source
 439
 440   my $resultsource = $object->result_source;
 441
 442 Accessor to the ResultSource this object was created from
 443
 444 =head2 register_column
 445
 446   $column_info = { .... };
 447   $class->register_column($column_name, $column_info);
 448
 449 Registers a column on the class. If the column_info has an 'accessor'
 450 key, creates an accessor named after the value if defined; if there is
 451 no such key, creates an accessor with the same name as the column
 452
 453 The column_info attributes are described in
 454 L<DBIx::Class::ResultSource/add_columns>
 455
 456 =cut
 457
 458 sub register_column {
 459   my ($class, $col, $info) = @_;
 460   my $acc = $col;
 461   if (exists $info->{accessor}) {
 462     return unless defined $info->{accessor};
 463     $acc = [ $info->{accessor}, $col ];
 464   }
 465   $class->mk_group_accessors('column' => $acc);
 466 }
 467
 468
 469 =head2 throw_exception
 470
 471 See Schema's throw_exception.
 472
 473 =cut
 474
 475 sub throw_exception {
 476   my $self=shift;
 477   if (ref $self && ref $self->result_source) {
 478     $self->result_source->schema->throw_exception(@_);
 479   } else {
 480     croak(@_);
 481   }
 482 }
 483
 484 1;
 485
 486 =head1 AUTHORS
 487
 488 Matt S. Trout <mst@shadowcatsystems.co.uk>
 489
 490 =head1 LICENSE
 491
 492 You may distribute this code under the same terms as Perl itself.
 493
 494 =cut