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