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