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