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