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 | |
35 | =cut |
9bc6db13 |
36 | |
ea2e61bf |
37 | sub new { |
38 | my ($class, $attrs) = @_; |
39 | $class = ref $class if ref $class; |
40 | my $new = bless({ _column_data => { } }, $class); |
41 | if ($attrs) { |
78bab9ca |
42 | $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; |
ea2e61bf |
43 | while (my ($k, $v) = each %{$attrs}) { |
510ca912 |
44 | $new->store_column($k => $v); |
ea2e61bf |
45 | } |
46 | } |
8fe001e1 |
47 | return $new; |
ea2e61bf |
48 | } |
49 | |
50 | sub insert { |
51 | my ($self) = @_; |
c687b87e |
52 | return if $self->in_database; |
c1d23573 |
53 | #use Data::Dumper; warn Dumper($self); |
ea2e61bf |
54 | my $sth = $self->_get_sth('insert', [ keys %{$self->{_column_data}} ], |
55 | $self->_table_name, undef); |
56 | $sth->execute(values %{$self->{_column_data}}); |
604d9f38 |
57 | $sth->finish; |
c687b87e |
58 | $self->in_database(1); |
8fe001e1 |
59 | $self->{_dirty_columns} = {}; |
ea2e61bf |
60 | return $self; |
61 | } |
62 | |
604d9f38 |
63 | sub in_database { |
c687b87e |
64 | my ($self, $val) = @_; |
65 | $self->{_in_database} = $val if @_ > 1; |
66 | return $self->{_in_database}; |
604d9f38 |
67 | } |
68 | |
ea2e61bf |
69 | sub create { |
70 | my ($class, $attrs) = @_; |
78bab9ca |
71 | $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; |
ea2e61bf |
72 | return $class->new($attrs)->insert; |
73 | } |
74 | |
75 | sub update { |
76 | my ($self) = @_; |
78bab9ca |
77 | $self->throw( "Not in database" ) unless $self->in_database; |
ea2e61bf |
78 | my @to_update = keys %{$self->{_dirty_columns} || {}}; |
a3018bd3 |
79 | return -1 unless @to_update; |
ea2e61bf |
80 | my $sth = $self->_get_sth('update', \@to_update, |
81 | $self->_table_name, $self->_ident_cond); |
a3018bd3 |
82 | my $rows = $sth->execute( (map { $self->{_column_data}{$_} } @to_update), |
ea2e61bf |
83 | $self->_ident_values ); |
604d9f38 |
84 | $sth->finish; |
a3018bd3 |
85 | if ($rows == 0) { |
78bab9ca |
86 | $self->throw( "Can't update $self: row not found" ); |
a3018bd3 |
87 | } elsif ($rows > 1) { |
78bab9ca |
88 | $self->throw("Can't update $self: updated more than one row"); |
a3018bd3 |
89 | } |
ea2e61bf |
90 | $self->{_dirty_columns} = {}; |
91 | return $self; |
92 | } |
93 | |
94 | sub delete { |
a3018bd3 |
95 | my $self = shift; |
96 | if (ref $self) { |
78bab9ca |
97 | $self->throw( "Not in database" ) unless $self->in_database; |
b8e1e21f |
98 | #warn $self->_ident_cond.' '.join(', ', $self->_ident_values); |
a3018bd3 |
99 | my $sth = $self->_get_sth('delete', undef, |
100 | $self->_table_name, $self->_ident_cond); |
101 | $sth->execute($self->_ident_values); |
102 | $sth->finish; |
c687b87e |
103 | $self->in_database(undef); |
a3018bd3 |
104 | } else { |
12bbb339 |
105 | my $attrs = { }; |
106 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
107 | $attrs = { %{ pop(@_) } }; |
108 | } |
a3018bd3 |
109 | my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_}); |
12bbb339 |
110 | my ($cond, @param) = $self->_cond_resolve($query, $attrs); |
a3018bd3 |
111 | my $sth = $self->_get_sth('delete', undef, $self->_table_name, $cond); |
12bbb339 |
112 | $sth->execute(@param); |
a3018bd3 |
113 | $sth->finish; |
114 | } |
ea2e61bf |
115 | return $self; |
116 | } |
117 | |
510ca912 |
118 | sub get_column { |
ea2e61bf |
119 | my ($self, $column) = @_; |
78bab9ca |
120 | $self->throw( "Can't fetch data as class method" ) unless ref $self; |
121 | $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column}; |
c1d23573 |
122 | return $self->{_column_data}{$column} |
123 | if exists $self->{_column_data}{$column}; |
124 | return undef; |
ea2e61bf |
125 | } |
126 | |
510ca912 |
127 | sub set_column { |
128 | my $self = shift; |
129 | my ($column) = @_; |
130 | my $ret = $self->store_column(@_); |
131 | $self->{_dirty_columns}{$column} = 1; |
132 | return $ret; |
133 | } |
134 | |
135 | sub store_column { |
ea2e61bf |
136 | my ($self, $column, $value) = @_; |
78bab9ca |
137 | $self->throw( "No such column '${column}'" ) |
138 | unless $self->_columns->{$column}; |
139 | $self->throw( "set_column called for ${column} without value" ) |
140 | if @_ < 3; |
510ca912 |
141 | return $self->{_column_data}{$column} = $value; |
ea2e61bf |
142 | } |
143 | |
ea2e61bf |
144 | sub _register_columns { |
145 | my ($class, @cols) = @_; |
146 | my $names = { %{$class->_columns} }; |
147 | $names->{$_} ||= {} for @cols; |
148 | $class->_columns($names); |
149 | } |
150 | |
151 | sub _mk_column_accessors { |
152 | my ($class, @cols) = @_; |
510ca912 |
153 | $class->mk_group_accessors('column' => @cols); |
ea2e61bf |
154 | } |
155 | |
510ca912 |
156 | sub add_columns { |
8fe001e1 |
157 | my ($class, @cols) = @_; |
158 | $class->_register_columns(@cols); |
159 | $class->_mk_column_accessors(@cols); |
160 | } |
161 | |
162 | sub retrieve_from_sql { |
163 | my ($class, $cond, @vals) = @_; |
a3018bd3 |
164 | $cond =~ s/^\s*WHERE//i; |
604d9f38 |
165 | my $attrs = (ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); |
166 | my @cols = $class->_select_columns($attrs); |
8fe001e1 |
167 | my $sth = $class->_get_sth( 'select', \@cols, $class->_table_name, $cond); |
b8e1e21f |
168 | #warn "$cond @vals"; |
54644855 |
169 | return $class->sth_to_objects($sth, \@vals, \@cols, { where => $cond }); |
510ca912 |
170 | } |
171 | |
172 | sub sth_to_objects { |
54644855 |
173 | my ($class, $sth, $args, $cols, $attrs) = @_; |
510ca912 |
174 | my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} ); |
95a70f01 |
175 | my $cursor_class = $class->_cursor_class; |
176 | eval "use $cursor_class;"; |
54644855 |
177 | my $cursor = $cursor_class->new($class, $sth, $args, \@cols, $attrs); |
95a70f01 |
178 | return (wantarray ? $cursor->all : $cursor); |
8fe001e1 |
179 | } |
180 | |
c1d23573 |
181 | sub _row_to_object { # WARNING: Destructive to @$row |
182 | my ($class, $cols, $row) = @_; |
183 | my $new = $class->new; |
184 | $new->store_column($_, shift @$row) for @$cols; |
185 | $new->in_database(1); |
186 | return $new; |
187 | } |
188 | |
8fe001e1 |
189 | sub search { |
12bbb339 |
190 | my $class = shift; |
191 | my $attrs = { }; |
192 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
193 | $attrs = { %{ pop(@_) } }; |
194 | } |
195 | my $query = ref $_[0] eq "HASH" ? shift: {@_}; |
196 | my ($cond, @param) = $class->_cond_resolve($query, $attrs); |
c687b87e |
197 | return $class->retrieve_from_sql($cond, @param, $attrs); |
a3018bd3 |
198 | } |
199 | |
200 | sub search_like { |
201 | my $class = shift; |
12bbb339 |
202 | my $attrs = { }; |
203 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
204 | $attrs = pop(@_); |
205 | } |
206 | return $class->search(@_, { %$attrs, cmp => 'LIKE' }); |
8fe001e1 |
207 | } |
208 | |
209 | sub _select_columns { |
210 | return keys %{$_[0]->_columns}; |
211 | } |
212 | |
213 | sub copy { |
214 | my ($self, $changes) = @_; |
215 | my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self); |
510ca912 |
216 | $new->set_column($_ => $changes->{$_}) for keys %$changes; |
a3018bd3 |
217 | return $new->insert; |
218 | } |
219 | |
12bbb339 |
220 | sub _cond_resolve { |
221 | my ($self, $query, $attrs) = @_; |
604d9f38 |
222 | return '1 = 1' unless keys %$query; |
12bbb339 |
223 | my $op = $attrs->{'cmp'} || '='; |
a3018bd3 |
224 | my $cond = join(' AND ', |
225 | map { (defined $query->{$_} |
226 | ? "$_ $op ?" |
227 | : (do { delete $query->{$_}; "$_ IS NULL"; })); |
228 | } keys %$query); |
12bbb339 |
229 | return ($cond, values %$query); |
8fe001e1 |
230 | } |
231 | |
510ca912 |
232 | sub table { |
233 | shift->_table_name(@_); |
234 | } |
235 | |
95a70f01 |
236 | sub find_or_create { |
237 | my $class = shift; |
238 | my $hash = ref $_[0] eq "HASH" ? shift: {@_}; |
239 | my ($exists) = $class->search($hash); |
240 | return defined($exists) ? $exists : $class->create($hash); |
241 | } |
242 | |
243 | sub retrieve_all { |
244 | my ($class) = @_; |
245 | return $class->retrieve_from_sql( '1' ); |
246 | } |
247 | |
ea2e61bf |
248 | 1; |
34d52be2 |
249 | |
250 | =back |
251 | |
252 | =head1 AUTHORS |
253 | |
254 | Matt S. Trout <perl-stuff@trout.me.uk> |
255 | |
256 | =head1 LICENSE |
257 | |
258 | You may distribute this code under the same terms as Perl itself. |
259 | |
260 | =cut |
261 | |