Commit | Line | Data |
7624b19f |
1 | package DBIx::Class::Row; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
1edd1722 |
6 | use base qw/DBIx::Class/; |
7 | |
8c49f629 |
8 | #__PACKAGE__->mk_group_accessors('simple' => 'result_source'); |
9 | |
7624b19f |
10 | =head1 NAME |
11 | |
12 | DBIx::Class::Row - Basic row methods |
13 | |
14 | =head1 SYNOPSIS |
15 | |
16 | =head1 DESCRIPTION |
17 | |
18 | This class is responsible for defining and doing basic operations on rows |
19 | derived from L<DBIx::Class::Table> objects. |
20 | |
21 | =head1 METHODS |
22 | |
8091aa91 |
23 | =head2 new |
7624b19f |
24 | |
25 | my $obj = My::Class->new($attrs); |
26 | |
27 | Creates a new row object from column => value mappings passed as a hash ref |
28 | |
29 | =cut |
30 | |
31 | sub new { |
32 | my ($class, $attrs) = @_; |
33 | $class = ref $class if ref $class; |
34 | my $new = bless({ _column_data => { } }, $class); |
35 | if ($attrs) { |
36 | $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; |
37 | while (my ($k, $v) = each %{$attrs}) { |
103647d5 |
38 | die "No such column $k on $class" unless $class->has_column($k); |
484c9dda |
39 | $new->store_column($k => $v); |
7624b19f |
40 | } |
41 | } |
42 | return $new; |
43 | } |
44 | |
8091aa91 |
45 | =head2 insert |
7624b19f |
46 | |
47 | $obj->insert; |
48 | |
49 | Inserts an object into the database if it isn't already in there. Returns |
50 | the object itself. |
51 | |
52 | =cut |
53 | |
54 | sub insert { |
55 | my ($self) = @_; |
56 | return $self if $self->in_storage; |
57 | #use Data::Dumper; warn Dumper($self); |
88cb6a1d |
58 | $self->result_source->storage->insert( |
b98e75f6 |
59 | $self->result_source->from, { $self->get_columns }); |
7624b19f |
60 | $self->in_storage(1); |
61 | $self->{_dirty_columns} = {}; |
62 | return $self; |
63 | } |
64 | |
8091aa91 |
65 | =head2 in_storage |
7624b19f |
66 | |
67 | $obj->in_storage; # Get value |
68 | $obj->in_storage(1); # Set value |
69 | |
70 | Indicated whether the object exists as a row in the database or not |
71 | |
72 | =cut |
73 | |
74 | sub in_storage { |
75 | my ($self, $val) = @_; |
76 | $self->{_in_storage} = $val if @_ > 1; |
77 | return $self->{_in_storage}; |
78 | } |
79 | |
8091aa91 |
80 | =head2 update |
7624b19f |
81 | |
82 | $obj->update; |
83 | |
84 | Must be run on an object that is already in the database; issues an SQL |
85 | UPDATE query to commit any changes to the object to the db if required. |
86 | |
87 | =cut |
88 | |
89 | sub update { |
90 | my ($self, $upd) = @_; |
91 | $self->throw( "Not in database" ) unless $self->in_storage; |
d7156e50 |
92 | my %to_update = $self->get_dirty_columns; |
c01ab172 |
93 | return $self unless keys %to_update; |
88cb6a1d |
94 | my $rows = $self->result_source->storage->update( |
95 | $self->result_source->from, \%to_update, $self->ident_condition); |
7624b19f |
96 | if ($rows == 0) { |
97 | $self->throw( "Can't update ${self}: row not found" ); |
98 | } elsif ($rows > 1) { |
99 | $self->throw("Can't update ${self}: updated more than one row"); |
100 | } |
101 | $self->{_dirty_columns} = {}; |
102 | return $self; |
103 | } |
104 | |
8091aa91 |
105 | =head2 delete |
7624b19f |
106 | |
107 | $obj->delete |
108 | |
109 | Deletes the object from the database. The object is still perfectly usable |
110 | accessor-wise etc. but ->in_storage will now return 0 and the object must |
111 | be re ->insert'ed before it can be ->update'ed |
112 | |
113 | =cut |
114 | |
115 | sub delete { |
116 | my $self = shift; |
117 | if (ref $self) { |
118 | $self->throw( "Not in database" ) unless $self->in_storage; |
88cb6a1d |
119 | $self->result_source->storage->delete( |
120 | $self->result_source->from, $self->ident_condition); |
7624b19f |
121 | $self->in_storage(undef); |
7624b19f |
122 | } else { |
123 | my $attrs = { }; |
124 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
125 | $attrs = { %{ pop(@_) } }; |
126 | } |
127 | my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_}); |
c01ab172 |
128 | $self->result_source->resultset->search(@_)->delete; |
7624b19f |
129 | } |
130 | return $self; |
131 | } |
132 | |
8091aa91 |
133 | =head2 get_column |
7624b19f |
134 | |
135 | my $val = $obj->get_column($col); |
136 | |
8091aa91 |
137 | Gets a column value from a row object. Currently, does not do |
138 | any queries; the column must have already been fetched from |
139 | the database and stored in the object. |
7624b19f |
140 | |
141 | =cut |
142 | |
143 | sub get_column { |
144 | my ($self, $column) = @_; |
145 | $self->throw( "Can't fetch data as class method" ) unless ref $self; |
7624b19f |
146 | return $self->{_column_data}{$column} |
147 | if exists $self->{_column_data}{$column}; |
d7156e50 |
148 | $self->throw( "No such column '${column}'" ) unless $self->has_column($column); |
7624b19f |
149 | return undef; |
150 | } |
151 | |
8091aa91 |
152 | =head2 get_columns |
076a6864 |
153 | |
154 | my %data = $obj->get_columns; |
155 | |
8091aa91 |
156 | Does C<get_column>, for all column values at once. |
076a6864 |
157 | |
158 | =cut |
159 | |
160 | sub get_columns { |
161 | my $self = shift; |
d7156e50 |
162 | return return %{$self->{_column_data}}; |
163 | } |
164 | |
165 | =head2 get_dirty_columns |
166 | |
167 | my %data = $obj->get_dirty_columns; |
168 | |
169 | Identical to get_columns but only returns those that have been changed. |
170 | |
171 | =cut |
172 | |
173 | sub get_dirty_columns { |
174 | my $self = shift; |
175 | return map { $_ => $self->{_column_data}{$_} } |
176 | keys %{$self->{_dirty_columns}}; |
076a6864 |
177 | } |
178 | |
8091aa91 |
179 | =head2 set_column |
7624b19f |
180 | |
181 | $obj->set_column($col => $val); |
182 | |
8091aa91 |
183 | Sets a column value. If the new value is different from the old one, |
184 | the column is marked as dirty for when you next call $obj->update. |
7624b19f |
185 | |
186 | =cut |
187 | |
188 | sub set_column { |
189 | my $self = shift; |
190 | my ($column) = @_; |
191 | my $old = $self->get_column($column); |
192 | my $ret = $self->store_column(@_); |
87772e46 |
193 | $self->{_dirty_columns}{$column} = 1 |
194 | if (defined $old ^ defined $ret) || (defined $old && $old ne $ret); |
7624b19f |
195 | return $ret; |
196 | } |
197 | |
8091aa91 |
198 | =head2 set_columns |
076a6864 |
199 | |
dc818523 |
200 | my $copy = $orig->set_columns({ $col => $val, ... }); |
076a6864 |
201 | |
8091aa91 |
202 | Sets more than one column value at once. |
076a6864 |
203 | |
204 | =cut |
205 | |
206 | sub set_columns { |
207 | my ($self,$data) = @_; |
208 | while (my ($col,$val) = each %$data) { |
209 | $self->set_column($col,$val); |
210 | } |
c01ab172 |
211 | return $self; |
076a6864 |
212 | } |
213 | |
8091aa91 |
214 | =head2 copy |
076a6864 |
215 | |
216 | my $copy = $orig->copy({ change => $to, ... }); |
217 | |
8091aa91 |
218 | Inserts a new row with the specified changes. |
076a6864 |
219 | |
220 | =cut |
221 | |
c01ab172 |
222 | sub copy { |
223 | my ($self, $changes) = @_; |
224 | my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self); |
225 | $new->set_column($_ => $changes->{$_}) for keys %$changes; |
226 | return $new->insert; |
227 | } |
228 | |
8091aa91 |
229 | =head2 store_column |
7624b19f |
230 | |
231 | $obj->store_column($col => $val); |
232 | |
8091aa91 |
233 | Sets a column value without marking it as dirty. |
7624b19f |
234 | |
235 | =cut |
236 | |
237 | sub store_column { |
238 | my ($self, $column, $value) = @_; |
239 | $self->throw( "No such column '${column}'" ) |
d7156e50 |
240 | unless exists $self->{_column_data}{$column} || $self->has_column($column); |
7624b19f |
241 | $self->throw( "set_column called for ${column} without value" ) |
242 | if @_ < 3; |
243 | return $self->{_column_data}{$column} = $value; |
244 | } |
245 | |
b52e9bf8 |
246 | =head2 inflate_result |
247 | |
c01ab172 |
248 | Class->inflate_result($result_source, \%me, \%prefetch?) |
b52e9bf8 |
249 | |
250 | Called by ResultSet to inflate a result from storage |
251 | |
252 | =cut |
253 | |
254 | sub inflate_result { |
c01ab172 |
255 | my ($class, $source, $me, $prefetch) = @_; |
b52e9bf8 |
256 | #use Data::Dumper; print Dumper(@_); |
c01ab172 |
257 | my $new = bless({ result_source => $source, |
258 | _column_data => $me, |
259 | _in_storage => 1 |
260 | }, |
261 | ref $class || $class); |
7fb16f1a |
262 | my $schema; |
b52e9bf8 |
263 | PRE: foreach my $pre (keys %{$prefetch||{}}) { |
4685e006 |
264 | my $rel_obj = $class->relationship_info($pre); |
265 | die "Can't prefetch non-eistant relationship ${pre}" unless $rel_obj; |
c01ab172 |
266 | $schema ||= $source->schema; |
7fb16f1a |
267 | my $pre_class = $schema->class($rel_obj->{class}); |
c01ab172 |
268 | my $fetched = $pre_class->inflate_result( |
269 | $schema->source($pre_class), @{$prefetch->{$pre}}); |
b52e9bf8 |
270 | $class->throw("No accessor for prefetched $pre") |
271 | unless defined $rel_obj->{attrs}{accessor}; |
2fb09619 |
272 | PRIMARY: foreach my $pri ($rel_obj->{class}->primary_columns) { |
273 | unless (defined $fetched->get_column($pri)) { |
274 | undef $fetched; |
275 | last PRIMARY; |
b52e9bf8 |
276 | } |
2fb09619 |
277 | } |
278 | if ($rel_obj->{attrs}{accessor} eq 'single') { |
b52e9bf8 |
279 | $new->{_relationship_data}{$pre} = $fetched; |
280 | } elsif ($rel_obj->{attrs}{accessor} eq 'filter') { |
281 | $new->{_inflated_column}{$pre} = $fetched; |
282 | } else { |
283 | $class->throw("Don't know how to store prefetched $pre"); |
284 | } |
285 | } |
7624b19f |
286 | return $new; |
287 | } |
288 | |
8091aa91 |
289 | =head2 insert_or_update |
7624b19f |
290 | |
291 | $obj->insert_or_update |
292 | |
8091aa91 |
293 | Updates the object if it's already in the db, else inserts it. |
7624b19f |
294 | |
295 | =cut |
296 | |
297 | sub insert_or_update { |
298 | my $self = shift; |
299 | return ($self->in_storage ? $self->update : $self->insert); |
300 | } |
301 | |
8091aa91 |
302 | =head2 is_changed |
7624b19f |
303 | |
304 | my @changed_col_names = $obj->is_changed |
305 | |
306 | =cut |
307 | |
308 | sub is_changed { |
309 | return keys %{shift->{_dirty_columns} || {}}; |
310 | } |
311 | |
312 | 1; |
313 | |
7624b19f |
314 | =head1 AUTHORS |
315 | |
daec44b8 |
316 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
7624b19f |
317 | |
318 | =head1 LICENSE |
319 | |
320 | You may distribute this code under the same terms as Perl itself. |
321 | |
322 | =cut |
323 | |