Refactor ::DBIHacks::_extract_fixed_condition_columns (sequel to 8d005ad9)
[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
8 use Scalar::Util 'blessed';
9 use List::Util 'first';
10 use Try::Tiny;
11 use DBIx::Class::Carp;
12 use DBIx::Class::_Util 'is_literal_value';
13
14 ###
15 ### Internal method
16 ### Do not use
17 ###
18 BEGIN {
19   *MULTICREATE_DEBUG =
20     $ENV{DBIC_MULTICREATE_DEBUG}
21       ? sub () { 1 }
22       : sub () { 0 };
23 }
24
25 use namespace::clean;
26
27 __PACKAGE__->mk_group_accessors ( simple => [ in_storage => '_in_storage' ] );
28
29 =head1 NAME
30
31 DBIx::Class::Row - Basic row methods
32
33 =head1 SYNOPSIS
34
35 =head1 DESCRIPTION
36
37 This class is responsible for defining and doing basic operations on rows
38 derived from L<DBIx::Class::ResultSource> objects.
39
40 Result objects are returned from L<DBIx::Class::ResultSet>s using the
41 L<create|DBIx::Class::ResultSet/create>, L<find|DBIx::Class::ResultSet/find>,
42 L<next|DBIx::Class::ResultSet/next> and L<all|DBIx::Class::ResultSet/all> methods,
43 as well as invocations of 'single' (
44 L<belongs_to|DBIx::Class::Relationship/belongs_to>,
45 L<has_one|DBIx::Class::Relationship/has_one> or
46 L<might_have|DBIx::Class::Relationship/might_have>)
47 relationship accessors of L<Result|DBIx::Class::Manual::ResultClass> objects.
48
49 =head1 NOTE
50
51 All "Row objects" derived from a Schema-attached L<DBIx::Class::ResultSet>
52 object (such as a typical C<< L<search|DBIx::Class::ResultSet/search>->
53 L<next|DBIx::Class::ResultSet/next> >> call) are actually Result
54 instances, based on your application's
55 L<Result class|DBIx::Class::Manual::Glossary/Result_class>.
56
57 L<DBIx::Class::Row> implements most of the row-based communication with the
58 underlying storage, but a Result class B<should not inherit from it directly>.
59 Usually, Result classes inherit from L<DBIx::Class::Core>, which in turn
60 combines the methods from several classes, one of them being
61 L<DBIx::Class::Row>.  Therefore, while many of the methods available to a
62 L<DBIx::Class::Core>-derived Result class are described in the following
63 documentation, it does not detail all of the methods available to Result
64 objects.  Refer to L<DBIx::Class::Manual::ResultClass> for more info.
65
66 =head1 METHODS
67
68 =head2 new
69
70   my $result = My::Class->new(\%attrs);
71
72   my $result = $schema->resultset('MySource')->new(\%colsandvalues);
73
74 =over
75
76 =item Arguments: \%attrs or \%colsandvalues
77
78 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
79
80 =back
81
82 While you can create a new result object by calling C<new> directly on
83 this class, you are better off calling it on a
84 L<DBIx::Class::ResultSet> object.
85
86 When calling it directly, you will not get a complete, usable row
87 object until you pass or set the C<result_source> attribute, to a
88 L<DBIx::Class::ResultSource> instance that is attached to a
89 L<DBIx::Class::Schema> with a valid connection.
90
91 C<$attrs> is a hashref of column name, value data. It can also contain
92 some other attributes such as the C<result_source>.
93
94 Passing an object, or an arrayref of objects as a value will call
95 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
96 passed a hashref or an arrayref of hashrefs as the value, these will
97 be turned into objects via new_related, and treated as if you had
98 passed objects.
99
100 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
101
102 Please note that if a value is not passed to new, no value will be sent
103 in the SQL INSERT call, and the column will therefore assume whatever
104 default value was specified in your database. While DBIC will retrieve the
105 value of autoincrement columns, it will never make an explicit database
106 trip to retrieve default values assigned by the RDBMS. You can explicitly
107 request that all values be fetched back from the database by calling
108 L</discard_changes>, or you can supply an explicit C<undef> to columns
109 with NULL as the default, and save yourself a SELECT.
110
111  CAVEAT:
112
113  The behavior described above will backfire if you use a foreign key column
114  with a database-defined default. If you call the relationship accessor on
115  an object that doesn't have a set value for the FK column, DBIC will throw
116  an exception, as it has no way of knowing the PK of the related object (if
117  there is one).
118
119 =cut
120
121 ## 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().
122 ## This only works because DBIC doesn't yet care to check whether the new_related objects have been passed all their mandatory columns
123 ## When doing the later insert, we need to make sure the PKs are set.
124 ## using _relationship_data in new and funky ways..
125 ## check Relationship::CascadeActions and Relationship::Accessor for compat
126 ## tests!
127
128 sub __new_related_find_or_new_helper {
129   my ($self, $rel_name, $values) = @_;
130
131   my $rsrc = $self->result_source;
132
133   # create a mock-object so all new/set_column component overrides will run:
134   my $rel_rs = $rsrc->related_source($rel_name)->resultset;
135   my $new_rel_obj = $rel_rs->new_result($values);
136   my $proc_data = { $new_rel_obj->get_columns };
137
138   if ($self->__their_pk_needs_us($rel_name)) {
139     MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via new_result\n";
140     return $new_rel_obj;
141   }
142   elsif ($rsrc->_pk_depends_on($rel_name, $proc_data )) {
143     if (! keys %$proc_data) {
144       # there is nothing to search for - blind create
145       MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $rel_name\n";
146     }
147     else {
148       MULTICREATE_DEBUG and print STDERR "MC $self constructing $rel_name via find_or_new\n";
149       # this is not *really* find or new, as we don't want to double-new the
150       # data (thus potentially double encoding or whatever)
151       my $exists = $rel_rs->find ($proc_data);
152       return $exists if $exists;
153     }
154     return $new_rel_obj;
155   }
156   else {
157     my $us = $rsrc->source_name;
158     $self->throw_exception (
159       "Unable to determine relationship '$rel_name' direction from '$us', "
160     . "possibly due to a missing reverse-relationship on '$rel_name' to '$us'."
161     );
162   }
163 }
164
165 sub __their_pk_needs_us { # this should maybe be in resultsource.
166   my ($self, $rel_name) = @_;
167   my $rsrc = $self->result_source;
168   my $reverse = $rsrc->reverse_relationship_info($rel_name);
169   my $rel_source = $rsrc->related_source($rel_name);
170   my $us = { $self->get_columns };
171   foreach my $key (keys %$reverse) {
172     # if their primary key depends on us, then we have to
173     # just create a result and we'll fill it out afterwards
174     return 1 if $rel_source->_pk_depends_on($key, $us);
175   }
176   return 0;
177 }
178
179 sub new {
180   my ($class, $attrs) = @_;
181   $class = ref $class if ref $class;
182
183   my $new = bless { _column_data => {}, _in_storage => 0 }, $class;
184
185   if ($attrs) {
186     $new->throw_exception("attrs must be a hashref")
187       unless ref($attrs) eq 'HASH';
188
189     my $rsrc = delete $attrs->{-result_source};
190     if ( my $h = delete $attrs->{-source_handle} ) {
191       $rsrc ||= $h->resolve;
192     }
193
194     $new->result_source($rsrc) if $rsrc;
195
196     if (my $col_from_rel = delete $attrs->{-cols_from_relations}) {
197       @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = ();
198     }
199
200     my ($related,$inflated);
201
202     foreach my $key (keys %$attrs) {
203       if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) {
204         ## Can we extract this lot to use with update(_or .. ) ?
205         $new->throw_exception("Can't do multi-create without result source")
206           unless $rsrc;
207         my $info = $rsrc->relationship_info($key);
208         my $acc_type = $info->{attrs}{accessor} || '';
209         if ($acc_type eq 'single') {
210           my $rel_obj = delete $attrs->{$key};
211           if(!blessed $rel_obj) {
212             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
213           }
214
215           if ($rel_obj->in_storage) {
216             $new->{_rel_in_storage}{$key} = 1;
217             $new->set_from_related($key, $rel_obj);
218           } else {
219             MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n";
220           }
221
222           $related->{$key} = $rel_obj;
223           next;
224         }
225         elsif ($acc_type eq 'multi' && ref $attrs->{$key} eq 'ARRAY' ) {
226           my $others = delete $attrs->{$key};
227           my $total = @$others;
228           my @objects;
229           foreach my $idx (0 .. $#$others) {
230             my $rel_obj = $others->[$idx];
231             if(!blessed $rel_obj) {
232               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
233             }
234
235             if ($rel_obj->in_storage) {
236               $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong');
237             } else {
238               MULTICREATE_DEBUG and
239                 print STDERR "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
240             }
241             push(@objects, $rel_obj);
242           }
243           $related->{$key} = \@objects;
244           next;
245         }
246         elsif ($acc_type eq 'filter') {
247           ## 'filter' should disappear and get merged in with 'single' above!
248           my $rel_obj = delete $attrs->{$key};
249           if(!blessed $rel_obj) {
250             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
251           }
252           if ($rel_obj->in_storage) {
253             $new->{_rel_in_storage}{$key} = 1;
254           }
255           else {
256             MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n";
257           }
258           $inflated->{$key} = $rel_obj;
259           next;
260         } elsif ($class->has_column($key)
261             && $class->column_info($key)->{_inflate_info}) {
262           $inflated->{$key} = $attrs->{$key};
263           next;
264         }
265       }
266       $new->throw_exception("No such column '$key' on $class")
267         unless $class->has_column($key);
268       $new->store_column($key => $attrs->{$key});
269     }
270
271     $new->{_relationship_data} = $related if $related;
272     $new->{_inflated_column} = $inflated if $inflated;
273   }
274
275   return $new;
276 }
277
278 =head2 $column_accessor
279
280   # Each pair does the same thing
281
282   # (un-inflated, regular column)
283   my $val = $result->get_column('first_name');
284   my $val = $result->first_name;
285
286   $result->set_column('first_name' => $val);
287   $result->first_name($val);
288
289   # (inflated column via DBIx::Class::InflateColumn::DateTime)
290   my $val = $result->get_inflated_column('last_modified');
291   my $val = $result->last_modified;
292
293   $result->set_inflated_column('last_modified' => $val);
294   $result->last_modified($val);
295
296 =over
297
298 =item Arguments: $value?
299
300 =item Return Value: $value
301
302 =back
303
304 A column accessor method is created for each column, which is used for
305 getting/setting the value for that column.
306
307 The actual method name is based on the
308 L<accessor|DBIx::Class::ResultSource/accessor> name given during the
309 L<Result Class|DBIx::Class::Manual::ResultClass> L<column definition
310 |DBIx::Class::ResultSource/add_columns>. Like L</set_column>, this
311 will not store the data in the database until L</insert> or L</update>
312 is called on the row.
313
314 =head2 insert
315
316   $result->insert;
317
318 =over
319
320 =item Arguments: none
321
322 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
323
324 =back
325
326 Inserts an object previously created by L</new> into the database if
327 it isn't already in there. Returns the object itself. To insert an
328 entirely new row into the database, use L<DBIx::Class::ResultSet/create>.
329
330 To fetch an uninserted result object, call
331 L<new_result|DBIx::Class::ResultSet/new_result> on a resultset.
332
333 This will also insert any uninserted, related objects held inside this
334 one, see L<DBIx::Class::ResultSet/create> for more details.
335
336 =cut
337
338 sub insert {
339   my ($self) = @_;
340   return $self if $self->in_storage;
341   my $rsrc = $self->result_source;
342   $self->throw_exception("No result_source set on this object; can't insert")
343     unless $rsrc;
344
345   my $storage = $rsrc->storage;
346
347   my $rollback_guard;
348
349   # Check if we stored uninserted relobjs here in new()
350   my %related_stuff = (%{$self->{_relationship_data} || {}},
351                        %{$self->{_inflated_column} || {}});
352
353   # insert what needs to be inserted before us
354   my %pre_insert;
355   for my $rel_name (keys %related_stuff) {
356     my $rel_obj = $related_stuff{$rel_name};
357
358     if (! $self->{_rel_in_storage}{$rel_name}) {
359       next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row'));
360
361       next unless $rsrc->_pk_depends_on(
362                     $rel_name, { $rel_obj->get_columns }
363                   );
364
365       # The guard will save us if we blow out of this scope via die
366       $rollback_guard ||= $storage->txn_scope_guard;
367
368       MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $rel_name $rel_obj\n";
369
370       my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns };
371       my $existing;
372
373       # if there are no keys - nothing to search for
374       if (keys %$them and $existing = $self->result_source
375                                            ->related_source($rel_name)
376                                            ->resultset
377                                            ->find($them)
378       ) {
379         %{$rel_obj} = %{$existing};
380       }
381       else {
382         $rel_obj->insert;
383       }
384
385       $self->{_rel_in_storage}{$rel_name} = 1;
386     }
387
388     $self->set_from_related($rel_name, $rel_obj);
389     delete $related_stuff{$rel_name};
390   }
391
392   # start a transaction here if not started yet and there is more stuff
393   # to insert after us
394   if (keys %related_stuff) {
395     $rollback_guard ||= $storage->txn_scope_guard
396   }
397
398   MULTICREATE_DEBUG and do {
399     no warnings 'uninitialized';
400     print STDERR "MC $self inserting (".join(', ', $self->get_columns).")\n";
401   };
402
403   # perform the insert - the storage will return everything it is asked to
404   # (autoinc primary columns and any retrieve_on_insert columns)
405   my %current_rowdata = $self->get_columns;
406   my $returned_cols = $storage->insert(
407     $rsrc,
408     { %current_rowdata }, # what to insert, copy because the storage *will* change it
409   );
410
411   for (keys %$returned_cols) {
412     $self->store_column($_, $returned_cols->{$_})
413       # this ensures we fire store_column only once
414       # (some asshats like overriding it)
415       if (
416         (!exists $current_rowdata{$_})
417           or
418         (defined $current_rowdata{$_} xor defined $returned_cols->{$_})
419           or
420         (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_})
421       );
422   }
423
424   delete $self->{_column_data_in_storage};
425   $self->in_storage(1);
426
427   $self->{_dirty_columns} = {};
428   $self->{related_resultsets} = {};
429
430   foreach my $rel_name (keys %related_stuff) {
431     next unless $rsrc->has_relationship ($rel_name);
432
433     my @cands = ref $related_stuff{$rel_name} eq 'ARRAY'
434       ? @{$related_stuff{$rel_name}}
435       : $related_stuff{$rel_name}
436     ;
437
438     if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row')
439     ) {
440       my $reverse = $rsrc->reverse_relationship_info($rel_name);
441       foreach my $obj (@cands) {
442         $obj->set_from_related($_, $self) for keys %$reverse;
443         if ($self->__their_pk_needs_us($rel_name)) {
444           if (exists $self->{_ignore_at_insert}{$rel_name}) {
445             MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $rel_name\n";
446           }
447           else {
448             MULTICREATE_DEBUG and print STDERR "MC $self inserting $rel_name $obj\n";
449             $obj->insert;
450           }
451         } else {
452           MULTICREATE_DEBUG and print STDERR "MC $self post-inserting $obj\n";
453           $obj->insert();
454         }
455       }
456     }
457   }
458
459   delete $self->{_ignore_at_insert};
460
461   $rollback_guard->commit if $rollback_guard;
462
463   return $self;
464 }
465
466 =head2 in_storage
467
468   $result->in_storage; # Get value
469   $result->in_storage(1); # Set value
470
471 =over
472
473 =item Arguments: none or 1|0
474
475 =item Return Value: 1|0
476
477 =back
478
479 Indicates whether the object exists as a row in the database or
480 not. This is set to true when L<DBIx::Class::ResultSet/find>,
481 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
482 are used.
483
484 Creating a result object using L<DBIx::Class::ResultSet/new_result>, or
485 calling L</delete> on one, sets it to false.
486
487
488 =head2 update
489
490   $result->update(\%columns?)
491
492 =over
493
494 =item Arguments: none or a hashref
495
496 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
497
498 =back
499
500 Throws an exception if the result object is not yet in the database,
501 according to L</in_storage>. Returns the object itself.
502
503 This method issues an SQL UPDATE query to commit any changes to the
504 object to the database if required (see L</get_dirty_columns>).
505 It throws an exception if a proper WHERE clause uniquely identifying
506 the database row can not be constructed (see
507 L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
508 for more details).
509
510 Also takes an optional hashref of C<< column_name => value >> pairs
511 to update on the object first. Be aware that the hashref will be
512 passed to C<set_inflated_columns>, which might edit it in place, so
513 don't rely on it being the same after a call to C<update>.  If you
514 need to preserve the hashref, it is sufficient to pass a shallow copy
515 to C<update>, e.g. ( { %{ $href } } )
516
517 If the values passed or any of the column values set on the object
518 contain scalar references, e.g.:
519
520   $result->last_modified(\'NOW()')->update();
521   # OR
522   $result->update({ last_modified => \'NOW()' });
523
524 The update will pass the values verbatim into SQL. (See
525 L<SQL::Abstract> docs).  The values in your Result object will NOT change
526 as a result of the update call, if you want the object to be updated
527 with the actual values from the database, call L</discard_changes>
528 after the update.
529
530   $result->update()->discard_changes();
531
532 To determine before calling this method, which column values have
533 changed and will be updated, call L</get_dirty_columns>.
534
535 To check if any columns will be updated, call L</is_changed>.
536
537 To force a column to be updated, call L</make_column_dirty> before
538 this method.
539
540 =cut
541
542 sub update {
543   my ($self, $upd) = @_;
544
545   $self->set_inflated_columns($upd) if $upd;
546
547   my %to_update = $self->get_dirty_columns
548     or return $self;
549
550   $self->throw_exception( "Not in database" ) unless $self->in_storage;
551
552   my $rows = $self->result_source->storage->update(
553     $self->result_source, \%to_update, $self->_storage_ident_condition
554   );
555   if ($rows == 0) {
556     $self->throw_exception( "Can't update ${self}: row not found" );
557   } elsif ($rows > 1) {
558     $self->throw_exception("Can't update ${self}: updated more than one row");
559   }
560   $self->{_dirty_columns} = {};
561   $self->{related_resultsets} = {};
562   delete $self->{_column_data_in_storage};
563   return $self;
564 }
565
566 =head2 delete
567
568   $result->delete
569
570 =over
571
572 =item Arguments: none
573
574 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
575
576 =back
577
578 Throws an exception if the object is not in the database according to
579 L</in_storage>. Also throws an exception if a proper WHERE clause
580 uniquely identifying the database row can not be constructed (see
581 L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
582 for more details).
583
584 The object is still perfectly usable, but L</in_storage> will
585 now return 0 and the object must be reinserted using L</insert>
586 before it can be used to L</update> the row again.
587
588 If you delete an object in a class with a C<has_many> relationship, an
589 attempt is made to delete all the related objects as well. To turn
590 this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
591 hashref of the relationship, see L<DBIx::Class::Relationship>. Any
592 database-level cascade or restrict will take precedence over a
593 DBIx-Class-based cascading delete, since DBIx-Class B<deletes the
594 main row first> and only then attempts to delete any remaining related
595 rows.
596
597 If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
598 and the transaction subsequently fails, the result object will remain marked as
599 not being in storage. If you know for a fact that the object is still in
600 storage (i.e. by inspecting the cause of the transaction's failure), you can
601 use C<< $obj->in_storage(1) >> to restore consistency between the object and
602 the database. This would allow a subsequent C<< $obj->delete >> to work
603 as expected.
604
605 See also L<DBIx::Class::ResultSet/delete>.
606
607 =cut
608
609 sub delete {
610   my $self = shift;
611   if (ref $self) {
612     $self->throw_exception( "Not in database" ) unless $self->in_storage;
613
614     $self->result_source->storage->delete(
615       $self->result_source, $self->_storage_ident_condition
616     );
617
618     delete $self->{_column_data_in_storage};
619     $self->in_storage(0);
620   }
621   else {
622     my $rsrc = try { $self->result_source_instance }
623       or $self->throw_exception("Can't do class delete without a ResultSource instance");
624
625     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
626     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
627     $rsrc->resultset->search(@_)->delete;
628   }
629   return $self;
630 }
631
632 =head2 get_column
633
634   my $val = $result->get_column($col);
635
636 =over
637
638 =item Arguments: $columnname
639
640 =item Return Value: The value of the column
641
642 =back
643
644 Throws an exception if the column name given doesn't exist according
645 to L<has_column|DBIx::Class::ResultSource/has_column>.
646
647 Returns a raw column value from the result object, if it has already
648 been fetched from the database or set by an accessor.
649
650 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
651 will be deflated and returned.
652
653 Note that if you used the C<columns> or the C<select/as>
654 L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
655 which C<$result> was derived, and B<did not include> C<$columnname> in the list,
656 this method will return C<undef> even if the database contains some value.
657
658 To retrieve all loaded column values as a hash, use L</get_columns>.
659
660 =cut
661
662 sub get_column {
663   my ($self, $column) = @_;
664   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
665
666   return $self->{_column_data}{$column}
667     if exists $self->{_column_data}{$column};
668
669   if (exists $self->{_inflated_column}{$column}) {
670     # deflate+return cycle
671     return $self->store_column($column, $self->_deflated_column(
672       $column, $self->{_inflated_column}{$column}
673     ));
674   }
675
676   $self->throw_exception( "No such column '${column}'" )
677     unless $self->has_column($column);
678
679   return undef;
680 }
681
682 =head2 has_column_loaded
683
684   if ( $result->has_column_loaded($col) ) {
685      print "$col has been loaded from db";
686   }
687
688 =over
689
690 =item Arguments: $columnname
691
692 =item Return Value: 0|1
693
694 =back
695
696 Returns a true value if the column value has been loaded from the
697 database (or set locally).
698
699 =cut
700
701 sub has_column_loaded {
702   my ($self, $column) = @_;
703   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
704
705   return (
706     exists $self->{_inflated_column}{$column}
707       or
708     exists $self->{_column_data}{$column}
709   ) ? 1 : 0;
710 }
711
712 =head2 get_columns
713
714   my %data = $result->get_columns;
715
716 =over
717
718 =item Arguments: none
719
720 =item Return Value: A hash of columnname, value pairs.
721
722 =back
723
724 Returns all loaded column data as a hash, containing raw values. To
725 get just one value for a particular column, use L</get_column>.
726
727 See L</get_inflated_columns> to get the inflated values.
728
729 =cut
730
731 sub get_columns {
732   my $self = shift;
733   if (exists $self->{_inflated_column}) {
734     # deflate cycle for each inflation, including filter rels
735     foreach my $col (keys %{$self->{_inflated_column}}) {
736       unless (exists $self->{_column_data}{$col}) {
737
738         # if cached related_resultset is present assume this was a prefetch
739         carp_unique(
740           "Returning primary keys of prefetched 'filter' rels as part of get_columns() is deprecated and will "
741         . 'eventually be removed entirely (set DBIC_COLUMNS_INCLUDE_FILTER_RELS to disable this warning)'
742         ) if (
743           ! $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS}
744             and
745           defined $self->{related_resultsets}{$col}
746             and
747           defined $self->{related_resultsets}{$col}->get_cache
748         );
749
750         $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}));
751       }
752     }
753   }
754   return %{$self->{_column_data}};
755 }
756
757 =head2 get_dirty_columns
758
759   my %data = $result->get_dirty_columns;
760
761 =over
762
763 =item Arguments: none
764
765 =item Return Value: A hash of column, value pairs
766
767 =back
768
769 Only returns the column, value pairs for those columns that have been
770 changed on this object since the last L</update> or L</insert> call.
771
772 See L</get_columns> to fetch all column/value pairs.
773
774 =cut
775
776 sub get_dirty_columns {
777   my $self = shift;
778   return map { $_ => $self->{_column_data}{$_} }
779            keys %{$self->{_dirty_columns}};
780 }
781
782 =head2 make_column_dirty
783
784   $result->make_column_dirty($col)
785
786 =over
787
788 =item Arguments: $columnname
789
790 =item Return Value: not defined
791
792 =back
793
794 Throws an exception if the column does not exist.
795
796 Marks a column as having been changed regardless of whether it has
797 really changed.
798
799 =cut
800
801 sub make_column_dirty {
802   my ($self, $column) = @_;
803
804   $self->throw_exception( "No such column '${column}'" )
805     unless exists $self->{_column_data}{$column} || $self->has_column($column);
806
807   # the entire clean/dirty code relies on exists, not on true/false
808   return 1 if exists $self->{_dirty_columns}{$column};
809
810   $self->{_dirty_columns}{$column} = 1;
811
812   # if we are just now making the column dirty, and if there is an inflated
813   # value, force it over the deflated one
814   if (exists $self->{_inflated_column}{$column}) {
815     $self->store_column($column,
816       $self->_deflated_column(
817         $column, $self->{_inflated_column}{$column}
818       )
819     );
820   }
821 }
822
823 =head2 get_inflated_columns
824
825   my %inflated_data = $obj->get_inflated_columns;
826
827 =over
828
829 =item Arguments: none
830
831 =item Return Value: A hash of column, object|value pairs
832
833 =back
834
835 Returns a hash of all column keys and associated values. Values for any
836 columns set to use inflation will be inflated and returns as objects.
837
838 See L</get_columns> to get the uninflated values.
839
840 See L<DBIx::Class::InflateColumn> for how to setup inflation.
841
842 =cut
843
844 sub get_inflated_columns {
845   my $self = shift;
846
847   my $loaded_colinfo = $self->columns_info ([
848     grep { $self->has_column_loaded($_) } $self->columns
849   ]);
850
851   my %cols_to_return = ( %{$self->{_column_data}}, %$loaded_colinfo );
852
853   unless ($ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS}) {
854     for (keys %$loaded_colinfo) {
855       # if cached related_resultset is present assume this was a prefetch
856       if (
857         $loaded_colinfo->{$_}{_inflate_info}
858           and
859         defined $self->{related_resultsets}{$_}
860           and
861         defined $self->{related_resultsets}{$_}->get_cache
862       ) {
863         carp_unique(
864           "Returning prefetched 'filter' rels as part of get_inflated_columns() is deprecated and will "
865         . 'eventually be removed entirely (set DBIC_COLUMNS_INCLUDE_FILTER_RELS to disable this warning)'
866         );
867         last;
868       }
869     }
870   }
871
872   map { $_ => (
873   (
874     ! exists $loaded_colinfo->{$_}
875       or
876     (
877       exists $loaded_colinfo->{$_}{accessor}
878         and
879       ! defined $loaded_colinfo->{$_}{accessor}
880     )
881   ) ? $self->get_column($_)
882     : $self->${ \(
883       defined $loaded_colinfo->{$_}{accessor}
884         ? $loaded_colinfo->{$_}{accessor}
885         : $_
886       )}
887   )} keys %cols_to_return;
888 }
889
890 sub _is_column_numeric {
891    my ($self, $column) = @_;
892     my $colinfo = $self->column_info ($column);
893
894     # cache for speed (the object may *not* have a resultsource instance)
895     if (
896       ! defined $colinfo->{is_numeric}
897         and
898       my $storage = try { $self->result_source->schema->storage }
899     ) {
900       $colinfo->{is_numeric} =
901         $storage->is_datatype_numeric ($colinfo->{data_type})
902           ? 1
903           : 0
904         ;
905     }
906
907     return $colinfo->{is_numeric};
908 }
909
910 =head2 set_column
911
912   $result->set_column($col => $val);
913
914 =over
915
916 =item Arguments: $columnname, $value
917
918 =item Return Value: $value
919
920 =back
921
922 Sets a raw column value. If the new value is different from the old one,
923 the column is marked as dirty for when you next call L</update>.
924
925 If passed an object or reference as a value, this method will happily
926 attempt to store it, and a later L</insert> or L</update> will try and
927 stringify/numify as appropriate. To set an object to be deflated
928 instead, see L</set_inflated_columns>, or better yet, use L</$column_accessor>.
929
930 =cut
931
932 sub set_column {
933   my ($self, $column, $new_value) = @_;
934
935   my $had_value = $self->has_column_loaded($column);
936   my $old_value = $self->get_column($column);
937
938   $new_value = $self->store_column($column, $new_value);
939
940   my $dirty =
941     $self->{_dirty_columns}{$column}
942       ||
943     $self->in_storage # no point tracking dirtyness on uninserted data
944       ? ! $self->_eq_column_values ($column, $old_value, $new_value)
945       : 1
946   ;
947
948   if ($dirty) {
949     # FIXME sadly the update code just checks for keys, not for their value
950     $self->{_dirty_columns}{$column} = 1;
951
952     # Clear out the relation/inflation cache related to this column
953     #
954     # FIXME - this is a quick *largely incorrect* hack, pending a more
955     # serious rework during the merge of single and filter rels
956     my $rel_names = $self->result_source->{_relationships};
957     for my $rel_name (keys %$rel_names) {
958
959       my $acc = $rel_names->{$rel_name}{attrs}{accessor} || '';
960
961       if ( $acc eq 'single' and $rel_names->{$rel_name}{attrs}{fk_columns}{$column} ) {
962         delete $self->{related_resultsets}{$rel_name};
963         delete $self->{_relationship_data}{$rel_name};
964         #delete $self->{_inflated_column}{$rel_name};
965       }
966       elsif ( $acc eq 'filter' and $rel_name eq $column) {
967         delete $self->{related_resultsets}{$rel_name};
968         #delete $self->{_relationship_data}{$rel_name};
969         delete $self->{_inflated_column}{$rel_name};
970       }
971     }
972
973     if (
974       # value change from something (even if NULL)
975       $had_value
976         and
977       # no storage - no storage-value
978       $self->in_storage
979         and
980       # no value already stored (multiple changes before commit to storage)
981       ! exists $self->{_column_data_in_storage}{$column}
982         and
983       $self->_track_storage_value($column)
984     ) {
985       $self->{_column_data_in_storage}{$column} = $old_value;
986     }
987   }
988
989   return $new_value;
990 }
991
992 sub _eq_column_values {
993   my ($self, $col, $old, $new) = @_;
994
995   if (defined $old xor defined $new) {
996     return 0;
997   }
998   elsif (not defined $old) {  # both undef
999     return 1;
1000   }
1001   elsif (
1002     is_literal_value $old
1003       or
1004     is_literal_value $new
1005   ) {
1006     return 0;
1007   }
1008   elsif ($old eq $new) {
1009     return 1;
1010   }
1011   elsif ($self->_is_column_numeric($col)) {  # do a numeric comparison if datatype allows it
1012     return $old == $new;
1013   }
1014   else {
1015     return 0;
1016   }
1017 }
1018
1019 # returns a boolean indicating if the passed column should have its original
1020 # value tracked between column changes and commitment to storage
1021 sub _track_storage_value {
1022   my ($self, $col) = @_;
1023   return defined first { $col eq $_ } ($self->primary_columns);
1024 }
1025
1026 =head2 set_columns
1027
1028   $result->set_columns({ $col => $val, ... });
1029
1030 =over
1031
1032 =item Arguments: \%columndata
1033
1034 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
1035
1036 =back
1037
1038 Sets multiple column, raw value pairs at once.
1039
1040 Works as L</set_column>.
1041
1042 =cut
1043
1044 sub set_columns {
1045   my ($self, $values) = @_;
1046   $self->set_column( $_, $values->{$_} ) for keys %$values;
1047   return $self;
1048 }
1049
1050 =head2 set_inflated_columns
1051
1052   $result->set_inflated_columns({ $col => $val, $rel_name => $obj, ... });
1053
1054 =over
1055
1056 =item Arguments: \%columndata
1057
1058 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
1059
1060 =back
1061
1062 Sets more than one column value at once. Any inflated values are
1063 deflated and the raw values stored.
1064
1065 Any related values passed as Result objects, using the relation name as a
1066 key, are reduced to the appropriate foreign key values and stored. If
1067 instead of related result objects, a hashref of column, value data is
1068 passed, will create the related object first then store.
1069
1070 Will even accept arrayrefs of data as a value to a
1071 L<DBIx::Class::Relationship/has_many> key, and create the related
1072 objects if necessary.
1073
1074 Be aware that the input hashref might be edited in place, so don't rely
1075 on it being the same after a call to C<set_inflated_columns>. If you
1076 need to preserve the hashref, it is sufficient to pass a shallow copy
1077 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
1078
1079 See also L<DBIx::Class::Relationship::Base/set_from_related>.
1080
1081 =cut
1082
1083 sub set_inflated_columns {
1084   my ( $self, $upd ) = @_;
1085   foreach my $key (keys %$upd) {
1086     if (ref $upd->{$key}) {
1087       my $info = $self->relationship_info($key);
1088       my $acc_type = $info->{attrs}{accessor} || '';
1089
1090       if ($acc_type eq 'single') {
1091         my $rel_obj = delete $upd->{$key};
1092         $self->set_from_related($key => $rel_obj);
1093         $self->{_relationship_data}{$key} = $rel_obj;
1094       }
1095       elsif ($acc_type eq 'multi') {
1096         $self->throw_exception(
1097           "Recursive update is not supported over relationships of type '$acc_type' ($key)"
1098         );
1099       }
1100       elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) {
1101         $self->set_inflated_column($key, delete $upd->{$key});
1102       }
1103     }
1104   }
1105   $self->set_columns($upd);
1106 }
1107
1108 =head2 copy
1109
1110   my $copy = $orig->copy({ change => $to, ... });
1111
1112 =over
1113
1114 =item Arguments: \%replacementdata
1115
1116 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass> copy
1117
1118 =back
1119
1120 Inserts a new row into the database, as a copy of the original
1121 object. If a hashref of replacement data is supplied, these will take
1122 precedence over data in the original. Also any columns which have
1123 the L<column info attribute|DBIx::Class::ResultSource/add_columns>
1124 C<< is_auto_increment => 1 >> are explicitly removed before the copy,
1125 so that the database can insert its own autoincremented values into
1126 the new object.
1127
1128 Relationships will be followed by the copy procedure B<only> if the
1129 relationship specifies a true value for its
1130 L<cascade_copy|DBIx::Class::Relationship::Base> attribute. C<cascade_copy>
1131 is set by default on C<has_many> relationships and unset on all others.
1132
1133 =cut
1134
1135 sub copy {
1136   my ($self, $changes) = @_;
1137   $changes ||= {};
1138   my $col_data = { %{$self->{_column_data}} };
1139
1140   my $colinfo = $self->columns_info([ keys %$col_data ]);
1141   foreach my $col (keys %$col_data) {
1142     delete $col_data->{$col}
1143       if $colinfo->{$col}{is_auto_increment};
1144   }
1145
1146   my $new = { _column_data => $col_data };
1147   bless $new, ref $self;
1148
1149   $new->result_source($self->result_source);
1150   $new->set_inflated_columns($changes);
1151   $new->insert;
1152
1153   # Its possible we'll have 2 relations to the same Source. We need to make
1154   # sure we don't try to insert the same row twice else we'll violate unique
1155   # constraints
1156   my $rel_names_copied = {};
1157
1158   foreach my $rel_name ($self->result_source->relationships) {
1159     my $rel_info = $self->result_source->relationship_info($rel_name);
1160
1161     next unless $rel_info->{attrs}{cascade_copy};
1162
1163     my $resolved = $self->result_source->_resolve_condition(
1164       $rel_info->{cond}, $rel_name, $new, $rel_name
1165     );
1166
1167     my $copied = $rel_names_copied->{ $rel_info->{source} } ||= {};
1168     foreach my $related ($self->search_related($rel_name)->all) {
1169       my $id_str = join("\0", $related->id);
1170       next if $copied->{$id_str};
1171       $copied->{$id_str} = 1;
1172       my $rel_copy = $related->copy($resolved);
1173     }
1174
1175   }
1176   return $new;
1177 }
1178
1179 =head2 store_column
1180
1181   $result->store_column($col => $val);
1182
1183 =over
1184
1185 =item Arguments: $columnname, $value
1186
1187 =item Return Value: The value sent to storage
1188
1189 =back
1190
1191 Set a raw value for a column without marking it as changed. This
1192 method is used internally by L</set_column> which you should probably
1193 be using.
1194
1195 This is the lowest level at which data is set on a result object,
1196 extend this method to catch all data setting methods.
1197
1198 =cut
1199
1200 sub store_column {
1201   my ($self, $column, $value) = @_;
1202   $self->throw_exception( "No such column '${column}'" )
1203     unless exists $self->{_column_data}{$column} || $self->has_column($column);
1204   $self->throw_exception( "set_column called for ${column} without value" )
1205     if @_ < 3;
1206   return $self->{_column_data}{$column} = $value;
1207 }
1208
1209 =head2 inflate_result
1210
1211   Class->inflate_result($result_source, \%me, \%prefetch?)
1212
1213 =over
1214
1215 =item Arguments: L<$result_source|DBIx::Class::ResultSource>, \%columndata, \%prefetcheddata
1216
1217 =item Return Value: L<$result|DBIx::Class::Manual::ResultClass>
1218
1219 =back
1220
1221 All L<DBIx::Class::ResultSet> methods that retrieve data from the
1222 database and turn it into result objects call this method.
1223
1224 Extend this method in your Result classes to hook into this process,
1225 for example to rebless the result into a different class.
1226
1227 Reblessing can also be done more easily by setting C<result_class> in
1228 your Result class. See L<DBIx::Class::ResultSource/result_class>.
1229
1230 Different types of results can also be created from a particular
1231 L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/result_class>.
1232
1233 =cut
1234
1235 sub inflate_result {
1236   my ($class, $rsrc, $me, $prefetch) = @_;
1237
1238   my $new = bless
1239     { _column_data => $me, _result_source => $rsrc },
1240     ref $class || $class
1241   ;
1242
1243   if ($prefetch) {
1244     for my $rel_name ( keys %$prefetch ) {
1245
1246       my $relinfo = $rsrc->relationship_info($rel_name) or do {
1247         my $err = sprintf
1248           "Inflation into non-existent relationship '%s' of '%s' requested",
1249           $rel_name,
1250           $rsrc->source_name,
1251         ;
1252         if (my ($colname) = sort { length($a) <=> length ($b) } keys %{$prefetch->{$rel_name}[0] || {}} ) {
1253           $err .= sprintf ", check the inflation specification (columns/as) ending in '...%s.%s'",
1254           $rel_name,
1255           $colname,
1256         }
1257
1258         $rsrc->throw_exception($err);
1259       };
1260
1261       $class->throw_exception("No accessor type declared for prefetched relationship '$rel_name'")
1262         unless $relinfo->{attrs}{accessor};
1263
1264       my $rel_rs = $new->related_resultset($rel_name);
1265
1266       my @rel_objects;
1267       if (
1268         @{ $prefetch->{$rel_name} || [] }
1269           and
1270         ref($prefetch->{$rel_name}) ne $DBIx::Class::ResultSource::RowParser::Util::null_branch_class
1271       ) {
1272
1273         if (ref $prefetch->{$rel_name}[0] eq 'ARRAY') {
1274           my $rel_rsrc = $rel_rs->result_source;
1275           my $rel_class = $rel_rs->result_class;
1276           my $rel_inflator = $rel_class->can('inflate_result');
1277           @rel_objects = map
1278             { $rel_class->$rel_inflator ( $rel_rsrc, @$_ ) }
1279             @{$prefetch->{$rel_name}}
1280           ;
1281         }
1282         else {
1283           @rel_objects = $rel_rs->result_class->inflate_result(
1284             $rel_rs->result_source, @{$prefetch->{$rel_name}}
1285           );
1286         }
1287       }
1288
1289       if ($relinfo->{attrs}{accessor} eq 'single') {
1290         $new->{_relationship_data}{$rel_name} = $rel_objects[0];
1291       }
1292       elsif ($relinfo->{attrs}{accessor} eq 'filter') {
1293         $new->{_inflated_column}{$rel_name} = $rel_objects[0];
1294       }
1295
1296       $rel_rs->set_cache(\@rel_objects);
1297     }
1298   }
1299
1300   $new->in_storage (1);
1301   return $new;
1302 }
1303
1304 =head2 update_or_insert
1305
1306   $result->update_or_insert
1307
1308 =over
1309
1310 =item Arguments: none
1311
1312 =item Return Value: Result of update or insert operation
1313
1314 =back
1315
1316 L</Update>s the object if it's already in the database, according to
1317 L</in_storage>, else L</insert>s it.
1318
1319 =head2 insert_or_update
1320
1321   $obj->insert_or_update
1322
1323 Alias for L</update_or_insert>
1324
1325 =cut
1326
1327 sub insert_or_update { shift->update_or_insert(@_) }
1328
1329 sub update_or_insert {
1330   my $self = shift;
1331   return ($self->in_storage ? $self->update : $self->insert);
1332 }
1333
1334 =head2 is_changed
1335
1336   my @changed_col_names = $result->is_changed();
1337   if ($result->is_changed()) { ... }
1338
1339 =over
1340
1341 =item Arguments: none
1342
1343 =item Return Value: 0|1 or @columnnames
1344
1345 =back
1346
1347 In list context returns a list of columns with uncommited changes, or
1348 in scalar context returns a true value if there are uncommitted
1349 changes.
1350
1351 =cut
1352
1353 sub is_changed {
1354   return keys %{shift->{_dirty_columns} || {}};
1355 }
1356
1357 =head2 is_column_changed
1358
1359   if ($result->is_column_changed('col')) { ... }
1360
1361 =over
1362
1363 =item Arguments: $columname
1364
1365 =item Return Value: 0|1
1366
1367 =back
1368
1369 Returns a true value if the column has uncommitted changes.
1370
1371 =cut
1372
1373 sub is_column_changed {
1374   my( $self, $col ) = @_;
1375   return exists $self->{_dirty_columns}->{$col};
1376 }
1377
1378 =head2 result_source
1379
1380   my $resultsource = $result->result_source;
1381
1382 =over
1383
1384 =item Arguments: L<$result_source?|DBIx::Class::ResultSource>
1385
1386 =item Return Value: L<$result_source|DBIx::Class::ResultSource>
1387
1388 =back
1389
1390 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1391
1392 =cut
1393
1394 sub result_source {
1395   $_[0]->throw_exception( 'result_source can be called on instances only' )
1396     unless ref $_[0];
1397
1398   @_ > 1
1399     ? $_[0]->{_result_source} = $_[1]
1400
1401     # note this is a || not a ||=, the difference is important
1402     : $_[0]->{_result_source} || do {
1403         my $class = ref $_[0];
1404         $_[0]->can('result_source_instance')
1405           ? $_[0]->result_source_instance
1406           : $_[0]->throw_exception(
1407             "No result source instance registered for $class, did you forget to call $class->table(...) ?"
1408           )
1409       }
1410   ;
1411 }
1412
1413 =head2 register_column
1414
1415   $column_info = { .... };
1416   $class->register_column($column_name, $column_info);
1417
1418 =over
1419
1420 =item Arguments: $columnname, \%columninfo
1421
1422 =item Return Value: not defined
1423
1424 =back
1425
1426 Registers a column on the class. If the column_info has an 'accessor'
1427 key, creates an accessor named after the value if defined; if there is
1428 no such key, creates an accessor with the same name as the column
1429
1430 The column_info attributes are described in
1431 L<DBIx::Class::ResultSource/add_columns>
1432
1433 =cut
1434
1435 sub register_column {
1436   my ($class, $col, $info) = @_;
1437   my $acc = $col;
1438   if (exists $info->{accessor}) {
1439     return unless defined $info->{accessor};
1440     $acc = [ $info->{accessor}, $col ];
1441   }
1442   $class->mk_group_accessors('column' => $acc);
1443 }
1444
1445 =head2 get_from_storage
1446
1447   my $copy = $result->get_from_storage($attrs)
1448
1449 =over
1450
1451 =item Arguments: \%attrs
1452
1453 =item Return Value: A Result object
1454
1455 =back
1456
1457 Fetches a fresh copy of the Result object from the database and returns it.
1458 Throws an exception if a proper WHERE clause identifying the database row
1459 can not be constructed (i.e. if the original object does not contain its
1460 entire
1461  L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
1462 ). If passed the \%attrs argument, will first apply these attributes to
1463 the resultset used to find the row.
1464
1465 This copy can then be used to compare to an existing result object, to
1466 determine if any changes have been made in the database since it was
1467 created.
1468
1469 To just update your Result object with any latest changes from the
1470 database, use L</discard_changes> instead.
1471
1472 The \%attrs argument should be compatible with
1473 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1474
1475 =cut
1476
1477 sub get_from_storage {
1478     my $self = shift @_;
1479     my $attrs = shift @_;
1480     my $resultset = $self->result_source->resultset;
1481
1482     if(defined $attrs) {
1483       $resultset = $resultset->search(undef, $attrs);
1484     }
1485
1486     return $resultset->find($self->_storage_ident_condition);
1487 }
1488
1489 =head2 discard_changes
1490
1491   $result->discard_changes
1492
1493 =over
1494
1495 =item Arguments: none or $attrs
1496
1497 =item Return Value: self (updates object in-place)
1498
1499 =back
1500
1501 Re-selects the row from the database, losing any changes that had
1502 been made. Throws an exception if a proper C<WHERE> clause identifying
1503 the database row can not be constructed (i.e. if the original object
1504 does not contain its entire
1505 L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>).
1506
1507 This method can also be used to refresh from storage, retrieving any
1508 changes made since the row was last read from storage.
1509
1510 $attrs, if supplied, is expected to be a hashref of attributes suitable for passing as the
1511 second argument to C<< $resultset->search($cond, $attrs) >>;
1512
1513 Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
1514 storage, a default of
1515 L<< C<< { force_pool => 'master' } >>
1516 |DBIx::Class::Storage::DBI::Replicated/SYNOPSIS >>  is automatically set for
1517 you. Prior to C<< DBIx::Class 0.08109 >> (before 2010) one would have been
1518 required to explicitly wrap the entire operation in a transaction to guarantee
1519 that up-to-date results are read from the master database.
1520
1521 =cut
1522
1523 sub discard_changes {
1524   my ($self, $attrs) = @_;
1525   return unless $self->in_storage; # Don't reload if we aren't real!
1526
1527   # add a replication default to read from the master only
1528   $attrs = { force_pool => 'master', %{$attrs||{}} };
1529
1530   if( my $current_storage = $self->get_from_storage($attrs)) {
1531
1532     # Set $self to the current.
1533     %$self = %$current_storage;
1534
1535     # Avoid a possible infinite loop with
1536     # sub DESTROY { $_[0]->discard_changes }
1537     bless $current_storage, 'Do::Not::Exist';
1538
1539     return $self;
1540   }
1541   else {
1542     $self->in_storage(0);
1543     return $self;
1544   }
1545 }
1546
1547 =head2 throw_exception
1548
1549 See L<DBIx::Class::Schema/throw_exception>.
1550
1551 =cut
1552
1553 sub throw_exception {
1554   my $self=shift;
1555
1556   if (ref $self && ref $self->result_source ) {
1557     $self->result_source->throw_exception(@_)
1558   }
1559   else {
1560     DBIx::Class::Exception->throw(@_);
1561   }
1562 }
1563
1564 =head2 id
1565
1566   my @pk = $result->id;
1567
1568 =over
1569
1570 =item Arguments: none
1571
1572 =item Returns: A list of primary key values
1573
1574 =back
1575
1576 Returns the primary key(s) for a row. Can't be called as a class method.
1577 Actually implemented in L<DBIx::Class::PK>
1578
1579 =head1 AUTHOR AND CONTRIBUTORS
1580
1581 See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
1582
1583 =head1 LICENSE
1584
1585 You may distribute this code under the same terms as Perl itself.
1586
1587 =cut
1588
1589 1;