make _determine_driver more reentrant
[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
168     foreach my $key (keys %$attrs) {
169       if (ref $attrs->{$key}) {
170         ## Can we extract this lot to use with update(_or .. ) ?
171         confess "Can't do multi-create without result source" unless $source;
172         my $info = $source->relationship_info($key);
173         if ($info && $info->{attrs}{accessor}
174           && $info->{attrs}{accessor} eq 'single')
175         {
176           my $rel_obj = delete $attrs->{$key};
177           if(!Scalar::Util::blessed($rel_obj)) {
178             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
179           }
180
181           if ($rel_obj->in_storage) {
182             $new->{_rel_in_storage}{$key} = 1;
183             $new->set_from_related($key, $rel_obj);
184           } else {
185             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
186           }
187
188           $related->{$key} = $rel_obj;
189           next;
190         } elsif ($info && $info->{attrs}{accessor}
191             && $info->{attrs}{accessor} eq 'multi'
192             && ref $attrs->{$key} eq 'ARRAY') {
193           my $others = delete $attrs->{$key};
194           my $total = @$others;
195           my @objects;
196           foreach my $idx (0 .. $#$others) {
197             my $rel_obj = $others->[$idx];
198             if(!Scalar::Util::blessed($rel_obj)) {
199               $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
200             }
201
202             if ($rel_obj->in_storage) {
203               $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong');
204             } else {
205               MULTICREATE_DEBUG and
206                 warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
207             }
208             push(@objects, $rel_obj);
209           }
210           $related->{$key} = \@objects;
211           next;
212         } elsif ($info && $info->{attrs}{accessor}
213           && $info->{attrs}{accessor} eq 'filter')
214         {
215           ## 'filter' should disappear and get merged in with 'single' above!
216           my $rel_obj = delete $attrs->{$key};
217           if(!Scalar::Util::blessed($rel_obj)) {
218             $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
219           }
220           if ($rel_obj->in_storage) {
221             $new->{_rel_in_storage}{$key} = 1;
222           }
223           else {
224             MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
225           }
226           $inflated->{$key} = $rel_obj;
227           next;
228         } elsif ($class->has_column($key)
229             && $class->column_info($key)->{_inflate_info}) {
230           $inflated->{$key} = $attrs->{$key};
231           next;
232         }
233       }
234       $new->throw_exception("No such column $key on $class")
235         unless $class->has_column($key);
236       $new->store_column($key => $attrs->{$key});
237     }
238
239     $new->{_relationship_data} = $related if $related;
240     $new->{_inflated_column} = $inflated if $inflated;
241   }
242
243   return $new;
244 }
245
246 =head2 insert
247
248   $row->insert;
249
250 =over
251
252 =item Arguments: none
253
254 =item Returns: The Row object
255
256 =back
257
258 Inserts an object previously created by L</new> into the database if
259 it isn't already in there. Returns the object itself. Requires the
260 object's result source to be set, or the class to have a
261 result_source_instance method. To insert an entirely new row into
262 the database, use C<create> (see L<DBIx::Class::ResultSet/create>).
263
264 To fetch an uninserted row object, call
265 L<new|DBIx::Class::ResultSet/new> on a resultset.
266
267 This will also insert any uninserted, related objects held inside this
268 one, see L<DBIx::Class::ResultSet/create> for more details.
269
270 =cut
271
272 sub insert {
273   my ($self) = @_;
274   return $self if $self->in_storage;
275   my $source = $self->result_source;
276   $source ||=  $self->result_source($self->result_source_instance)
277     if $self->can('result_source_instance');
278   $self->throw_exception("No result_source set on this object; can't insert")
279     unless $source;
280
281   my $rollback_guard;
282
283   # Check if we stored uninserted relobjs here in new()
284   my %related_stuff = (%{$self->{_relationship_data} || {}},
285                        %{$self->{_inflated_column} || {}});
286
287   # insert what needs to be inserted before us
288   my %pre_insert;
289   for my $relname (keys %related_stuff) {
290     my $rel_obj = $related_stuff{$relname};
291
292     if (! $self->{_rel_in_storage}{$relname}) {
293       next unless (Scalar::Util::blessed($rel_obj)
294                     && $rel_obj->isa('DBIx::Class::Row'));
295
296       next unless $source->_pk_depends_on(
297                     $relname, { $rel_obj->get_columns }
298                   );
299
300       # The guard will save us if we blow out of this scope via die
301       $rollback_guard ||= $source->storage->txn_scope_guard;
302
303       MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
304
305       my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
306       my $re = $self->result_source
307                     ->related_source($relname)
308                     ->resultset
309                     ->find_or_create($them);
310
311       %{$rel_obj} = %{$re};
312       $self->{_rel_in_storage}{$relname} = 1;
313     }
314
315     $self->set_from_related($relname, $rel_obj);
316     delete $related_stuff{$relname};
317   }
318
319   # start a transaction here if not started yet and there is more stuff
320   # to insert after us
321   if (keys %related_stuff) {
322     $rollback_guard ||= $source->storage->txn_scope_guard
323   }
324
325   MULTICREATE_DEBUG and do {
326     no warnings 'uninitialized';
327     warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
328   };
329   my $updated_cols = $source->storage->insert($source, { $self->get_columns });
330   foreach my $col (keys %$updated_cols) {
331     $self->store_column($col, $updated_cols->{$col});
332   }
333
334   ## PK::Auto
335   my @auto_pri = grep {
336                   (not defined $self->get_column($_))
337                     ||
338                   (ref($self->get_column($_)) eq 'SCALAR')
339                  } $self->primary_columns;
340
341   if (@auto_pri) {
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   foreach my $relname (keys %related_stuff) {
357     my $rel_obj = $related_stuff{$relname};
358     my @cands;
359     if (Scalar::Util::blessed($rel_obj)
360           && $rel_obj->isa('DBIx::Class::Row'))
361     {
362       @cands = ($rel_obj);
363     }
364     elsif (ref $rel_obj eq 'ARRAY') {
365       @cands = @$rel_obj;
366     }
367
368     if (@cands) {
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};
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   return map {
755     my $accessor = $self->column_info($_)->{'accessor'} || $_;
756     ($_ => $self->$accessor);
757   } grep $self->has_column_loaded($_), $self->columns;
758 }
759
760 =head2 set_column
761
762   $row->set_column($col => $val);
763
764 =over
765
766 =item Arguments: $columnname, $value
767
768 =item Returns: $value
769
770 =back
771
772 Sets a raw column value. If the new value is different from the old one,
773 the column is marked as dirty for when you next call L</update>.
774
775 If passed an object or reference as a value, this method will happily
776 attempt to store it, and a later L</insert> or L</update> will try and
777 stringify/numify as appropriate. To set an object to be deflated
778 instead, see L</set_inflated_columns>.
779
780 =cut
781
782 sub set_column {
783   my ($self, $column, $new_value) = @_;
784
785   $self->{_orig_ident} ||= $self->ident_condition;
786   my $old_value = $self->get_column($column);
787
788   $self->store_column($column, $new_value);
789
790   my $dirty;
791   if (!$self->in_storage) { # no point tracking dirtyness on uninserted data
792     $dirty = 1;
793   }
794   elsif (defined $old_value xor defined $new_value) {
795     $dirty = 1;
796   }
797   elsif (not defined $old_value) {  # both undef
798     $dirty = 0;
799   }
800   elsif ($old_value eq $new_value) {
801     $dirty = 0;
802   }
803   else {  # do a numeric comparison if datatype allows it
804     my $colinfo = $self->column_info ($column);
805
806     # cache for speed (the object may *not* have a resultsource instance)
807     if (not defined $colinfo->{is_numeric} && $self->_source_handle) {
808       $colinfo->{is_numeric} =
809         $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type})
810           ? 1
811           : 0
812         ;
813     }
814
815     if ($colinfo->{is_numeric}) {
816       $dirty = $old_value != $new_value;
817     }
818     else {
819       $dirty = 1;
820     }
821   }
822
823   # sadly the update code just checks for keys, not for their value
824   $self->{_dirty_columns}{$column} = 1 if $dirty;
825
826   # XXX clear out the relation cache for this column
827   delete $self->{related_resultsets}{$column};
828
829   return $new_value;
830 }
831
832 =head2 set_columns
833
834   $row->set_columns({ $col => $val, ... });
835
836 =over
837
838 =item Arguments: \%columndata
839
840 =item Returns: The Row object
841
842 =back
843
844 Sets multiple column, raw value pairs at once.
845
846 Works as L</set_column>.
847
848 =cut
849
850 sub set_columns {
851   my ($self,$data) = @_;
852   foreach my $col (keys %$data) {
853     $self->set_column($col,$data->{$col});
854   }
855   return $self;
856 }
857
858 =head2 set_inflated_columns
859
860   $row->set_inflated_columns({ $col => $val, $relname => $obj, ... });
861
862 =over
863
864 =item Arguments: \%columndata
865
866 =item Returns: The Row object
867
868 =back
869
870 Sets more than one column value at once. Any inflated values are
871 deflated and the raw values stored.
872
873 Any related values passed as Row objects, using the relation name as a
874 key, are reduced to the appropriate foreign key values and stored. If
875 instead of related row objects, a hashref of column, value data is
876 passed, will create the related object first then store.
877
878 Will even accept arrayrefs of data as a value to a
879 L<DBIx::Class::Relationship/has_many> key, and create the related
880 objects if necessary.
881
882 Be aware that the input hashref might be edited in place, so dont rely
883 on it being the same after a call to C<set_inflated_columns>. If you
884 need to preserve the hashref, it is sufficient to pass a shallow copy
885 to C<set_inflated_columns>, e.g. ( { %{ $href } } )
886
887 See also L<DBIx::Class::Relationship::Base/set_from_related>.
888
889 =cut
890
891 sub set_inflated_columns {
892   my ( $self, $upd ) = @_;
893   foreach my $key (keys %$upd) {
894     if (ref $upd->{$key}) {
895       my $info = $self->relationship_info($key);
896       if ($info && $info->{attrs}{accessor}
897         && $info->{attrs}{accessor} eq 'single')
898       {
899         my $rel = delete $upd->{$key};
900         $self->set_from_related($key => $rel);
901         $self->{_relationship_data}{$key} = $rel;
902       } elsif ($info && $info->{attrs}{accessor}
903         && $info->{attrs}{accessor} eq 'multi') {
904           $self->throw_exception(
905             "Recursive update is not supported over relationships of type multi ($key)"
906           );
907       }
908       elsif ($self->has_column($key)
909         && exists $self->column_info($key)->{_inflate_info})
910       {
911         $self->set_inflated_column($key, delete $upd->{$key});
912       }
913     }
914   }
915   $self->set_columns($upd);
916 }
917
918 =head2 copy
919
920   my $copy = $orig->copy({ change => $to, ... });
921
922 =over
923
924 =item Arguments: \%replacementdata
925
926 =item Returns: The Row object copy
927
928 =back
929
930 Inserts a new row into the database, as a copy of the original
931 object. If a hashref of replacement data is supplied, these will take
932 precedence over data in the original. Also any columns which have
933 the L<column info attribute|DBIx::Class::ResultSource/add_columns>
934 C<< is_auto_increment => 1 >> are explicitly removed before the copy,
935 so that the database can insert its own autoincremented values into
936 the new object.
937
938 Relationships will be followed by the copy procedure B<only> if the
939 relationship specifes a true value for its
940 L<cascade_copy|DBIx::Class::Relationship::Base> attribute. C<cascade_copy>
941 is set by default on C<has_many> relationships and unset on all others.
942
943 =cut
944
945 sub copy {
946   my ($self, $changes) = @_;
947   $changes ||= {};
948   my $col_data = { %{$self->{_column_data}} };
949   foreach my $col (keys %$col_data) {
950     delete $col_data->{$col}
951       if $self->result_source->column_info($col)->{is_auto_increment};
952   }
953
954   my $new = { _column_data => $col_data };
955   bless $new, ref $self;
956
957   $new->result_source($self->result_source);
958   $new->set_inflated_columns($changes);
959   $new->insert;
960
961   # Its possible we'll have 2 relations to the same Source. We need to make
962   # sure we don't try to insert the same row twice esle we'll violate unique
963   # constraints
964   my $rels_copied = {};
965
966   foreach my $rel ($self->result_source->relationships) {
967     my $rel_info = $self->result_source->relationship_info($rel);
968
969     next unless $rel_info->{attrs}{cascade_copy};
970
971     my $resolved = $self->result_source->_resolve_condition(
972       $rel_info->{cond}, $rel, $new
973     );
974
975     my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
976     foreach my $related ($self->search_related($rel)) {
977       my $id_str = join("\0", $related->id);
978       next if $copied->{$id_str};
979       $copied->{$id_str} = 1;
980       my $rel_copy = $related->copy($resolved);
981     }
982
983   }
984   return $new;
985 }
986
987 =head2 store_column
988
989   $row->store_column($col => $val);
990
991 =over
992
993 =item Arguments: $columnname, $value
994
995 =item Returns: The value sent to storage
996
997 =back
998
999 Set a raw value for a column without marking it as changed. This
1000 method is used internally by L</set_column> which you should probably
1001 be using.
1002
1003 This is the lowest level at which data is set on a row object,
1004 extend this method to catch all data setting methods.
1005
1006 =cut
1007
1008 sub store_column {
1009   my ($self, $column, $value) = @_;
1010   $self->throw_exception( "No such column '${column}'" )
1011     unless exists $self->{_column_data}{$column} || $self->has_column($column);
1012   $self->throw_exception( "set_column called for ${column} without value" )
1013     if @_ < 3;
1014   return $self->{_column_data}{$column} = $value;
1015 }
1016
1017 =head2 inflate_result
1018
1019   Class->inflate_result($result_source, \%me, \%prefetch?)
1020
1021 =over
1022
1023 =item Arguments: $result_source, \%columndata, \%prefetcheddata
1024
1025 =item Returns: A Row object
1026
1027 =back
1028
1029 All L<DBIx::Class::ResultSet> methods that retrieve data from the
1030 database and turn it into row objects call this method.
1031
1032 Extend this method in your Result classes to hook into this process,
1033 for example to rebless the result into a different class.
1034
1035 Reblessing can also be done more easily by setting C<result_class> in
1036 your Result class. See L<DBIx::Class::ResultSource/result_class>.
1037
1038 Different types of results can also be created from a particular
1039 L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/result_class>.
1040
1041 =cut
1042
1043 sub inflate_result {
1044   my ($class, $source, $me, $prefetch) = @_;
1045
1046   my ($source_handle) = $source;
1047
1048   if ($source->isa('DBIx::Class::ResultSourceHandle')) {
1049       $source = $source_handle->resolve
1050   } else {
1051       $source_handle = $source->handle
1052   }
1053
1054   my $new = {
1055     _source_handle => $source_handle,
1056     _column_data => $me,
1057   };
1058   bless $new, (ref $class || $class);
1059
1060   my $schema;
1061   foreach my $pre (keys %{$prefetch||{}}) {
1062     my $pre_val = $prefetch->{$pre};
1063     my $pre_source = $source->related_source($pre);
1064     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
1065       unless $pre_source;
1066     if (ref($pre_val->[0]) eq 'ARRAY') { # multi
1067       my @pre_objects;
1068
1069       for my $me_pref (@$pre_val) {
1070
1071         # the collapser currently *could* return bogus elements with all
1072         # columns set to undef
1073         my $has_def;
1074         for (values %{$me_pref->[0]}) {
1075           if (defined $_) {
1076             $has_def++;
1077             last;
1078           }
1079         }
1080         next unless $has_def;
1081
1082         push @pre_objects, $pre_source->result_class->inflate_result(
1083           $pre_source, @$me_pref
1084         );
1085       }
1086
1087       $new->related_resultset($pre)->set_cache(\@pre_objects);
1088     } elsif (defined $pre_val->[0]) {
1089       my $fetched;
1090       unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
1091          and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
1092       {
1093         $fetched = $pre_source->result_class->inflate_result(
1094                       $pre_source, @{$pre_val});
1095       }
1096       my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
1097       $class->throw_exception("No accessor for prefetched $pre")
1098        unless defined $accessor;
1099       if ($accessor eq 'single') {
1100         $new->{_relationship_data}{$pre} = $fetched;
1101       } elsif ($accessor eq 'filter') {
1102         $new->{_inflated_column}{$pre} = $fetched;
1103       } else {
1104        $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor '$accessor'");
1105       }
1106       $new->related_resultset($pre)->set_cache([ $fetched ]);
1107     }
1108   }
1109
1110   $new->in_storage (1);
1111   return $new;
1112 }
1113
1114 =head2 update_or_insert
1115
1116   $row->update_or_insert
1117
1118 =over
1119
1120 =item Arguments: none
1121
1122 =item Returns: Result of update or insert operation
1123
1124 =back
1125
1126 L</Update>s the object if it's already in the database, according to
1127 L</in_storage>, else L</insert>s it.
1128
1129 =head2 insert_or_update
1130
1131   $obj->insert_or_update
1132
1133 Alias for L</update_or_insert>
1134
1135 =cut
1136
1137 sub insert_or_update { shift->update_or_insert(@_) }
1138
1139 sub update_or_insert {
1140   my $self = shift;
1141   return ($self->in_storage ? $self->update : $self->insert);
1142 }
1143
1144 =head2 is_changed
1145
1146   my @changed_col_names = $row->is_changed();
1147   if ($row->is_changed()) { ... }
1148
1149 =over
1150
1151 =item Arguments: none
1152
1153 =item Returns: 0|1 or @columnnames
1154
1155 =back
1156
1157 In list context returns a list of columns with uncommited changes, or
1158 in scalar context returns a true value if there are uncommitted
1159 changes.
1160
1161 =cut
1162
1163 sub is_changed {
1164   return keys %{shift->{_dirty_columns} || {}};
1165 }
1166
1167 =head2 is_column_changed
1168
1169   if ($row->is_column_changed('col')) { ... }
1170
1171 =over
1172
1173 =item Arguments: $columname
1174
1175 =item Returns: 0|1
1176
1177 =back
1178
1179 Returns a true value if the column has uncommitted changes.
1180
1181 =cut
1182
1183 sub is_column_changed {
1184   my( $self, $col ) = @_;
1185   return exists $self->{_dirty_columns}->{$col};
1186 }
1187
1188 =head2 result_source
1189
1190   my $resultsource = $row->result_source;
1191
1192 =over
1193
1194 =item Arguments: none
1195
1196 =item Returns: a ResultSource instance
1197
1198 =back
1199
1200 Accessor to the L<DBIx::Class::ResultSource> this object was created from.
1201
1202 =cut
1203
1204 sub result_source {
1205     my $self = shift;
1206
1207     if (@_) {
1208         $self->_source_handle($_[0]->handle);
1209     } else {
1210         $self->_source_handle->resolve;
1211     }
1212 }
1213
1214 =head2 register_column
1215
1216   $column_info = { .... };
1217   $class->register_column($column_name, $column_info);
1218
1219 =over
1220
1221 =item Arguments: $columnname, \%columninfo
1222
1223 =item Returns: undefined
1224
1225 =back
1226
1227 Registers a column on the class. If the column_info has an 'accessor'
1228 key, creates an accessor named after the value if defined; if there is
1229 no such key, creates an accessor with the same name as the column
1230
1231 The column_info attributes are described in
1232 L<DBIx::Class::ResultSource/add_columns>
1233
1234 =cut
1235
1236 sub register_column {
1237   my ($class, $col, $info) = @_;
1238   my $acc = $col;
1239   if (exists $info->{accessor}) {
1240     return unless defined $info->{accessor};
1241     $acc = [ $info->{accessor}, $col ];
1242   }
1243   $class->mk_group_accessors('column' => $acc);
1244 }
1245
1246 =head2 get_from_storage
1247
1248   my $copy = $row->get_from_storage($attrs)
1249
1250 =over
1251
1252 =item Arguments: \%attrs
1253
1254 =item Returns: A Row object
1255
1256 =back
1257
1258 Fetches a fresh copy of the Row object from the database and returns it.
1259
1260 If passed the \%attrs argument, will first apply these attributes to
1261 the resultset used to find the row.
1262
1263 This copy can then be used to compare to an existing row object, to
1264 determine if any changes have been made in the database since it was
1265 created.
1266
1267 To just update your Row object with any latest changes from the
1268 database, use L</discard_changes> instead.
1269
1270 The \%attrs argument should be compatible with
1271 L<DBIx::Class::ResultSet/ATTRIBUTES>.
1272
1273 =cut
1274
1275 sub get_from_storage {
1276     my $self = shift @_;
1277     my $attrs = shift @_;
1278     my $resultset = $self->result_source->resultset;
1279
1280     if(defined $attrs) {
1281       $resultset = $resultset->search(undef, $attrs);
1282     }
1283
1284     return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1285 }
1286
1287 =head2 discard_changes ($attrs)
1288
1289 Re-selects the row from the database, losing any changes that had
1290 been made.
1291
1292 This method can also be used to refresh from storage, retrieving any
1293 changes made since the row was last read from storage.
1294
1295 $attrs is expected to be a hashref of attributes suitable for passing as the
1296 second argument to $resultset->search($cond, $attrs);
1297
1298 =cut
1299
1300 sub discard_changes {
1301   my ($self, $attrs) = @_;
1302   delete $self->{_dirty_columns};
1303   return unless $self->in_storage; # Don't reload if we aren't real!
1304
1305   # add a replication default to read from the master only
1306   $attrs = { force_pool => 'master', %{$attrs||{}} };
1307
1308   if( my $current_storage = $self->get_from_storage($attrs)) {
1309
1310     # Set $self to the current.
1311     %$self = %$current_storage;
1312
1313     # Avoid a possible infinite loop with
1314     # sub DESTROY { $_[0]->discard_changes }
1315     bless $current_storage, 'Do::Not::Exist';
1316
1317     return $self;
1318   }
1319   else {
1320     $self->in_storage(0);
1321     return $self;
1322   }
1323 }
1324
1325
1326 =head2 throw_exception
1327
1328 See L<DBIx::Class::Schema/throw_exception>.
1329
1330 =cut
1331
1332 sub throw_exception {
1333   my $self=shift;
1334   if (ref $self && ref $self->result_source && $self->result_source->schema) {
1335     $self->result_source->schema->throw_exception(@_);
1336   } else {
1337     croak(@_);
1338   }
1339 }
1340
1341 =head2 id
1342
1343   my @pk = $row->id;
1344
1345 =over
1346
1347 =item Arguments: none
1348
1349 =item Returns: A list of primary key values
1350
1351 =back
1352
1353 Returns the primary key(s) for a row. Can't be called as a class method.
1354 Actually implemented in L<DBIx::Class::PK>
1355
1356 =head2 discard_changes
1357
1358   $row->discard_changes
1359
1360 =over
1361
1362 =item Arguments: none
1363
1364 =item Returns: nothing (updates object in-place)
1365
1366 =back
1367
1368 Retrieves and sets the row object data from the database, losing any
1369 local changes made.
1370
1371 This method can also be used to refresh from storage, retrieving any
1372 changes made since the row was last read from storage. Actually
1373 implemented in L<DBIx::Class::PK>
1374
1375 Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
1376 storage, please kept in mind that if you L</discard_changes> on a row that you
1377 just updated or created, you should wrap the entire bit inside a transaction.
1378 Otherwise you run the risk that you insert or update to the master database
1379 but read from a replicant database that has not yet been updated from the
1380 master.  This will result in unexpected results.
1381
1382 =cut
1383
1384 1;
1385
1386 =head1 AUTHORS
1387
1388 Matt S. Trout <mst@shadowcatsystems.co.uk>
1389
1390 =head1 LICENSE
1391
1392 You may distribute this code under the same terms as Perl itself.
1393
1394 =cut