1) changed all 4 space indentation to 2 space style indents for replication code...
[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 __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 get_inflated_columns
455
456   my %inflated_data = $obj->get_inflated_columns;
457
458 Similar to get_columns but objects are returned for inflated columns
459 instead of their raw non-inflated values.
460
461 =cut
462
463 sub get_inflated_columns {
464   my $self = shift;
465   return map {
466     my $accessor = $self->column_info($_)->{'accessor'} || $_;
467     ($_ => $self->$accessor);
468   } $self->columns;
469 }
470
471 =head2 set_column
472
473   $obj->set_column($col => $val);
474
475 Sets a raw column value. If the new value is different from the old one,
476 the column is marked as dirty for when you next call $obj->update.
477
478 If passed an object or reference, this will happily attempt store the
479 value, and a later insert/update will try and stringify/numify as
480 appropriate.
481
482 =cut
483
484 sub set_column {
485   my $self = shift;
486   my ($column) = @_;
487   $self->{_orig_ident} ||= $self->ident_condition;
488   my $old = $self->get_column($column);
489   my $ret = $self->store_column(@_);
490   $self->{_dirty_columns}{$column} = 1
491     if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
492
493   # XXX clear out the relation cache for this column
494   delete $self->{related_resultsets}{$column};
495
496   return $ret;
497 }
498
499 =head2 set_columns
500
501   my $copy = $orig->set_columns({ $col => $val, ... });
502
503 Sets more than one column value at once.
504
505 =cut
506
507 sub set_columns {
508   my ($self,$data) = @_;
509   foreach my $col (keys %$data) {
510     $self->set_column($col,$data->{$col});
511   }
512   return $self;
513 }
514
515 =head2 set_inflated_columns
516
517   my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
518
519 Sets more than one column value at once, taking care to respect inflations and
520 relationships if relevant. Be aware that this hashref might be edited in place,
521 so dont rely on it being the same after a call to C<set_inflated_columns>. If
522 you need to preserve the hashref, it is sufficient to pass a shallow copy to
523 C<set_inflated_columns>, e.g. ( { %{ $href } } )
524
525 =cut
526
527 sub set_inflated_columns {
528   my ( $self, $upd ) = @_;
529   foreach my $key (keys %$upd) {
530     if (ref $upd->{$key}) {
531       my $info = $self->relationship_info($key);
532       if ($info && $info->{attrs}{accessor}
533         && $info->{attrs}{accessor} eq 'single')
534       {
535         my $rel = delete $upd->{$key};
536         $self->set_from_related($key => $rel);
537         $self->{_relationship_data}{$key} = $rel;          
538       } elsif ($info && $info->{attrs}{accessor}
539         && $info->{attrs}{accessor} eq 'multi'
540         && ref $upd->{$key} eq 'ARRAY') {
541         my $others = delete $upd->{$key};
542         foreach my $rel_obj (@$others) {
543           if(!Scalar::Util::blessed($rel_obj)) {
544             $rel_obj = $self->create_related($key, $rel_obj);
545           }
546         }
547         $self->{_relationship_data}{$key} = $others; 
548 #            $related->{$key} = $others;
549         next;
550       }
551       elsif ($self->has_column($key)
552         && exists $self->column_info($key)->{_inflate_info})
553       {
554         $self->set_inflated_column($key, delete $upd->{$key});          
555       }
556     }
557   }
558   $self->set_columns($upd);    
559 }
560
561 =head2 copy
562
563   my $copy = $orig->copy({ change => $to, ... });
564
565 Inserts a new row with the specified changes. If the row has related
566 objects in a C<has_many> then those objects may be copied too depending
567 on the C<cascade_copy> relationship attribute.
568
569 =cut
570
571 sub copy {
572   my ($self, $changes) = @_;
573   $changes ||= {};
574   my $col_data = { %{$self->{_column_data}} };
575   foreach my $col (keys %$col_data) {
576     delete $col_data->{$col}
577       if $self->result_source->column_info($col)->{is_auto_increment};
578   }
579
580   my $new = { _column_data => $col_data };
581   bless $new, ref $self;
582
583   $new->result_source($self->result_source);
584   $new->set_inflated_columns($changes);
585   $new->insert;
586
587   # Its possible we'll have 2 relations to the same Source. We need to make 
588   # sure we don't try to insert the same row twice esle we'll violate unique
589   # constraints
590   my $rels_copied = {};
591
592   foreach my $rel ($self->result_source->relationships) {
593     my $rel_info = $self->result_source->relationship_info($rel);
594
595     next unless $rel_info->{attrs}{cascade_copy};
596   
597     my $resolved = $self->result_source->resolve_condition(
598       $rel_info->{cond}, $rel, $new
599     );
600
601     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
602     foreach my $related ($self->search_related($rel)) {
603       my $id_str = join("\0", $related->id);
604       next if $copied->{$id_str};
605       $copied->{$id_str} = 1;
606       my $rel_copy = $related->copy($resolved);
607     }
608  
609   }
610   return $new;
611 }
612
613 =head2 store_column
614
615   $obj->store_column($col => $val);
616
617 Sets a column value without marking it as dirty.
618
619 =cut
620
621 sub store_column {
622   my ($self, $column, $value) = @_;
623   $self->throw_exception( "No such column '${column}'" )
624     unless exists $self->{_column_data}{$column} || $self->has_column($column);
625   $self->throw_exception( "set_column called for ${column} without value" )
626     if @_ < 3;
627   return $self->{_column_data}{$column} = $value;
628 }
629
630 =head2 inflate_result
631
632   Class->inflate_result($result_source, \%me, \%prefetch?)
633
634 Called by ResultSet to inflate a result from storage
635
636 =cut
637
638 sub inflate_result {
639   my ($class, $source, $me, $prefetch) = @_;
640
641   my ($source_handle) = $source;
642
643   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
644       $source = $source_handle->resolve
645   } else {
646       $source_handle = $source->handle
647   }
648
649   my $new = {
650     _source_handle => $source_handle,
651     _column_data => $me,
652     _in_storage => 1
653   };
654   bless $new, (ref $class || $class);
655
656   my $schema;
657   foreach my $pre (keys %{$prefetch||{}}) {
658     my $pre_val = $prefetch->{$pre};
659     my $pre_source = $source->related_source($pre);
660     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
661       unless $pre_source;
662     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
663       my @pre_objects;
664       foreach my $pre_rec (@$pre_val) {
665         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
666            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
667           next;
668         }
669         push(@pre_objects, $pre_source->result_class->inflate_result(
670                              $pre_source, @{$pre_rec}));
671       }
672       $new->related_resultset($pre)->set_cache(\@pre_objects);
673     } elsif (defined $pre_val->[0]) {
674       my $fetched;
675       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
676          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
677       {
678         $fetched = $pre_source->result_class->inflate_result(
679                       $pre_source, @{$pre_val});
680       }
681       $new->related_resultset($pre)->set_cache([ $fetched ]);
682       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
683       $class->throw_exception("No accessor for prefetched $pre")
684        unless defined $accessor;
685       if ($accessor eq 'single') {
686         $new->{_relationship_data}{$pre} = $fetched;
687       } elsif ($accessor eq 'filter') {
688         $new->{_inflated_column}{$pre} = $fetched;
689       } else {
690        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
691       }
692     }
693   }
694   return $new;
695 }
696
697 =head2 update_or_insert
698
699   $obj->update_or_insert
700
701 Updates the object if it's already in the database, according to
702 L</in_storage>, else inserts it.
703
704 =head2 insert_or_update
705
706   $obj->insert_or_update
707
708 Alias for L</update_or_insert>
709
710 =cut
711
712 *insert_or_update = \&update_or_insert;
713 sub update_or_insert {
714   my $self = shift;
715   return ($self->in_storage ? $self->update : $self->insert);
716 }
717
718 =head2 is_changed
719
720   my @changed_col_names = $obj->is_changed();
721   if ($obj->is_changed()) { ... }
722
723 In array context returns a list of columns with uncommited changes, or
724 in scalar context returns a true value if there are uncommitted
725 changes.
726
727 =cut
728
729 sub is_changed {
730   return keys %{shift->{_dirty_columns} || {}};
731 }
732
733 =head2 is_column_changed
734
735   if ($obj->is_column_changed('col')) { ... }
736
737 Returns a true value if the column has uncommitted changes.
738
739 =cut
740
741 sub is_column_changed {
742   my( $self, $col ) = @_;
743   return exists $self->{_dirty_columns}->{$col};
744 }
745
746 =head2 result_source
747
748   my $resultsource = $object->result_source;
749
750 Accessor to the ResultSource this object was created from
751
752 =cut
753
754 sub result_source {
755     my $self = shift;
756
757     if (@_) {
758         $self->_source_handle($_[0]->handle);
759     } else {
760         $self->_source_handle->resolve;
761     }
762 }
763
764 =head2 register_column
765
766   $column_info = { .... };
767   $class->register_column($column_name, $column_info);
768
769 Registers a column on the class. If the column_info has an 'accessor'
770 key, creates an accessor named after the value if defined; if there is
771 no such key, creates an accessor with the same name as the column
772
773 The column_info attributes are described in
774 L<DBIx::Class::ResultSource/add_columns>
775
776 =cut
777
778 sub register_column {
779   my ($class, $col, $info) = @_;
780   my $acc = $col;
781   if (exists $info->{accessor}) {
782     return unless defined $info->{accessor};
783     $acc = [ $info->{accessor}, $col ];
784   }
785   $class->mk_group_accessors('column' => $acc);
786 }
787
788
789 =head2 throw_exception
790
791 See Schema's throw_exception.
792
793 =cut
794
795 sub throw_exception {
796   my $self=shift;
797   if (ref $self && ref $self->result_source && $self->result_source->schema) {
798     $self->result_source->schema->throw_exception(@_);
799   } else {
800     croak(@_);
801   }
802 }
803
804 =head2 id
805
806 Returns the primary key(s) for a row. Can't be called as a class method.
807 Actually implemented in L<DBIx::Class::PK>
808
809 =head2 discard_changes
810
811 Re-selects the row from the database, losing any changes that had
812 been made.
813
814 This method can also be used to refresh from storage, retrieving any
815 changes made since the row was last read from storage. Actually
816 implemented in L<DBIx::Class::PK>
817
818 =cut
819
820 1;
821
822 =head1 AUTHORS
823
824 Matt S. Trout <mst@shadowcatsystems.co.uk>
825
826 =head1 LICENSE
827
828 You may distribute this code under the same terms as Perl itself.
829
830 =cut