Merge 'subquery' into 'trunk'
[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 use Scalar::Util ();
9 use Scope::Guard;
10
11 BEGIN {
12   *MULTICREATE_DEBUG =
13     $ENV{DBIC_MULTICREATE_DEBUG}
14       ? sub () { 1 }
15       : sub () { 0 };
16 }
17
18 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
19
20 =head1 NAME
21
22 DBIx::Class::Row - Basic row methods
23
24 =head1 SYNOPSIS
25
26 =head1 DESCRIPTION
27
28 This class is responsible for defining and doing basic operations on rows
29 derived from L<DBIx::Class::ResultSource> objects.
30
31 Row objects are returned from L<DBIx::Class::ResultSet>s using the
32 L<create|DBIx::Class::ResultSet/create>, L<find|DBIx::Class::ResultSet/find>,
33 L<next|DBIx::Class::ResultSet/next> and L<all|DBIx::Class::ResultSet/all> methods,
34 as well as invocations of 'single' (
35 L<belongs_to|DBIx::Class::Relationship/belongs_to>,
36 L<has_one|DBIx::Class::Relationship/has_one> or
37 L<might_have|DBIx::Class::Relationship/might_have>)
38 relationship accessors of L<DBIx::Class::Row> objects.
39
40 =head1 METHODS
41
42 =head2 new
43
44   my $row = My::Class->new(\%attrs);
45
46   my $row = $schema->resultset('MySource')->new(\%colsandvalues);
47
48 =over
49
50 =item Arguments: \%attrs or \%colsandvalues
51
52 =item Returns: A Row object
53
54 =back
55
56 While you can create a new row object by calling C<new> directly on
57 this class, you are better off calling it on a
58 L<DBIx::Class::ResultSet> object.
59
60 When calling it directly, you will not get a complete, usable row
61 object until you pass or set the C<source_handle> attribute, to a
62 L<DBIx::Class::ResultSource> instance that is attached to a
63 L<DBIx::Class::Schema> with a valid connection.
64
65 C<$attrs> is a hashref of column name, value data. It can also contain
66 some other attributes such as the C<source_handle>.
67
68 Passing an object, or an arrayref of objects as a value will call
69 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
70 passed a hashref or an arrayref of hashrefs as the value, these will
71 be turned into objects via new_related, and treated as if you had
72 passed objects.
73
74 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
75
76 =cut
77
78 ## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
79 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
80 ## When doing the later insert, we need to make sure the PKs are set.
81 ## using _relationship_data in new and funky ways..
82 ## check Relationship::CascadeActions and Relationship::Accessor for compat
83 ## tests!
84
85 sub __new_related_find_or_new_helper {
86   my ($self, $relname, $data) = @_;
87   if ($self->__their_pk_needs_us($relname, $data)) {
88     return $self->result_source
89                 ->related_source($relname)
90                 ->resultset
91                 ->new_result($data);
92   }
93   if ($self->result_source->pk_depends_on($relname, $data)) {
94     return $self->result_source
95                 ->related_source($relname)
96                 ->resultset
97                 ->find_or_create($data);
98   }
99   return $self->find_or_new_related($relname, $data);
100 }
101
102 sub __their_pk_needs_us { # this should maybe be in resultsource.
103   my ($self, $relname, $data) = @_;
104   my $source = $self->result_source;
105   my $reverse = $source->reverse_relationship_info($relname);
106   my $rel_source = $source->related_source($relname);
107   my $us = { $self->get_columns };
108   foreach my $key (keys %$reverse) {
109     # if their primary key depends on us, then we have to
110     # just create a result and we'll fill it out afterwards
111     return 1 if $rel_source->pk_depends_on($key, $us);
112   }
113   return 0;
114 }
115
116 sub new {
117   my ($class, $attrs) = @_;
118   $class = ref $class if ref $class;
119
120   my $new = {
121       _column_data          => {},
122   };
123   bless $new, $class;
124
125   if (my $handle = delete $attrs->{-source_handle}) {
126     $new->_source_handle($handle);
127   }
128
129   my $source;
130   if ($source = delete $attrs->{-result_source}) {
131     $new->result_source($source);
132   }
133
134   if ($attrs) {
135     $new->throw_exception("attrs must be a hashref")
136       unless ref($attrs) eq 'HASH';
137     
138     my ($related,$inflated);
139     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
140     $new->{_rel_in_storage} = 1;
141
142     foreach my $key (keys %$attrs) {
143       if (ref $attrs->{$key}) {
144         ## Can we extract this lot to use with update(_or .. ) ?
145         confess "Can't do multi-create without result source" unless $source;
146         my $info = $source->relationship_info($key);
147         if ($info && $info->{attrs}{accessor}
148           && $info->{attrs}{accessor} eq 'single')
149         {
150           my $rel_obj = delete $attrs->{$key};
151           if(!Scalar::Util::blessed($rel_obj)) {
152             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
153           }
154
155           if ($rel_obj->in_storage) {
156             $new->set_from_related($key, $rel_obj);
157           } else {
158             $new->{_rel_in_storage} = 0;
159             MULTICREATE_DEBUG and warn "MC $new: uninserted $key $rel_obj\n";
160           }
161
162           $related->{$key} = $rel_obj;
163           next;
164         } elsif ($info && $info->{attrs}{accessor}
165             && $info->{attrs}{accessor} eq 'multi'
166             && ref $attrs->{$key} eq 'ARRAY') {
167           my $others = delete $attrs->{$key};
168           my $total = @$others;
169           my @objects;
170           foreach my $idx (0 .. $#$others) {
171             my $rel_obj = $others->[$idx];
172             if(!Scalar::Util::blessed($rel_obj)) {
173               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
174             }
175
176             if ($rel_obj->in_storage) {
177               $new->set_from_related($key, $rel_obj);
178             } else {
179               $new->{_rel_in_storage} = 0;
180               MULTICREATE_DEBUG and
181                 warn "MC $new: uninserted $key $rel_obj ($idx of $total)\n";
182             }
183             $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
184             push(@objects, $rel_obj);
185           }
186           $related->{$key} = \@objects;
187           next;
188         } elsif ($info && $info->{attrs}{accessor}
189           && $info->{attrs}{accessor} eq 'filter')
190         {
191           ## 'filter' should disappear and get merged in with 'single' above!
192           my $rel_obj = delete $attrs->{$key};
193           if(!Scalar::Util::blessed($rel_obj)) {
194             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
195           }
196           unless ($rel_obj->in_storage) {
197             $new->{_rel_in_storage} = 0;
198             MULTICREATE_DEBUG and warn "MC $new: uninserted $key $rel_obj";
199           }
200           $inflated->{$key} = $rel_obj;
201           next;
202         } elsif ($class->has_column($key)
203             && $class->column_info($key)->{_inflate_info}) {
204           $inflated->{$key} = $attrs->{$key};
205           next;
206         }
207       }
208       $new->throw_exception("No such column $key on $class")
209         unless $class->has_column($key);
210       $new->store_column($key => $attrs->{$key});          
211     }
212
213     $new->{_relationship_data} = $related if $related;
214     $new->{_inflated_column} = $inflated if $inflated;
215   }
216
217   return $new;
218 }
219
220 =head2 insert
221
222   $row->insert;
223
224 =over
225
226 =item Arguments: none
227
228 =item Returns: The Row object
229
230 =back
231
232 Inserts an object previously created by L</new> into the database if
233 it isn't already in there. Returns the object itself. Requires the
234 object's result source to be set, or the class to have a
235 result_source_instance method. To insert an entirely new row into
236 the database, use C<create> (see L<DBIx::Class::ResultSet/create>).
237
238 To fetch an uninserted row object, call
239 L<new|DBIx::Class::ResultSet/new> on a resultset.
240
241 This will also insert any uninserted, related objects held inside this
242 one, see L<DBIx::Class::ResultSet/create> for more details.
243
244 =cut
245
246 sub insert {
247   my ($self) = @_;
248   return $self if $self->in_storage;
249   my $source = $self->result_source;
250   $source ||=  $self->result_source($self->result_source_instance)
251     if $self->can('result_source_instance');
252   $self->throw_exception("No result_source set on this object; can't insert")
253     unless $source;
254
255   my $rollback_guard;
256
257   # Check if we stored uninserted relobjs here in new()
258   my %related_stuff = (%{$self->{_relationship_data} || {}}, 
259                        %{$self->{_inflated_column} || {}});
260
261   if(!$self->{_rel_in_storage}) {
262
263     # The guard will save us if we blow out of this scope via die
264     $rollback_guard = $source->storage->txn_scope_guard;
265
266     ## Should all be in relationship_data, but we need to get rid of the
267     ## 'filter' reltype..
268     ## These are the FK rels, need their IDs for the insert.
269
270     my @pri = $self->primary_columns;
271
272     REL: foreach my $relname (keys %related_stuff) {
273
274       my $rel_obj = $related_stuff{$relname};
275
276       next REL unless (Scalar::Util::blessed($rel_obj)
277                        && $rel_obj->isa('DBIx::Class::Row'));
278
279       next REL unless $source->pk_depends_on(
280                         $relname, { $rel_obj->get_columns }
281                       );
282
283       MULTICREATE_DEBUG and warn "MC $self pre-inserting $relname $rel_obj\n";
284
285       $rel_obj->insert();
286       $self->set_from_related($relname, $rel_obj);
287       delete $related_stuff{$relname};
288     }
289   }
290
291   MULTICREATE_DEBUG and warn "MC $self inserting self\n";
292   my $updated_cols = $source->storage->insert($source, { $self->get_columns });
293   foreach my $col (keys %$updated_cols) {
294     $self->store_column($col, $updated_cols->{$col});
295   }
296
297   ## PK::Auto
298   my @auto_pri = grep {
299                    !defined $self->get_column($_) || 
300                    ref($self->get_column($_)) eq 'SCALAR'
301                  } $self->primary_columns;
302
303   if (@auto_pri) {
304     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
305     #  if defined $too_many;
306     MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\n";
307     my $storage = $self->result_source->storage;
308     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
309       unless $storage->can('last_insert_id');
310     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
311     $self->throw_exception( "Can't get last insert id" )
312       unless (@ids == @auto_pri);
313     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
314 #use Data::Dumper; warn Dumper($self);
315   }
316
317
318   $self->{_dirty_columns} = {};
319   $self->{related_resultsets} = {};
320
321   if(!$self->{_rel_in_storage}) {
322     ## Now do the has_many rels, that need $selfs ID.
323     foreach my $relname (keys %related_stuff) {
324       my $rel_obj = $related_stuff{$relname};
325       my @cands;
326       if (Scalar::Util::blessed($rel_obj)
327           && $rel_obj->isa('DBIx::Class::Row')) {
328         @cands = ($rel_obj);
329       } elsif (ref $rel_obj eq 'ARRAY') {
330         @cands = @$rel_obj;
331       }
332       if (@cands) {
333         my $reverse = $source->reverse_relationship_info($relname);
334         foreach my $obj (@cands) {
335           $obj->set_from_related($_, $self) for keys %$reverse;
336           my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
337           if ($self->__their_pk_needs_us($relname, $them)) {
338             MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
339             my $re = $self->find_or_create_related($relname, $them);
340             $obj->{_column_data} = $re->{_column_data};
341             MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
342           } else {
343             MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
344             $obj->insert();
345           }
346         }
347       }
348     }
349     $rollback_guard->commit;
350   }
351
352   $self->in_storage(1);
353   undef $self->{_orig_ident};
354   return $self;
355 }
356
357 =head2 in_storage
358
359   $row->in_storage; # Get value
360   $row->in_storage(1); # Set value
361
362 =over
363
364 =item Arguments: none or 1|0
365
366 =item Returns: 1|0
367
368 =back
369
370 Indicates whether the object exists as a row in the database or
371 not. This is set to true when L<DBIx::Class::ResultSet/find>,
372 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
373 are used. 
374
375 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
376 L</delete> on one, sets it to false.
377
378 =cut
379
380 sub in_storage {
381   my ($self, $val) = @_;
382   $self->{_in_storage} = $val if @_ > 1;
383   return $self->{_in_storage};
384 }
385
386 =head2 update
387
388   $row->update(\%columns?)
389
390 =over
391
392 =item Arguments: none or a hashref
393
394 =item Returns: The Row object
395
396 =back
397
398 Throws an exception if the row object is not yet in the database,
399 according to L</in_storage>.
400
401 This method issues an SQL UPDATE query to commit any changes to the
402 object to the database if required.
403
404 Also takes an optional hashref of C<< column_name => value> >> pairs
405 to update on the object first. Be aware that the hashref will be
406 passed to C<set_inflated_columns>, which might edit it in place, so
407 don't rely on it being the same after a call to C<update>.  If you
408 need to preserve the hashref, it is sufficient to pass a shallow copy
409 to C<update>, e.g. ( { %{ $href } } )
410
411 If the values passed or any of the column values set on the object
412 contain scalar references, eg:
413
414   $row->last_modified(\'NOW()');
415   # OR
416   $row->update({ last_modified => \'NOW()' });
417
418 The update will pass the values verbatim into SQL. (See
419 L<SQL::Abstract> docs).  The values in your Row object will NOT change
420 as a result of the update call, if you want the object to be updated
421 with the actual values from the database, call L</discard_changes>
422 after the update.
423
424   $row->update()->discard_changes();
425
426 To determine before calling this method, which column values have
427 changed and will be updated, call L</get_dirty_columns>.
428
429 To check if any columns will be updated, call L</is_changed>.
430
431 To force a column to be updated, call L</make_column_dirty> before
432 this method.
433
434 =cut
435
436 sub update {
437   my ($self, $upd) = @_;
438   $self->throw_exception( "Not in database" ) unless $self->in_storage;
439   my $ident_cond = $self->ident_condition;
440   $self->throw_exception("Cannot safely update a row in a PK-less table")
441     if ! keys %$ident_cond;
442
443   $self->set_inflated_columns($upd) if $upd;
444   my %to_update = $self->get_dirty_columns;
445   return $self unless keys %to_update;
446   my $rows = $self->result_source->storage->update(
447                $self->result_source, \%to_update,
448                $self->{_orig_ident} || $ident_cond
449              );
450   if ($rows == 0) {
451     $self->throw_exception( "Can't update ${self}: row not found" );
452   } elsif ($rows > 1) {
453     $self->throw_exception("Can't update ${self}: updated more than one row");
454   }
455   $self->{_dirty_columns} = {};
456   $self->{related_resultsets} = {};
457   undef $self->{_orig_ident};
458   return $self;
459 }
460
461 =head2 delete
462
463   $row->delete
464
465 =over
466
467 =item Arguments: none
468
469 =item Returns: The Row object
470
471 =back
472
473 Throws an exception if the object is not in the database according to
474 L</in_storage>. Runs an SQL DELETE statement using the primary key
475 values to locate the row.
476
477 The object is still perfectly usable, but L</in_storage> will
478 now return 0 and the object must be reinserted using L</insert>
479 before it can be used to L</update> the row again. 
480
481 If you delete an object in a class with a C<has_many> relationship, an
482 attempt is made to delete all the related objects as well. To turn
483 this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
484 hashref of the relationship, see L<DBIx::Class::Relationship>. Any
485 database-level cascade or restrict will take precedence over a
486 DBIx-Class-based cascading delete. 
487
488 If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
489 and the transaction subsequently fails, the row object will remain marked as
490 not being in storage. If you know for a fact that the object is still in
491 storage (i.e. by inspecting the cause of the transaction's failure), you can
492 use C<< $obj->in_storage(1) >> to restore consistency between the object and
493 the database. This would allow a subsequent C<< $obj->delete >> to work
494 as expected.
495
496 See also L<DBIx::Class::ResultSet/delete>.
497
498 =cut
499
500 sub delete {
501   my $self = shift;
502   if (ref $self) {
503     $self->throw_exception( "Not in database" ) unless $self->in_storage;
504     my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
505     $self->throw_exception("Cannot safely delete a row in a PK-less table")
506       if ! keys %$ident_cond;
507     foreach my $column (keys %$ident_cond) {
508             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
509               unless exists $self->{_column_data}{$column};
510     }
511     $self->result_source->storage->delete(
512       $self->result_source, $ident_cond);
513     $self->in_storage(undef);
514   } else {
515     $self->throw_exception("Can't do class delete without a ResultSource instance")
516       unless $self->can('result_source_instance');
517     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
518     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
519     $self->result_source_instance->resultset->search(@_)->delete;
520   }
521   return $self;
522 }
523
524 =head2 get_column
525
526   my $val = $row->get_column($col);
527
528 =over
529
530 =item Arguments: $columnname
531
532 =item Returns: The value of the column
533
534 =back
535
536 Throws an exception if the column name given doesn't exist according
537 to L</has_column>.
538
539 Returns a raw column value from the row object, if it has already
540 been fetched from the database or set by an accessor.
541
542 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
543 will be deflated and returned.
544
545 Note that if you used the C<columns> or the C<select/as>
546 L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
547 which C<$row> was derived, and B<did not include> C<$columnname> in the list,
548 this method will return C<undef> even if the database contains some value.
549
550 To retrieve all loaded column values as a hash, use L</get_columns>.
551
552 =cut
553
554 sub get_column {
555   my ($self, $column) = @_;
556   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
557   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
558   if (exists $self->{_inflated_column}{$column}) {
559     return $self->store_column($column,
560       $self->_deflated_column($column, $self->{_inflated_column}{$column}));   
561   }
562   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
563   return undef;
564 }
565
566 =head2 has_column_loaded
567
568   if ( $row->has_column_loaded($col) ) {
569      print "$col has been loaded from db";
570   }
571
572 =over
573
574 =item Arguments: $columnname
575
576 =item Returns: 0|1
577
578 =back
579
580 Returns a true value if the column value has been loaded from the
581 database (or set locally).
582
583 =cut
584
585 sub has_column_loaded {
586   my ($self, $column) = @_;
587   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
588   return 1 if exists $self->{_inflated_column}{$column};
589   return exists $self->{_column_data}{$column};
590 }
591
592 =head2 get_columns
593
594   my %data = $row->get_columns;
595
596 =over
597
598 =item Arguments: none
599
600 =item Returns: A hash of columnname, value pairs.
601
602 =back
603
604 Returns all loaded column data as a hash, containing raw values. To
605 get just one value for a particular column, use L</get_column>.
606
607 =cut
608
609 sub get_columns {
610   my $self = shift;
611   if (exists $self->{_inflated_column}) {
612     foreach my $col (keys %{$self->{_inflated_column}}) {
613       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
614         unless exists $self->{_column_data}{$col};
615     }
616   }
617   return %{$self->{_column_data}};
618 }
619
620 =head2 get_dirty_columns
621
622   my %data = $row->get_dirty_columns;
623
624 =over
625
626 =item Arguments: none
627
628 =item Returns: A hash of column, value pairs
629
630 =back
631
632 Only returns the column, value pairs for those columns that have been
633 changed on this object since the last L</update> or L</insert> call.
634
635 See L</get_columns> to fetch all column/value pairs.
636
637 =cut
638
639 sub get_dirty_columns {
640   my $self = shift;
641   return map { $_ => $self->{_column_data}{$_} }
642            keys %{$self->{_dirty_columns}};
643 }
644
645 =head2 make_column_dirty
646
647   $row->make_column_dirty($col)
648
649 =over
650
651 =item Arguments: $columnname
652
653 =item Returns: undefined
654
655 =back
656
657 Throws an exception if the column does not exist.
658
659 Marks a column as having been changed regardless of whether it has
660 really changed.  
661
662 =cut
663 sub make_column_dirty {
664   my ($self, $column) = @_;
665
666   $self->throw_exception( "No such column '${column}'" )
667     unless exists $self->{_column_data}{$column} || $self->has_column($column);
668   $self->{_dirty_columns}{$column} = 1;
669 }
670
671 =head2 get_inflated_columns
672
673   my %inflated_data = $obj->get_inflated_columns;
674
675 =over
676
677 =item Arguments: none
678
679 =item Returns: A hash of column, object|value pairs
680
681 =back
682
683 Returns a hash of all column keys and associated values. Values for any
684 columns set to use inflation will be inflated and returns as objects.
685
686 See L</get_columns> to get the uninflated values.
687
688 See L<DBIx::Class::InflateColumn> for how to setup inflation.
689
690 =cut
691
692 sub get_inflated_columns {
693   my $self = shift;
694   return map {
695     my $accessor = $self->column_info($_)->{'accessor'} || $_;
696     ($_ => $self->$accessor);
697   } $self->columns;
698 }
699
700 =head2 set_column
701
702   $row->set_column($col => $val);
703
704 =over
705
706 =item Arguments: $columnname, $value
707
708 =item Returns: $value
709
710 =back
711
712 Sets a raw column value. If the new value is different from the old one,
713 the column is marked as dirty for when you next call L</update>.
714
715 If passed an object or reference as a value, this method will happily
716 attempt to store it, and a later L</insert> or L</update> will try and
717 stringify/numify as appropriate. To set an object to be deflated
718 instead, see L</set_inflated_columns>.
719
720 =cut
721
722 sub set_column {
723   my ($self, $column, $new_value) = @_;
724
725   $self->{_orig_ident} ||= $self->ident_condition;
726   my $old_value = $self->get_column($column);
727
728   $self->store_column($column, $new_value);
729   $self->{_dirty_columns}{$column} = 1
730     if (defined $old_value xor defined $new_value) || (defined $old_value && $old_value ne $new_value);
731
732   # XXX clear out the relation cache for this column
733   delete $self->{related_resultsets}{$column};
734
735   return $new_value;
736 }
737
738 =head2 set_columns
739
740   $row->set_columns({ $col => $val, ... });
741
742 =over 
743
744 =item Arguments: \%columndata
745
746 =item Returns: The Row object
747
748 =back
749
750 Sets multiple column, raw value pairs at once.
751
752 Works as L</set_column>.
753
754 =cut
755
756 sub set_columns {
757   my ($self,$data) = @_;
758   foreach my $col (keys %$data) {
759     $self->set_column($col,$data->{$col});
760   }
761   return $self;
762 }
763
764 =head2 set_inflated_columns
765
766   $row->set_inflated_columns({ $col => $val, $relname => $obj, ... });
767
768 =over
769
770 =item Arguments: \%columndata
771
772 =item Returns: The Row object
773
774 =back
775
776 Sets more than one column value at once. Any inflated values are
777 deflated and the raw values stored. 
778
779 Any related values passed as Row objects, using the relation name as a
780 key, are reduced to the appropriate foreign key values and stored. If
781 instead of related row objects, a hashref of column, value data is
782 passed, will create the related object first then store.
783
784 Will even accept arrayrefs of data as a value to a
785 L<DBIx::Class::Relationship/has_many> key, and create the related
786 objects if necessary.
787
788 Be aware that the input hashref might be edited in place, so dont rely
789 on it being the same after a call to C<set_inflated_columns>. If you
790 need to preserve the hashref, it is sufficient to pass a shallow copy
791 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
792
793 See also L<DBIx::Class::Relationship::Base/set_from_related>.
794
795 =cut
796
797 sub set_inflated_columns {
798   my ( $self, $upd ) = @_;
799   foreach my $key (keys %$upd) {
800     if (ref $upd->{$key}) {
801       my $info = $self->relationship_info($key);
802       if ($info && $info->{attrs}{accessor}
803         && $info->{attrs}{accessor} eq 'single')
804       {
805         my $rel = delete $upd->{$key};
806         $self->set_from_related($key => $rel);
807         $self->{_relationship_data}{$key} = $rel;
808       } elsif ($info && $info->{attrs}{accessor}
809         && $info->{attrs}{accessor} eq 'multi') {
810           $self->throw_exception(
811             "Recursive update is not supported over relationships of type multi ($key)"
812           );
813       }
814       elsif ($self->has_column($key)
815         && exists $self->column_info($key)->{_inflate_info})
816       {
817         $self->set_inflated_column($key, delete $upd->{$key});
818       }
819     }
820   }
821   $self->set_columns($upd);    
822 }
823
824 =head2 copy
825
826   my $copy = $orig->copy({ change => $to, ... });
827
828 =over
829
830 =item Arguments: \%replacementdata
831
832 =item Returns: The Row object copy
833
834 =back
835
836 Inserts a new row into the database, as a copy of the original
837 object. If a hashref of replacement data is supplied, these will take
838 precedence over data in the original.
839
840 If the row has related objects in a
841 L<DBIx::Class::Relationship/has_many> then those objects may be copied
842 too depending on the L<cascade_copy|DBIx::Class::Relationship>
843 relationship attribute.
844
845 =cut
846
847 sub copy {
848   my ($self, $changes) = @_;
849   $changes ||= {};
850   my $col_data = { %{$self->{_column_data}} };
851   foreach my $col (keys %$col_data) {
852     delete $col_data->{$col}
853       if $self->result_source->column_info($col)->{is_auto_increment};
854   }
855
856   my $new = { _column_data => $col_data };
857   bless $new, ref $self;
858
859   $new->result_source($self->result_source);
860   $new->set_inflated_columns($changes);
861   $new->insert;
862
863   # Its possible we'll have 2 relations to the same Source. We need to make 
864   # sure we don't try to insert the same row twice esle we'll violate unique
865   # constraints
866   my $rels_copied = {};
867
868   foreach my $rel ($self->result_source->relationships) {
869     my $rel_info = $self->result_source->relationship_info($rel);
870
871     next unless $rel_info->{attrs}{cascade_copy};
872   
873     my $resolved = $self->result_source->resolve_condition(
874       $rel_info->{cond}, $rel, $new
875     );
876
877     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
878     foreach my $related ($self->search_related($rel)) {
879       my $id_str = join("\0", $related->id);
880       next if $copied->{$id_str};
881       $copied->{$id_str} = 1;
882       my $rel_copy = $related->copy($resolved);
883     }
884  
885   }
886   return $new;
887 }
888
889 =head2 store_column
890
891   $row->store_column($col => $val);
892
893 =over
894
895 =item Arguments: $columnname, $value
896
897 =item Returns: The value sent to storage
898
899 =back
900
901 Set a raw value for a column without marking it as changed. This
902 method is used internally by L</set_column> which you should probably
903 be using.
904
905 This is the lowest level at which data is set on a row object,
906 extend this method to catch all data setting methods.
907
908 =cut
909
910 sub store_column {
911   my ($self, $column, $value) = @_;
912   $self->throw_exception( "No such column '${column}'" )
913     unless exists $self->{_column_data}{$column} || $self->has_column($column);
914   $self->throw_exception( "set_column called for ${column} without value" )
915     if @_ < 3;
916   return $self->{_column_data}{$column} = $value;
917 }
918
919 =head2 inflate_result
920
921   Class->inflate_result($result_source, \%me, \%prefetch?)
922
923 =over
924
925 =item Arguments: $result_source, \%columndata, \%prefetcheddata
926
927 =item Returns: A Row object
928
929 =back
930
931 All L<DBIx::Class::ResultSet> methods that retrieve data from the
932 database and turn it into row objects call this method.
933
934 Extend this method in your Result classes to hook into this process,
935 for example to rebless the result into a different class.
936
937 Reblessing can also be done more easily by setting C<result_class> in
938 your Result class. See L<DBIx::Class::ResultSource/result_class>.
939
940 =cut
941
942 sub inflate_result {
943   my ($class, $source, $me, $prefetch) = @_;
944
945   my ($source_handle) = $source;
946
947   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
948       $source = $source_handle->resolve
949   } else {
950       $source_handle = $source->handle
951   }
952
953   my $new = {
954     _source_handle => $source_handle,
955     _column_data => $me,
956     _in_storage => 1
957   };
958   bless $new, (ref $class || $class);
959
960   my $schema;
961   foreach my $pre (keys %{$prefetch||{}}) {
962     my $pre_val = $prefetch->{$pre};
963     my $pre_source = $source->related_source($pre);
964     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
965       unless $pre_source;
966     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
967       my @pre_objects;
968       foreach my $pre_rec (@$pre_val) {
969         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
970            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
971           next;
972         }
973         push(@pre_objects, $pre_source->result_class->inflate_result(
974                              $pre_source, @{$pre_rec}));
975       }
976       $new->related_resultset($pre)->set_cache(\@pre_objects);
977     } elsif (defined $pre_val->[0]) {
978       my $fetched;
979       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
980          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
981       {
982         $fetched = $pre_source->result_class->inflate_result(
983                       $pre_source, @{$pre_val});
984       }
985       $new->related_resultset($pre)->set_cache([ $fetched ]);
986       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
987       $class->throw_exception("No accessor for prefetched $pre")
988        unless defined $accessor;
989       if ($accessor eq 'single') {
990         $new->{_relationship_data}{$pre} = $fetched;
991       } elsif ($accessor eq 'filter') {
992         $new->{_inflated_column}{$pre} = $fetched;
993       } else {
994        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
995       }
996     }
997   }
998   return $new;
999 }
1000
1001 =head2 update_or_insert
1002
1003   $row->update_or_insert
1004
1005 =over
1006
1007 =item Arguments: none
1008
1009 =item Returns: Result of update or insert operation
1010
1011 =back
1012
1013 L</Update>s the object if it's already in the database, according to
1014 L</in_storage>, else L</insert>s it.
1015
1016 =head2 insert_or_update
1017
1018   $obj->insert_or_update
1019
1020 Alias for L</update_or_insert>
1021
1022 =cut
1023
1024 sub insert_or_update { shift->update_or_insert(@_) }
1025
1026 sub update_or_insert {
1027   my $self = shift;
1028   return ($self->in_storage ? $self->update : $self->insert);
1029 }
1030
1031 =head2 is_changed
1032
1033   my @changed_col_names = $row->is_changed();
1034   if ($row->is_changed()) { ... }
1035
1036 =over
1037
1038 =item Arguments: none
1039
1040 =item Returns: 0|1 or @columnnames
1041
1042 =back
1043
1044 In list context returns a list of columns with uncommited changes, or
1045 in scalar context returns a true value if there are uncommitted
1046 changes.
1047
1048 =cut
1049
1050 sub is_changed {
1051   return keys %{shift->{_dirty_columns} || {}};
1052 }
1053
1054 =head2 is_column_changed
1055
1056   if ($row->is_column_changed('col')) { ... }
1057
1058 =over
1059
1060 =item Arguments: $columname
1061
1062 =item Returns: 0|1
1063
1064 =back
1065
1066 Returns a true value if the column has uncommitted changes.
1067
1068 =cut
1069
1070 sub is_column_changed {
1071   my( $self, $col ) = @_;
1072   return exists $self->{_dirty_columns}->{$col};
1073 }
1074
1075 =head2 result_source
1076
1077   my $resultsource = $row->result_source;
1078
1079 =over
1080
1081 =item Arguments: none
1082
1083 =item Returns: a ResultSource instance
1084
1085 =back
1086
1087 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1088
1089 =cut
1090
1091 sub result_source {
1092     my $self = shift;
1093
1094     if (@_) {
1095         $self->_source_handle($_[0]->handle);
1096     } else {
1097         $self->_source_handle->resolve;
1098     }
1099 }
1100
1101 =head2 register_column
1102
1103   $column_info = { .... };
1104   $class->register_column($column_name, $column_info);
1105
1106 =over
1107
1108 =item Arguments: $columnname, \%columninfo
1109
1110 =item Returns: undefined
1111
1112 =back
1113
1114 Registers a column on the class. If the column_info has an 'accessor'
1115 key, creates an accessor named after the value if defined; if there is
1116 no such key, creates an accessor with the same name as the column
1117
1118 The column_info attributes are described in
1119 L<DBIx::Class::ResultSource/add_columns>
1120
1121 =cut
1122
1123 sub register_column {
1124   my ($class, $col, $info) = @_;
1125   my $acc = $col;
1126   if (exists $info->{accessor}) {
1127     return unless defined $info->{accessor};
1128     $acc = [ $info->{accessor}, $col ];
1129   }
1130   $class->mk_group_accessors('column' => $acc);
1131 }
1132
1133 =head2 get_from_storage
1134
1135   my $copy = $row->get_from_storage($attrs)
1136
1137 =over
1138
1139 =item Arguments: \%attrs
1140
1141 =item Returns: A Row object
1142
1143 =back
1144
1145 Fetches a fresh copy of the Row object from the database and returns it.
1146
1147 If passed the \%attrs argument, will first apply these attributes to
1148 the resultset used to find the row.
1149
1150 This copy can then be used to compare to an existing row object, to
1151 determine if any changes have been made in the database since it was
1152 created.
1153
1154 To just update your Row object with any latest changes from the
1155 database, use L</discard_changes> instead.
1156
1157 The \%attrs argument should be compatible with
1158 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1159
1160 =cut
1161
1162 sub get_from_storage {
1163     my $self = shift @_;
1164     my $attrs = shift @_;
1165     my $resultset = $self->result_source->resultset;
1166     
1167     if(defined $attrs) {
1168         $resultset = $resultset->search(undef, $attrs);
1169     }
1170     
1171     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1172 }
1173
1174 =head2 throw_exception
1175
1176 See L<DBIx::Class::Schema/throw_exception>.
1177
1178 =cut
1179
1180 sub throw_exception {
1181   my $self=shift;
1182   if (ref $self && ref $self->result_source && $self->result_source->schema) {
1183     $self->result_source->schema->throw_exception(@_);
1184   } else {
1185     croak(@_);
1186   }
1187 }
1188
1189 =head2 id
1190
1191   my @pk = $row->id;
1192
1193 =over
1194
1195 =item Arguments: none
1196
1197 =item Returns: A list of primary key values
1198
1199 =back
1200
1201 Returns the primary key(s) for a row. Can't be called as a class method.
1202 Actually implemented in L<DBIx::Class::PK>
1203
1204 =head2 discard_changes
1205
1206   $row->discard_changes
1207
1208 =over
1209
1210 =item Arguments: none
1211
1212 =item Returns: nothing (updates object in-place)
1213
1214 =back
1215
1216 Retrieves and sets the row object data from the database, losing any
1217 local changes made.
1218
1219 This method can also be used to refresh from storage, retrieving any
1220 changes made since the row was last read from storage. Actually
1221 implemented in L<DBIx::Class::PK>
1222
1223 =cut
1224
1225 1;
1226
1227 =head1 AUTHORS
1228
1229 Matt S. Trout <mst@shadowcatsystems.co.uk>
1230
1231 =head1 LICENSE
1232
1233 You may distribute this code under the same terms as Perl itself.
1234
1235 =cut