first commit
|
1 |
package DBI::Custom; |
2 |
use Object::Simple; |
|
add some method
|
3 |
use DBI; |
4 |
use SQL::Abstract; |
|
first commit
|
5 | |
cleanup
|
6 |
sub new { |
7 |
my $self = shift->Object::Simple::new(@_); |
|
8 |
my $class = ref $self; |
|
9 |
return bless {%{$class->model}, %{$self}}, $class; |
|
first commit
|
10 |
} |
11 | ||
cleanup
|
12 |
sub create_model {shift->Object::Simple::new(@_); |
first commit
|
13 | |
cleanup
|
14 |
sub initialize_model { |
15 |
my ($class, $callback) = @_; |
|
16 |
|
|
17 |
my $model = $class->create_model; |
|
18 |
|
|
19 |
$callback->($model); |
|
20 |
|
|
21 |
$class->model($model); |
|
first commit
|
22 |
} |
23 | ||
24 |
# Class attribute |
|
cleanup
|
25 |
sub connect_info : Attr { type => 'hash' } |
26 |
sub table_infos : Attr { type => 'hash' } |
|
add some method
|
27 |
sub dbh : Attr {} |
28 |
sub sql_abstract : Attr { auto_build => sub { shift->sql_abstract(SQL::Abstract->new) }} |
|
first commit
|
29 | |
30 |
sub column_info { |
|
cleanup
|
31 |
my ($self, $table, $column_name, $column_info) = @_; |
32 |
|
|
33 |
if (@_ > 3) { |
|
34 |
$self->table_infos->{$table}{column}{$column_name} = $column_info; |
|
35 |
return $self; |
|
36 |
} |
|
37 |
return $self->table_infos->{$table}{column}{$column_name}; |
|
first commit
|
38 |
} |
39 | ||
40 |
sub columns { |
|
cleanup
|
41 |
my ($self, $table) = @_; |
first commit
|
42 |
|
43 |
return sort { |
|
cleanup
|
44 |
$self->table_infos->{$table}{column}{$a}{pos} |
first commit
|
45 |
<=> |
cleanup
|
46 |
$self->table_infos->{$table}{column}{$b}{pos} |
47 |
} keys %{$self->table_info->{$table}{column}} |
|
first commit
|
48 |
} |
49 | ||
50 |
sub tables { |
|
cleanup
|
51 |
my $self = shift; |
first commit
|
52 |
return keys %{$self->table_info}; |
53 |
} |
|
54 | ||
cleanup
|
55 |
sub create_table { |
56 |
my ($self, $table, @row_infos) = @_; |
|
57 |
|
|
58 |
$self->table_infos->{$table} = {}; |
|
59 |
|
|
60 |
for (my $i = 0; $i < @columns; i++) { |
|
61 |
my $column = $columns[$i]; |
|
62 |
|
|
63 |
my $column_name = shift @$column; |
|
64 |
my $column_type = shift @$column; |
|
65 |
my %column_options = @$column; |
|
66 |
|
|
67 |
my $column_info = {}; |
|
68 |
|
|
69 |
$column_info->{pos} = $i; |
|
70 |
$column_info->{type} = $column_type; |
|
71 |
$column_info->{options} = \%column_options; |
|
72 |
|
|
73 |
$self->column_info($table, $column_name, $column_info); |
|
74 |
} |
|
75 |
} |
|
76 | ||
add some method
|
77 |
sub load_table_definitions { |
78 |
my $self = shift; |
|
79 |
my $dsn = $self->connect_info->{dsn}; |
|
80 |
} |
|
cleanup
|
81 | |
add some method
|
82 |
sub connect { |
83 |
my $self = shift; |
|
84 |
my $connect_info = $self->connect_info; |
|
85 |
|
|
86 |
my $dbh = DBI->connect( |
|
87 |
$connect_info->{dsn}, |
|
88 |
$connect_info->{user}, |
|
89 |
$connect_info->{password}, |
|
90 |
{ |
|
91 |
RaiseError => 1, |
|
92 |
PrintError => 0, |
|
93 |
AutoCommit => 1, |
|
94 |
%{$connect_info->{options} || {} } |
|
95 |
} |
|
96 |
); |
|
97 |
|
|
98 |
$self->dbh($dbh); |
|
99 |
} |
|
first commit
|
100 | |
add some method
|
101 |
sub reconnect { |
102 |
my $self = shift; |
|
103 |
$self->dbh(undef); |
|
104 |
$self->connect; |
|
105 |
} |
|
first commit
|
106 | |
add some method
|
107 |
sub query { |
108 |
my ($self, $query, @binds) = @_; |
|
109 |
$self->{success} = 0; |
|
110 | ||
111 |
$self->_replace_omniholder(\$query, \@binds); |
|
112 | ||
113 |
my $st; |
|
114 |
my $sth; |
|
115 | ||
116 |
my $old = $old_statements{$self}; |
|
117 | ||
118 |
if (my $i = (grep $old->[$_][0] eq $query, 0..$#$old)[0]) { |
|
119 |
$st = splice(@$old, $i, 1)->[1]; |
|
120 |
$sth = $st->{sth}; |
|
121 |
} else { |
|
122 |
eval { $sth = $self->{dbh}->prepare($query) } or do { |
|
123 |
if ($@) { |
|
124 |
$@ =~ s/ at \S+ line \d+\.\n\z//; |
|
125 |
Carp::croak($@); |
|
126 |
} |
|
127 |
$self->{reason} = "Prepare failed ($DBI::errstr)"; |
|
128 |
return _dummy; |
|
129 |
}; |
|
130 | ||
131 |
# $self is quoted on purpose, to pass along the stringified version, |
|
132 |
# and avoid increasing reference count. |
|
133 |
$st = bless { |
|
134 |
db => "$self", |
|
135 |
sth => $sth, |
|
136 |
query => $query |
|
137 |
}, 'DBIx::Simple::Statement'; |
|
138 |
$statements{$self}{$st} = $st; |
|
139 |
} |
|
first commit
|
140 | |
add some method
|
141 |
eval { $sth->execute(@binds) } or do { |
142 |
if ($@) { |
|
143 |
$@ =~ s/ at \S+ line \d+\.\n\z//; |
|
144 |
Carp::croak($@); |
|
145 |
} |
|
first commit
|
146 | |
add some method
|
147 |
$self->{reason} = "Execute failed ($DBI::errstr)"; |
148 |
return _dummy; |
|
149 |
}; |
|
150 | ||
151 |
$self->{success} = 1; |
|
152 | ||
153 |
return bless { st => $st, lc_columns => $self->{lc_columns} }, $self->{result_class}; |
|
154 |
} |
|
155 | ||
156 |
sub query { |
|
157 |
my ($self, $sql) = @_; |
|
158 |
my $sth = $self->dbh->prepare($sql); |
|
159 |
$sth->execute(@bind); |
|
160 |
} |
|
161 | ||
162 |
sub select { |
|
163 |
my ($table, $column_names, $where, $order) = @_; |
|
first commit
|
164 |
|
add some method
|
165 |
my ($stmt, @bind) = $self->sql_abstract->select($table, $column_names, $where, $order); |
166 |
my $sth = $self->dbh->prepare($stmt); |
|
167 |
$sth->execute(@bind); |
|
168 |
} |
|
169 | ||
170 |
sub insert { |
|
171 |
my ($self, $table, $values) = @_; |
|
first commit
|
172 |
|
add some method
|
173 |
my ($stmt, @bind) = $self->sql_abstract->insert($table, $values); |
174 |
my $sth = $self->dbh->prepare($stmt); |
|
175 |
$sth->execute(@bind); |
|
176 |
} |
|
177 | ||
178 |
sub update { |
|
179 |
my ($self, $values, $where) = @_; |
|
180 |
my ($stmt, @bind) = $self->sql_abstract->update($table, $values, $where); |
|
181 |
my $sth = $self->dbh->prepare($stmt); |
|
182 |
$sth->execute(@bind); |
|
first commit
|
183 |
} |
184 | ||
add some method
|
185 |
sub delete { |
186 |
my ($self, $where) = @_; |
|
187 |
my ($stmt, @bind) = $self->sql_abstract->delete($table, $where); |
|
188 |
my $sth = $self->dbh->prepare($stmt); |
|
189 |
$sth->execute(@bind); |
|
190 |
} |
|
191 | ||
192 | ||
first commit
|
193 | |
194 |
Object::Simple->build_class; |
|
195 | ||
196 |
=head1 NAME |
|
197 | ||
198 |
DBI::Custom - The great new DBI::Custom! |
|
199 | ||
200 |
=head1 VERSION |
|
201 | ||
202 |
Version 0.01 |
|
203 | ||
204 |
=cut |
|
205 | ||
206 |
our $VERSION = '0.01'; |
|
207 | ||
208 | ||
209 |
=head1 SYNOPSIS |
|
210 | ||
211 |
Quick summary of what the module does. |
|
212 | ||
213 |
Perhaps a little code snippet. |
|
214 | ||
215 |
use DBI::Custom; |
|
216 | ||
217 |
my $foo = DBI::Custom->new(); |
|
218 |
... |
|
219 | ||
220 |
=head1 EXPORT |
|
221 | ||
222 |
A list of functions that can be exported. You can delete this section |
|
223 |
if you don't export anything, such as for a purely object-oriented module. |
|
224 | ||
225 |
=head1 FUNCTIONS |
|
226 | ||
227 |
=head2 function1 |
|
228 | ||
229 |
=cut |
|
230 | ||
231 |
sub function1 { |
|
232 |
} |
|
233 | ||
234 |
=head2 function2 |
|
235 | ||
236 |
=cut |
|
237 | ||
238 |
sub function2 { |
|
239 |
} |
|
240 | ||
241 |
=head1 AUTHOR |
|
242 | ||
243 |
Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >> |
|
244 | ||
245 |
=head1 BUGS |
|
246 | ||
247 |
Please report any bugs or feature requests to C<bug-dbi-custom at rt.cpan.org>, or through |
|
248 |
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBI-Custom>. I will be notified, and then you'll |
|
249 |
automatically be notified of progress on your bug as I make changes. |
|
250 | ||
251 | ||
252 | ||
253 | ||
254 |
=head1 SUPPORT |
|
255 | ||
256 |
You can find documentation for this module with the perldoc command. |
|
257 | ||
258 |
perldoc DBI::Custom |
|
259 | ||
260 | ||
261 |
You can also look for information at: |
|
262 | ||
263 |
=over 4 |
|
264 | ||
265 |
=item * RT: CPAN's request tracker |
|
266 | ||
267 |
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBI-Custom> |
|
268 | ||
269 |
=item * AnnoCPAN: Annotated CPAN documentation |
|
270 | ||
271 |
L<http://annocpan.org/dist/DBI-Custom> |
|
272 | ||
273 |
=item * CPAN Ratings |
|
274 | ||
275 |
L<http://cpanratings.perl.org/d/DBI-Custom> |
|
276 | ||
277 |
=item * Search CPAN |
|
278 | ||
279 |
L<http://search.cpan.org/dist/DBI-Custom/> |
|
280 | ||
281 |
=back |
|
282 | ||
283 | ||
284 |
=head1 ACKNOWLEDGEMENTS |
|
285 | ||
286 | ||
287 |
=head1 COPYRIGHT & LICENSE |
|
288 | ||
289 |
Copyright 2009 Yuki Kimoto, all rights reserved. |
|
290 | ||
291 |
This program is free software; you can redistribute it and/or modify it |
|
292 |
under the same terms as Perl itself. |
|
293 | ||
294 | ||
295 |
=cut |
|
296 | ||
297 |
1; # End of DBI::Custom |