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     if (ref $pre_val->[0] eq 'ARRAY') { # multi
 308       my @pre_objects;
 309       foreach my $pre_rec (@$pre_val) {
 310         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
 311            and !defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
 312           next;
 313         }
 314         push(@pre_objects, $pre_source->result_class->inflate_result(
 315                              $pre_source, @{$pre_rec}));
 316       }
 317       $new->related_resultset($pre)->set_cache(\@pre_objects);
 318     } else {
 319       my $fetched;
 320       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
 321          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
 322       {
 323         $fetched = $pre_source->result_class->inflate_result(
 324                       $pre_source, @{$pre_val});
 325       }
 326       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
 327       $class->throw_exception("No accessor for prefetched $pre")
 328        unless defined $accessor;
 329       if ($accessor eq 'single') {
 330         $new->{_relationship_data}{$pre} = $fetched;
 331       } elsif ($accessor eq 'filter') {
 332         $new->{_inflated_column}{$pre} = $fetched;
 333       } else {
 334        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
 335       }
 336     }
 337   }
 338   return $new;
 339 }
 340
 341 =head2 insert_or_update
 342
 343   $obj->insert_or_update
 344
 345 Updates the object if it's already in the db, else inserts it.
 346
 347 =cut
 348
 349 sub insert_or_update {
 350   my $self = shift;
 351   return ($self->in_storage ? $self->update : $self->insert);
 352 }
 353
 354 =head2 is_changed
 355
 356   my @changed_col_names = $obj->is_changed
 357
 358 =cut
 359
 360 sub is_changed {
 361   return keys %{shift->{_dirty_columns} || {}};
 362 }
 363
 364 =head2 result_source
 365
 366   Accessor to the ResultSource this object was created from
 367
 368 =head2 register_column
 369
 370 =head3 Arguments: ($column, $column_info)
 371
 372   Registers a column on the class. If the column_info has an 'accessor' key,
 373   creates an accessor named after the value if defined; if there is no such
 374   key, creates an accessor with the same name as the column
 375
 376 =cut
 377
 378 sub register_column {
 379   my ($class, $col, $info) = @_;
 380   my $acc = $col;
 381   if (exists $info->{accessor}) {
 382     return unless defined $info->{accessor};
 383     $acc = [ $info->{accessor}, $col ];
 384   }
 385   $class->mk_group_accessors('column' => $acc);
 386 }
 387
 388
 389 =head2 throw_exception
 390
 391 See Schema's throw_exception.
 392
 393 =cut
 394
 395 sub throw_exception {
 396   my $self=shift;
 397   if (ref $self && ref $self->result_source) {
 398     $self->result_source->schema->throw_exception(@_);
 399   } else {
 400     croak(@_);
 401   }
 402 }
 403
 404 1;
 405
 406 =head1 AUTHORS
 407
 408 Matt S. Trout <mst@shadowcatsystems.co.uk>
 409
 410 =head1 LICENSE
 411
 412 You may distribute this code under the same terms as Perl itself.
 413
 414 =cut
 415