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