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->set_columns($changes);
 259   $new->insert;
 260   foreach my $rel ($self->result_source->relationships) {
 261     my $rel_info = $self->result_source->relationship_info($rel);
 262     if ($rel_info->{attrs}{cascade_copy}) {
 263       my $resolved = $self->result_source->resolve_condition(
 264        $rel_info->{cond}, $rel, $new);
 265       foreach my $related ($self->search_related($rel)) {
 266         $related->copy($resolved);
 267       }
 268     }
 269   }
 270   return $new;
 271 }
 272
 273 =head2 store_column
 274
 275   $obj->store_column($col => $val);
 276
 277 Sets a column value without marking it as dirty.
 278
 279 =cut
 280
 281 sub store_column {
 282   my ($self, $column, $value) = @_;
 283   $self->throw_exception( "No such column '${column}'" )
 284     unless exists $self->{_column_data}{$column} || $self->has_column($column);
 285   $self->throw_exception( "set_column called for ${column} without value" )
 286     if @_ < 3;
 287   return $self->{_column_data}{$column} = $value;
 288 }
 289
 290 =head2 inflate_result
 291
 292   Class->inflate_result($result_source, \%me, \%prefetch?)
 293
 294 Called by ResultSet to inflate a result from storage
 295
 296 =cut
 297
 298 sub inflate_result {
 299   my ($class, $source, $me, $prefetch) = @_;
 300   #use Data::Dumper; print Dumper(@_);
 301   my $new = bless({ result_source => $source,
 302                     _column_data => $me,
 303                     _in_storage => 1
 304                   },
 305                   ref $class || $class);
 306   my $schema;
 307   foreach my $pre (keys %{$prefetch||{}}) {
 308     my $pre_val = $prefetch->{$pre};
 309     my $pre_source = $source->related_source($pre);
 310     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
 311       unless $pre_source;
 312     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
 313       my @pre_objects;
 314       foreach my $pre_rec (@$pre_val) {
 315         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 316            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 317           next;
 318         }
 319         push(@pre_objects, $pre_source->result_class->inflate_result(
 320                              $pre_source, @{$pre_rec}));
 321       }
 322       $new->related_resultset($pre)->set_cache(\@pre_objects);
 323     } elsif (defined $pre_val->[0]) {
 324       my $fetched;
 325       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 326          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 327       {
 328         $fetched = $pre_source->result_class->inflate_result(
 329                       $pre_source, @{$pre_val});
 330       }
 331       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 332       $class->throw_exception("No accessor for prefetched $pre")
 333        unless defined $accessor;
 334       if ($accessor eq 'single') {
 335         $new->{_relationship_data}{$pre} = $fetched;
 336       } elsif ($accessor eq 'filter') {
 337         $new->{_inflated_column}{$pre} = $fetched;
 338       } else {
 339        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 340       }
 341     }
 342   }
 343   return $new;
 344 }
 345
 346 =head2 update_or_insert
 347
 348   $obj->update_or_insert
 349
 350 Updates the object if it's already in the db, else inserts it.
 351
 352 =cut
 353
 354 *insert_or_update = \&update_or_insert;
 355 sub update_or_insert {
 356   my $self = shift;
 357   return ($self->in_storage ? $self->update : $self->insert);
 358 }
 359
 360 =head2 is_changed
 361
 362   my @changed_col_names = $obj->is_changed
 363
 364 =cut
 365
 366 sub is_changed {
 367   return keys %{shift->{_dirty_columns} || {}};
 368 }
 369
 370 =head2 result_source
 371
 372   Accessor to the ResultSource this object was created from
 373
 374 =head2 register_column
 375
 376 =over 4
 377
 378 =item Arguments: $column, $column_info
 379
 380 =back
 381
 382   Registers a column on the class. If the column_info has an 'accessor' key,
 383   creates an accessor named after the value if defined; if there is no such
 384   key, creates an accessor with the same name as the column
 385
 386 =cut
 387
 388 sub register_column {
 389   my ($class, $col, $info) = @_;
 390   my $acc = $col;
 391   if (exists $info->{accessor}) {
 392     return unless defined $info->{accessor};
 393     $acc = [ $info->{accessor}, $col ];
 394   }
 395   $class->mk_group_accessors('column' => $acc);
 396 }
 397
 398
 399 =head2 throw_exception
 400
 401 See Schema's throw_exception.
 402
 403 =cut
 404
 405 sub throw_exception {
 406   my $self=shift;
 407   if (ref $self && ref $self->result_source) {
 408     $self->result_source->schema->throw_exception(@_);
 409   } else {
 410     croak(@_);
 411   }
 412 }
 413
 414 1;
 415
 416 =head1 AUTHORS
 417
 418 Matt S. Trout <mst@shadowcatsystems.co.uk>
 419
 420 =head1 LICENSE
 421
 422 You may distribute this code under the same terms as Perl itself.
 423
 424 =cut
 425