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