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