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