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