0fde913192b25dc212d3bd69f7ac76479e58ea7a
[dbsrgits/DBIx-Class-Historic.git] / 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 use Scalar::Util ();
9
10 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
11
12 =head1 NAME
13
14 DBIx::Class::Row - Basic row methods
15
16 =head1 SYNOPSIS
17
18 =head1 DESCRIPTION
19
20 This class is responsible for defining and doing basic operations on rows
21 derived from L<DBIx::Class::ResultSource> objects.
22
23 =head1 METHODS
24
25 =head2 new
26
27   my $obj = My::Class->new($attrs);
28
29 Creates a new row object from column => value mappings passed as a hash ref
30
31 Passing an object, or an arrayref of objects as a value will call
32 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
33 passed a hashref or an arrayref of hashrefs as the value, these will
34 be turned into objects via new_related, and treated as if you had
35 passed objects.
36
37 =cut
38
39 ## NB (JER) - this assumes set_from_related can cope with multi-rels
40 ## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
41 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
42 ## When doing the later insert, we need to make sure the PKs are set.
43 ## using _relationship_data in new and funky ways..
44 ## check Relationship::CascadeActions and Relationship::Accessor for compat
45 ## tests!
46
47 sub new {
48   my ($class, $attrs, $source) = @_;
49   $class = ref $class if ref $class;
50
51   my $new = { _column_data => {} };
52   bless $new, $class;
53
54   $new->_source_handle($source) if $source;
55
56   if ($attrs) {
57     $new->throw_exception("attrs must be a hashref")
58       unless ref($attrs) eq 'HASH';
59     
60     my ($related,$inflated);
61     foreach my $key (keys %$attrs) {
62       if (ref $attrs->{$key}) {
63         my $info = $class->relationship_info($key);
64         if ($info && $info->{attrs}{accessor}
65           && $info->{attrs}{accessor} eq 'single')
66         {
67           my $rel_obj = $attrs->{$key};
68           $new->{_rel_in_storage} = 1;
69           if(!Scalar::Util::blessed($rel_obj)) {
70             $rel_obj = $new->new_related($key, $rel_obj);
71             $new->{_rel_in_storage} = 0;
72           }
73           $new->set_from_related($key, $attrs->{$key});        
74           $related->{$key} = $attrs->{$key};
75           next;
76         } elsif ($info && $info->{attrs}{accessor}
77             && $info->{attrs}{accessor} eq 'multi'
78             && ref $attrs->{$key} eq 'ARRAY') {
79             my $others = $attrs->{$key};
80             $new->{_rel_in_storage} = 1;
81             foreach my $rel_obj (@$others) {
82               if(!Scalar::Util::blessed($rel_obj)) {
83                 $rel_obj = $new->new_related($key, $rel_obj);
84                 $new->{_rel_in_storage} = 0;
85               }
86             }
87             $new->set_from_related($key, $others);
88             $related->{$key} = $attrs->{$key};
89         } elsif ($class->has_column($key)
90           && exists $class->column_info($key)->{_inflate_info})
91         {
92           ## 'filter' should disappear and get merged in with 'single' above!
93           my $rel_obj = $attrs->{$key};
94           $new->{_rel_in_storage} = 1;
95           if(!Scalar::Util::blessed($rel_obj)) {
96             $rel_obj = $new->new_related($key, $rel_obj);
97             $new->{_rel_in_storage} = 0;
98           }
99           $inflated->{$key} = $rel_obj;
100           next;
101         }
102       }
103       $new->throw_exception("No such column $key on $class")
104         unless $class->has_column($key);
105       $new->store_column($key => $attrs->{$key});          
106     }
107     if (my $source = delete $attrs->{-result_source}) {
108       $new->result_source($source);
109     }
110
111     $new->{_relationship_data} = $related if $related;
112     $new->{_inflated_column} = $inflated if $inflated;
113   }
114
115   return $new;
116 }
117
118 =head2 insert
119
120   $obj->insert;
121
122 Inserts an object into the database if it isn't already in
123 there. Returns the object itself. Requires the object's result source to
124 be set, or the class to have a result_source_instance method. To insert
125 an entirely new object into the database, use C<create> (see
126 L<DBIx::Class::ResultSet/create>).
127
128 =cut
129
130 sub insert {
131   my ($self) = @_;
132   return $self if $self->in_storage;
133   my $source = $self->result_source;
134   $source ||=  $self->result_source($self->result_source_instance)
135     if $self->can('result_source_instance');
136   $self->throw_exception("No result_source set on this object; can't insert")
137     unless $source;
138
139   # Check if we stored uninserted relobjs here in new()
140   $source->storage->txn_begin if(!$self->{_rel_in_storage});
141
142   my %related_stuff = (%{$self->{_relationship_data} || {}}, 
143                        %{$self->{_inflated_column} || {}});
144   ## Should all be in relationship_data, but we need to get rid of the
145   ## 'filter' reltype..
146   foreach my $relname (keys %related_stuff) {
147     my $relobj = $related_stuff{$relname};
148     if(ref $relobj ne 'ARRAY') {
149       $relobj->insert() if(!$relobj->in_storage);
150       $self->set_from_related($relname, $relobj);
151     }
152   }
153
154   $source->storage->insert($source->from, { $self->get_columns });
155
156   foreach my $relname (keys %related_stuff) {
157     my $relobj = $related_stuff{$relname};
158     if(ref $relobj eq 'ARRAY') {
159       foreach my $obj (@$relobj) {
160         my $info = $self->relationship_info($relname);
161         ## What about multi-col FKs ?
162         my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
163         $obj->set_from_related($key, $self);
164         $obj->insert() if(!$obj->in_storage);
165       }
166     }
167   }
168   $source->storage->txn_commit if(!$self->{_rel_in_storage});
169
170   $self->in_storage(1);
171   $self->{_dirty_columns} = {};
172   $self->{related_resultsets} = {};
173   undef $self->{_orig_ident};
174   return $self;
175 }
176
177 =head2 in_storage
178
179   $obj->in_storage; # Get value
180   $obj->in_storage(1); # Set value
181
182 Indicated whether the object exists as a row in the database or not
183
184 =cut
185
186 sub in_storage {
187   my ($self, $val) = @_;
188   $self->{_in_storage} = $val if @_ > 1;
189   return $self->{_in_storage};
190 }
191
192 =head2 update
193
194   $obj->update;
195
196 Must be run on an object that is already in the database; issues an SQL
197 UPDATE query to commit any changes to the object to the database if
198 required.
199
200 =cut
201
202 sub update {
203   my ($self, $upd) = @_;
204   $self->throw_exception( "Not in database" ) unless $self->in_storage;
205   my $ident_cond = $self->ident_condition;
206   $self->throw_exception("Cannot safely update a row in a PK-less table")
207     if ! keys %$ident_cond;
208
209   if ($upd) {
210     foreach my $key (keys %$upd) {
211       if (ref $upd->{$key}) {
212         my $info = $self->relationship_info($key);
213         if ($info && $info->{attrs}{accessor}
214           && $info->{attrs}{accessor} eq 'single')
215         {
216           my $rel = delete $upd->{$key};
217           $self->set_from_related($key => $rel);
218           $self->{_relationship_data}{$key} = $rel;          
219         } 
220         elsif ($self->has_column($key)
221           && exists $self->column_info($key)->{_inflate_info})
222         {
223           $self->set_inflated_column($key, delete $upd->{$key});          
224         }
225       }
226     }
227     $self->set_columns($upd);    
228   }
229   my %to_update = $self->get_dirty_columns;
230   return $self unless keys %to_update;
231   my $rows = $self->result_source->storage->update(
232                $self->result_source, \%to_update,
233                $self->{_orig_ident} || $ident_cond
234              );
235   if ($rows == 0) {
236     $self->throw_exception( "Can't update ${self}: row not found" );
237   } elsif ($rows > 1) {
238     $self->throw_exception("Can't update ${self}: updated more than one row");
239   }
240   $self->{_dirty_columns} = {};
241   $self->{related_resultsets} = {};
242   undef $self->{_orig_ident};
243   return $self;
244 }
245
246 =head2 delete
247
248   $obj->delete
249
250 Deletes the object from the database. The object is still perfectly
251 usable, but C<< ->in_storage() >> will now return 0 and the object must
252 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
253 on it. If you delete an object in a class with a C<has_many>
254 relationship, all the related objects will be deleted as well. To turn
255 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
256 hashref. Any database-level cascade or restrict will take precedence
257 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
258
259 =cut
260
261 sub delete {
262   my $self = shift;
263   if (ref $self) {
264     $self->throw_exception( "Not in database" ) unless $self->in_storage;
265     my $ident_cond = $self->ident_condition;
266     $self->throw_exception("Cannot safely delete a row in a PK-less table")
267       if ! keys %$ident_cond;
268     foreach my $column (keys %$ident_cond) {
269             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
270               unless exists $self->{_column_data}{$column};
271     }
272     $self->result_source->storage->delete(
273       $self->result_source, $ident_cond);
274     $self->in_storage(undef);
275   } else {
276     $self->throw_exception("Can't do class delete without a ResultSource instance")
277       unless $self->can('result_source_instance');
278     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
279     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
280     $self->result_source_instance->resultset->search(@_)->delete;
281   }
282   return $self;
283 }
284
285 =head2 get_column
286
287   my $val = $obj->get_column($col);
288
289 Gets a column value from a row object. Does not do any queries; the column 
290 must have already been fetched from the database and stored in the object. If 
291 there is an inflated value stored that has not yet been deflated, it is deflated
292 when the method is invoked.
293
294 =cut
295
296 sub get_column {
297   my ($self, $column) = @_;
298   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
299   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
300   if (exists $self->{_inflated_column}{$column}) {
301     return $self->store_column($column,
302       $self->_deflated_column($column, $self->{_inflated_column}{$column}));   
303   }
304   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
305   return undef;
306 }
307
308 =head2 has_column_loaded
309
310   if ( $obj->has_column_loaded($col) ) {
311      print "$col has been loaded from db";
312   }
313
314 Returns a true value if the column value has been loaded from the
315 database (or set locally).
316
317 =cut
318
319 sub has_column_loaded {
320   my ($self, $column) = @_;
321   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
322   return 1 if exists $self->{_inflated_column}{$column};
323   return exists $self->{_column_data}{$column};
324 }
325
326 =head2 get_columns
327
328   my %data = $obj->get_columns;
329
330 Does C<get_column>, for all column values at once.
331
332 =cut
333
334 sub get_columns {
335   my $self = shift;
336   if (exists $self->{_inflated_column}) {
337     foreach my $col (keys %{$self->{_inflated_column}}) {
338       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
339         unless exists $self->{_column_data}{$col};
340     }
341   }
342   return %{$self->{_column_data}};
343 }
344
345 =head2 get_dirty_columns
346
347   my %data = $obj->get_dirty_columns;
348
349 Identical to get_columns but only returns those that have been changed.
350
351 =cut
352
353 sub get_dirty_columns {
354   my $self = shift;
355   return map { $_ => $self->{_column_data}{$_} }
356            keys %{$self->{_dirty_columns}};
357 }
358
359 =head2 set_column
360
361   $obj->set_column($col => $val);
362
363 Sets a column value. If the new value is different from the old one,
364 the column is marked as dirty for when you next call $obj->update.
365
366 =cut
367
368 sub set_column {
369   my $self = shift;
370   my ($column) = @_;
371   $self->{_orig_ident} ||= $self->ident_condition;
372   my $old = $self->get_column($column);
373   my $ret = $self->store_column(@_);
374   $self->{_dirty_columns}{$column} = 1
375     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
376   return $ret;
377 }
378
379 =head2 set_columns
380
381   my $copy = $orig->set_columns({ $col => $val, ... });
382
383 Sets more than one column value at once.
384
385 =cut
386
387 sub set_columns {
388   my ($self,$data) = @_;
389   foreach my $col (keys %$data) {
390     $self->set_column($col,$data->{$col});
391   }
392   return $self;
393 }
394
395 =head2 copy
396
397   my $copy = $orig->copy({ change => $to, ... });
398
399 Inserts a new row with the specified changes.
400
401 =cut
402
403 sub copy {
404   my ($self, $changes) = @_;
405   $changes ||= {};
406   my $col_data = { %{$self->{_column_data}} };
407   foreach my $col (keys %$col_data) {
408     delete $col_data->{$col}
409       if $self->result_source->column_info($col)->{is_auto_increment};
410   }
411
412   my $new = { _column_data => $col_data };
413   bless $new, ref $self;
414
415   $new->result_source($self->result_source);
416   $new->set_columns($changes);
417   $new->insert;
418   foreach my $rel ($self->result_source->relationships) {
419     my $rel_info = $self->result_source->relationship_info($rel);
420     if ($rel_info->{attrs}{cascade_copy}) {
421       my $resolved = $self->result_source->resolve_condition(
422        $rel_info->{cond}, $rel, $new);
423       foreach my $related ($self->search_related($rel)) {
424         $related->copy($resolved);
425       }
426     }
427   }
428   return $new;
429 }
430
431 =head2 store_column
432
433   $obj->store_column($col => $val);
434
435 Sets a column value without marking it as dirty.
436
437 =cut
438
439 sub store_column {
440   my ($self, $column, $value) = @_;
441   $self->throw_exception( "No such column '${column}'" )
442     unless exists $self->{_column_data}{$column} || $self->has_column($column);
443   $self->throw_exception( "set_column called for ${column} without value" )
444     if @_ < 3;
445   return $self->{_column_data}{$column} = $value;
446 }
447
448 =head2 inflate_result
449
450   Class->inflate_result($result_source, \%me, \%prefetch?)
451
452 Called by ResultSet to inflate a result from storage
453
454 =cut
455
456 sub inflate_result {
457   my ($class, $source, $me, $prefetch) = @_;
458
459   my ($source_handle) = $source;
460
461   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
462       $source = $source_handle->resolve
463   } else {
464       $source_handle = $source->handle
465   }
466
467   my $new = {
468     _source_handle => $source_handle,
469     _column_data => $me,
470     _in_storage => 1
471   };
472   bless $new, (ref $class || $class);
473
474   my $schema;
475   foreach my $pre (keys %{$prefetch||{}}) {
476     my $pre_val = $prefetch->{$pre};
477     my $pre_source = $source->related_source($pre);
478     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
479       unless $pre_source;
480     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
481       my @pre_objects;
482       foreach my $pre_rec (@$pre_val) {
483         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
484            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
485           next;
486         }
487         push(@pre_objects, $pre_source->result_class->inflate_result(
488                              $pre_source, @{$pre_rec}));
489       }
490       $new->related_resultset($pre)->set_cache(\@pre_objects);
491     } elsif (defined $pre_val->[0]) {
492       my $fetched;
493       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
494          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
495       {
496         $fetched = $pre_source->result_class->inflate_result(
497                       $pre_source, @{$pre_val});
498       }
499       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
500       $class->throw_exception("No accessor for prefetched $pre")
501        unless defined $accessor;
502       if ($accessor eq 'single') {
503         $new->{_relationship_data}{$pre} = $fetched;
504       } elsif ($accessor eq 'filter') {
505         $new->{_inflated_column}{$pre} = $fetched;
506       } else {
507        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
508       }
509     }
510   }
511   return $new;
512 }
513
514 =head2 update_or_insert
515
516   $obj->update_or_insert
517
518 Updates the object if it's already in the db, else inserts it.
519
520 =head2 insert_or_update
521
522   $obj->insert_or_update
523
524 Alias for L</update_or_insert>
525
526 =cut
527
528 *insert_or_update = \&update_or_insert;
529 sub update_or_insert {
530   my $self = shift;
531   return ($self->in_storage ? $self->update : $self->insert);
532 }
533
534 =head2 is_changed
535
536   my @changed_col_names = $obj->is_changed();
537   if ($obj->is_changed()) { ... }
538
539 In array context returns a list of columns with uncommited changes, or
540 in scalar context returns a true value if there are uncommitted
541 changes.
542
543 =cut
544
545 sub is_changed {
546   return keys %{shift->{_dirty_columns} || {}};
547 }
548
549 =head2 is_column_changed
550
551   if ($obj->is_column_changed('col')) { ... }
552
553 Returns a true value if the column has uncommitted changes.
554
555 =cut
556
557 sub is_column_changed {
558   my( $self, $col ) = @_;
559   return exists $self->{_dirty_columns}->{$col};
560 }
561
562 =head2 result_source
563
564   my $resultsource = $object->result_source;
565
566 Accessor to the ResultSource this object was created from
567
568 =cut
569
570 sub result_source {
571     my $self = shift;
572
573     if (@_) {
574         $self->_source_handle($_[0]->handle);
575     } else {
576         $self->_source_handle->resolve;
577     }
578 }
579
580 =head2 register_column
581
582   $column_info = { .... };
583   $class->register_column($column_name, $column_info);
584
585 Registers a column on the class. If the column_info has an 'accessor'
586 key, creates an accessor named after the value if defined; if there is
587 no such key, creates an accessor with the same name as the column
588
589 The column_info attributes are described in
590 L<DBIx::Class::ResultSource/add_columns>
591
592 =cut
593
594 sub register_column {
595   my ($class, $col, $info) = @_;
596   my $acc = $col;
597   if (exists $info->{accessor}) {
598     return unless defined $info->{accessor};
599     $acc = [ $info->{accessor}, $col ];
600   }
601   $class->mk_group_accessors('column' => $acc);
602 }
603
604
605 =head2 throw_exception
606
607 See Schema's throw_exception.
608
609 =cut
610
611 sub throw_exception {
612   my $self=shift;
613   if (ref $self && ref $self->result_source) {
614     $self->result_source->schema->throw_exception(@_);
615   } else {
616     croak(@_);
617   }
618 }
619
620 1;
621
622 =head1 AUTHORS
623
624 Matt S. Trout <mst@shadowcatsystems.co.uk>
625
626 =head1 LICENSE
627
628 You may distribute this code under the same terms as Perl itself.
629
630 =cut