Add automatic naming of unique constraints
[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 sub has_column_loaded {
174   my ($self, $column) = @_;
175   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
176   return exists $self->{_column_data}{$column};
177 }
178
179 =head2 get_columns
180
181   my %data = $obj->get_columns;
182
183 Does C<get_column>, for all column values at once.
184
185 =cut
186
187 sub get_columns {
188   my $self = shift;
189   return %{$self->{_column_data}};
190 }
191
192 =head2 get_dirty_columns
193
194   my %data = $obj->get_dirty_columns;
195
196 Identical to get_columns but only returns those that have been changed.
197
198 =cut
199
200 sub get_dirty_columns {
201   my $self = shift;
202   return map { $_ => $self->{_column_data}{$_} }
203            keys %{$self->{_dirty_columns}};
204 }
205
206 =head2 set_column
207
208   $obj->set_column($col => $val);
209
210 Sets a column value. If the new value is different from the old one,
211 the column is marked as dirty for when you next call $obj->update.
212
213 =cut
214
215 sub set_column {
216   my $self = shift;
217   my ($column) = @_;
218   my $old = $self->get_column($column);
219   my $ret = $self->store_column(@_);
220   $self->{_dirty_columns}{$column} = 1
221     if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
222   return $ret;
223 }
224
225 =head2 set_columns
226
227   my $copy = $orig->set_columns({ $col => $val, ... });
228
229 Sets more than one column value at once.
230
231 =cut
232
233 sub set_columns {
234   my ($self,$data) = @_;
235   foreach my $col (keys %$data) {
236     $self->set_column($col,$data->{$col});
237   }
238   return $self;
239 }
240
241 =head2 copy
242
243   my $copy = $orig->copy({ change => $to, ... });
244
245 Inserts a new row with the specified changes.
246
247 =cut
248
249 sub copy {
250   my ($self, $changes) = @_;
251   $changes ||= {};
252   my $col_data = { %{$self->{_column_data}} };
253   foreach my $col (keys %$col_data) {
254     delete $col_data->{$col}
255       if $self->result_source->column_info($col)->{is_auto_increment};
256   }
257   my $new = bless { _column_data => $col_data }, ref $self;
258   $new->result_source($self->result_source);
259   $new->set_columns($changes);
260   $new->insert;
261   foreach my $rel ($self->result_source->relationships) {
262     my $rel_info = $self->result_source->relationship_info($rel);
263     if ($rel_info->{attrs}{cascade_copy}) {
264       my $resolved = $self->result_source->resolve_condition(
265        $rel_info->{cond}, $rel, $new);
266       foreach my $related ($self->search_related($rel)) {
267         $related->copy($resolved);
268       }
269     }
270   }
271   return $new;
272 }
273
274 =head2 store_column
275
276   $obj->store_column($col => $val);
277
278 Sets a column value without marking it as dirty.
279
280 =cut
281
282 sub store_column {
283   my ($self, $column, $value) = @_;
284   $self->throw_exception( "No such column '${column}'" )
285     unless exists $self->{_column_data}{$column} || $self->has_column($column);
286   $self->throw_exception( "set_column called for ${column} without value" )
287     if @_ < 3;
288   return $self->{_column_data}{$column} = $value;
289 }
290
291 =head2 inflate_result
292
293   Class->inflate_result($result_source, \%me, \%prefetch?)
294
295 Called by ResultSet to inflate a result from storage
296
297 =cut
298
299 sub inflate_result {
300   my ($class, $source, $me, $prefetch) = @_;
301   #use Data::Dumper; print Dumper(@_);
302   my $new = bless({ result_source => $source,
303                     _column_data => $me,
304                     _in_storage => 1
305                   },
306                   ref $class || $class);
307   my $schema;
308   foreach my $pre (keys %{$prefetch||{}}) {
309     my $pre_val = $prefetch->{$pre};
310     my $pre_source = $source->related_source($pre);
311     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
312       unless $pre_source;
313     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
314       my @pre_objects;
315       foreach my $pre_rec (@$pre_val) {
316         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
317            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
318           next;
319         }
320         push(@pre_objects, $pre_source->result_class->inflate_result(
321                              $pre_source, @{$pre_rec}));
322       }
323       $new->related_resultset($pre)->set_cache(\@pre_objects);
324     } elsif (defined $pre_val->[0]) {
325       my $fetched;
326       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
327          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
328       {
329         $fetched = $pre_source->result_class->inflate_result(
330                       $pre_source, @{$pre_val});
331       }
332       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
333       $class->throw_exception("No accessor for prefetched $pre")
334        unless defined $accessor;
335       if ($accessor eq 'single') {
336         $new->{_relationship_data}{$pre} = $fetched;
337       } elsif ($accessor eq 'filter') {
338         $new->{_inflated_column}{$pre} = $fetched;
339       } else {
340        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
341       }
342     }
343   }
344   return $new;
345 }
346
347 =head2 update_or_insert
348
349   $obj->update_or_insert
350
351 Updates the object if it's already in the db, else inserts it.
352
353 =cut
354
355 *insert_or_update = \&update_or_insert;
356 sub update_or_insert {
357   my $self = shift;
358   return ($self->in_storage ? $self->update : $self->insert);
359 }
360
361 =head2 is_changed
362
363   my @changed_col_names = $obj->is_changed();
364   if ($obj->is_changed()) { ... }
365
366 =cut
367
368 sub is_changed {
369   return keys %{shift->{_dirty_columns} || {}};
370 }
371
372 =head2 is_column_changed
373
374   if ($obj->is_column_changed('col')) { ... }
375
376 =cut
377
378 sub is_column_changed {
379   my( $self, $col ) = @_;
380   return exists $self->{_dirty_columns}->{$col};
381 }
382
383 =head2 result_source
384
385   Accessor to the ResultSource this object was created from
386
387 =head2 register_column
388
389 =over 4
390
391 =item Arguments: $column, $column_info
392
393 =back
394
395   Registers a column on the class. If the column_info has an 'accessor' key,
396   creates an accessor named after the value if defined; if there is no such
397   key, creates an accessor with the same name as the column
398
399 =cut
400
401 sub register_column {
402   my ($class, $col, $info) = @_;
403   my $acc = $col;
404   if (exists $info->{accessor}) {
405     return unless defined $info->{accessor};
406     $acc = [ $info->{accessor}, $col ];
407   }
408   $class->mk_group_accessors('column' => $acc);
409 }
410
411
412 =head2 throw_exception
413
414 See Schema's throw_exception.
415
416 =cut
417
418 sub throw_exception {
419   my $self=shift;
420   if (ref $self && ref $self->result_source) {
421     $self->result_source->schema->throw_exception(@_);
422   } else {
423     croak(@_);
424   }
425 }
426
427 1;
428
429 =head1 AUTHORS
430
431 Matt S. Trout <mst@shadowcatsystems.co.uk>
432
433 =head1 LICENSE
434
435 You may distribute this code under the same terms as Perl itself.
436
437 =cut
438