added tests for required modules, minor documentation update
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Row.pm
1 package DBIx::Class::Row;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use Scalar::Util ();
9 use Scope::Guard;
10
11 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
12
13 =head1 NAME
14
15 DBIx::Class::Row - Basic row methods
16
17 =head1 SYNOPSIS
18
19 =head1 DESCRIPTION
20
21 This class is responsible for defining and doing basic operations on rows
22 derived from L<DBIx::Class::ResultSource> objects.
23
24 =head1 METHODS
25
26 =head2 new
27
28   my $obj = My::Class->new($attrs);
29
30 Creates a new row object from column => value mappings passed as a hash ref
31
32 Passing an object, or an arrayref of objects as a value will call
33 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
34 passed a hashref or an arrayref of hashrefs as the value, these will
35 be turned into objects via new_related, and treated as if you had
36 passed objects.
37
38 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
39
40 =cut
41
42 ## 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().
43 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
44 ## When doing the later insert, we need to make sure the PKs are set.
45 ## using _relationship_data in new and funky ways..
46 ## check Relationship::CascadeActions and Relationship::Accessor for compat
47 ## tests!
48
49 sub new {
50   my ($class, $attrs) = @_;
51   $class = ref $class if ref $class;
52
53   my $new = {
54       _column_data          => {},
55   };
56   bless $new, $class;
57
58   if (my $handle = delete $attrs->{-source_handle}) {
59     $new->_source_handle($handle);
60   }
61   if (my $source = delete $attrs->{-result_source}) {
62     $new->result_source($source);
63   }
64
65   if ($attrs) {
66     $new->throw_exception("attrs must be a hashref")
67       unless ref($attrs) eq 'HASH';
68     
69     my ($related,$inflated);
70     ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
71     $new->{_rel_in_storage} = 1;
72
73     foreach my $key (keys %$attrs) {
74       if (ref $attrs->{$key}) {
75         ## Can we extract this lot to use with update(_or .. ) ?
76         my $info = $class->relationship_info($key);
77         if ($info && $info->{attrs}{accessor}
78           && $info->{attrs}{accessor} eq 'single')
79         {
80           my $rel_obj = delete $attrs->{$key};
81           if(!Scalar::Util::blessed($rel_obj)) {
82             $rel_obj = $new->find_or_new_related($key, $rel_obj);
83           }
84
85           $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
86
87           $new->set_from_related($key, $rel_obj);        
88           $related->{$key} = $rel_obj;
89           next;
90         } elsif ($info && $info->{attrs}{accessor}
91             && $info->{attrs}{accessor} eq 'multi'
92             && ref $attrs->{$key} eq 'ARRAY') {
93           my $others = delete $attrs->{$key};
94           foreach my $rel_obj (@$others) {
95             if(!Scalar::Util::blessed($rel_obj)) {
96               $rel_obj = $new->new_related($key, $rel_obj);
97               $new->{_rel_in_storage} = 0;
98             }
99
100             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
101           }
102           $related->{$key} = $others;
103           next;
104         } elsif ($info && $info->{attrs}{accessor}
105           && $info->{attrs}{accessor} eq 'filter')
106         {
107           ## 'filter' should disappear and get merged in with 'single' above!
108           my $rel_obj = delete $attrs->{$key};
109           if(!Scalar::Util::blessed($rel_obj)) {
110             $rel_obj = $new->find_or_new_related($key, $rel_obj);
111             $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
112           }
113           $inflated->{$key} = $rel_obj;
114           next;
115         } elsif ($class->has_column($key)
116             && $class->column_info($key)->{_inflate_info}) {
117           $inflated->{$key} = $attrs->{$key};
118           next;
119         }
120       }
121       $new->throw_exception("No such column $key on $class")
122         unless $class->has_column($key);
123       $new->store_column($key => $attrs->{$key});          
124     }
125
126     $new->{_relationship_data} = $related if $related;
127     $new->{_inflated_column} = $inflated if $inflated;
128   }
129
130   return $new;
131 }
132
133 =head2 insert
134
135   $obj->insert;
136
137 Inserts an object into the database if it isn't already in
138 there. Returns the object itself. Requires the object's result source to
139 be set, or the class to have a result_source_instance method. To insert
140 an entirely new object into the database, use C<create> (see
141 L<DBIx::Class::ResultSet/create>).
142
143 To fetch an uninserted row object, call
144 L<new|DBIx::Class::ResultSet/new> on a resultset.
145
146 This will also insert any uninserted, related objects held inside this
147 one, see L<DBIx::Class::ResultSet/create> for more details.
148
149 =cut
150
151 sub insert {
152   my ($self) = @_;
153   return $self if $self->in_storage;
154   my $source = $self->result_source;
155   $source ||=  $self->result_source($self->result_source_instance)
156     if $self->can('result_source_instance');
157   $self->throw_exception("No result_source set on this object; can't insert")
158     unless $source;
159
160   my $rollback_guard;
161
162   # Check if we stored uninserted relobjs here in new()
163   my %related_stuff = (%{$self->{_relationship_data} || {}}, 
164                        %{$self->{_inflated_column} || {}});
165
166   if(!$self->{_rel_in_storage}) {
167
168     # The guard will save us if we blow out of this scope via die
169     $rollback_guard = $source->storage->txn_scope_guard;
170
171     ## Should all be in relationship_data, but we need to get rid of the
172     ## 'filter' reltype..
173     ## These are the FK rels, need their IDs for the insert.
174
175     my @pri = $self->primary_columns;
176
177     REL: foreach my $relname (keys %related_stuff) {
178
179       my $rel_obj = $related_stuff{$relname};
180
181       next REL unless (Scalar::Util::blessed($rel_obj)
182                        && $rel_obj->isa('DBIx::Class::Row'));
183
184       my $cond = $source->relationship_info($relname)->{cond};
185
186       next REL unless ref($cond) eq 'HASH';
187
188       # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
189
190       my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
191
192       # assume anything that references our PK probably is dependent on us
193       # rather than vice versa, unless the far side is (a) defined or (b)
194       # auto-increment
195
196       foreach my $p (@pri) {
197         if (exists $keyhash->{$p}) {
198           unless (defined($rel_obj->get_column($keyhash->{$p}))
199                   || $rel_obj->column_info($keyhash->{$p})
200                              ->{is_auto_increment}) {
201             next REL;
202           }
203         }
204       }
205
206       $rel_obj->insert();
207       $self->set_from_related($relname, $rel_obj);
208       delete $related_stuff{$relname};
209     }
210   }
211
212   my $updated_cols = $source->storage->insert($source, { $self->get_columns });
213   $self->set_columns($updated_cols);
214
215   ## PK::Auto
216   my @auto_pri = grep {
217                    !defined $self->get_column($_) || 
218                    ref($self->get_column($_)) eq 'SCALAR'
219                  } $self->primary_columns;
220
221   if (@auto_pri) {
222     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
223     #  if defined $too_many;
224
225     my $storage = $self->result_source->storage;
226     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
227       unless $storage->can('last_insert_id');
228     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
229     $self->throw_exception( "Can't get last insert id" )
230       unless (@ids == @auto_pri);
231     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
232   }
233
234   if(!$self->{_rel_in_storage}) {
235     ## Now do the has_many rels, that need $selfs ID.
236     foreach my $relname (keys %related_stuff) {
237       my $rel_obj = $related_stuff{$relname};
238       my @cands;
239       if (Scalar::Util::blessed($rel_obj)
240           && $rel_obj->isa('DBIx::Class::Row')) {
241         @cands = ($rel_obj);
242       } elsif (ref $rel_obj eq 'ARRAY') {
243         @cands = @$rel_obj;
244       }
245       if (@cands) {
246         my $reverse = $source->reverse_relationship_info($relname);
247         foreach my $obj (@cands) {
248           $obj->set_from_related($_, $self) for keys %$reverse;
249           $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
250         }
251       }
252     }
253     $rollback_guard->commit;
254   }
255
256   $self->in_storage(1);
257   $self->{_dirty_columns} = {};
258   $self->{related_resultsets} = {};
259   undef $self->{_orig_ident};
260   return $self;
261 }
262
263 =head2 in_storage
264
265   $obj->in_storage; # Get value
266   $obj->in_storage(1); # Set value
267
268 Indicates whether the object exists as a row in the database or
269 not. This is set to true when L<DBIx::Class::ResultSet/find>,
270 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
271 are used. 
272
273 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
274 L</delete> on one, sets it to false.
275
276 =cut
277
278 sub in_storage {
279   my ($self, $val) = @_;
280   $self->{_in_storage} = $val if @_ > 1;
281   return $self->{_in_storage};
282 }
283
284 =head2 update
285
286   $obj->update \%columns?;
287
288 Must be run on an object that is already in the database; issues an SQL
289 UPDATE query to commit any changes to the object to the database if
290 required.
291
292 Also takes an options hashref of C<< column_name => value> pairs >> to update
293 first. But be aware that the hashref will be passed to
294 C<set_inflated_columns>, which might edit it in place, so dont rely on it being
295 the same after a call to C<update>.  If you need to preserve the hashref, it is
296 sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
297
298 If the values passed or any of the column values set on the object
299 contain scalar references, eg:
300
301   $obj->last_modified(\'NOW()');
302   # OR
303   $obj->update({ last_modified => \'NOW()' });
304
305 The update will pass the values verbatim into SQL. (See
306 L<SQL::Abstract> docs).  The values in your Row object will NOT change
307 as a result of the update call, if you want the object to be updated
308 with the actual values from the database, call L</discard_changes>
309 after the update.
310
311   $obj->update()->discard_changes();
312
313 =cut
314
315 sub update {
316   my ($self, $upd) = @_;
317   $self->throw_exception( "Not in database" ) unless $self->in_storage;
318   my $ident_cond = $self->ident_condition;
319   $self->throw_exception("Cannot safely update a row in a PK-less table")
320     if ! keys %$ident_cond;
321
322   $self->set_inflated_columns($upd) if $upd;
323   my %to_update = $self->get_dirty_columns;
324   return $self unless keys %to_update;
325   my $rows = $self->result_source->storage->update(
326                $self->result_source, \%to_update,
327                $self->{_orig_ident} || $ident_cond
328              );
329   if ($rows == 0) {
330     $self->throw_exception( "Can't update ${self}: row not found" );
331   } elsif ($rows > 1) {
332     $self->throw_exception("Can't update ${self}: updated more than one row");
333   }
334   $self->{_dirty_columns} = {};
335   $self->{related_resultsets} = {};
336   undef $self->{_orig_ident};
337   return $self;
338 }
339
340 =head2 delete
341
342   $obj->delete
343
344 Deletes the object from the database. The object is still perfectly
345 usable, but C<< ->in_storage() >> will now return 0 and the object must
346 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
347 on it. If you delete an object in a class with a C<has_many>
348 relationship, all the related objects will be deleted as well. To turn
349 this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
350 hashref. Any database-level cascade or restrict will take precedence
351 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
352
353 =cut
354
355 sub delete {
356   my $self = shift;
357   if (ref $self) {
358     $self->throw_exception( "Not in database" ) unless $self->in_storage;
359     my $ident_cond = $self->ident_condition;
360     $self->throw_exception("Cannot safely delete a row in a PK-less table")
361       if ! keys %$ident_cond;
362     foreach my $column (keys %$ident_cond) {
363             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
364               unless exists $self->{_column_data}{$column};
365     }
366     $self->result_source->storage->delete(
367       $self->result_source, $ident_cond);
368     $self->in_storage(undef);
369   } else {
370     $self->throw_exception("Can't do class delete without a ResultSource instance")
371       unless $self->can('result_source_instance');
372     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
373     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
374     $self->result_source_instance->resultset->search(@_)->delete;
375   }
376   return $self;
377 }
378
379 =head2 get_column
380
381   my $val = $obj->get_column($col);
382
383 Returns a raw column value from the row object, if it has already
384 been fetched from the database or set by an accessor.
385
386 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
387 will be deflated and returned.
388
389 =cut
390
391 sub get_column {
392   my ($self, $column) = @_;
393   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
394   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
395   if (exists $self->{_inflated_column}{$column}) {
396     return $self->store_column($column,
397       $self->_deflated_column($column, $self->{_inflated_column}{$column}));   
398   }
399   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
400   return undef;
401 }
402
403 =head2 has_column_loaded
404
405   if ( $obj->has_column_loaded($col) ) {
406      print "$col has been loaded from db";
407   }
408
409 Returns a true value if the column value has been loaded from the
410 database (or set locally).
411
412 =cut
413
414 sub has_column_loaded {
415   my ($self, $column) = @_;
416   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
417   return 1 if exists $self->{_inflated_column}{$column};
418   return exists $self->{_column_data}{$column};
419 }
420
421 =head2 get_columns
422
423   my %data = $obj->get_columns;
424
425 Does C<get_column>, for all loaded column values at once.
426
427 =cut
428
429 sub get_columns {
430   my $self = shift;
431   if (exists $self->{_inflated_column}) {
432     foreach my $col (keys %{$self->{_inflated_column}}) {
433       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
434         unless exists $self->{_column_data}{$col};
435     }
436   }
437   return %{$self->{_column_data}};
438 }
439
440 =head2 get_dirty_columns
441
442   my %data = $obj->get_dirty_columns;
443
444 Identical to get_columns but only returns those that have been changed.
445
446 =cut
447
448 sub get_dirty_columns {
449   my $self = shift;
450   return map { $_ => $self->{_column_data}{$_} }
451            keys %{$self->{_dirty_columns}};
452 }
453
454 =head2 make_column_dirty
455
456 Marks a column dirty regardless if it has really changed.  Throws an
457 exception if the column does not exist.
458
459 =cut
460 sub make_column_dirty {
461   my ($self, $column) = @_;
462
463   $self->throw_exception( "No such column '${column}'" )
464     unless exists $self->{_column_data}{$column} || $self->has_column($column);
465   $self->{_dirty_columns}{$column} = 1;
466 }
467
468 =head2 get_inflated_columns
469
470   my %inflated_data = $obj->get_inflated_columns;
471
472 Similar to get_columns but objects are returned for inflated columns
473 instead of their raw non-inflated values.
474
475 =cut
476
477 sub get_inflated_columns {
478   my $self = shift;
479   return map {
480     my $accessor = $self->column_info($_)->{'accessor'} || $_;
481     ($_ => $self->$accessor);
482   } $self->columns;
483 }
484
485 =head2 set_column
486
487   $obj->set_column($col => $val);
488
489 Sets a raw column value. If the new value is different from the old one,
490 the column is marked as dirty for when you next call $obj->update.
491
492 If passed an object or reference, this will happily attempt store the
493 value, and a later insert/update will try and stringify/numify as
494 appropriate.
495
496 =cut
497
498 sub set_column {
499   my $self = shift;
500   my ($column) = @_;
501   $self->{_orig_ident} ||= $self->ident_condition;
502   my $old = $self->get_column($column);
503   my $ret = $self->store_column(@_);
504   $self->{_dirty_columns}{$column} = 1
505     if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
506
507   # XXX clear out the relation cache for this column
508   delete $self->{related_resultsets}{$column};
509
510   return $ret;
511 }
512
513 =head2 set_columns
514
515   my $copy = $orig->set_columns({ $col => $val, ... });
516
517 Sets more than one column value at once.
518
519 =cut
520
521 sub set_columns {
522   my ($self,$data) = @_;
523   foreach my $col (keys %$data) {
524     $self->set_column($col,$data->{$col});
525   }
526   return $self;
527 }
528
529 =head2 set_inflated_columns
530
531   my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
532
533 Sets more than one column value at once, taking care to respect inflations and
534 relationships if relevant. Be aware that this hashref might be edited in place,
535 so dont rely on it being the same after a call to C<set_inflated_columns>. If
536 you need to preserve the hashref, it is sufficient to pass a shallow copy to
537 C<set_inflated_columns>, e.g. ( { %{ $href } } )
538
539 =cut
540
541 sub set_inflated_columns {
542   my ( $self, $upd ) = @_;
543   foreach my $key (keys %$upd) {
544     if (ref $upd->{$key}) {
545       my $info = $self->relationship_info($key);
546       if ($info && $info->{attrs}{accessor}
547         && $info->{attrs}{accessor} eq 'single')
548       {
549         my $rel = delete $upd->{$key};
550         $self->set_from_related($key => $rel);
551         $self->{_relationship_data}{$key} = $rel;          
552       } elsif ($info && $info->{attrs}{accessor}
553         && $info->{attrs}{accessor} eq 'multi'
554         && ref $upd->{$key} eq 'ARRAY') {
555         my $others = delete $upd->{$key};
556         foreach my $rel_obj (@$others) {
557           if(!Scalar::Util::blessed($rel_obj)) {
558             $rel_obj = $self->create_related($key, $rel_obj);
559           }
560         }
561         $self->{_relationship_data}{$key} = $others; 
562 #            $related->{$key} = $others;
563         next;
564       }
565       elsif ($self->has_column($key)
566         && exists $self->column_info($key)->{_inflate_info})
567       {
568         $self->set_inflated_column($key, delete $upd->{$key});          
569       }
570     }
571   }
572   $self->set_columns($upd);    
573 }
574
575 =head2 copy
576
577   my $copy = $orig->copy({ change => $to, ... });
578
579 Inserts a new row with the specified changes. If the row has related
580 objects in a C<has_many> then those objects may be copied too depending
581 on the C<cascade_copy> relationship attribute.
582
583 =cut
584
585 sub copy {
586   my ($self, $changes) = @_;
587   $changes ||= {};
588   my $col_data = { %{$self->{_column_data}} };
589   foreach my $col (keys %$col_data) {
590     delete $col_data->{$col}
591       if $self->result_source->column_info($col)->{is_auto_increment};
592   }
593
594   my $new = { _column_data => $col_data };
595   bless $new, ref $self;
596
597   $new->result_source($self->result_source);
598   $new->set_inflated_columns($changes);
599   $new->insert;
600
601   # Its possible we'll have 2 relations to the same Source. We need to make 
602   # sure we don't try to insert the same row twice esle we'll violate unique
603   # constraints
604   my $rels_copied = {};
605
606   foreach my $rel ($self->result_source->relationships) {
607     my $rel_info = $self->result_source->relationship_info($rel);
608
609     next unless $rel_info->{attrs}{cascade_copy};
610   
611     my $resolved = $self->result_source->resolve_condition(
612       $rel_info->{cond}, $rel, $new
613     );
614
615     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
616     foreach my $related ($self->search_related($rel)) {
617       my $id_str = join("\0", $related->id);
618       next if $copied->{$id_str};
619       $copied->{$id_str} = 1;
620       my $rel_copy = $related->copy($resolved);
621     }
622  
623   }
624   return $new;
625 }
626
627 =head2 store_column
628
629   $obj->store_column($col => $val);
630
631 Sets a column value without marking it as dirty.
632
633 =cut
634
635 sub store_column {
636   my ($self, $column, $value) = @_;
637   $self->throw_exception( "No such column '${column}'" )
638     unless exists $self->{_column_data}{$column} || $self->has_column($column);
639   $self->throw_exception( "set_column called for ${column} without value" )
640     if @_ < 3;
641   return $self->{_column_data}{$column} = $value;
642 }
643
644 =head2 inflate_result
645
646   Class->inflate_result($result_source, \%me, \%prefetch?)
647
648 Called by ResultSet to inflate a result from storage
649
650 =cut
651
652 sub inflate_result {
653   my ($class, $source, $me, $prefetch) = @_;
654
655   my ($source_handle) = $source;
656
657   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
658       $source = $source_handle->resolve
659   } else {
660       $source_handle = $source->handle
661   }
662
663   my $new = {
664     _source_handle => $source_handle,
665     _column_data => $me,
666     _in_storage => 1
667   };
668   bless $new, (ref $class || $class);
669
670   my $schema;
671   foreach my $pre (keys %{$prefetch||{}}) {
672     my $pre_val = $prefetch->{$pre};
673     my $pre_source = $source->related_source($pre);
674     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
675       unless $pre_source;
676     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
677       my @pre_objects;
678       foreach my $pre_rec (@$pre_val) {
679         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
680            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
681           next;
682         }
683         push(@pre_objects, $pre_source->result_class->inflate_result(
684                              $pre_source, @{$pre_rec}));
685       }
686       $new->related_resultset($pre)->set_cache(\@pre_objects);
687     } elsif (defined $pre_val->[0]) {
688       my $fetched;
689       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
690          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
691       {
692         $fetched = $pre_source->result_class->inflate_result(
693                       $pre_source, @{$pre_val});
694       }
695       $new->related_resultset($pre)->set_cache([ $fetched ]);
696       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
697       $class->throw_exception("No accessor for prefetched $pre")
698        unless defined $accessor;
699       if ($accessor eq 'single') {
700         $new->{_relationship_data}{$pre} = $fetched;
701       } elsif ($accessor eq 'filter') {
702         $new->{_inflated_column}{$pre} = $fetched;
703       } else {
704        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
705       }
706     }
707   }
708   return $new;
709 }
710
711 =head2 update_or_insert
712
713   $obj->update_or_insert
714
715 Updates the object if it's already in the database, according to
716 L</in_storage>, else inserts it.
717
718 =head2 insert_or_update
719
720   $obj->insert_or_update
721
722 Alias for L</update_or_insert>
723
724 =cut
725
726 *insert_or_update = \&update_or_insert;
727 sub update_or_insert {
728   my $self = shift;
729   return ($self->in_storage ? $self->update : $self->insert);
730 }
731
732 =head2 is_changed
733
734   my @changed_col_names = $obj->is_changed();
735   if ($obj->is_changed()) { ... }
736
737 In array context returns a list of columns with uncommited changes, or
738 in scalar context returns a true value if there are uncommitted
739 changes.
740
741 =cut
742
743 sub is_changed {
744   return keys %{shift->{_dirty_columns} || {}};
745 }
746
747 =head2 is_column_changed
748
749   if ($obj->is_column_changed('col')) { ... }
750
751 Returns a true value if the column has uncommitted changes.
752
753 =cut
754
755 sub is_column_changed {
756   my( $self, $col ) = @_;
757   return exists $self->{_dirty_columns}->{$col};
758 }
759
760 =head2 result_source
761
762   my $resultsource = $object->result_source;
763
764 Accessor to the ResultSource this object was created from
765
766 =cut
767
768 sub result_source {
769     my $self = shift;
770
771     if (@_) {
772         $self->_source_handle($_[0]->handle);
773     } else {
774         $self->_source_handle->resolve;
775     }
776 }
777
778 =head2 register_column
779
780   $column_info = { .... };
781   $class->register_column($column_name, $column_info);
782
783 Registers a column on the class. If the column_info has an 'accessor'
784 key, creates an accessor named after the value if defined; if there is
785 no such key, creates an accessor with the same name as the column
786
787 The column_info attributes are described in
788 L<DBIx::Class::ResultSource/add_columns>
789
790 =cut
791
792 sub register_column {
793   my ($class, $col, $info) = @_;
794   my $acc = $col;
795   if (exists $info->{accessor}) {
796     return unless defined $info->{accessor};
797     $acc = [ $info->{accessor}, $col ];
798   }
799   $class->mk_group_accessors('column' => $acc);
800 }
801
802 =head2 get_from_storage ($attrs)
803
804 Returns a new Row which is whatever the Storage has for the currently created
805 Row object.  You can use this to see if the storage has become inconsistent with
806 whatever your Row object is.
807
808 $attrs is expected to be a hashref of attributes suitable for passing as the
809 second argument to $resultset->search($cond, $attrs);
810
811 =cut
812
813 sub get_from_storage {
814     my $self = shift @_;
815     my $attrs = shift @_;
816     my @primary_columns = map { $self->$_ } $self->primary_columns;
817     my $resultset = $self->result_source->resultset;
818     
819     if(defined $attrs) {
820         $resultset = $resultset->search(undef, $attrs);
821     }
822     
823     return $resultset->find(@primary_columns);  
824 }
825
826 =head2 throw_exception
827
828 See Schema's throw_exception.
829
830 =cut
831
832 sub throw_exception {
833   my $self=shift;
834   if (ref $self && ref $self->result_source && $self->result_source->schema) {
835     $self->result_source->schema->throw_exception(@_);
836   } else {
837     croak(@_);
838   }
839 }
840
841 =head2 id
842
843 Returns the primary key(s) for a row. Can't be called as a class method.
844 Actually implemented in L<DBIx::Class::PK>
845
846 =head2 discard_changes
847
848 Re-selects the row from the database, losing any changes that had
849 been made.
850
851 This method can also be used to refresh from storage, retrieving any
852 changes made since the row was last read from storage. Actually
853 implemented in L<DBIx::Class::PK>
854
855 =cut
856
857 1;
858
859 =head1 AUTHORS
860
861 Matt S. Trout <mst@shadowcatsystems.co.uk>
862
863 =head1 LICENSE
864
865 You may distribute this code under the same terms as Perl itself.
866
867 =cut