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     while (my ($k, $v) = each %$attrs) {
  42       $new->throw_exception("No such column $k on $class")
  43         unless $class->has_column($k);
  44       $new->store_column($k => $v);
  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 sub has_column_loaded {
 174   my ($self, $column) = @_;
 175   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
 176   return exists $self->{_column_data}{$column};
 177 }
 178
 179 =head2 get_columns
 180
 181   my %data = $obj->get_columns;
 182
 183 Does C<get_column>, for all column values at once.
 184
 185 =cut
 186
 187 sub get_columns {
 188   my $self = shift;
 189   return %{$self->{_column_data}};
 190 }
 191
 192 =head2 get_dirty_columns
 193
 194   my %data = $obj->get_dirty_columns;
 195
 196 Identical to get_columns but only returns those that have been changed.
 197
 198 =cut
 199
 200 sub get_dirty_columns {
 201   my $self = shift;
 202   return map { $_ => $self->{_column_data}{$_} }
 203            keys %{$self->{_dirty_columns}};
 204 }
 205
 206 =head2 set_column
 207
 208   $obj->set_column($col => $val);
 209
 210 Sets a column value. If the new value is different from the old one,
 211 the column is marked as dirty for when you next call $obj->update.
 212
 213 =cut
 214
 215 sub set_column {
 216   my $self = shift;
 217   my ($column) = @_;
 218   my $old = $self->get_column($column);
 219   my $ret = $self->store_column(@_);
 220   $self->{_dirty_columns}{$column} = 1
 221     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
 222   return $ret;
 223 }
 224
 225 =head2 set_columns
 226
 227   my $copy = $orig->set_columns({ $col => $val, ... });
 228
 229 Sets more than one column value at once.
 230
 231 =cut
 232
 233 sub set_columns {
 234   my ($self,$data) = @_;
 235   while (my ($col,$val) = each %$data) {
 236     $self->set_column($col,$val);
 237   }
 238   return $self;
 239 }
 240
 241 =head2 copy
 242
 243   my $copy = $orig->copy({ change => $to, ... });
 244
 245 Inserts a new row with the specified changes.
 246
 247 =cut
 248
 249 sub copy {
 250   my ($self, $changes) = @_;
 251   $changes ||= {};
 252   my $col_data = { %{$self->{_column_data}} };
 253   foreach my $col (keys %$col_data) {
 254     delete $col_data->{$col}
 255       if $self->result_source->column_info($col)->{is_auto_increment};
 256   }
 257   my $new = bless { _column_data => $col_data }, ref $self;
 258   $new->result_source($self->result_source);
 259   $new->set_columns($changes);
 260   $new->insert;
 261   foreach my $rel ($self->result_source->relationships) {
 262     my $rel_info = $self->result_source->relationship_info($rel);
 263     if ($rel_info->{attrs}{cascade_copy}) {
 264       my $resolved = $self->result_source->resolve_condition(
 265        $rel_info->{cond}, $rel, $new);
 266       foreach my $related ($self->search_related($rel)) {
 267         $related->copy($resolved);
 268       }
 269     }
 270   }
 271   return $new;
 272 }
 273
 274 =head2 store_column
 275
 276   $obj->store_column($col => $val);
 277
 278 Sets a column value without marking it as dirty.
 279
 280 =cut
 281
 282 sub store_column {
 283   my ($self, $column, $value) = @_;
 284   $self->throw_exception( "No such column '${column}'" )
 285     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 286   $self->throw_exception( "set_column called for ${column} without value" )
 287     if @_ < 3;
 288   return $self->{_column_data}{$column} = $value;
 289 }
 290
 291 =head2 inflate_result
 292
 293   Class->inflate_result($result_source, \%me, \%prefetch?)
 294
 295 Called by ResultSet to inflate a result from storage
 296
 297 =cut
 298
 299 sub inflate_result {
 300   my ($class, $source, $me, $prefetch) = @_;
 301   #use Data::Dumper; print Dumper(@_);
 302   my $new = bless({ result_source => $source,
 303                     _column_data => $me,
 304                     _in_storage => 1
 305                   },
 306                   ref $class || $class);
 307   my $schema;
 308   foreach my $pre (keys %{$prefetch||{}}) {
 309     my $pre_val = $prefetch->{$pre};
 310     my $pre_source = $source->related_source($pre);
 311     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 312       unless $pre_source;
 313     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 314       my @pre_objects;
 315       foreach my $pre_rec (@$pre_val) {
 316         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 317            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 318           next;
 319         }
 320         push(@pre_objects, $pre_source->result_class->inflate_result(
 321                              $pre_source, @{$pre_rec}));
 322       }
 323       $new->related_resultset($pre)->set_cache(\@pre_objects);
 324     } elsif (defined $pre_val->[0]) {
 325       my $fetched;
 326       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 327          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 328       {
 329         $fetched = $pre_source->result_class->inflate_result(
 330                       $pre_source, @{$pre_val});
 331       }
 332       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 333       $class->throw_exception("No accessor for prefetched $pre")
 334        unless defined $accessor;
 335       if ($accessor eq 'single') {
 336         $new->{_relationship_data}{$pre} = $fetched;
 337       } elsif ($accessor eq 'filter') {
 338         $new->{_inflated_column}{$pre} = $fetched;
 339       } else {
 340        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 341       }
 342     }
 343   }
 344   return $new;
 345 }
 346
 347 =head2 update_or_insert
 348
 349   $obj->update_or_insert
 350
 351 Updates the object if it's already in the db, else inserts it.
 352
 353 =cut
 354
 355 *insert_or_update = \&update_or_insert;
 356 sub update_or_insert {
 357   my $self = shift;
 358   return ($self->in_storage ? $self->update : $self->insert);
 359 }
 360
 361 =head2 is_changed
 362
 363   my @changed_col_names = $obj->is_changed
 364
 365 =cut
 366
 367 sub is_changed {
 368   return keys %{shift->{_dirty_columns} || {}};
 369 }
 370
 371 =head2 result_source
 372
 373   Accessor to the ResultSource this object was created from
 374
 375 =head2 register_column
 376
 377 =over 4
 378
 379 =item Arguments: $column, $column_info
 380
 381 =back
 382
 383   Registers a column on the class. If the column_info has an 'accessor' key,
 384   creates an accessor named after the value if defined; if there is no such
 385   key, creates an accessor with the same name as the column
 386
 387 =cut
 388
 389 sub register_column {
 390   my ($class, $col, $info) = @_;
 391   my $acc = $col;
 392   if (exists $info->{accessor}) {
 393     return unless defined $info->{accessor};
 394     $acc = [ $info->{accessor}, $col ];
 395   }
 396   $class->mk_group_accessors('column' => $acc);
 397 }
 398
 399
 400 =head2 throw_exception
 401
 402 See Schema's throw_exception.
 403
 404 =cut
 405
 406 sub throw_exception {
 407   my $self=shift;
 408   if (ref $self && ref $self->result_source) {
 409     $self->result_source->schema->throw_exception(@_);
 410   } else {
 411     croak(@_);
 412   }
 413 }
 414
 415 1;
 416
 417 =head1 AUTHORS
 418
 419 Matt S. Trout <mst@shadowcatsystems.co.uk>
 420
 421 =head1 LICENSE
 422
 423 You may distribute this code under the same terms as Perl itself.
 424
 425 =cut
 426