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