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