Fixed DBICTest Schema class names, added class_resolver system to make them work
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Table.pm
CommitLineData
ea2e61bf 1package DBIx::Class::Table;
2
3use strict;
4use warnings;
5
223b8fe3 6use DBIx::Class::ResultSet;
95a70f01 7
8use 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
223b8fe3 16__PACKAGE__->mk_classdata('_resultset_class' => 'DBIx::Class::ResultSet');
95a70f01 17
223b8fe3 18sub iterator_class { shift->_resultset_class(@_) }
525035fb 19
34d52be2 20=head1 NAME
21
22DBIx::Class::Table - Basic table methods
23
24=head1 SYNOPSIS
25
26=head1 DESCRIPTION
27
28This class is responsible for defining and doing basic operations on
29L<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
39Creates a new object from column => value mappings passed as a hash ref
40
34d52be2 41=cut
9bc6db13 42
ea2e61bf 43sub 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
60Inserts an object into the database if it isn't already in there. Returns
61the object itself.
62
63=cut
64
ea2e61bf 65sub insert {
66 my ($self) = @_;
8d5134b0 67 return $self if $self->in_storage;
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;
8d5134b0 75 $self->in_storage(1);
8fe001e1 76 $self->{_dirty_columns} = {};
ea2e61bf 77 return $self;
78}
79
8d5134b0 80=item in_storage
39fe0e65 81
8d5134b0 82 $obj->in_storage; # Get value
83 $obj->in_storage(1); # Set value
39fe0e65 84
85Indicated whether the object exists as a row in the database or not
86
87=cut
88
8d5134b0 89sub in_storage {
c687b87e 90 my ($self, $val) = @_;
8d5134b0 91 $self->{_in_storage} = $val if @_ > 1;
92 return $self->{_in_storage};
604d9f38 93}
94
39fe0e65 95=item create
96
97 my $new = My::Class->create($attrs);
98
99A shortcut for My::Class->new($attrs)->insert;
100
101=cut
102
ea2e61bf 103sub 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
113Must be run on an object that is already in the database; issues an SQL
114UPDATE query to commit any changes to the object to the db if required.
115
116=cut
117
ea2e61bf 118sub update {
8b445e33 119 my ($self, $upd) = @_;
8d5134b0 120 $self->throw( "Not in database" ) unless $self->in_storage;
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 135sub 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
146Deletes the object from the database. The object is still perfectly usable
8d5134b0 147accessor-wise etc. but ->in_storage will now return 0 and the object must
39fe0e65 148be re ->insert'ed before it can be ->update'ed
149
150=cut
151
ea2e61bf 152sub delete {
a3018bd3 153 my $self = shift;
154 if (ref $self) {
8d5134b0 155 $self->throw( "Not in database" ) unless $self->in_storage;
b8e1e21f 156 #warn $self->_ident_cond.' '.join(', ', $self->_ident_values);
8b445e33 157 $self->storage->delete($self->_table_name, $self->ident_condition);
8d5134b0 158 $self->in_storage(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
177Fetches a column value
178
179=cut
180
510ca912 181sub 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
194Sets a column value; if the new value is different to the old the column
195is marked as dirty for when you next call $obj->update
196
197=cut
198
510ca912 199sub 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
212Sets a column value without marking it as dirty
213
214=cut
215
510ca912 216sub 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 225sub _register_columns {
226 my ($class, @cols) = @_;
227 my $names = { %{$class->_columns} };
228 $names->{$_} ||= {} for @cols;
229 $class->_columns($names);
230}
231
232sub _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
241Adds columns to the current package, and creates accessors for them
242
243=cut
244
510ca912 245sub add_columns {
8fe001e1 246 my ($class, @cols) = @_;
247 $class->_register_columns(@cols);
248 $class->_mk_column_accessors(@cols);
249}
250
656796f2 251=item search_literal
39fe0e65 252
656796f2 253 my @obj = $class->search_literal($literal_where_cond, @bind);
254 my $cursor = $class->search_literal($literal_where_cond, @bind);
39fe0e65 255
256=cut
257
656796f2 258sub search_literal {
8fe001e1 259 my ($class, $cond, @vals) = @_;
a3018bd3 260 $cond =~ s/^\s*WHERE//i;
8da9889b 261 my $attrs = (ref $vals[$#vals] eq 'HASH' ? { %{ pop(@vals) } } : {});
262 $attrs->{bind} = \@vals;
263 return $class->search(\$cond, $attrs);
510ca912 264}
265
656796f2 266=item count_literal
39fe0e65 267
656796f2 268 my $count = $class->count_literal($literal_where_cond);
39fe0e65 269
270=cut
271
656796f2 272sub count_literal {
223b8fe3 273 my ($class, $cond, @vals) = @_;
fcbc5f29 274 $cond =~ s/^\s*WHERE//i;
275 my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
8b445e33 276 $attrs->{bind} = [ @vals ];
223b8fe3 277 return $class->count($cond, $attrs);
fcbc5f29 278}
279
39fe0e65 280=item count
281
282 my $count = $class->count({ foo => 3 });
283
284=cut
285
06d90c6b 286sub count {
287 my $class = shift;
288 my $attrs = { };
289 if (@_ > 1 && ref $_[$#_] eq 'HASH') {
290 $attrs = { %{ pop(@_) } };
291 }
223b8fe3 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];
06d90c6b 297}
298
223b8fe3 299sub cursor_to_resultset {
54644855 300 my ($class, $sth, $args, $cols, $attrs) = @_;
223b8fe3 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);
8fe001e1 305}
306
c1d23573 307sub _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;
8d5134b0 311 $new->in_storage(1);
c1d23573 312 return $new;
313}
314
39fe0e65 315=item search
316
317 my @obj = $class->search({ foo => 3 });
318 my $cursor = $class->search({ foo => 3 });
319
320=cut
321
8fe001e1 322sub search {
12bbb339 323 my $class = shift;
8b445e33 324 #warn "@_";
12bbb339 325 my $attrs = { };
326 if (@_ > 1 && ref $_[$#_] eq 'HASH') {
327 $attrs = { %{ pop(@_) } };
328 }
8da9889b 329 my $query = (@_ == 1 || ref $_[0] eq "HASH" ? shift: {@_});
223b8fe3 330 my @cols = $class->_select_columns;
331 return $class->cursor_to_resultset(undef, $attrs->{bind}, \@cols,
332 { where => $query, %$attrs });
a3018bd3 333}
334
39fe0e65 335=item search_like
336
337Identical to search except defaults to 'LIKE' instead of '=' in condition
338
339=cut
340
a3018bd3 341sub search_like {
342 my $class = shift;
12bbb339 343 my $attrs = { };
344 if (@_ > 1 && ref $_[$#_] eq 'HASH') {
345 $attrs = pop(@_);
346 }
223b8fe3 347 my $query = ref $_[0] eq "HASH" ? { %{shift()} }: {@_};
348 $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
349 return $class->search($query, { %$attrs });
8fe001e1 350}
351
352sub _select_columns {
353 return keys %{$_[0]->_columns};
354}
355
39fe0e65 356=item copy
357
358 my $copy = $orig->copy({ change => $to, ... });
359
360=cut
361
8fe001e1 362sub copy {
363 my ($self, $changes) = @_;
364 my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self);
510ca912 365 $new->set_column($_ => $changes->{$_}) for keys %$changes;
a3018bd3 366 return $new->insert;
367}
368
126042ee 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#}
8fe001e1 380
39fe0e65 381=item table
382
383 __PACKAGE__->table('tbl_name');
384
385=cut
386
510ca912 387sub table {
388 shift->_table_name(@_);
389}
390
39fe0e65 391=item find_or_create
392
393 $class->find_or_create({ key => $val, ... });
394
395Searches for a record matching the search condition; if it doesn't find one,
396creates one and returns that instead
397
398=cut
399
95a70f01 400sub 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
39fe0e65 407=item insert_or_update
408
409 $obj->insert_or_update
410
411Updates the object if it's already in the db, else inserts it
412
413=cut
414
b28cc0ba 415sub insert_or_update {
416 my $self = shift;
8d5134b0 417 return ($self->in_storage ? $self->update : $self->insert);
b28cc0ba 418}
419
39fe0e65 420=item is_changed
421
422 my @changed_col_names = $obj->is_changed
423
424=cut
425
cc0f266f 426sub is_changed {
427 return keys %{shift->{_dirty_columns} || {}};
428}
429
8b445e33 430sub columns { return keys %{shift->_columns}; }
431
ea2e61bf 4321;
34d52be2 433
434=back
435
436=head1 AUTHORS
437
438Matt S. Trout <perl-stuff@trout.me.uk>
439
440=head1 LICENSE
441
442You may distribute this code under the same terms as Perl itself.
443
444=cut
445