Fix the merge with txn_scope_guard() and put the necessary =cut in.
[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   $source->storage->insert($source, { $self->get_columns });
213
214   ## PK::Auto
215   my @auto_pri = grep {
216                    !defined $self->get_column($_) || 
217                    ref($self->get_column($_)) eq 'SCALAR'
218                  } $self->primary_columns;
219
220   if (@auto_pri) {
221     #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
222     #  if defined $too_many;
223
224     my $storage = $self->result_source->storage;
225     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
226       unless $storage->can('last_insert_id');
227     my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
228     $self->throw_exception( "Can't get last insert id" )
229       unless (@ids == @auto_pri);
230     $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
231   }
232
233   if(!$self->{_rel_in_storage}) {
234     ## Now do the has_many rels, that need $selfs ID.
235     foreach my $relname (keys %related_stuff) {
236       my $rel_obj = $related_stuff{$relname};
237       my @cands;
238       if (Scalar::Util::blessed($rel_obj)
239           && $rel_obj->isa('DBIx::Class::Row')) {
240         @cands = ($rel_obj);
241       } elsif (ref $rel_obj eq 'ARRAY') {
242         @cands = @$rel_obj;
243       }
244       if (@cands) {
245         my $reverse = $source->reverse_relationship_info($relname);
246         foreach my $obj (@cands) {
247           $obj->set_from_related($_, $self) for keys %$reverse;
248           $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
249         }
250       }
251     }
252     $rollback_guard->commit;
253   }
254
255   $self->in_storage(1);
256   $self->{_dirty_columns} = {};
257   $self->{related_resultsets} = {};
258   undef $self->{_orig_ident};
259   return $self;
260 }
261
262 =head2 in_storage
263
264   $obj->in_storage; # Get value
265   $obj->in_storage(1); # Set value
266
267 Indicates whether the object exists as a row in the database or
268 not. This is set to true when L<DBIx::Class::ResultSet/find>,
269 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
270 are used. 
271
272 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
273 L</delete> on one, sets it to false.
274
275 =cut
276
277 sub in_storage {
278   my ($self, $val) = @_;
279   $self->{_in_storage} = $val if @_ > 1;
280   return $self->{_in_storage};
281 }
282
283 =head2 update
284
285   $obj->update \%columns?;
286
287 Must be run on an object that is already in the database; issues an SQL
288 UPDATE query to commit any changes to the object to the database if
289 required.
290
291 Also takes an options hashref of C<< column_name => value> pairs >> to update
292 first. But be aware that the hashref will be passed to
293 C<set_inflated_columns>, which might edit it in place, so dont rely on it being
294 the same after a call to C<update>.  If you need to preserve the hashref, it is
295 sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
296
297 =cut
298
299 sub update {
300   my ($self, $upd) = @_;
301   $self->throw_exception( "Not in database" ) unless $self->in_storage;
302   my $ident_cond = $self->ident_condition;
303   $self->throw_exception("Cannot safely update a row in a PK-less table")
304     if ! keys %$ident_cond;
305
306   $self->set_inflated_columns($upd) if $upd;
307   my %to_update = $self->get_dirty_columns;
308   return $self unless keys %to_update;
309   my $rows = $self->result_source->storage->update(
310                $self->result_source, \%to_update,
311                $self->{_orig_ident} || $ident_cond
312              );
313   if ($rows == 0) {
314     $self->throw_exception( "Can't update ${self}: row not found" );
315   } elsif ($rows > 1) {
316     $self->throw_exception("Can't update ${self}: updated more than one row");
317   }
318   $self->{_dirty_columns} = {};
319   $self->{related_resultsets} = {};
320   undef $self->{_orig_ident};
321   return $self;
322 }
323
324 =head2 delete
325
326   $obj->delete
327
328 Deletes the object from the database. The object is still perfectly
329 usable, but C<< ->in_storage() >> will now return 0 and the object must
330 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
331 on it. If you delete an object in a class with a C<has_many>
332 relationship, all the related objects will be deleted as well. To turn
333 this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
334 hashref. Any database-level cascade or restrict will take precedence
335 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
336
337 =cut
338
339 sub delete {
340   my $self = shift;
341   if (ref $self) {
342     $self->throw_exception( "Not in database" ) unless $self->in_storage;
343     my $ident_cond = $self->ident_condition;
344     $self->throw_exception("Cannot safely delete a row in a PK-less table")
345       if ! keys %$ident_cond;
346     foreach my $column (keys %$ident_cond) {
347             $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
348               unless exists $self->{_column_data}{$column};
349     }
350     $self->result_source->storage->delete(
351       $self->result_source, $ident_cond);
352     $self->in_storage(undef);
353   } else {
354     $self->throw_exception("Can't do class delete without a ResultSource instance")
355       unless $self->can('result_source_instance');
356     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
357     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
358     $self->result_source_instance->resultset->search(@_)->delete;
359   }
360   return $self;
361 }
362
363 =head2 get_column
364
365   my $val = $obj->get_column($col);
366
367 Returns a raw column value from the row object, if it has already
368 been fetched from the database or set by an accessor.
369
370 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
371 will be deflated and returned.
372
373 =cut
374
375 sub get_column {
376   my ($self, $column) = @_;
377   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
378   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
379   if (exists $self->{_inflated_column}{$column}) {
380     return $self->store_column($column,
381       $self->_deflated_column($column, $self->{_inflated_column}{$column}));   
382   }
383   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
384   return undef;
385 }
386
387 =head2 has_column_loaded
388
389   if ( $obj->has_column_loaded($col) ) {
390      print "$col has been loaded from db";
391   }
392
393 Returns a true value if the column value has been loaded from the
394 database (or set locally).
395
396 =cut
397
398 sub has_column_loaded {
399   my ($self, $column) = @_;
400   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
401   return 1 if exists $self->{_inflated_column}{$column};
402   return exists $self->{_column_data}{$column};
403 }
404
405 =head2 get_columns
406
407   my %data = $obj->get_columns;
408
409 Does C<get_column>, for all loaded column values at once.
410
411 =cut
412
413 sub get_columns {
414   my $self = shift;
415   if (exists $self->{_inflated_column}) {
416     foreach my $col (keys %{$self->{_inflated_column}}) {
417       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
418         unless exists $self->{_column_data}{$col};
419     }
420   }
421   return %{$self->{_column_data}};
422 }
423
424 =head2 get_dirty_columns
425
426   my %data = $obj->get_dirty_columns;
427
428 Identical to get_columns but only returns those that have been changed.
429
430 =cut
431
432 sub get_dirty_columns {
433   my $self = shift;
434   return map { $_ => $self->{_column_data}{$_} }
435            keys %{$self->{_dirty_columns}};
436 }
437
438 =head2 get_inflated_columns
439
440   my %inflated_data = $obj->get_inflated_columns;
441
442 Similar to get_columns but objects are returned for inflated columns
443 instead of their raw non-inflated values.
444
445 =cut
446
447 sub get_inflated_columns {
448   my $self = shift;
449   return map {
450     my $accessor = $self->column_info($_)->{'accessor'} || $_;
451     ($_ => $self->$accessor);
452   } $self->columns;
453 }
454
455 =head2 set_column
456
457   $obj->set_column($col => $val);
458
459 Sets a raw column value. If the new value is different from the old one,
460 the column is marked as dirty for when you next call $obj->update.
461
462 If passed an object or reference, this will happily attempt store the
463 value, and a later insert/update will try and stringify/numify as
464 appropriate.
465
466 =cut
467
468 sub set_column {
469   my $self = shift;
470   my ($column) = @_;
471   $self->{_orig_ident} ||= $self->ident_condition;
472   my $old = $self->get_column($column);
473   my $ret = $self->store_column(@_);
474   $self->{_dirty_columns}{$column} = 1
475     if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
476
477   # XXX clear out the relation cache for this column
478   delete $self->{related_resultsets}{$column};
479
480   return $ret;
481 }
482
483 =head2 set_columns
484
485   my $copy = $orig->set_columns({ $col => $val, ... });
486
487 Sets more than one column value at once.
488
489 =cut
490
491 sub set_columns {
492   my ($self,$data) = @_;
493   foreach my $col (keys %$data) {
494     $self->set_column($col,$data->{$col});
495   }
496   return $self;
497 }
498
499 =head2 set_inflated_columns
500
501   my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
502
503 Sets more than one column value at once, taking care to respect inflations and
504 relationships if relevant. Be aware that this hashref might be edited in place,
505 so dont rely on it being the same after a call to C<set_inflated_columns>. If
506 you need to preserve the hashref, it is sufficient to pass a shallow copy to
507 C<set_inflated_columns>, e.g. ( { %{ $href } } )
508
509 =cut
510
511 sub set_inflated_columns {
512   my ( $self, $upd ) = @_;
513   foreach my $key (keys %$upd) {
514     if (ref $upd->{$key}) {
515       my $info = $self->relationship_info($key);
516       if ($info && $info->{attrs}{accessor}
517         && $info->{attrs}{accessor} eq 'single')
518       {
519         my $rel = delete $upd->{$key};
520         $self->set_from_related($key => $rel);
521         $self->{_relationship_data}{$key} = $rel;          
522       } elsif ($info && $info->{attrs}{accessor}
523         && $info->{attrs}{accessor} eq 'multi'
524         && ref $upd->{$key} eq 'ARRAY') {
525         my $others = delete $upd->{$key};
526         foreach my $rel_obj (@$others) {
527           if(!Scalar::Util::blessed($rel_obj)) {
528             $rel_obj = $self->create_related($key, $rel_obj);
529           }
530         }
531         $self->{_relationship_data}{$key} = $others; 
532 #            $related->{$key} = $others;
533         next;
534       }
535       elsif ($self->has_column($key)
536         && exists $self->column_info($key)->{_inflate_info})
537       {
538         $self->set_inflated_column($key, delete $upd->{$key});          
539       }
540     }
541   }
542   $self->set_columns($upd);    
543 }
544
545 =head2 copy
546
547   my $copy = $orig->copy({ change => $to, ... });
548
549 Inserts a new row with the specified changes.
550
551 =cut
552
553 sub copy {
554   my ($self, $changes) = @_;
555   $changes ||= {};
556   my $col_data = { %{$self->{_column_data}} };
557   foreach my $col (keys %$col_data) {
558     delete $col_data->{$col}
559       if $self->result_source->column_info($col)->{is_auto_increment};
560   }
561
562   my $new = { _column_data => $col_data };
563   bless $new, ref $self;
564
565   $new->result_source($self->result_source);
566   $new->set_inflated_columns($changes);
567   $new->insert;
568
569   # Its possible we'll have 2 relations to the same Source. We need to make 
570   # sure we don't try to insert the same row twice esle we'll violate unique
571   # constraints
572   my $rels_copied = {};
573
574   foreach my $rel ($self->result_source->relationships) {
575     my $rel_info = $self->result_source->relationship_info($rel);
576
577     next unless $rel_info->{attrs}{cascade_copy};
578   
579     my $resolved = $self->result_source->resolve_condition(
580       $rel_info->{cond}, $rel, $new
581     );
582
583     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
584     foreach my $related ($self->search_related($rel)) {
585       my $id_str = join("\0", $related->id);
586       next if $copied->{$id_str};
587       $copied->{$id_str} = 1;
588       my $rel_copy = $related->copy($resolved);
589     }
590  
591   }
592   return $new;
593 }
594
595 =head2 store_column
596
597   $obj->store_column($col => $val);
598
599 Sets a column value without marking it as dirty.
600
601 =cut
602
603 sub store_column {
604   my ($self, $column, $value) = @_;
605   $self->throw_exception( "No such column '${column}'" )
606     unless exists $self->{_column_data}{$column} || $self->has_column($column);
607   $self->throw_exception( "set_column called for ${column} without value" )
608     if @_ < 3;
609   return $self->{_column_data}{$column} = $value;
610 }
611
612 =head2 inflate_result
613
614   Class->inflate_result($result_source, \%me, \%prefetch?)
615
616 Called by ResultSet to inflate a result from storage
617
618 =cut
619
620 sub inflate_result {
621   my ($class, $source, $me, $prefetch) = @_;
622
623   my ($source_handle) = $source;
624
625   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
626       $source = $source_handle->resolve
627   } else {
628       $source_handle = $source->handle
629   }
630
631   my $new = {
632     _source_handle => $source_handle,
633     _column_data => $me,
634     _in_storage => 1
635   };
636   bless $new, (ref $class || $class);
637
638   my $schema;
639   foreach my $pre (keys %{$prefetch||{}}) {
640     my $pre_val = $prefetch->{$pre};
641     my $pre_source = $source->related_source($pre);
642     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
643       unless $pre_source;
644     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
645       my @pre_objects;
646       foreach my $pre_rec (@$pre_val) {
647         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
648            and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
649           next;
650         }
651         push(@pre_objects, $pre_source->result_class->inflate_result(
652                              $pre_source, @{$pre_rec}));
653       }
654       $new->related_resultset($pre)->set_cache(\@pre_objects);
655     } elsif (defined $pre_val->[0]) {
656       my $fetched;
657       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
658          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
659       {
660         $fetched = $pre_source->result_class->inflate_result(
661                       $pre_source, @{$pre_val});
662       }
663       $new->related_resultset($pre)->set_cache([ $fetched ]);
664       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
665       $class->throw_exception("No accessor for prefetched $pre")
666        unless defined $accessor;
667       if ($accessor eq 'single') {
668         $new->{_relationship_data}{$pre} = $fetched;
669       } elsif ($accessor eq 'filter') {
670         $new->{_inflated_column}{$pre} = $fetched;
671       } else {
672        $class->throw_exception("Prefetch not supported with accessor '$accessor'");
673       }
674     }
675   }
676   return $new;
677 }
678
679 =head2 update_or_insert
680
681   $obj->update_or_insert
682
683 Updates the object if it's already in the database, according to
684 L</in_storage>, else inserts it.
685
686 =head2 insert_or_update
687
688   $obj->insert_or_update
689
690 Alias for L</update_or_insert>
691
692 =cut
693
694 *insert_or_update = \&update_or_insert;
695 sub update_or_insert {
696   my $self = shift;
697   return ($self->in_storage ? $self->update : $self->insert);
698 }
699
700 =head2 is_changed
701
702   my @changed_col_names = $obj->is_changed();
703   if ($obj->is_changed()) { ... }
704
705 In array context returns a list of columns with uncommited changes, or
706 in scalar context returns a true value if there are uncommitted
707 changes.
708
709 =cut
710
711 sub is_changed {
712   return keys %{shift->{_dirty_columns} || {}};
713 }
714
715 =head2 is_column_changed
716
717   if ($obj->is_column_changed('col')) { ... }
718
719 Returns a true value if the column has uncommitted changes.
720
721 =cut
722
723 sub is_column_changed {
724   my( $self, $col ) = @_;
725   return exists $self->{_dirty_columns}->{$col};
726 }
727
728 =head2 result_source
729
730   my $resultsource = $object->result_source;
731
732 Accessor to the ResultSource this object was created from
733
734 =cut
735
736 sub result_source {
737     my $self = shift;
738
739     if (@_) {
740         $self->_source_handle($_[0]->handle);
741     } else {
742         $self->_source_handle->resolve;
743     }
744 }
745
746 =head2 register_column
747
748   $column_info = { .... };
749   $class->register_column($column_name, $column_info);
750
751 Registers a column on the class. If the column_info has an 'accessor'
752 key, creates an accessor named after the value if defined; if there is
753 no such key, creates an accessor with the same name as the column
754
755 The column_info attributes are described in
756 L<DBIx::Class::ResultSource/add_columns>
757
758 =cut
759
760 sub register_column {
761   my ($class, $col, $info) = @_;
762   my $acc = $col;
763   if (exists $info->{accessor}) {
764     return unless defined $info->{accessor};
765     $acc = [ $info->{accessor}, $col ];
766   }
767   $class->mk_group_accessors('column' => $acc);
768 }
769
770
771 =head2 throw_exception
772
773 See Schema's throw_exception.
774
775 =cut
776
777 sub throw_exception {
778   my $self=shift;
779   if (ref $self && ref $self->result_source && $self->result_source->schema) {
780     $self->result_source->schema->throw_exception(@_);
781   } else {
782     croak(@_);
783   }
784 }
785
786 =head2 id
787
788 Returns the primary key(s) for a row. Can't be called as a class method.
789 Actually implemented in L<DBIx::Class::PK>
790
791 =head2 discard_changes
792
793 Re-selects the row from the database, losing any changes that had
794 been made.
795
796 This method can also be used to refresh from storage, retrieving any
797 changes made since the row was last read from storage. Actually
798 implemented in L<DBIx::Class::PK>
799
800 =cut
801
802 1;
803
804 =head1 AUTHORS
805
806 Matt S. Trout <mst@shadowcatsystems.co.uk>
807
808 =head1 LICENSE
809
810 You may distribute this code under the same terms as Perl itself.
811
812 =cut