resultset_class/result_class now (again) auto loads the specified class; requires...
[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 set_column
296
297   $obj->set_column($col => $val);
298
299 Sets a column value. If the new value is different from the old one,
300 the column is marked as dirty for when you next call $obj->update.
301
302 =cut
303
304 sub set_column {
305   my $self = shift;
306   my ($column) = @_;
307   $self->{_orig_ident} ||= $self->ident_condition;
308   my $old = $self->get_column($column);
309   my $ret = $self->store_column(@_);
310   $self->{_dirty_columns}{$column} = 1
311     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
312   return $ret;
313 }
314
315 =head2 set_columns
316
317   my $copy = $orig->set_columns({ $col => $val, ... });
318
319 Sets more than one column value at once.
320
321 =cut
322
323 sub set_columns {
324   my ($self,$data) = @_;
325   foreach my $col (keys %$data) {
326     $self->set_column($col,$data->{$col});
327   }
328   return $self;
329 }
330
331 =head2 copy
332
333   my $copy = $orig->copy({ change => $to, ... });
334
335 Inserts a new row with the specified changes.
336
337 =cut
338
339 sub copy {
340   my ($self, $changes) = @_;
341   $changes ||= {};
342   my $col_data = { %{$self->{_column_data}} };
343   foreach my $col (keys %$col_data) {
344     delete $col_data->{$col}
345       if $self->result_source->column_info($col)->{is_auto_increment};
346   }
347
348   my $new = { _column_data => $col_data };
349   bless $new, ref $self;
350
351   $new->result_source($self->result_source);
352   $new->set_columns($changes);
353   $new->insert;
354   foreach my $rel ($self->result_source->relationships) {
355     my $rel_info = $self->result_source->relationship_info($rel);
356     if ($rel_info->{attrs}{cascade_copy}) {
357       my $resolved = $self->result_source->resolve_condition(
358        $rel_info->{cond}, $rel, $new);
359       foreach my $related ($self->search_related($rel)) {
360         $related->copy($resolved);
361       }
362     }
363   }
364   return $new;
365 }
366
367 =head2 store_column
368
369   $obj->store_column($col => $val);
370
371 Sets a column value without marking it as dirty.
372
373 =cut
374
375 sub store_column {
376   my ($self, $column, $value) = @_;
377   $self->throw_exception( "No such column '${column}'" )
378     unless exists $self->{_column_data}{$column} || $self->has_column($column);
379   $self->throw_exception( "set_column called for ${column} without value" )
380     if @_ < 3;
381   return $self->{_column_data}{$column} = $value;
382 }
383
384 =head2 inflate_result
385
386   Class->inflate_result($result_source, \%me, \%prefetch?)
387
388 Called by ResultSet to inflate a result from storage
389
390 =cut
391
392 sub inflate_result {
393   my ($class, $source, $me, $prefetch) = @_;
394
395   my ($source_handle) = $source;
396
397   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
398       $source = $source_handle->resolve
399   } else {
400       $source_handle = $source->handle
401   }
402
403   my $new = {
404     _source_handle => $source_handle,
405     _column_data => $me,
406     _in_storage => 1
407   };
408   bless $new, (ref $class || $class);
409
410   my $schema;
411   foreach my $pre (keys %{$prefetch||{}}) {
412     my $pre_val = $prefetch->{$pre};
413     my $pre_source = $source->related_source($pre);
414     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
415       unless $pre_source;
416     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
417       my @pre_objects;
418       foreach my $pre_rec (@$pre_val) {
419         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
420            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
421           next;
422         }
423         push(@pre_objects, $pre_source->result_class->inflate_result(
424                              $pre_source, @{$pre_rec}));
425       }
426       $new->related_resultset($pre)->set_cache(\@pre_objects);
427     } elsif (defined $pre_val->[0]) {
428       my $fetched;
429       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
430          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
431       {
432         $fetched = $pre_source->result_class->inflate_result(
433                       $pre_source, @{$pre_val});
434       }
435       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
436       $class->throw_exception("No accessor for prefetched $pre")
437        unless defined $accessor;
438       if ($accessor eq 'single') {
439         $new->{_relationship_data}{$pre} = $fetched;
440       } elsif ($accessor eq 'filter') {
441         $new->{_inflated_column}{$pre} = $fetched;
442       } else {
443        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
444       }
445     }
446   }
447   return $new;
448 }
449
450 =head2 update_or_insert
451
452   $obj->update_or_insert
453
454 Updates the object if it's already in the db, else inserts it.
455
456 =head2 insert_or_update
457
458   $obj->insert_or_update
459
460 Alias for L</update_or_insert>
461
462 =cut
463
464 *insert_or_update = \&update_or_insert;
465 sub update_or_insert {
466   my $self = shift;
467   return ($self->in_storage ? $self->update : $self->insert);
468 }
469
470 =head2 is_changed
471
472   my @changed_col_names = $obj->is_changed();
473   if ($obj->is_changed()) { ... }
474
475 In array context returns a list of columns with uncommited changes, or
476 in scalar context returns a true value if there are uncommitted
477 changes.
478
479 =cut
480
481 sub is_changed {
482   return keys %{shift->{_dirty_columns} || {}};
483 }
484
485 =head2 is_column_changed
486
487   if ($obj->is_column_changed('col')) { ... }
488
489 Returns a true value if the column has uncommitted changes.
490
491 =cut
492
493 sub is_column_changed {
494   my( $self, $col ) = @_;
495   return exists $self->{_dirty_columns}->{$col};
496 }
497
498 =head2 result_source
499
500   my $resultsource = $object->result_source;
501
502 Accessor to the ResultSource this object was created from
503
504 =cut
505
506 sub result_source {
507     my $self = shift;
508
509     if (@_) {
510         $self->_source_handle($_[0]->handle);
511     } else {
512         $self->_source_handle->resolve;
513     }
514 }
515
516 =head2 register_column
517
518   $column_info = { .... };
519   $class->register_column($column_name, $column_info);
520
521 Registers a column on the class. If the column_info has an 'accessor'
522 key, creates an accessor named after the value if defined; if there is
523 no such key, creates an accessor with the same name as the column
524
525 The column_info attributes are described in
526 L<DBIx::Class::ResultSource/add_columns>
527
528 =cut
529
530 sub register_column {
531   my ($class, $col, $info) = @_;
532   my $acc = $col;
533   if (exists $info->{accessor}) {
534     return unless defined $info->{accessor};
535     $acc = [ $info->{accessor}, $col ];
536   }
537   $class->mk_group_accessors('column' => $acc);
538 }
539
540
541 =head2 throw_exception
542
543 See Schema's throw_exception.
544
545 =cut
546
547 sub throw_exception {
548   my $self=shift;
549   if (ref $self && ref $self->result_source) {
550     $self->result_source->schema->throw_exception(@_);
551   } else {
552     croak(@_);
553   }
554 }
555
556 1;
557
558 =head1 AUTHORS
559
560 Matt S. Trout <mst@shadowcatsystems.co.uk>
561
562 =head1 LICENSE
563
564 You may distribute this code under the same terms as Perl itself.
565
566 =cut