Fixed DBICTest Schema class names, added class_resolver system to make them work
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Table.pm
1 package DBIx::Class::Table;
2
3 use strict;
4 use warnings;
5
6 use DBIx::Class::ResultSet;
7
8 use base qw/Class::Data::Inheritable/;
9
10 __PACKAGE__->mk_classdata('_columns' => {});
11
12 __PACKAGE__->mk_classdata('_table_name');
13
14 __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do anything yet!
15
16 __PACKAGE__->mk_classdata('_resultset_class' => 'DBIx::Class::ResultSet');
17
18 sub iterator_class { shift->_resultset_class(@_) }
19
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
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
41 =cut
42
43 sub new {
44   my ($class, $attrs) = @_;
45   $class = ref $class if ref $class;
46   my $new = bless({ _column_data => { } }, $class);
47   if ($attrs) {
48     $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH';
49     while (my ($k, $v) = each %{$attrs}) {
50       $new->store_column($k => $v);
51     }
52   }
53   return $new;
54 }
55
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
65 sub insert {
66   my ($self) = @_;
67   return $self if $self->in_storage;
68   #use Data::Dumper; warn Dumper($self);
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;
75   $self->in_storage(1);
76   $self->{_dirty_columns} = {};
77   return $self;
78 }
79
80 =item in_storage
81
82   $obj->in_storage; # Get value
83   $obj->in_storage(1); # Set value
84
85 Indicated whether the object exists as a row in the database or not
86
87 =cut
88
89 sub in_storage {
90   my ($self, $val) = @_;
91   $self->{_in_storage} = $val if @_ > 1;
92   return $self->{_in_storage};
93 }
94
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
103 sub create {
104   my ($class, $attrs) = @_;
105   $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
106   return $class->new($attrs)->insert;
107 }
108
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
118 sub update {
119   my ($self, $upd) = @_;
120   $self->throw( "Not in database" ) unless $self->in_storage;
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);
126   if ($rows == 0) {
127     $self->throw( "Can't update ${self}: row not found" );
128   } elsif ($rows > 1) {
129     $self->throw("Can't update ${self}: updated more than one row");
130   }
131   $self->{_dirty_columns} = {};
132   return $self;
133 }
134
135 sub ident_condition {
136   my ($self) = @_;
137   my %cond;
138   $cond{$_} = $self->get_column($_) for keys %{$self->_primaries};
139   return \%cond;
140 }
141
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_storage will now return 0 and the object must
148 be re ->insert'ed before it can be ->update'ed
149
150 =cut
151
152 sub delete {
153   my $self = shift;
154   if (ref $self) {
155     $self->throw( "Not in database" ) unless $self->in_storage;
156     #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
157     $self->storage->delete($self->_table_name, $self->ident_condition);
158     $self->in_storage(undef);
159     #$self->store_column($_ => undef) for $self->primary_columns;
160       # Should probably also arrange to trash PK if auto
161       # but if we do, post-delete cascade triggers fail :/
162   } else {
163     my $attrs = { };
164     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
165       $attrs = { %{ pop(@_) } };
166     }
167     my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_});
168     $self->storage->delete($self->_table_name, $query);
169   }
170   return $self;
171 }
172
173 =item get_column
174
175   my $val = $obj->get_column($col);
176
177 Fetches a column value
178
179 =cut
180
181 sub get_column {
182   my ($self, $column) = @_;
183   $self->throw( "Can't fetch data as class method" ) unless ref $self;
184   $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column};
185   return $self->{_column_data}{$column}
186     if exists $self->{_column_data}{$column};
187   return undef;
188 }
189
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
199 sub set_column {
200   my $self = shift;
201   my ($column) = @_;
202   my $old = $self->get_column($column);
203   my $ret = $self->store_column(@_);
204   $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret;
205   return $ret;
206 }
207
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
216 sub store_column {
217   my ($self, $column, $value) = @_;
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;
222   return $self->{_column_data}{$column} = $value;
223 }
224
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) = @_;
234   $class->mk_group_accessors('column' => @cols);
235 }
236
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
245 sub add_columns {
246   my ($class, @cols) = @_;
247   $class->_register_columns(@cols);
248   $class->_mk_column_accessors(@cols);
249 }
250
251 =item search_literal
252
253   my @obj    = $class->search_literal($literal_where_cond, @bind);
254   my $cursor = $class->search_literal($literal_where_cond, @bind);
255
256 =cut
257
258 sub search_literal {
259   my ($class, $cond, @vals) = @_;
260   $cond =~ s/^\s*WHERE//i;
261   my $attrs = (ref $vals[$#vals] eq 'HASH' ? { %{ pop(@vals) } } : {});
262   $attrs->{bind} = \@vals;
263   return $class->search(\$cond, $attrs);
264 }
265
266 =item count_literal
267
268   my $count = $class->count_literal($literal_where_cond);
269
270 =cut
271
272 sub count_literal {
273   my ($class, $cond, @vals) = @_;
274   $cond =~ s/^\s*WHERE//i;
275   my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
276   $attrs->{bind} = [ @vals ];
277   return $class->count($cond, $attrs);
278 }
279
280 =item count
281
282   my $count = $class->count({ foo => 3 });
283
284 =cut
285
286 sub count {
287   my $class = shift;
288   my $attrs = { };
289   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
290     $attrs = { %{ pop(@_) } };
291   }
292   my $query  = ref $_[0] eq "HASH" || (@_ == 1) ? shift: {@_};
293   my @cols = 'COUNT(*)';
294   my $cursor = $class->storage->select($class->_table_name, \@cols,
295                                          $query, $attrs);
296   return ($cursor->next)[0];
297 }
298
299 sub cursor_to_resultset {
300   my ($class, $sth, $args, $cols, $attrs) = @_;
301   my $rs_class = $class->_resultset_class;
302   eval "use $rs_class;";
303   my $rs = $rs_class->new($class, $sth, $args, $cols, $attrs);
304   return (wantarray ? $rs->all : $rs);
305 }
306
307 sub _row_to_object { # WARNING: Destructive to @$row
308   my ($class, $cols, $row) = @_;
309   my $new = $class->new;
310   $new->store_column($_, shift @$row) for @$cols;
311   $new->in_storage(1);
312   return $new;
313 }
314
315 =item search 
316
317   my @obj    = $class->search({ foo => 3 });
318   my $cursor = $class->search({ foo => 3 });
319
320 =cut
321
322 sub search {
323   my $class = shift;
324   #warn "@_";
325   my $attrs = { };
326   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
327     $attrs = { %{ pop(@_) } };
328   }
329   my $query    = (@_ == 1 || ref $_[0] eq "HASH" ? shift: {@_});
330   my @cols = $class->_select_columns;
331   return $class->cursor_to_resultset(undef, $attrs->{bind}, \@cols,
332                                     { where => $query, %$attrs });
333 }
334
335 =item search_like
336
337 Identical to search except defaults to 'LIKE' instead of '=' in condition
338
339 =cut
340
341 sub search_like {
342   my $class    = shift;
343   my $attrs = { };
344   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
345     $attrs = pop(@_);
346   }
347   my $query    = ref $_[0] eq "HASH" ? { %{shift()} }: {@_};
348   $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
349   return $class->search($query, { %$attrs });
350 }
351
352 sub _select_columns {
353   return keys %{$_[0]->_columns};
354 }
355
356 =item copy
357
358   my $copy = $orig->copy({ change => $to, ... });
359
360 =cut
361
362 sub copy {
363   my ($self, $changes) = @_;
364   my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
365   $new->set_column($_ => $changes->{$_}) for keys %$changes;
366   return $new->insert;
367 }
368
369 #sub _cond_resolve {
370 #  my ($self, $query, $attrs) = @_;
371 #  return '1 = 1' unless keys %$query;
372 #  my $op = $attrs->{'cmp'} || '=';
373 #  my $cond = join(' AND ',
374 #               map { (defined $query->{$_}
375 #                       ? "$_ $op ?"
376 #                       : (do { delete $query->{$_}; "$_ IS NULL"; }));
377 #                   } keys %$query);
378 #  return ($cond, values %$query);
379 #}
380
381 =item table
382
383   __PACKAGE__->table('tbl_name');
384
385 =cut
386
387 sub table {
388   shift->_table_name(@_);
389 }
390
391 =item find_or_create
392
393   $class->find_or_create({ key => $val, ... });
394
395 Searches for a record matching the search condition; if it doesn't find one,
396 creates one and returns that instead
397
398 =cut
399
400 sub find_or_create {
401   my $class    = shift;
402   my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
403   my ($exists) = $class->search($hash);
404   return defined($exists) ? $exists : $class->create($hash);
405 }
406
407 =item insert_or_update
408
409   $obj->insert_or_update
410
411 Updates the object if it's already in the db, else inserts it
412
413 =cut
414
415 sub insert_or_update {
416   my $self = shift;
417   return ($self->in_storage ? $self->update : $self->insert);
418 }
419
420 =item is_changed
421
422   my @changed_col_names = $obj->is_changed
423
424 =cut
425
426 sub is_changed {
427   return keys %{shift->{_dirty_columns} || {}};
428 }
429
430 sub columns { return keys %{shift->_columns}; }
431
432 1;
433
434 =back
435
436 =head1 AUTHORS
437
438 Matt S. Trout <perl-stuff@trout.me.uk>
439
440 =head1 LICENSE
441
442 You may distribute this code under the same terms as Perl itself.
443
444 =cut
445