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