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