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