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