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