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