Commit | Line | Data |
ea2e61bf |
1 | package DBIx::Class::Table; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
95a70f01 |
6 | use DBIx::Class::Cursor; |
7 | |
8 | use base qw/Class::Data::Inheritable/; |
ea2e61bf |
9 | |
10 | __PACKAGE__->mk_classdata('_columns' => {}); |
11 | |
ea2e61bf |
12 | __PACKAGE__->mk_classdata('_table_name'); |
13 | |
34d52be2 |
14 | __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do anything yet! |
15 | |
95a70f01 |
16 | __PACKAGE__->mk_classdata('_cursor_class' => 'DBIx::Class::Cursor'); |
17 | |
525035fb |
18 | sub iterator_class { shift->_cursor_class(@_) } |
19 | |
34d52be2 |
20 | =head1 NAME |
21 | |
22 | DBIx::Class::Table - Basic table methods |
23 | |
24 | =head1 SYNOPSIS |
25 | |
26 | =head1 DESCRIPTION |
27 | |
28 | This class is responsible for defining and doing basic operations on |
29 | L<DBIx::Class> objects. |
30 | |
31 | =head1 METHODS |
32 | |
33 | =over 4 |
34 | |
39fe0e65 |
35 | =item new |
36 | |
37 | my $obj = My::Class->new($attrs); |
38 | |
39 | Creates a new object from column => value mappings passed as a hash ref |
40 | |
34d52be2 |
41 | =cut |
9bc6db13 |
42 | |
ea2e61bf |
43 | sub new { |
44 | my ($class, $attrs) = @_; |
45 | $class = ref $class if ref $class; |
46 | my $new = bless({ _column_data => { } }, $class); |
47 | if ($attrs) { |
78bab9ca |
48 | $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; |
ea2e61bf |
49 | while (my ($k, $v) = each %{$attrs}) { |
510ca912 |
50 | $new->store_column($k => $v); |
ea2e61bf |
51 | } |
52 | } |
8fe001e1 |
53 | return $new; |
ea2e61bf |
54 | } |
55 | |
39fe0e65 |
56 | =item insert |
57 | |
58 | $obj->insert; |
59 | |
60 | Inserts an object into the database if it isn't already in there. Returns |
61 | the object itself. |
62 | |
63 | =cut |
64 | |
ea2e61bf |
65 | sub insert { |
66 | my ($self) = @_; |
39fe0e65 |
67 | return $self if $self->in_database; |
c1d23573 |
68 | #use Data::Dumper; warn Dumper($self); |
8b445e33 |
69 | my %in; |
70 | $in{$_} = $self->get_column($_) |
71 | for grep { defined $self->get_column($_) } $self->columns; |
72 | my %out = %{ $self->storage->insert($self->_table_name, \%in) }; |
73 | $self->store_column($_, $out{$_}) |
74 | for grep { $self->get_column($_) ne $out{$_} } keys %out; |
c687b87e |
75 | $self->in_database(1); |
8fe001e1 |
76 | $self->{_dirty_columns} = {}; |
ea2e61bf |
77 | return $self; |
78 | } |
79 | |
39fe0e65 |
80 | =item in_database |
81 | |
82 | $obj->in_database; # Get value |
83 | $obj->in_database(1); # Set value |
84 | |
85 | Indicated whether the object exists as a row in the database or not |
86 | |
87 | =cut |
88 | |
604d9f38 |
89 | sub in_database { |
c687b87e |
90 | my ($self, $val) = @_; |
91 | $self->{_in_database} = $val if @_ > 1; |
92 | return $self->{_in_database}; |
604d9f38 |
93 | } |
94 | |
39fe0e65 |
95 | =item create |
96 | |
97 | my $new = My::Class->create($attrs); |
98 | |
99 | A shortcut for My::Class->new($attrs)->insert; |
100 | |
101 | =cut |
102 | |
ea2e61bf |
103 | sub create { |
104 | my ($class, $attrs) = @_; |
78bab9ca |
105 | $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; |
ea2e61bf |
106 | return $class->new($attrs)->insert; |
107 | } |
108 | |
39fe0e65 |
109 | =item update |
110 | |
111 | $obj->update; |
112 | |
113 | Must be run on an object that is already in the database; issues an SQL |
114 | UPDATE query to commit any changes to the object to the db if required. |
115 | |
116 | =cut |
117 | |
ea2e61bf |
118 | sub update { |
8b445e33 |
119 | my ($self, $upd) = @_; |
78bab9ca |
120 | $self->throw( "Not in database" ) unless $self->in_database; |
8b445e33 |
121 | my %to_update = %{$upd || {}}; |
122 | $to_update{$_} = $self->get_column($_) for $self->is_changed; |
123 | return -1 unless keys %to_update; |
124 | my $rows = $self->storage->update($self->_table_name, \%to_update, |
125 | $self->ident_condition); |
a3018bd3 |
126 | if ($rows == 0) { |
8b445e33 |
127 | $self->throw( "Can't update ${self}: row not found" ); |
a3018bd3 |
128 | } elsif ($rows > 1) { |
8b445e33 |
129 | $self->throw("Can't update ${self}: updated more than one row"); |
a3018bd3 |
130 | } |
ea2e61bf |
131 | $self->{_dirty_columns} = {}; |
132 | return $self; |
133 | } |
134 | |
8b445e33 |
135 | sub ident_condition { |
136 | my ($self) = @_; |
137 | my %cond; |
138 | $cond{$_} = $self->get_column($_) for keys %{$self->_primaries}; |
139 | return \%cond; |
140 | } |
141 | |
39fe0e65 |
142 | =item delete |
143 | |
144 | $obj->delete |
145 | |
146 | Deletes the object from the database. The object is still perfectly usable |
147 | accessor-wise etc. but ->in_database will now return 0 and the object must |
148 | be re ->insert'ed before it can be ->update'ed |
149 | |
150 | =cut |
151 | |
ea2e61bf |
152 | sub delete { |
a3018bd3 |
153 | my $self = shift; |
154 | if (ref $self) { |
78bab9ca |
155 | $self->throw( "Not in database" ) unless $self->in_database; |
b8e1e21f |
156 | #warn $self->_ident_cond.' '.join(', ', $self->_ident_values); |
8b445e33 |
157 | $self->storage->delete($self->_table_name, $self->ident_condition); |
c687b87e |
158 | $self->in_database(undef); |
8b445e33 |
159 | #$self->store_column($_ => undef) for $self->primary_columns; |
39fe0e65 |
160 | # Should probably also arrange to trash PK if auto |
8b445e33 |
161 | # but if we do, post-delete cascade triggers fail :/ |
a3018bd3 |
162 | } else { |
12bbb339 |
163 | my $attrs = { }; |
164 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
165 | $attrs = { %{ pop(@_) } }; |
166 | } |
a3018bd3 |
167 | my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_}); |
8b445e33 |
168 | $self->storage->delete($self->_table_name, $query); |
a3018bd3 |
169 | } |
ea2e61bf |
170 | return $self; |
171 | } |
172 | |
39fe0e65 |
173 | =item get_column |
174 | |
175 | my $val = $obj->get_column($col); |
176 | |
177 | Fetches a column value |
178 | |
179 | =cut |
180 | |
510ca912 |
181 | sub get_column { |
ea2e61bf |
182 | my ($self, $column) = @_; |
78bab9ca |
183 | $self->throw( "Can't fetch data as class method" ) unless ref $self; |
184 | $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column}; |
c1d23573 |
185 | return $self->{_column_data}{$column} |
186 | if exists $self->{_column_data}{$column}; |
187 | return undef; |
ea2e61bf |
188 | } |
189 | |
39fe0e65 |
190 | =item set_column |
191 | |
192 | $obj->set_column($col => $val); |
193 | |
194 | Sets a column value; if the new value is different to the old the column |
195 | is marked as dirty for when you next call $obj->update |
196 | |
197 | =cut |
198 | |
510ca912 |
199 | sub set_column { |
200 | my $self = shift; |
201 | my ($column) = @_; |
cc0f266f |
202 | my $old = $self->get_column($column); |
510ca912 |
203 | my $ret = $self->store_column(@_); |
cc0f266f |
204 | $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret; |
510ca912 |
205 | return $ret; |
206 | } |
207 | |
39fe0e65 |
208 | =item store_column |
209 | |
210 | $obj->store_column($col => $val); |
211 | |
212 | Sets a column value without marking it as dirty |
213 | |
214 | =cut |
215 | |
510ca912 |
216 | sub store_column { |
ea2e61bf |
217 | my ($self, $column, $value) = @_; |
78bab9ca |
218 | $self->throw( "No such column '${column}'" ) |
219 | unless $self->_columns->{$column}; |
220 | $self->throw( "set_column called for ${column} without value" ) |
221 | if @_ < 3; |
510ca912 |
222 | return $self->{_column_data}{$column} = $value; |
ea2e61bf |
223 | } |
224 | |
ea2e61bf |
225 | sub _register_columns { |
226 | my ($class, @cols) = @_; |
227 | my $names = { %{$class->_columns} }; |
228 | $names->{$_} ||= {} for @cols; |
229 | $class->_columns($names); |
230 | } |
231 | |
232 | sub _mk_column_accessors { |
233 | my ($class, @cols) = @_; |
510ca912 |
234 | $class->mk_group_accessors('column' => @cols); |
ea2e61bf |
235 | } |
236 | |
39fe0e65 |
237 | =item add_columns |
238 | |
239 | __PACKAGE__->add_columns(qw/col1 col2 col3/); |
240 | |
241 | Adds columns to the current package, and creates accessors for them |
242 | |
243 | =cut |
244 | |
510ca912 |
245 | sub add_columns { |
8fe001e1 |
246 | my ($class, @cols) = @_; |
247 | $class->_register_columns(@cols); |
248 | $class->_mk_column_accessors(@cols); |
249 | } |
250 | |
39fe0e65 |
251 | =item retrieve_from_sql |
252 | |
253 | my @obj = $class->retrieve_from_sql($sql_where_cond, @bind); |
254 | my $cursor = $class->retrieve_from_sql($sql_where_cond, @bind); |
255 | |
256 | =cut |
257 | |
8fe001e1 |
258 | sub retrieve_from_sql { |
259 | my ($class, $cond, @vals) = @_; |
a3018bd3 |
260 | $cond =~ s/^\s*WHERE//i; |
604d9f38 |
261 | my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); |
262 | my @cols = $class->_select_columns($attrs); |
8b445e33 |
263 | #warn "@cols $cond @vals"; |
264 | return $class->sth_to_objects(undef, \@vals, \@cols, { where => \$cond }); |
510ca912 |
265 | } |
266 | |
39fe0e65 |
267 | =item count_from_sql |
268 | |
269 | my $count = $class->count($sql_where_cond); |
270 | |
271 | =cut |
272 | |
fcbc5f29 |
273 | sub count_from_sql { |
8b445e33 |
274 | my ($self, $cond, @vals) = @_; |
fcbc5f29 |
275 | $cond =~ s/^\s*WHERE//i; |
276 | my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); |
277 | my @cols = 'COUNT(*)'; |
8b445e33 |
278 | $attrs->{bind} = [ @vals ]; |
279 | my $sth = $self->storage->select($self->_table_name,\@cols,\$cond, $attrs); |
fcbc5f29 |
280 | #warn "$cond @vals"; |
fcbc5f29 |
281 | my ($count) = $sth->fetchrow_array; |
39fe0e65 |
282 | $sth->finish; |
fcbc5f29 |
283 | return $count; |
284 | } |
285 | |
39fe0e65 |
286 | =item count |
287 | |
288 | my $count = $class->count({ foo => 3 }); |
289 | |
290 | =cut |
291 | |
06d90c6b |
292 | sub count { |
293 | my $class = shift; |
294 | my $attrs = { }; |
295 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
296 | $attrs = { %{ pop(@_) } }; |
297 | } |
8b445e33 |
298 | my $query = ref $_[0] eq "HASH" || (@_ == 1) ? shift: {@_}; |
299 | my ($cond) = $class->_cond_resolve($query, $attrs); |
300 | return $class->count_from_sql($cond, @{$attrs->{bind}||[]}, $attrs); |
06d90c6b |
301 | } |
302 | |
39fe0e65 |
303 | =item sth_to_objects |
304 | |
305 | my @obj = $class->sth_to_objects($sth, \@bind, \@columns, $attrs); |
306 | my $cursor = $class->sth_to_objects($sth, \@bind, \@columns, $attrs); |
307 | |
308 | =cut |
309 | |
510ca912 |
310 | sub sth_to_objects { |
54644855 |
311 | my ($class, $sth, $args, $cols, $attrs) = @_; |
510ca912 |
312 | my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} ); |
4a07648a |
313 | my @args = map { ref $_ ? ''.$_ : $_ } @$args; # Stringify objects |
95a70f01 |
314 | my $cursor_class = $class->_cursor_class; |
315 | eval "use $cursor_class;"; |
4a07648a |
316 | my $cursor = $cursor_class->new($class, $sth, \@args, \@cols, $attrs); |
95a70f01 |
317 | return (wantarray ? $cursor->all : $cursor); |
8fe001e1 |
318 | } |
319 | |
c1d23573 |
320 | sub _row_to_object { # WARNING: Destructive to @$row |
321 | my ($class, $cols, $row) = @_; |
322 | my $new = $class->new; |
323 | $new->store_column($_, shift @$row) for @$cols; |
324 | $new->in_database(1); |
325 | return $new; |
326 | } |
327 | |
39fe0e65 |
328 | =item search |
329 | |
330 | my @obj = $class->search({ foo => 3 }); |
331 | my $cursor = $class->search({ foo => 3 }); |
332 | |
333 | =cut |
334 | |
8fe001e1 |
335 | sub search { |
12bbb339 |
336 | my $class = shift; |
8b445e33 |
337 | #warn "@_"; |
12bbb339 |
338 | my $attrs = { }; |
339 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
340 | $attrs = { %{ pop(@_) } }; |
341 | } |
342 | my $query = ref $_[0] eq "HASH" ? shift: {@_}; |
343 | my ($cond, @param) = $class->_cond_resolve($query, $attrs); |
c687b87e |
344 | return $class->retrieve_from_sql($cond, @param, $attrs); |
a3018bd3 |
345 | } |
346 | |
39fe0e65 |
347 | =item search_like |
348 | |
349 | Identical to search except defaults to 'LIKE' instead of '=' in condition |
350 | |
351 | =cut |
352 | |
a3018bd3 |
353 | sub search_like { |
354 | my $class = shift; |
12bbb339 |
355 | my $attrs = { }; |
356 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
357 | $attrs = pop(@_); |
358 | } |
359 | return $class->search(@_, { %$attrs, cmp => 'LIKE' }); |
8fe001e1 |
360 | } |
361 | |
362 | sub _select_columns { |
363 | return keys %{$_[0]->_columns}; |
364 | } |
365 | |
39fe0e65 |
366 | =item copy |
367 | |
368 | my $copy = $orig->copy({ change => $to, ... }); |
369 | |
370 | =cut |
371 | |
8fe001e1 |
372 | sub copy { |
373 | my ($self, $changes) = @_; |
374 | my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self); |
510ca912 |
375 | $new->set_column($_ => $changes->{$_}) for keys %$changes; |
a3018bd3 |
376 | return $new->insert; |
377 | } |
378 | |
126042ee |
379 | #sub _cond_resolve { |
380 | # my ($self, $query, $attrs) = @_; |
381 | # return '1 = 1' unless keys %$query; |
382 | # my $op = $attrs->{'cmp'} || '='; |
383 | # my $cond = join(' AND ', |
384 | # map { (defined $query->{$_} |
385 | # ? "$_ $op ?" |
386 | # : (do { delete $query->{$_}; "$_ IS NULL"; })); |
387 | # } keys %$query); |
388 | # return ($cond, values %$query); |
389 | #} |
8fe001e1 |
390 | |
39fe0e65 |
391 | =item table |
392 | |
393 | __PACKAGE__->table('tbl_name'); |
394 | |
395 | =cut |
396 | |
510ca912 |
397 | sub table { |
398 | shift->_table_name(@_); |
399 | } |
400 | |
39fe0e65 |
401 | =item find_or_create |
402 | |
403 | $class->find_or_create({ key => $val, ... }); |
404 | |
405 | Searches for a record matching the search condition; if it doesn't find one, |
406 | creates one and returns that instead |
407 | |
408 | =cut |
409 | |
95a70f01 |
410 | sub find_or_create { |
411 | my $class = shift; |
412 | my $hash = ref $_[0] eq "HASH" ? shift: {@_}; |
413 | my ($exists) = $class->search($hash); |
414 | return defined($exists) ? $exists : $class->create($hash); |
415 | } |
416 | |
39fe0e65 |
417 | =item insert_or_update |
418 | |
419 | $obj->insert_or_update |
420 | |
421 | Updates the object if it's already in the db, else inserts it |
422 | |
423 | =cut |
424 | |
b28cc0ba |
425 | sub insert_or_update { |
426 | my $self = shift; |
427 | return ($self->in_database ? $self->update : $self->insert); |
428 | } |
429 | |
39fe0e65 |
430 | =item retrieve_all |
431 | |
432 | my @all = $class->retrieve_all; |
433 | |
434 | =cut |
435 | |
95a70f01 |
436 | sub retrieve_all { |
437 | my ($class) = @_; |
438 | return $class->retrieve_from_sql( '1' ); |
439 | } |
440 | |
39fe0e65 |
441 | =item is_changed |
442 | |
443 | my @changed_col_names = $obj->is_changed |
444 | |
445 | =cut |
446 | |
cc0f266f |
447 | sub is_changed { |
448 | return keys %{shift->{_dirty_columns} || {}}; |
449 | } |
450 | |
8b445e33 |
451 | sub columns { return keys %{shift->_columns}; } |
452 | |
ea2e61bf |
453 | 1; |
34d52be2 |
454 | |
455 | =back |
456 | |
457 | =head1 AUTHORS |
458 | |
459 | Matt S. Trout <perl-stuff@trout.me.uk> |
460 | |
461 | =head1 LICENSE |
462 | |
463 | You may distribute this code under the same terms as Perl itself. |
464 | |
465 | =cut |
466 | |