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