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