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