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