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