Commit | Line | Data |
7624b19f |
1 | package DBIx::Class::Row; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
1edd1722 |
6 | use base qw/DBIx::Class/; |
701da8c4 |
7 | use 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 | |
7624b19f |
13 | =head1 NAME |
14 | |
15 | DBIx::Class::Row - Basic row methods |
16 | |
17 | =head1 SYNOPSIS |
18 | |
19 | =head1 DESCRIPTION |
20 | |
21 | This class is responsible for defining and doing basic operations on rows |
1ea77c14 |
22 | derived 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 | |
30 | Creates a new row object from column => value mappings passed as a hash ref |
31 | |
32 | =cut |
33 | |
34 | sub new { |
35 | my ($class, $attrs) = @_; |
36 | $class = ref $class if ref $class; |
37 | my $new = bless({ _column_data => { } }, $class); |
38 | if ($attrs) { |
701da8c4 |
39 | $new->throw_exception("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; |
7624b19f |
40 | while (my ($k, $v) = each %{$attrs}) { |
701da8c4 |
41 | $new->throw_exception("No such column $k on $class") unless $class->has_column($k); |
484c9dda |
42 | $new->store_column($k => $v); |
7624b19f |
43 | } |
44 | } |
45 | return $new; |
46 | } |
47 | |
8091aa91 |
48 | =head2 insert |
7624b19f |
49 | |
50 | $obj->insert; |
51 | |
52 | Inserts an object into the database if it isn't already in there. Returns |
097d3227 |
53 | the object itself. Requires the object's result source to be set, or the |
54 | class to have a result_source_instance method. |
7624b19f |
55 | |
56 | =cut |
57 | |
58 | sub insert { |
59 | my ($self) = @_; |
60 | return $self if $self->in_storage; |
097d3227 |
61 | $self->{result_source} ||= $self->result_source_instance |
62 | if $self->can('result_source_instance'); |
63 | my $source = $self->{result_source}; |
701da8c4 |
64 | $self->throw_exception("No result_source set on this object; can't insert") unless $source; |
7624b19f |
65 | #use Data::Dumper; warn Dumper($self); |
097d3227 |
66 | $source->storage->insert($source->from, { $self->get_columns }); |
7624b19f |
67 | $self->in_storage(1); |
68 | $self->{_dirty_columns} = {}; |
64acc2bc |
69 | $self->{related_resultsets} = {}; |
7624b19f |
70 | return $self; |
71 | } |
72 | |
8091aa91 |
73 | =head2 in_storage |
7624b19f |
74 | |
75 | $obj->in_storage; # Get value |
76 | $obj->in_storage(1); # Set value |
77 | |
78 | Indicated whether the object exists as a row in the database or not |
79 | |
80 | =cut |
81 | |
82 | sub in_storage { |
83 | my ($self, $val) = @_; |
84 | $self->{_in_storage} = $val if @_ > 1; |
85 | return $self->{_in_storage}; |
86 | } |
87 | |
8091aa91 |
88 | =head2 update |
7624b19f |
89 | |
90 | $obj->update; |
91 | |
92 | Must be run on an object that is already in the database; issues an SQL |
93 | UPDATE query to commit any changes to the object to the db if required. |
94 | |
95 | =cut |
96 | |
97 | sub update { |
98 | my ($self, $upd) = @_; |
701da8c4 |
99 | $self->throw_exception( "Not in database" ) unless $self->in_storage; |
d7156e50 |
100 | my %to_update = $self->get_dirty_columns; |
c01ab172 |
101 | return $self unless keys %to_update; |
4b12b3c2 |
102 | my $ident_cond = $self->ident_condition; |
103 | $self->throw_exception("Cannot safely update a row in a PK-less table") |
104 | if ! keys %$ident_cond; |
88cb6a1d |
105 | my $rows = $self->result_source->storage->update( |
4b12b3c2 |
106 | $self->result_source->from, \%to_update, $ident_cond); |
7624b19f |
107 | if ($rows == 0) { |
701da8c4 |
108 | $self->throw_exception( "Can't update ${self}: row not found" ); |
7624b19f |
109 | } elsif ($rows > 1) { |
701da8c4 |
110 | $self->throw_exception("Can't update ${self}: updated more than one row"); |
7624b19f |
111 | } |
112 | $self->{_dirty_columns} = {}; |
64acc2bc |
113 | $self->{related_resultsets} = {}; |
7624b19f |
114 | return $self; |
115 | } |
116 | |
8091aa91 |
117 | =head2 delete |
7624b19f |
118 | |
119 | $obj->delete |
120 | |
121 | Deletes the object from the database. The object is still perfectly usable |
122 | accessor-wise etc. but ->in_storage will now return 0 and the object must |
123 | be re ->insert'ed before it can be ->update'ed |
124 | |
125 | =cut |
126 | |
127 | sub delete { |
128 | my $self = shift; |
129 | if (ref $self) { |
701da8c4 |
130 | $self->throw_exception( "Not in database" ) unless $self->in_storage; |
4b12b3c2 |
131 | my $ident_cond = $self->ident_condition; |
132 | $self->throw_exception("Cannot safely delete a row in a PK-less table") |
133 | if ! keys %$ident_cond; |
88cb6a1d |
134 | $self->result_source->storage->delete( |
4b12b3c2 |
135 | $self->result_source->from, $ident_cond); |
7624b19f |
136 | $self->in_storage(undef); |
7624b19f |
137 | } else { |
701da8c4 |
138 | $self->throw_exception("Can't do class delete without a ResultSource instance") |
097d3227 |
139 | unless $self->can('result_source_instance'); |
7624b19f |
140 | my $attrs = { }; |
141 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
142 | $attrs = { %{ pop(@_) } }; |
143 | } |
144 | my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_}); |
097d3227 |
145 | $self->result_source_instance->resultset->search(@_)->delete; |
7624b19f |
146 | } |
147 | return $self; |
148 | } |
149 | |
8091aa91 |
150 | =head2 get_column |
7624b19f |
151 | |
152 | my $val = $obj->get_column($col); |
153 | |
8091aa91 |
154 | Gets a column value from a row object. Currently, does not do |
155 | any queries; the column must have already been fetched from |
156 | the database and stored in the object. |
7624b19f |
157 | |
158 | =cut |
159 | |
160 | sub get_column { |
161 | my ($self, $column) = @_; |
701da8c4 |
162 | $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; |
7624b19f |
163 | return $self->{_column_data}{$column} |
164 | if exists $self->{_column_data}{$column}; |
701da8c4 |
165 | $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column); |
7624b19f |
166 | return undef; |
167 | } |
168 | |
8091aa91 |
169 | =head2 get_columns |
076a6864 |
170 | |
171 | my %data = $obj->get_columns; |
172 | |
8091aa91 |
173 | Does C<get_column>, for all column values at once. |
076a6864 |
174 | |
175 | =cut |
176 | |
177 | sub get_columns { |
178 | my $self = shift; |
cb5f2eea |
179 | return %{$self->{_column_data}}; |
d7156e50 |
180 | } |
181 | |
182 | =head2 get_dirty_columns |
183 | |
184 | my %data = $obj->get_dirty_columns; |
185 | |
186 | Identical to get_columns but only returns those that have been changed. |
187 | |
188 | =cut |
189 | |
190 | sub get_dirty_columns { |
191 | my $self = shift; |
192 | return map { $_ => $self->{_column_data}{$_} } |
193 | keys %{$self->{_dirty_columns}}; |
076a6864 |
194 | } |
195 | |
8091aa91 |
196 | =head2 set_column |
7624b19f |
197 | |
198 | $obj->set_column($col => $val); |
199 | |
8091aa91 |
200 | Sets a column value. If the new value is different from the old one, |
201 | the column is marked as dirty for when you next call $obj->update. |
7624b19f |
202 | |
203 | =cut |
204 | |
205 | sub set_column { |
206 | my $self = shift; |
207 | my ($column) = @_; |
208 | my $old = $self->get_column($column); |
209 | my $ret = $self->store_column(@_); |
87772e46 |
210 | $self->{_dirty_columns}{$column} = 1 |
211 | if (defined $old ^ defined $ret) || (defined $old && $old ne $ret); |
7624b19f |
212 | return $ret; |
213 | } |
214 | |
8091aa91 |
215 | =head2 set_columns |
076a6864 |
216 | |
dc818523 |
217 | my $copy = $orig->set_columns({ $col => $val, ... }); |
076a6864 |
218 | |
8091aa91 |
219 | Sets more than one column value at once. |
076a6864 |
220 | |
221 | =cut |
222 | |
223 | sub set_columns { |
224 | my ($self,$data) = @_; |
225 | while (my ($col,$val) = each %$data) { |
226 | $self->set_column($col,$val); |
227 | } |
c01ab172 |
228 | return $self; |
076a6864 |
229 | } |
230 | |
8091aa91 |
231 | =head2 copy |
076a6864 |
232 | |
233 | my $copy = $orig->copy({ change => $to, ... }); |
234 | |
8091aa91 |
235 | Inserts a new row with the specified changes. |
076a6864 |
236 | |
237 | =cut |
238 | |
c01ab172 |
239 | sub copy { |
240 | my ($self, $changes) = @_; |
333cce60 |
241 | $changes ||= {}; |
fde6e28e |
242 | my $col_data = { %{$self->{_column_data}} }; |
243 | foreach my $col (keys %$col_data) { |
244 | delete $col_data->{$col} |
245 | if $self->result_source->column_info($col)->{is_auto_increment}; |
246 | } |
247 | my $new = bless({ _column_data => $col_data }, ref $self); |
c01ab172 |
248 | $new->set_column($_ => $changes->{$_}) for keys %$changes; |
333cce60 |
249 | $new->insert; |
250 | foreach my $rel ($self->result_source->relationships) { |
251 | my $rel_info = $self->result_source->relationship_info($rel); |
252 | if ($rel_info->{attrs}{cascade_copy}) { |
253 | my $resolved = $self->result_source->resolve_condition( |
254 | $rel_info->{cond}, $rel, $new); |
255 | foreach my $related ($self->search_related($rel)) { |
256 | $related->copy($resolved); |
257 | } |
258 | } |
259 | } |
260 | $new; |
c01ab172 |
261 | } |
262 | |
8091aa91 |
263 | =head2 store_column |
7624b19f |
264 | |
265 | $obj->store_column($col => $val); |
266 | |
8091aa91 |
267 | Sets a column value without marking it as dirty. |
7624b19f |
268 | |
269 | =cut |
270 | |
271 | sub store_column { |
272 | my ($self, $column, $value) = @_; |
701da8c4 |
273 | $self->throw_exception( "No such column '${column}'" ) |
d7156e50 |
274 | unless exists $self->{_column_data}{$column} || $self->has_column($column); |
701da8c4 |
275 | $self->throw_exception( "set_column called for ${column} without value" ) |
7624b19f |
276 | if @_ < 3; |
277 | return $self->{_column_data}{$column} = $value; |
278 | } |
279 | |
b52e9bf8 |
280 | =head2 inflate_result |
281 | |
c01ab172 |
282 | Class->inflate_result($result_source, \%me, \%prefetch?) |
b52e9bf8 |
283 | |
284 | Called by ResultSet to inflate a result from storage |
285 | |
286 | =cut |
287 | |
288 | sub inflate_result { |
c01ab172 |
289 | my ($class, $source, $me, $prefetch) = @_; |
b52e9bf8 |
290 | #use Data::Dumper; print Dumper(@_); |
c01ab172 |
291 | my $new = bless({ result_source => $source, |
292 | _column_data => $me, |
293 | _in_storage => 1 |
294 | }, |
295 | ref $class || $class); |
7fb16f1a |
296 | my $schema; |
64acc2bc |
297 | foreach my $pre (keys %{$prefetch||{}}) { |
298 | my $pre_val = $prefetch->{$pre}; |
299 | # if first prefetch item is arrayref, assume this is a has_many prefetch |
300 | # and that objects are pre inflated (TODO: check arrayref contents using "ref" to make sure) |
301 | if( ref $pre_val->[0] eq 'ARRAY' ) { |
302 | $new->related_resultset($pre)->set_cache( $pre_val->[0] ); |
f5541c37 |
303 | } |
64acc2bc |
304 | else { |
305 | my $pre_source = $source->related_source($pre); |
306 | $class->throw_exception("Can't prefetch non-existent relationship ${pre}") unless $pre_source; |
307 | my $fetched; |
308 | unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_} |
309 | and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns) |
310 | { |
311 | $fetched = $pre_source->result_class->inflate_result( |
312 | $pre_source, @{$prefetch->{$pre}}); |
313 | } |
314 | my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; |
315 | $class->throw_exception("No accessor for prefetched $pre") |
316 | unless defined $accessor; |
317 | if ($accessor eq 'single') { |
318 | $new->{_relationship_data}{$pre} = $fetched; |
319 | } elsif ($accessor eq 'filter') { |
320 | $new->{_inflated_column}{$pre} = $fetched; |
321 | } elsif ($accessor eq 'multi') { |
322 | $class->throw_exception("Cache must be enabled for has_many prefetch '$pre'"); |
323 | } else { |
324 | $class->throw_exception("Prefetch not supported with accessor '$accessor'"); |
325 | } |
b52e9bf8 |
326 | } |
327 | } |
7624b19f |
328 | return $new; |
329 | } |
330 | |
8091aa91 |
331 | =head2 insert_or_update |
7624b19f |
332 | |
333 | $obj->insert_or_update |
334 | |
8091aa91 |
335 | Updates the object if it's already in the db, else inserts it. |
7624b19f |
336 | |
337 | =cut |
338 | |
339 | sub insert_or_update { |
340 | my $self = shift; |
341 | return ($self->in_storage ? $self->update : $self->insert); |
342 | } |
343 | |
8091aa91 |
344 | =head2 is_changed |
7624b19f |
345 | |
346 | my @changed_col_names = $obj->is_changed |
347 | |
348 | =cut |
349 | |
350 | sub is_changed { |
351 | return keys %{shift->{_dirty_columns} || {}}; |
352 | } |
353 | |
097d3227 |
354 | =head2 result_source |
355 | |
356 | Accessor to the ResultSource this object was created from |
357 | |
71e65b39 |
358 | =head2 register_column($column, $column_info) |
1f23a877 |
359 | |
91b0fbd7 |
360 | Registers a column on the class. If the column_info has an 'accessor' key, |
361 | creates an accessor named after the value if defined; if there is no such |
362 | key, creates an accessor with the same name as the column |
1f23a877 |
363 | |
097d3227 |
364 | =cut |
365 | |
1f23a877 |
366 | sub register_column { |
367 | my ($class, $col, $info) = @_; |
91b0fbd7 |
368 | my $acc = $col; |
369 | if (exists $info->{accessor}) { |
370 | return unless defined $info->{accessor}; |
371 | $acc = [ $info->{accessor}, $col ]; |
372 | } |
373 | $class->mk_group_accessors('column' => $acc); |
1f23a877 |
374 | } |
375 | |
701da8c4 |
376 | |
5160b401 |
377 | =head2 throw_exception |
701da8c4 |
378 | |
379 | See Schema's throw_exception. |
380 | |
381 | =cut |
382 | |
383 | sub throw_exception { |
384 | my $self=shift; |
385 | if (ref $self && ref $self->result_source) { |
386 | $self->result_source->schema->throw_exception(@_); |
387 | } else { |
388 | croak(@_); |
389 | } |
390 | } |
391 | |
7624b19f |
392 | 1; |
393 | |
7624b19f |
394 | =head1 AUTHORS |
395 | |
daec44b8 |
396 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
7624b19f |
397 | |
398 | =head1 LICENSE |
399 | |
400 | You may distribute this code under the same terms as Perl itself. |
401 | |
402 | =cut |
403 | |