Cleaner error message for using source() without required argument
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Row.pm
1 package DBIx::Class::Row;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 use 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' => [result_source => '_result_source']);
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<result_source> 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<result_source>.
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 = bless { _column_data => {} }, $class;
164
165   if ($attrs) {
166     $new->throw_exception("attrs must be a hashref")
167       unless ref($attrs) eq 'HASH';
168
169     my $source = delete $attrs->{-result_source};
170     if ( my $h = delete $attrs->{-source_handle} ) {
171       $source ||= $h->resolve;
172     }
173
174     $new->result_source($source) if $source;
175
176     if (my $col_from_rel = delete $attrs->{-cols_from_relations}) {
177       @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = ();
178     }
179
180     my ($related,$inflated);
181
182     foreach my $key (keys %$attrs) {
183       if (ref $attrs->{$key}) {
184         ## Can we extract this lot to use with update(_or .. ) ?
185         $new->throw_exception("Can't do multi-create without result source")
186           unless $source;
187         my $info = $source->relationship_info($key);
188         my $acc_type = $info->{attrs}{accessor} || '';
189         if ($acc_type eq 'single') {
190           my $rel_obj = delete $attrs->{$key};
191           if(!blessed $rel_obj) {
192             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
193           }
194
195           if ($rel_obj->in_storage) {
196             $new->{_rel_in_storage}{$key} = 1;
197             $new->set_from_related($key, $rel_obj);
198           } else {
199             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
200           }
201
202           $related->{$key} = $rel_obj;
203           next;
204         }
205         elsif ($acc_type eq 'multi' && ref $attrs->{$key} eq 'ARRAY' ) {
206           my $others = delete $attrs->{$key};
207           my $total = @$others;
208           my @objects;
209           foreach my $idx (0 .. $#$others) {
210             my $rel_obj = $others->[$idx];
211             if(!blessed $rel_obj) {
212               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
213             }
214
215             if ($rel_obj->in_storage) {
216               $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong');
217             } else {
218               MULTICREATE_DEBUG and
219                 warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
220             }
221             push(@objects, $rel_obj);
222           }
223           $related->{$key} = \@objects;
224           next;
225         }
226         elsif ($acc_type eq 'filter') {
227           ## 'filter' should disappear and get merged in with 'single' above!
228           my $rel_obj = delete $attrs->{$key};
229           if(!blessed $rel_obj) {
230             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
231           }
232           if ($rel_obj->in_storage) {
233             $new->{_rel_in_storage}{$key} = 1;
234           }
235           else {
236             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
237           }
238           $inflated->{$key} = $rel_obj;
239           next;
240         } elsif ($class->has_column($key)
241             && $class->column_info($key)->{_inflate_info}) {
242           $inflated->{$key} = $attrs->{$key};
243           next;
244         }
245       }
246       $new->throw_exception("No such column $key on $class")
247         unless $class->has_column($key);
248       $new->store_column($key => $attrs->{$key});
249     }
250
251     $new->{_relationship_data} = $related if $related;
252     $new->{_inflated_column} = $inflated if $inflated;
253   }
254
255   return $new;
256 }
257
258 =head2 insert
259
260   $row->insert;
261
262 =over
263
264 =item Arguments: none
265
266 =item Returns: The Row object
267
268 =back
269
270 Inserts an object previously created by L</new> into the database if
271 it isn't already in there. Returns the object itself. Requires the
272 object's result source to be set, or the class to have a
273 result_source_instance method. To insert an entirely new row into
274 the database, use C<create> (see L<DBIx::Class::ResultSet/create>).
275
276 To fetch an uninserted row object, call
277 L<new|DBIx::Class::ResultSet/new> on a resultset.
278
279 This will also insert any uninserted, related objects held inside this
280 one, see L<DBIx::Class::ResultSet/create> for more details.
281
282 =cut
283
284 sub insert {
285   my ($self) = @_;
286   return $self if $self->in_storage;
287   my $source = $self->result_source;
288   $source ||=  $self->result_source($self->result_source_instance)
289     if $self->can('result_source_instance');
290   $self->throw_exception("No result_source set on this object; can't insert")
291     unless $source;
292
293   my $storage = $source->storage;
294
295   my $rollback_guard;
296
297   # Check if we stored uninserted relobjs here in new()
298   my %related_stuff = (%{$self->{_relationship_data} || {}},
299                        %{$self->{_inflated_column} || {}});
300
301   # insert what needs to be inserted before us
302   my %pre_insert;
303   for my $relname (keys %related_stuff) {
304     my $rel_obj = $related_stuff{$relname};
305
306     if (! $self->{_rel_in_storage}{$relname}) {
307       next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row'));
308
309       next unless $source->_pk_depends_on(
310                     $relname, { $rel_obj->get_columns }
311                   );
312
313       # The guard will save us if we blow out of this scope via die
314       $rollback_guard ||= $storage->txn_scope_guard;
315
316       MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
317
318       my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns };
319       my $existing;
320
321       # if there are no keys - nothing to search for
322       if (keys %$them and $existing = $self->result_source
323                                            ->related_source($relname)
324                                            ->resultset
325                                            ->find($them)
326       ) {
327         %{$rel_obj} = %{$existing};
328       }
329       else {
330         $rel_obj->insert;
331       }
332
333       $self->{_rel_in_storage}{$relname} = 1;
334     }
335
336     $self->set_from_related($relname, $rel_obj);
337     delete $related_stuff{$relname};
338   }
339
340   # start a transaction here if not started yet and there is more stuff
341   # to insert after us
342   if (keys %related_stuff) {
343     $rollback_guard ||= $storage->txn_scope_guard
344   }
345
346   MULTICREATE_DEBUG and do {
347     no warnings 'uninitialized';
348     warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
349   };
350
351   my %current_rowdata = $self->get_columns;
352
353   # perform the insert - the storage may return some stuff for us right there
354   #
355   my $returned_cols = $storage->insert(
356     $source,
357     \%current_rowdata,
358   );
359
360   for (keys %$returned_cols) {
361     $self->store_column(
362       $_,
363       ( $current_rowdata{$_} = $returned_cols->{$_} )
364     );
365   }
366
367   # see if any of the pcols still need filling (or re-querying in case of scalarrefs)
368   my @missing_pri = grep
369     { ! defined $current_rowdata{$_} or ref $current_rowdata{$_} eq 'SCALAR' }
370     $self->primary_columns
371   ;
372
373   if (@missing_pri) {
374     MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @missing_pri )."\n";
375
376     $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
377       unless $storage->can('last_insert_id');
378
379     my @pri_values = $storage->last_insert_id($self->result_source, @missing_pri);
380
381     $self->throw_exception( "Can't get last insert id" )
382       unless (@pri_values == @missing_pri);
383
384     $self->store_column($missing_pri[$_] => $pri_values[$_]) for 0 .. $#missing_pri;
385   }
386
387   $self->{_dirty_columns} = {};
388   $self->{related_resultsets} = {};
389
390   foreach my $relname (keys %related_stuff) {
391     next unless $source->has_relationship ($relname);
392
393     my @cands = ref $related_stuff{$relname} eq 'ARRAY'
394       ? @{$related_stuff{$relname}}
395       : $related_stuff{$relname}
396     ;
397
398     if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row')
399     ) {
400       my $reverse = $source->reverse_relationship_info($relname);
401       foreach my $obj (@cands) {
402         $obj->set_from_related($_, $self) for keys %$reverse;
403         if ($self->__their_pk_needs_us($relname)) {
404           if (exists $self->{_ignore_at_insert}{$relname}) {
405             MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
406           }
407           else {
408             MULTICREATE_DEBUG and warn "MC $self inserting $relname $obj";
409             $obj->insert;
410           }
411         } else {
412           MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
413           $obj->insert();
414         }
415       }
416     }
417   }
418
419   $self->in_storage(1);
420   delete $self->{_orig_ident};
421   delete $self->{_orig_ident_failreason};
422   delete $self->{_ignore_at_insert};
423   $rollback_guard->commit if $rollback_guard;
424
425   return $self;
426 }
427
428 =head2 in_storage
429
430   $row->in_storage; # Get value
431   $row->in_storage(1); # Set value
432
433 =over
434
435 =item Arguments: none or 1|0
436
437 =item Returns: 1|0
438
439 =back
440
441 Indicates whether the object exists as a row in the database or
442 not. This is set to true when L<DBIx::Class::ResultSet/find>,
443 L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
444 are used.
445
446 Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
447 L</delete> on one, sets it to false.
448
449 =cut
450
451 sub in_storage {
452   my ($self, $val) = @_;
453   $self->{_in_storage} = $val if @_ > 1;
454   return $self->{_in_storage} ? 1 : 0;
455 }
456
457 =head2 update
458
459   $row->update(\%columns?)
460
461 =over
462
463 =item Arguments: none or a hashref
464
465 =item Returns: The Row object
466
467 =back
468
469 Throws an exception if the row object is not yet in the database,
470 according to L</in_storage>.
471
472 This method issues an SQL UPDATE query to commit any changes to the
473 object to the database if required (see L</get_dirty_columns>).
474 It throws an exception if a proper WHERE clause uniquely identifying
475 the database row can not be constructed (see
476 L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
477 for more details).
478
479 Also takes an optional hashref of C<< column_name => value >> pairs
480 to update on the object first. Be aware that the hashref will be
481 passed to C<set_inflated_columns>, which might edit it in place, so
482 don't rely on it being the same after a call to C<update>.  If you
483 need to preserve the hashref, it is sufficient to pass a shallow copy
484 to C<update>, e.g. ( { %{ $href } } )
485
486 If the values passed or any of the column values set on the object
487 contain scalar references, e.g.:
488
489   $row->last_modified(\'NOW()');
490   # OR
491   $row->update({ last_modified => \'NOW()' });
492
493 The update will pass the values verbatim into SQL. (See
494 L<SQL::Abstract> docs).  The values in your Row object will NOT change
495 as a result of the update call, if you want the object to be updated
496 with the actual values from the database, call L</discard_changes>
497 after the update.
498
499   $row->update()->discard_changes();
500
501 To determine before calling this method, which column values have
502 changed and will be updated, call L</get_dirty_columns>.
503
504 To check if any columns will be updated, call L</is_changed>.
505
506 To force a column to be updated, call L</make_column_dirty> before
507 this method.
508
509 =cut
510
511 sub update {
512   my ($self, $upd) = @_;
513
514   $self->set_inflated_columns($upd) if $upd;
515
516   my %to_update = $self->get_dirty_columns
517     or return $self;
518
519   my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
520   $self->throw_exception( "Not in database" ) unless $self->in_storage;
521
522   $self->throw_exception($self->{_orig_ident_failreason})
523     if ! keys %$ident_cond;
524
525   my $rows = $self->result_source->storage->update(
526     $self->result_source, \%to_update, $ident_cond
527   );
528   if ($rows == 0) {
529     $self->throw_exception( "Can't update ${self}: row not found" );
530   } elsif ($rows > 1) {
531     $self->throw_exception("Can't update ${self}: updated more than one row");
532   }
533   $self->{_dirty_columns} = {};
534   $self->{related_resultsets} = {};
535   delete $self->{_orig_ident};
536   return $self;
537 }
538
539 =head2 delete
540
541   $row->delete
542
543 =over
544
545 =item Arguments: none
546
547 =item Returns: The Row object
548
549 =back
550
551 Throws an exception if the object is not in the database according to
552 L</in_storage>. Also throws an exception if a proper WHERE clause
553 uniquely identifying the database row can not be constructed (see
554 L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
555 for more details).
556
557 The object is still perfectly usable, but L</in_storage> will
558 now return 0 and the object must be reinserted using L</insert>
559 before it can be used to L</update> the row again.
560
561 If you delete an object in a class with a C<has_many> relationship, an
562 attempt is made to delete all the related objects as well. To turn
563 this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
564 hashref of the relationship, see L<DBIx::Class::Relationship>. Any
565 database-level cascade or restrict will take precedence over a
566 DBIx-Class-based cascading delete, since DBIx-Class B<deletes the
567 main row first> and only then attempts to delete any remaining related
568 rows.
569
570 If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
571 and the transaction subsequently fails, the row object will remain marked as
572 not being in storage. If you know for a fact that the object is still in
573 storage (i.e. by inspecting the cause of the transaction's failure), you can
574 use C<< $obj->in_storage(1) >> to restore consistency between the object and
575 the database. This would allow a subsequent C<< $obj->delete >> to work
576 as expected.
577
578 See also L<DBIx::Class::ResultSet/delete>.
579
580 =cut
581
582 sub delete {
583   my $self = shift;
584   if (ref $self) {
585     $self->throw_exception( "Not in database" ) unless $self->in_storage;
586
587     my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
588     $self->throw_exception($self->{_orig_ident_failreason})
589       if ! keys %$ident_cond;
590
591     $self->result_source->storage->delete(
592       $self->result_source, $ident_cond
593     );
594
595     delete $self->{_orig_ident};  # no longer identifiable
596     $self->in_storage(undef);
597   }
598   else {
599     $self->throw_exception("Can't do class delete without a ResultSource instance")
600       unless $self->can('result_source_instance');
601     my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
602     my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
603     $self->result_source_instance->resultset->search(@_)->delete;
604   }
605   return $self;
606 }
607
608 =head2 get_column
609
610   my $val = $row->get_column($col);
611
612 =over
613
614 =item Arguments: $columnname
615
616 =item Returns: The value of the column
617
618 =back
619
620 Throws an exception if the column name given doesn't exist according
621 to L</has_column>.
622
623 Returns a raw column value from the row object, if it has already
624 been fetched from the database or set by an accessor.
625
626 If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
627 will be deflated and returned.
628
629 Note that if you used the C<columns> or the C<select/as>
630 L<search attributes|DBIx::Class::ResultSet/ATTRIBUTES> on the resultset from
631 which C<$row> was derived, and B<did not include> C<$columnname> in the list,
632 this method will return C<undef> even if the database contains some value.
633
634 To retrieve all loaded column values as a hash, use L</get_columns>.
635
636 =cut
637
638 sub get_column {
639   my ($self, $column) = @_;
640   $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
641   return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
642   if (exists $self->{_inflated_column}{$column}) {
643     return $self->store_column($column,
644       $self->_deflated_column($column, $self->{_inflated_column}{$column}));
645   }
646   $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
647   return undef;
648 }
649
650 =head2 has_column_loaded
651
652   if ( $row->has_column_loaded($col) ) {
653      print "$col has been loaded from db";
654   }
655
656 =over
657
658 =item Arguments: $columnname
659
660 =item Returns: 0|1
661
662 =back
663
664 Returns a true value if the column value has been loaded from the
665 database (or set locally).
666
667 =cut
668
669 sub has_column_loaded {
670   my ($self, $column) = @_;
671   $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
672   return 1 if exists $self->{_inflated_column}{$column};
673   return exists $self->{_column_data}{$column};
674 }
675
676 =head2 get_columns
677
678   my %data = $row->get_columns;
679
680 =over
681
682 =item Arguments: none
683
684 =item Returns: A hash of columnname, value pairs.
685
686 =back
687
688 Returns all loaded column data as a hash, containing raw values. To
689 get just one value for a particular column, use L</get_column>.
690
691 See L</get_inflated_columns> to get the inflated values.
692
693 =cut
694
695 sub get_columns {
696   my $self = shift;
697   if (exists $self->{_inflated_column}) {
698     foreach my $col (keys %{$self->{_inflated_column}}) {
699       $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
700         unless exists $self->{_column_data}{$col};
701     }
702   }
703   return %{$self->{_column_data}};
704 }
705
706 =head2 get_dirty_columns
707
708   my %data = $row->get_dirty_columns;
709
710 =over
711
712 =item Arguments: none
713
714 =item Returns: A hash of column, value pairs
715
716 =back
717
718 Only returns the column, value pairs for those columns that have been
719 changed on this object since the last L</update> or L</insert> call.
720
721 See L</get_columns> to fetch all column/value pairs.
722
723 =cut
724
725 sub get_dirty_columns {
726   my $self = shift;
727   return map { $_ => $self->{_column_data}{$_} }
728            keys %{$self->{_dirty_columns}};
729 }
730
731 =head2 make_column_dirty
732
733   $row->make_column_dirty($col)
734
735 =over
736
737 =item Arguments: $columnname
738
739 =item Returns: undefined
740
741 =back
742
743 Throws an exception if the column does not exist.
744
745 Marks a column as having been changed regardless of whether it has
746 really changed.
747
748 =cut
749 sub make_column_dirty {
750   my ($self, $column) = @_;
751
752   $self->throw_exception( "No such column '${column}'" )
753     unless exists $self->{_column_data}{$column} || $self->has_column($column);
754
755   # the entire clean/dirty code relies on exists, not on true/false
756   return 1 if exists $self->{_dirty_columns}{$column};
757
758   $self->{_dirty_columns}{$column} = 1;
759
760   # if we are just now making the column dirty, and if there is an inflated
761   # value, force it over the deflated one
762   if (exists $self->{_inflated_column}{$column}) {
763     $self->store_column($column,
764       $self->_deflated_column(
765         $column, $self->{_inflated_column}{$column}
766       )
767     );
768   }
769 }
770
771 =head2 get_inflated_columns
772
773   my %inflated_data = $obj->get_inflated_columns;
774
775 =over
776
777 =item Arguments: none
778
779 =item Returns: A hash of column, object|value pairs
780
781 =back
782
783 Returns a hash of all column keys and associated values. Values for any
784 columns set to use inflation will be inflated and returns as objects.
785
786 See L</get_columns> to get the uninflated values.
787
788 See L<DBIx::Class::InflateColumn> for how to setup inflation.
789
790 =cut
791
792 sub get_inflated_columns {
793   my $self = shift;
794
795   my $loaded_colinfo = $self->columns_info ([
796     grep { $self->has_column_loaded($_) } $self->columns
797   ]);
798
799   my %inflated;
800   for my $col (keys %$loaded_colinfo) {
801     if (exists $loaded_colinfo->{$col}{accessor}) {
802       my $acc = $loaded_colinfo->{$col}{accessor};
803       $inflated{$col} = $self->$acc if defined $acc;
804     }
805     else {
806       $inflated{$col} = $self->$col;
807     }
808   }
809
810   # return all loaded columns with the inflations overlayed on top
811   return %{ { $self->get_columns, %inflated } };
812 }
813
814 sub _is_column_numeric {
815    my ($self, $column) = @_;
816     my $colinfo = $self->column_info ($column);
817
818     # cache for speed (the object may *not* have a resultsource instance)
819     if (
820       ! defined $colinfo->{is_numeric}
821         and
822       my $storage = try { $self->result_source->schema->storage }
823     ) {
824       $colinfo->{is_numeric} =
825         $storage->is_datatype_numeric ($colinfo->{data_type})
826           ? 1
827           : 0
828         ;
829     }
830
831     return $colinfo->{is_numeric};
832 }
833
834 =head2 set_column
835
836   $row->set_column($col => $val);
837
838 =over
839
840 =item Arguments: $columnname, $value
841
842 =item Returns: $value
843
844 =back
845
846 Sets a raw column value. If the new value is different from the old one,
847 the column is marked as dirty for when you next call L</update>.
848
849 If passed an object or reference as a value, this method will happily
850 attempt to store it, and a later L</insert> or L</update> will try and
851 stringify/numify as appropriate. To set an object to be deflated
852 instead, see L</set_inflated_columns>.
853
854 =cut
855
856 sub set_column {
857   my ($self, $column, $new_value) = @_;
858
859   # if we can't get an ident condition on first try - mark the object as unidentifiable
860   # (by using an empty hashref) and store the error for further diag
861   unless ($self->{_orig_ident}) {
862     try {
863       $self->{_orig_ident} = $self->ident_condition
864     }
865     catch {
866       $self->{_orig_ident_failreason} = $_;
867       $self->{_orig_ident} = {};
868     };
869   }
870
871   my $old_value = $self->get_column($column);
872   $new_value = $self->store_column($column, $new_value);
873
874   my $dirty =
875     $self->{_dirty_columns}{$column}
876       ||
877     $self->in_storage # no point tracking dirtyness on uninserted data
878       ? ! $self->_eq_column_values ($column, $old_value, $new_value)
879       : 1
880   ;
881
882   if ($dirty) {
883     # FIXME sadly the update code just checks for keys, not for their value
884     $self->{_dirty_columns}{$column} = 1;
885
886     # Clear out the relation/inflation cache related to this column
887     #
888     # FIXME - this is a quick *largely incorrect* hack, pending a more
889     # serious rework during the merge of single and filter rels
890     my $rels = $self->result_source->{_relationships};
891     for my $rel (keys %$rels) {
892
893       my $acc = $rels->{$rel}{attrs}{accessor} || '';
894
895       if ( $acc eq 'single' and $rels->{$rel}{attrs}{fk_columns}{$column} ) {
896         delete $self->{related_resultsets}{$rel};
897         delete $self->{_relationship_data}{$rel};
898         #delete $self->{_inflated_column}{$rel};
899       }
900       elsif ( $acc eq 'filter' and $rel eq $column) {
901         delete $self->{related_resultsets}{$rel};
902         #delete $self->{_relationship_data}{$rel};
903         delete $self->{_inflated_column}{$rel};
904       }
905     }
906   }
907
908   return $new_value;
909 }
910
911 sub _eq_column_values {
912   my ($self, $col, $old, $new) = @_;
913
914   if (defined $old xor defined $new) {
915     return 0;
916   }
917   elsif (not defined $old) {  # both undef
918     return 1;
919   }
920   elsif ($old eq $new) {
921     return 1;
922   }
923   elsif ($self->_is_column_numeric($col)) {  # do a numeric comparison if datatype allows it
924     return $old == $new;
925   }
926   else {
927     return 0;
928   }
929 }
930
931 =head2 set_columns
932
933   $row->set_columns({ $col => $val, ... });
934
935 =over
936
937 =item Arguments: \%columndata
938
939 =item Returns: The Row object
940
941 =back
942
943 Sets multiple column, raw value pairs at once.
944
945 Works as L</set_column>.
946
947 =cut
948
949 sub set_columns {
950   my ($self,$data) = @_;
951   foreach my $col (keys %$data) {
952     $self->set_column($col,$data->{$col});
953   }
954   return $self;
955 }
956
957 =head2 set_inflated_columns
958
959   $row->set_inflated_columns({ $col => $val, $relname => $obj, ... });
960
961 =over
962
963 =item Arguments: \%columndata
964
965 =item Returns: The Row object
966
967 =back
968
969 Sets more than one column value at once. Any inflated values are
970 deflated and the raw values stored.
971
972 Any related values passed as Row objects, using the relation name as a
973 key, are reduced to the appropriate foreign key values and stored. If
974 instead of related row objects, a hashref of column, value data is
975 passed, will create the related object first then store.
976
977 Will even accept arrayrefs of data as a value to a
978 L<DBIx::Class::Relationship/has_many> key, and create the related
979 objects if necessary.
980
981 Be aware that the input hashref might be edited in place, so don't rely
982 on it being the same after a call to C<set_inflated_columns>. If you
983 need to preserve the hashref, it is sufficient to pass a shallow copy
984 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
985
986 See also L<DBIx::Class::Relationship::Base/set_from_related>.
987
988 =cut
989
990 sub set_inflated_columns {
991   my ( $self, $upd ) = @_;
992   foreach my $key (keys %$upd) {
993     if (ref $upd->{$key}) {
994       my $info = $self->relationship_info($key);
995       my $acc_type = $info->{attrs}{accessor} || '';
996       if ($acc_type eq 'single') {
997         my $rel = delete $upd->{$key};
998         $self->set_from_related($key => $rel);
999         $self->{_relationship_data}{$key} = $rel;
1000       }
1001       elsif ($acc_type eq 'multi') {
1002         $self->throw_exception(
1003           "Recursive update is not supported over relationships of type '$acc_type' ($key)"
1004         );
1005       }
1006       elsif ($self->has_column($key) && exists $self->column_info($key)->{_inflate_info}) {
1007         $self->set_inflated_column($key, delete $upd->{$key});
1008       }
1009     }
1010   }
1011   $self->set_columns($upd);
1012 }
1013
1014 =head2 copy
1015
1016   my $copy = $orig->copy({ change => $to, ... });
1017
1018 =over
1019
1020 =item Arguments: \%replacementdata
1021
1022 =item Returns: The Row object copy
1023
1024 =back
1025
1026 Inserts a new row into the database, as a copy of the original
1027 object. If a hashref of replacement data is supplied, these will take
1028 precedence over data in the original. Also any columns which have
1029 the L<column info attribute|DBIx::Class::ResultSource/add_columns>
1030 C<< is_auto_increment => 1 >> are explicitly removed before the copy,
1031 so that the database can insert its own autoincremented values into
1032 the new object.
1033
1034 Relationships will be followed by the copy procedure B<only> if the
1035 relationship specifies a true value for its
1036 L<cascade_copy|DBIx::Class::Relationship::Base> attribute. C<cascade_copy>
1037 is set by default on C<has_many> relationships and unset on all others.
1038
1039 =cut
1040
1041 sub copy {
1042   my ($self, $changes) = @_;
1043   $changes ||= {};
1044   my $col_data = { %{$self->{_column_data}} };
1045
1046   my $colinfo = $self->columns_info([ keys %$col_data ]);
1047   foreach my $col (keys %$col_data) {
1048     delete $col_data->{$col}
1049       if $colinfo->{$col}{is_auto_increment};
1050   }
1051
1052   my $new = { _column_data => $col_data };
1053   bless $new, ref $self;
1054
1055   $new->result_source($self->result_source);
1056   $new->set_inflated_columns($changes);
1057   $new->insert;
1058
1059   # Its possible we'll have 2 relations to the same Source. We need to make
1060   # sure we don't try to insert the same row twice else we'll violate unique
1061   # constraints
1062   my $rels_copied = {};
1063
1064   foreach my $rel ($self->result_source->relationships) {
1065     my $rel_info = $self->result_source->relationship_info($rel);
1066
1067     next unless $rel_info->{attrs}{cascade_copy};
1068
1069     my $resolved = $self->result_source->_resolve_condition(
1070       $rel_info->{cond}, $rel, $new
1071     );
1072
1073     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
1074     foreach my $related ($self->search_related($rel)) {
1075       my $id_str = join("\0", $related->id);
1076       next if $copied->{$id_str};
1077       $copied->{$id_str} = 1;
1078       my $rel_copy = $related->copy($resolved);
1079     }
1080
1081   }
1082   return $new;
1083 }
1084
1085 =head2 store_column
1086
1087   $row->store_column($col => $val);
1088
1089 =over
1090
1091 =item Arguments: $columnname, $value
1092
1093 =item Returns: The value sent to storage
1094
1095 =back
1096
1097 Set a raw value for a column without marking it as changed. This
1098 method is used internally by L</set_column> which you should probably
1099 be using.
1100
1101 This is the lowest level at which data is set on a row object,
1102 extend this method to catch all data setting methods.
1103
1104 =cut
1105
1106 sub store_column {
1107   my ($self, $column, $value) = @_;
1108   $self->throw_exception( "No such column '${column}'" )
1109     unless exists $self->{_column_data}{$column} || $self->has_column($column);
1110   $self->throw_exception( "set_column called for ${column} without value" )
1111     if @_ < 3;
1112   return $self->{_column_data}{$column} = $value;
1113 }
1114
1115 =head2 inflate_result
1116
1117   Class->inflate_result($result_source, \%me, \%prefetch?)
1118
1119 =over
1120
1121 =item Arguments: $result_source, \%columndata, \%prefetcheddata
1122
1123 =item Returns: A Row object
1124
1125 =back
1126
1127 All L<DBIx::Class::ResultSet> methods that retrieve data from the
1128 database and turn it into row objects call this method.
1129
1130 Extend this method in your Result classes to hook into this process,
1131 for example to rebless the result into a different class.
1132
1133 Reblessing can also be done more easily by setting C<result_class> in
1134 your Result class. See L<DBIx::Class::ResultSource/result_class>.
1135
1136 Different types of results can also be created from a particular
1137 L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/result_class>.
1138
1139 =cut
1140
1141 sub inflate_result {
1142   my ($class, $source, $me, $prefetch) = @_;
1143
1144   $source = $source->resolve
1145     if $source->isa('DBIx::Class::ResultSourceHandle');
1146
1147   my $new = bless
1148     { _column_data => $me, _result_source => $source },
1149     ref $class || $class
1150   ;
1151
1152   foreach my $pre (keys %{$prefetch||{}}) {
1153
1154     my $pre_source = $source->related_source($pre)
1155       or $class->throw_exception("Can't prefetch non-existent relationship ${pre}");
1156
1157     my $accessor = $source->relationship_info($pre)->{attrs}{accessor}
1158       or $class->throw_exception("No accessor for prefetched $pre");
1159
1160     my @pre_vals;
1161     if (ref $prefetch->{$pre}[0] eq 'ARRAY') {
1162       @pre_vals = @{$prefetch->{$pre}};
1163     }
1164     elsif ($accessor eq 'multi') {
1165       $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor 'multi'");
1166     }
1167     else {
1168       @pre_vals = $prefetch->{$pre};
1169     }
1170
1171     my @pre_objects;
1172     for my $me_pref (@pre_vals) {
1173
1174         # FIXME - this should not be necessary
1175         # the collapser currently *could* return bogus elements with all
1176         # columns set to undef
1177         my $has_def;
1178         for (values %{$me_pref->[0]}) {
1179           if (defined $_) {
1180             $has_def++;
1181             last;
1182           }
1183         }
1184         next unless $has_def;
1185
1186         push @pre_objects, $pre_source->result_class->inflate_result(
1187           $pre_source, @$me_pref
1188         );
1189     }
1190
1191     if ($accessor eq 'single') {
1192       $new->{_relationship_data}{$pre} = $pre_objects[0];
1193     }
1194     elsif ($accessor eq 'filter') {
1195       $new->{_inflated_column}{$pre} = $pre_objects[0];
1196     }
1197
1198     $new->related_resultset($pre)->set_cache(\@pre_objects);
1199   }
1200
1201   $new->in_storage (1);
1202   return $new;
1203 }
1204
1205 =head2 update_or_insert
1206
1207   $row->update_or_insert
1208
1209 =over
1210
1211 =item Arguments: none
1212
1213 =item Returns: Result of update or insert operation
1214
1215 =back
1216
1217 L</Update>s the object if it's already in the database, according to
1218 L</in_storage>, else L</insert>s it.
1219
1220 =head2 insert_or_update
1221
1222   $obj->insert_or_update
1223
1224 Alias for L</update_or_insert>
1225
1226 =cut
1227
1228 sub insert_or_update { shift->update_or_insert(@_) }
1229
1230 sub update_or_insert {
1231   my $self = shift;
1232   return ($self->in_storage ? $self->update : $self->insert);
1233 }
1234
1235 =head2 is_changed
1236
1237   my @changed_col_names = $row->is_changed();
1238   if ($row->is_changed()) { ... }
1239
1240 =over
1241
1242 =item Arguments: none
1243
1244 =item Returns: 0|1 or @columnnames
1245
1246 =back
1247
1248 In list context returns a list of columns with uncommited changes, or
1249 in scalar context returns a true value if there are uncommitted
1250 changes.
1251
1252 =cut
1253
1254 sub is_changed {
1255   return keys %{shift->{_dirty_columns} || {}};
1256 }
1257
1258 =head2 is_column_changed
1259
1260   if ($row->is_column_changed('col')) { ... }
1261
1262 =over
1263
1264 =item Arguments: $columname
1265
1266 =item Returns: 0|1
1267
1268 =back
1269
1270 Returns a true value if the column has uncommitted changes.
1271
1272 =cut
1273
1274 sub is_column_changed {
1275   my( $self, $col ) = @_;
1276   return exists $self->{_dirty_columns}->{$col};
1277 }
1278
1279 =head2 result_source
1280
1281   my $resultsource = $row->result_source;
1282
1283 =over
1284
1285 =item Arguments: $result_source_instance
1286
1287 =item Returns: a ResultSource instance
1288
1289 =back
1290
1291 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
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 ) {
1442     $self->result_source->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;