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