remove_columns now deletes columns from _columns fixing has_columns false positives
[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/;
1edd1722 8
097d3227 9__PACKAGE__->load_components(qw/AccessorGroup/);
10
11__PACKAGE__->mk_group_accessors('simple' => 'result_source');
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
24=head1 METHODS
25
8091aa91 26=head2 new
7624b19f 27
28 my $obj = My::Class->new($attrs);
29
30Creates a new row object from column => value mappings passed as a hash ref
31
32=cut
33
34sub new {
35 my ($class, $attrs) = @_;
36 $class = ref $class if ref $class;
04786a4c 37
38 my $new = { _column_data => {} };
39 bless $new, $class;
40
7624b19f 41 if ($attrs) {
27f01d1f 42 $new->throw_exception("attrs must be a hashref")
43 unless ref($attrs) eq 'HASH';
a2ca474b 44 foreach my $k (keys %$attrs) {
27f01d1f 45 $new->throw_exception("No such column $k on $class")
75d07914 46 unless $class->has_column($k);
a2ca474b 47 $new->store_column($k => $attrs->{$k});
7624b19f 48 }
49 }
04786a4c 50
7624b19f 51 return $new;
52}
53
8091aa91 54=head2 insert
7624b19f 55
56 $obj->insert;
57
b8810cc5 58Inserts an object into the database if it isn't already in
59there. Returns the object itself. Requires the object's result source to
60be set, or the class to have a result_source_instance method. To insert
61an entirely new object into the database, use C<create> (see
62L<DBIx::Class::ResultSet/create>).
7624b19f 63
64=cut
65
66sub insert {
67 my ($self) = @_;
68 return $self if $self->in_storage;
097d3227 69 $self->{result_source} ||= $self->result_source_instance
70 if $self->can('result_source_instance');
71 my $source = $self->{result_source};
aeb1bf75 72 $self->throw_exception("No result_source set on this object; can't insert")
73 unless $source;
7624b19f 74 #use Data::Dumper; warn Dumper($self);
097d3227 75 $source->storage->insert($source->from, { $self->get_columns });
7624b19f 76 $self->in_storage(1);
77 $self->{_dirty_columns} = {};
64acc2bc 78 $self->{related_resultsets} = {};
7624b19f 79 return $self;
80}
81
8091aa91 82=head2 in_storage
7624b19f 83
84 $obj->in_storage; # Get value
85 $obj->in_storage(1); # Set value
86
87Indicated whether the object exists as a row in the database or not
88
89=cut
90
91sub in_storage {
92 my ($self, $val) = @_;
93 $self->{_in_storage} = $val if @_ > 1;
94 return $self->{_in_storage};
95}
96
8091aa91 97=head2 update
7624b19f 98
99 $obj->update;
100
101Must be run on an object that is already in the database; issues an SQL
102UPDATE query to commit any changes to the object to the db if required.
103
104=cut
105
106sub update {
107 my ($self, $upd) = @_;
701da8c4 108 $self->throw_exception( "Not in database" ) unless $self->in_storage;
fc27a867 109 $self->set_columns($upd) if $upd;
d7156e50 110 my %to_update = $self->get_dirty_columns;
c01ab172 111 return $self unless keys %to_update;
4b12b3c2 112 my $ident_cond = $self->ident_condition;
113 $self->throw_exception("Cannot safely update a row in a PK-less table")
114 if ! keys %$ident_cond;
88cb6a1d 115 my $rows = $self->result_source->storage->update(
4b12b3c2 116 $self->result_source->from, \%to_update, $ident_cond);
7624b19f 117 if ($rows == 0) {
701da8c4 118 $self->throw_exception( "Can't update ${self}: row not found" );
7624b19f 119 } elsif ($rows > 1) {
701da8c4 120 $self->throw_exception("Can't update ${self}: updated more than one row");
7624b19f 121 }
122 $self->{_dirty_columns} = {};
64acc2bc 123 $self->{related_resultsets} = {};
7624b19f 124 return $self;
125}
126
8091aa91 127=head2 delete
7624b19f 128
129 $obj->delete
130
b8810cc5 131Deletes the object from the database. The object is still perfectly
132usable, but C<-E<gt>in_storage()> will now return 0 and the object must
133reinserted using C<-E<gt>insert()> before C<-E(<gt>update()> can be used
134on it. If you delete an object in a class with a C<has_many>
135relationship, all the related objects will be deleted as well. To turn
136this behavior off, pass C<cascade_delete => 0> in the C<$attr>
137hashref. Any database-level cascade or restrict will take precedence
138over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
7624b19f 139
140=cut
141
142sub delete {
143 my $self = shift;
144 if (ref $self) {
701da8c4 145 $self->throw_exception( "Not in database" ) unless $self->in_storage;
4b12b3c2 146 my $ident_cond = $self->ident_condition;
147 $self->throw_exception("Cannot safely delete a row in a PK-less table")
148 if ! keys %$ident_cond;
e0f56292 149 foreach my $column (keys %$ident_cond) {
75d07914 150 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
151 unless exists $self->{_column_data}{$column};
e0f56292 152 }
88cb6a1d 153 $self->result_source->storage->delete(
4b12b3c2 154 $self->result_source->from, $ident_cond);
7624b19f 155 $self->in_storage(undef);
7624b19f 156 } else {
701da8c4 157 $self->throw_exception("Can't do class delete without a ResultSource instance")
097d3227 158 unless $self->can('result_source_instance');
aeb1bf75 159 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
160 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
097d3227 161 $self->result_source_instance->resultset->search(@_)->delete;
7624b19f 162 }
163 return $self;
164}
165
8091aa91 166=head2 get_column
7624b19f 167
168 my $val = $obj->get_column($col);
169
8091aa91 170Gets a column value from a row object. Currently, does not do
171any queries; the column must have already been fetched from
172the database and stored in the object.
7624b19f 173
174=cut
175
176sub get_column {
177 my ($self, $column) = @_;
701da8c4 178 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
aeb1bf75 179 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
701da8c4 180 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
7624b19f 181 return undef;
182}
183
9b83fccd 184=head2 has_column_loaded
185
186 if ( $obj->has_column_loaded($col) ) {
187 print "$col has been loaded from db";
188 }
189
190Returns a true value if the column value has been loaded from the
191database (or set locally).
192
193=cut
194
def81720 195sub has_column_loaded {
196 my ($self, $column) = @_;
197 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
aeb1bf75 198 return exists $self->{_column_data}{$column};
def81720 199}
200
8091aa91 201=head2 get_columns
076a6864 202
203 my %data = $obj->get_columns;
204
8091aa91 205Does C<get_column>, for all column values at once.
076a6864 206
207=cut
208
209sub get_columns {
210 my $self = shift;
cb5f2eea 211 return %{$self->{_column_data}};
d7156e50 212}
213
214=head2 get_dirty_columns
215
216 my %data = $obj->get_dirty_columns;
217
218Identical to get_columns but only returns those that have been changed.
219
220=cut
221
222sub get_dirty_columns {
223 my $self = shift;
224 return map { $_ => $self->{_column_data}{$_} }
225 keys %{$self->{_dirty_columns}};
076a6864 226}
227
8091aa91 228=head2 set_column
7624b19f 229
230 $obj->set_column($col => $val);
231
8091aa91 232Sets a column value. If the new value is different from the old one,
233the column is marked as dirty for when you next call $obj->update.
7624b19f 234
235=cut
236
237sub set_column {
238 my $self = shift;
239 my ($column) = @_;
240 my $old = $self->get_column($column);
241 my $ret = $self->store_column(@_);
87772e46 242 $self->{_dirty_columns}{$column} = 1
243 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
7624b19f 244 return $ret;
245}
246
8091aa91 247=head2 set_columns
076a6864 248
dc818523 249 my $copy = $orig->set_columns({ $col => $val, ... });
076a6864 250
8091aa91 251Sets more than one column value at once.
076a6864 252
253=cut
254
255sub set_columns {
256 my ($self,$data) = @_;
a2ca474b 257 foreach my $col (keys %$data) {
258 $self->set_column($col,$data->{$col});
076a6864 259 }
c01ab172 260 return $self;
076a6864 261}
262
8091aa91 263=head2 copy
076a6864 264
265 my $copy = $orig->copy({ change => $to, ... });
266
8091aa91 267Inserts a new row with the specified changes.
076a6864 268
269=cut
270
c01ab172 271sub copy {
272 my ($self, $changes) = @_;
333cce60 273 $changes ||= {};
fde6e28e 274 my $col_data = { %{$self->{_column_data}} };
275 foreach my $col (keys %$col_data) {
276 delete $col_data->{$col}
277 if $self->result_source->column_info($col)->{is_auto_increment};
278 }
04786a4c 279
280 my $new = { _column_data => $col_data };
281 bless $new, ref $self;
282
83419ec6 283 $new->result_source($self->result_source);
ecd1f408 284 $new->set_columns($changes);
333cce60 285 $new->insert;
286 foreach my $rel ($self->result_source->relationships) {
287 my $rel_info = $self->result_source->relationship_info($rel);
288 if ($rel_info->{attrs}{cascade_copy}) {
289 my $resolved = $self->result_source->resolve_condition(
290 $rel_info->{cond}, $rel, $new);
291 foreach my $related ($self->search_related($rel)) {
292 $related->copy($resolved);
293 }
294 }
295 }
2c4c67b6 296 return $new;
c01ab172 297}
298
8091aa91 299=head2 store_column
7624b19f 300
301 $obj->store_column($col => $val);
302
8091aa91 303Sets a column value without marking it as dirty.
7624b19f 304
305=cut
306
307sub store_column {
308 my ($self, $column, $value) = @_;
75d07914 309 $self->throw_exception( "No such column '${column}'" )
d7156e50 310 unless exists $self->{_column_data}{$column} || $self->has_column($column);
75d07914 311 $self->throw_exception( "set_column called for ${column} without value" )
7624b19f 312 if @_ < 3;
313 return $self->{_column_data}{$column} = $value;
314}
315
b52e9bf8 316=head2 inflate_result
317
c01ab172 318 Class->inflate_result($result_source, \%me, \%prefetch?)
b52e9bf8 319
320Called by ResultSet to inflate a result from storage
321
322=cut
323
324sub inflate_result {
c01ab172 325 my ($class, $source, $me, $prefetch) = @_;
b52e9bf8 326 #use Data::Dumper; print Dumper(@_);
04786a4c 327 my $new = {
328 result_source => $source,
329 _column_data => $me,
330 _in_storage => 1
331 };
332 bless $new, (ref $class || $class);
333
7fb16f1a 334 my $schema;
64acc2bc 335 foreach my $pre (keys %{$prefetch||{}}) {
336 my $pre_val = $prefetch->{$pre};
f9cc31dd 337 my $pre_source = $source->related_source($pre);
a86b1efe 338 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
339 unless $pre_source;
0f66a01b 340 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
a86b1efe 341 my @pre_objects;
342 foreach my $pre_rec (@$pre_val) {
75d07914 343 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
5a5bec6c 344 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
a86b1efe 345 next;
346 }
347 push(@pre_objects, $pre_source->result_class->inflate_result(
348 $pre_source, @{$pre_rec}));
349 }
350 $new->related_resultset($pre)->set_cache(\@pre_objects);
62e87ea8 351 } elsif (defined $pre_val->[0]) {
a86b1efe 352 my $fetched;
75d07914 353 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
a86b1efe 354 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
355 {
356 $fetched = $pre_source->result_class->inflate_result(
75d07914 357 $pre_source, @{$pre_val});
a86b1efe 358 }
359 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
360 $class->throw_exception("No accessor for prefetched $pre")
361 unless defined $accessor;
362 if ($accessor eq 'single') {
363 $new->{_relationship_data}{$pre} = $fetched;
364 } elsif ($accessor eq 'filter') {
365 $new->{_inflated_column}{$pre} = $fetched;
366 } else {
367 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
368 }
b52e9bf8 369 }
370 }
7624b19f 371 return $new;
372}
373
9b465d00 374=head2 update_or_insert
7624b19f 375
9b465d00 376 $obj->update_or_insert
7624b19f 377
8091aa91 378Updates the object if it's already in the db, else inserts it.
7624b19f 379
9b83fccd 380=head2 insert_or_update
381
382 $obj->insert_or_update
383
384Alias for L</update_or_insert>
385
7624b19f 386=cut
387
9b465d00 388*insert_or_update = \&update_or_insert;
389sub update_or_insert {
7624b19f 390 my $self = shift;
391 return ($self->in_storage ? $self->update : $self->insert);
392}
393
8091aa91 394=head2 is_changed
7624b19f 395
228dbcb4 396 my @changed_col_names = $obj->is_changed();
397 if ($obj->is_changed()) { ... }
7624b19f 398
9b83fccd 399In array context returns a list of columns with uncommited changes, or
400in scalar context returns a true value if there are uncommitted
401changes.
402
7624b19f 403=cut
404
405sub is_changed {
406 return keys %{shift->{_dirty_columns} || {}};
407}
228dbcb4 408
409=head2 is_column_changed
410
411 if ($obj->is_column_changed('col')) { ... }
412
9b83fccd 413Returns a true value if the column has uncommitted changes.
414
228dbcb4 415=cut
416
417sub is_column_changed {
418 my( $self, $col ) = @_;
419 return exists $self->{_dirty_columns}->{$col};
420}
7624b19f 421
097d3227 422=head2 result_source
423
9b83fccd 424 my $resultsource = $object->result_source;
097d3227 425
9b83fccd 426Accessor to the ResultSource this object was created from
87c4e602 427
9b83fccd 428=head2 register_column
27f01d1f 429
9b83fccd 430 $column_info = { .... };
431 $class->register_column($column_name, $column_info);
27f01d1f 432
9b83fccd 433Registers a column on the class. If the column_info has an 'accessor'
434key, creates an accessor named after the value if defined; if there is
435no such key, creates an accessor with the same name as the column
1f23a877 436
9b83fccd 437The column_info attributes are described in
438L<DBIx::Class::ResultSource/add_columns>
1f23a877 439
097d3227 440=cut
441
1f23a877 442sub register_column {
443 my ($class, $col, $info) = @_;
91b0fbd7 444 my $acc = $col;
445 if (exists $info->{accessor}) {
446 return unless defined $info->{accessor};
447 $acc = [ $info->{accessor}, $col ];
448 }
449 $class->mk_group_accessors('column' => $acc);
1f23a877 450}
451
701da8c4 452
5160b401 453=head2 throw_exception
701da8c4 454
455See Schema's throw_exception.
456
457=cut
458
459sub throw_exception {
460 my $self=shift;
461 if (ref $self && ref $self->result_source) {
462 $self->result_source->schema->throw_exception(@_);
463 } else {
464 croak(@_);
465 }
466}
467
7624b19f 4681;
469
7624b19f 470=head1 AUTHORS
471
daec44b8 472Matt S. Trout <mst@shadowcatsystems.co.uk>
7624b19f 473
474=head1 LICENSE
475
476You may distribute this code under the same terms as Perl itself.
477
478=cut
479