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