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