File Coverage

blib/lib/DBIx/DBO/DBD.pm
Criterion Covered Total %
statement 424 461 91.9
branch 202 264 76.5
condition 71 96 73.9
subroutine 59 62 95.1
pod n/a
total 756 883 85.6


line stmt bran cond sub pod time code
1             package # hide from PAUSE
2             DBIx::DBO::DBD;
3              
4 11     11   68 use strict;
  11         27  
  11         11158  
5 11     11   79 use warnings;
  11         22  
  11         1232  
6 11     11   59 use Carp 'croak';
  11         22  
  11         7101  
7 11     11   77 use Scalar::Util 'blessed';
  11         20  
  11         881  
8 11     11   64 use constant PLACEHOLDER => "\x{b1}\x{a4}\x{221e}";
  11         20  
  11         65280  
9              
10             our @CARP_NOT = qw(DBIx::DBO DBIx::DBO::DBD DBIx::DBO::Table DBIx::DBO::Query DBIx::DBO::Row);
11             *DBIx::DBO::CARP_NOT = \@CARP_NOT;
12             *DBIx::DBO::Table::CARP_NOT = \@CARP_NOT;
13             *DBIx::DBO::Query::CARP_NOT = \@CARP_NOT;
14             *DBIx::DBO::Row::CARP_NOT = \@CARP_NOT;
15              
16             our $placeholder = PLACEHOLDER;
17             $placeholder = qr/\Q$placeholder/;
18              
19             sub _isa {
20 2068     2068   4097 my($me, @class) = @_;
21 2068 100       9826 if (blessed $me) {
22 820   100     8934 $me->isa($_) and return 1 for @class;
23             }
24             }
25              
26             sub _init_dbo {
27 13     13   30 my($class, $me) = @_;
28 13         75 return $me;
29             }
30              
31             sub _get_table_schema {
32 0     0   0 my($class, $me, $schema, $table) = @_;
33              
34 0         0 my $q_schema = $schema;
35 0         0 my $q_table = $table;
36 0 0       0 $q_schema =~ s/([\\_%])/\\$1/g if defined $q_schema;
37 0         0 $q_table =~ s/([\\_%])/\\$1/g;
38              
39             # First try just these types
40 0         0 my $info = $me->rdbh->table_info(undef, $q_schema, $q_table,
41             'TABLE,VIEW,GLOBAL TEMPORARY,LOCAL TEMPORARY,SYSTEM TABLE')->fetchall_arrayref;
42             # Then if we found nothing, try any type
43 0 0 0     0 $info = $me->rdbh->table_info(undef, $q_schema, $q_table)->fetchall_arrayref if $info and @$info == 0;
44 0 0 0     0 croak 'Invalid table: '.$class->_qi($me, $schema, $table) unless $info and @$info == 1 and $info->[0][2] eq $table;
      0        
45 0         0 return $info->[0][1];
46             }
47              
48             sub _get_column_info {
49 3     3   8 my($class, $me, $schema, $table) = @_;
50              
51 3         13 my $cols = $me->rdbh->column_info(undef, $schema, $table, '%');
52 3   100     10808 $cols = $cols && $cols->fetchall_arrayref({}) || [];
53 3 100       408 croak 'Invalid table: '.$class->_qi($me, $schema, $table) unless @$cols;
54              
55 2         5 return map { $_->{COLUMN_NAME} => $_->{ORDINAL_POSITION} } @$cols;
  5         31  
56             }
57              
58             sub _get_table_info {
59 3     3   12 my($class, $me, $schema, $table) = @_;
60              
61 3         81 my %h;
62 3         27 $h{Column_Idx} = { $class->_get_column_info($me, $schema, $table) };
63 2         5 $h{Columns} = [ sort { $h{Column_Idx}{$a} <=> $h{Column_Idx}{$b} } keys %{$h{Column_Idx}} ];
  4         15  
  2         14  
64              
65 2         6 $h{PrimaryKeys} = [];
66 2         25 $class->_set_table_key_info($me, $schema, $table, \%h);
67              
68 2 50       227 return $me->{TableInfo}{defined $schema ? $schema : ''}{$table} = \%h;
69             }
70              
71             sub _set_table_key_info {
72 2     2   4 my($class, $me, $schema, $table, $h) = @_;
73              
74 2 50       8 if (my $sth = $me->rdbh->primary_key_info(undef, $schema, $table)) {
75 2         1424 $h->{PrimaryKeys}[$_->{KEY_SEQ} - 1] = $_->{COLUMN_NAME} for @{$sth->fetchall_arrayref({})};
  2         9  
76             }
77             }
78              
79             sub _unquote_table {
80 18     18   38 my($class, $me, $table) = @_;
81             # TODO: Better splitting of: schema.table or `schema`.`table` or "schema"."table"@"catalog" or ...
82 18 50       167 $table =~ /^(?:("|)(.+)\1\.|)("|)(.+)\3$/ or croak "Invalid table: \"$table\"";
83 18         134 return ($2, $4);
84             }
85              
86             sub _selectrow_array {
87 3     3   9 my($class, $me, $sql, $attr, @bind) = @_;
88 3         11 $class->_sql($me, $sql, @bind);
89 3         12 $me->rdbh->selectrow_array($sql, $attr, @bind);
90             }
91              
92             sub _selectrow_arrayref {
93 4     4   13 my($class, $me, $sql, $attr, @bind) = @_;
94 4         16 $class->_sql($me, $sql, @bind);
95 4         13 $me->rdbh->selectrow_arrayref($sql, $attr, @bind);
96             }
97              
98             sub _selectrow_hashref {
99 1     1   3 my($class, $me, $sql, $attr, @bind) = @_;
100 1         4 $class->_sql($me, $sql, @bind);
101 1         3 $me->rdbh->selectrow_hashref($sql, $attr, @bind);
102             }
103              
104             sub _selectall_arrayref {
105 4     4   12 my($class, $me, $sql, $attr, @bind) = @_;
106 4         16 $class->_sql($me, $sql, @bind);
107 4         94 $me->rdbh->selectall_arrayref($sql, $attr, @bind);
108             }
109              
110             sub _selectall_hashref {
111 1     1   5 my($class, $me, $sql, $key, $attr, @bind) = @_;
112 1         5 $class->_sql($me, $sql, @bind);
113 1         5 $me->rdbh->selectall_hashref($sql, $key, $attr, @bind);
114             }
115              
116             sub _qi {
117 206     206   592 my($class, $me, @id) = @_;
118 206 100       779 return $me->rdbh->quote_identifier(@id) if $me->config('QuoteIdentifier');
119             # Strip off any null/undef elements (ie schema)
120 2   100     41 shift(@id) while @id and not (defined $id[0] and length $id[0]);
      100        
121 2         20 return join '.', @id;
122             }
123              
124             sub _sql {
125 86     86   153 my $class = shift;
126 86         185 my $me = shift;
127 86 50       259 if (my $hook = $me->config('HookSQL')) {
128 86         318 $hook->($me, @_);
129             }
130 86 50       291 my $dbg = $me->config('DebugSQL') or return;
131 0         0 my($sql, @bind) = @_;
132              
133 0 0       0 require Carp::Heavy if eval "$Carp::VERSION < 1.12";
134 0         0 my $loc = Carp::short_error_loc();
135 0         0 my %i = Carp::caller_info($loc);
136 0         0 my $trace;
137 0 0       0 if ($dbg > 1) {
138 0         0 $trace = "\t$i{sub_name} called at $i{file} line $i{line}\n";
139 0         0 $trace .= "\t$i{sub_name} called at $i{file} line $i{line}\n" while %i = Carp::caller_info(++$loc);
140             } else {
141 0         0 $trace = "\t$i{sub} called at $i{file} line $i{line}\n";
142             }
143 0         0 warn $sql."\n(".join(', ', map $me->rdbh->quote($_), @bind).")\n".$trace;
144             }
145              
146             sub _do {
147 20     20   58 my($class, $me, $sql, $attr, @bind) = @_;
148 20         82 $class->_sql($me, $sql, @bind);
149 20         81 $me->dbh->do($sql, $attr, @bind);
150             }
151              
152             sub _build_sql_select {
153 44     44   89 my($class, $me) = @_;
154 44         385 my $sql = 'SELECT '.$class->_build_show($me);
155 44         196 $sql .= ' FROM '.$class->_build_from($me);
156 44         74 my $clause;
157 44 100       164 $sql .= ' WHERE '.$clause if $clause = $class->_build_where($me);
158 44 100       177 $sql .= ' GROUP BY '.$clause if $clause = $class->_build_group($me);
159 44 100       160 $sql .= ' HAVING '.$clause if $clause = $class->_build_having($me);
160 44 100       148 $sql .= ' ORDER BY '.$clause if $clause = $class->_build_order($me);
161 44 100       194 $sql .= ' '.$clause if $clause = $class->_build_limit($me);
162 44         173 return $sql;
163             }
164              
165             sub _bind_params_select {
166 50     50   93 my($class, $me) = @_;
167 50         177 my $h = $me->_build_data;
168 269         1563 map {
169 50 100       98 exists $h->{$_} ? @{$h->{$_}} : ()
  300         554  
170             } qw(Show_Bind From_Bind Where_Bind Group_Bind Having_Bind Order_Bind);
171             }
172              
173             sub _build_sql_update {
174 6     6   16 my($class, $me, @arg) = @_;
175 6 50       22 croak 'Update is not valid with a GROUP BY clause' if $class->_build_group($me);
176 6 50       121 croak 'Update is not valid with a HAVING clause' if $class->_build_having($me);
177 6         23 my $sql = 'UPDATE '.$class->_build_from($me);
178 6         31 $sql .= ' SET '.$class->_build_set($me, @arg);
179 6         13 my $clause;
180 6 100       22 $sql .= ' WHERE '.$clause if $clause = $class->_build_where($me);
181 6 50       21 $sql .= ' ORDER BY '.$clause if $clause = $class->_build_order($me);
182 6 50       25 $sql .= ' '.$clause if $clause = $class->_build_limit($me);
183 6         21 $sql;
184             }
185              
186             sub _bind_params_update {
187 6     6   11 my($class, $me) = @_;
188 6         20 my $h = $me->_build_data;
189 21         58 map {
190 6 100       13 exists $h->{$_} ? @{$h->{$_}} : ()
  24         46  
191             } qw(From_Bind Set_Bind Where_Bind Order_Bind);
192             }
193              
194             sub _build_sql_delete {
195 1     1   2 my($class, $me) = @_;
196 1 50       6 croak 'Delete is not valid with a GROUP BY clause' if $class->_build_group($me);
197 1         5 my $sql = 'DELETE FROM '.$class->_build_from($me);
198 1         3 my $clause;
199 1 50       5 $sql .= ' WHERE '.$clause if $clause = $class->_build_where($me);
200 1 50       4 $sql .= ' ORDER BY '.$clause if $clause = $class->_build_order($me);
201 1 50       5 $sql .= ' '.$clause if $clause = $class->_build_limit($me);
202 1         4 $sql;
203             }
204              
205             sub _bind_params_delete {
206 1     1   4 my($class, $me) = @_;
207 1         6 my $h = $me->_build_data;
208 2         20 map {
209 1 100       4 exists $h->{$_} ? @{$h->{$_}} : ()
  3         9  
210             } qw(From_Bind Where_Bind Order_Bind);
211             }
212              
213             sub _build_table {
214 28     28   44 my($class, $me, $t) = @_;
215 28         121 my $from = $t->_from($me->{build_data});
216 28         371 my $alias = $me->_table_alias($t);
217 28 100       102 $alias = defined $alias ? ' '.$class->_qi($me, $alias) : '';
218 28         319 return $from.$alias;
219             }
220              
221             sub _build_show {
222 44     44   267 my($class, $me) = @_;
223 44         191 my $h = $me->_build_data;
224 44 100       199 return $h->{show} if defined $h->{show};
225 23 100       59 my $distinct = $h->{Show_Distinct} ? 'DISTINCT ' : '';
226 23         36 undef @{$h->{Show_Bind}};
  23         68  
227 23 100       35 return $h->{show} = $distinct.'*' unless @{$h->{Showing}};
  23         98  
228 14         25 my @flds;
229 14         24 for my $fld (@{$h->{Showing}}) {
  14         42  
230 26 100       162 if (_isa($fld, 'DBIx::DBO::Table', 'DBIx::DBO::Query')) {
231 8   66     34 push @flds, $class->_qi($me, $me->_table_alias($fld) || $fld->{Name}).'.*';
232             } else {
233 18 50       55 $h->{_subqueries}{$fld->[0][0]} = $fld->[0][0]->sql if _isa($fld->[0][0], 'DBIx::DBO::Query');
234 18         80 push @flds, $class->_build_val($me, $h->{Show_Bind}, @$fld);
235             }
236             }
237 14         154 return $h->{show} = $distinct.join(', ', @flds);
238             }
239              
240             sub _build_from {
241 84     84   129 my($class, $me) = @_;
242 84         240 my $h = $me->_build_data;
243 84 100       414 return $h->{from} if defined $h->{from};
244 22         31 undef @{$h->{From_Bind}};
  22         63  
245 22         80 my @tables = $me->tables;
246 22         119 $h->{from} = $class->_build_table($me, $tables[0]);
247 22         82 for (my $i = 1; $i < @tables; $i++) {
248 6         29 $h->{from} .= $h->{Join}[$i].$class->_build_table($me, $tables[$i]);
249 6 100       42 $h->{from} .= ' ON '.join(' AND ', $class->_build_where_chunk($me, $h->{From_Bind}, 'OR', $h->{Join_On}[$i]))
250             if $h->{Join_On}[$i];
251             }
252 22         82 return $h->{from};
253             }
254              
255             sub _parse_col_val {
256 69     69   243 my($class, $me, $col, %c) = @_;
257 69 100       201 unless (defined $c{Aliases}) {
258 54         559 (my $method = (caller(1))[3]) =~ s/.*:://;
259 54         217 $c{Aliases} = $class->_alias_preference($me, $method);
260             }
261 69 100       272 return $class->_parse_val($me, $col, Check => 'Column', %c) if ref $col;
262 39         135 return [ $class->_parse_col($me, $col, $c{Aliases}) ];
263             }
264              
265             # In some cases column aliases can be used, but this differs by DB and where in the statement it's used.
266             # The $method is the method we were called from: (join_on|column|where|having|_del_where|order_by|group_by)
267             # This method provides a way for DBs to override the default which is always 1 except for join_on.
268             # Return values: 0 = Don't use aliases, 1 = Check aliases then columns, 2 = Check columns then aliases
269             sub _alias_preference {
270             # my($class, $me, $method) = @_;
271 55 100   55   210 return $_[2] eq 'join_on' ? 0 : 1;
272             }
273              
274             sub _valid_col {
275 61     61   109 my($class, $me, $col) = @_;
276             # Check if the object is an alias
277 61 100       258 return $col if $col->[0] == $me;
278             # TODO: Sub-queries
279             # Check if the column is from one of our tables
280 51         182 for my $tbl ($me->tables) {
281 62 100       332 return $col if $col->[0] == $tbl;
282             }
283 1         126 croak 'Invalid column, the column is from a table not included in this query';
284             }
285              
286             sub _parse_col {
287 101     101   976 my($class, $me, $col, $_check_aliases) = @_;
288 101 100       258 if (ref $col) {
289 14 50       36 return $class->_valid_col($me, $col) if _isa($col, 'DBIx::DBO::Column');
290 0         0 croak 'Invalid column: '.$col;
291             }
292             # If $_check_aliases is not defined dont accept an alias
293 87   100     486 $me->_inner_col($col, $_check_aliases || 0);
294             }
295              
296             sub _build_col {
297 147     147   305 my($class, $me, $col) = @_;
298 147         585 $class->_qi($me, $me->_table_alias($col->[0]), $col->[1]);
299             }
300              
301             sub _parse_val {
302 133     133   365 my($class, $me, $fld, %c) = @_;
303 133 100       407 $c{Check} = '' unless defined $c{Check};
304              
305 133         243 my $func;
306             my $opt;
307 133 100       515 if (ref $fld eq 'SCALAR') {
    100          
    100          
308 15 0       39 croak 'Invalid '.($c{Check} eq 'Column' ? 'column' : 'field').' reference (scalar ref to undef)'
    50          
309             unless defined $$fld;
310 15         23 $func = $$fld;
311 15         31 $fld = [];
312             } elsif (ref $fld eq 'HASH') {
313 18 100       76 $func = $fld->{FUNC} if exists $fld->{FUNC};
314 18 100       119 $opt->{AS} = $fld->{AS} if exists $fld->{AS};
315 18 100       63 if (exists $fld->{ORDER}) {
316 2 50       17 croak 'Invalid ORDER, must be ASC or DESC' if $fld->{ORDER} !~ /^(A|DE)SC$/i;
317 2         7 $opt->{ORDER} = uc $fld->{ORDER};
318             }
319 18 100       64 $opt->{COLLATE} = $fld->{COLLATE} if exists $fld->{COLLATE};
320 18 100       50 if (exists $fld->{COL}) {
321 11 50       34 croak 'Invalid HASH containing both COL and VAL' if exists $fld->{VAL};
322 11 100       53 my @cols = ref $fld->{COL} eq 'ARRAY' ? @{$fld->{COL}} : $fld->{COL};
  1         3  
323 11         72 $fld = [ map $class->_parse_col($me, $_, $c{Aliases}), @cols ];
324             } else {
325 7 100       26 $fld = exists $fld->{VAL} ? $fld->{VAL} : [];
326             }
327             } elsif (_isa($fld, 'DBIx::DBO::Column')) {
328 15         63 return [ $class->_valid_col($me, $fld) ];
329             }
330 118 100       386 $fld = [$fld] unless ref $fld eq 'ARRAY';
331              
332             # Swap placeholders
333 118         231 my $with = @$fld;
334 118 100 66     467 if (defined $func) {
    50          
335 27         103 my $need = $class->_substitute_placeholders($me, $func);
336 27 100       202 croak "The number of params ($with) does not match the number of placeholders ($need)" if $need != $with;
337             } elsif ($with != 1 and $c{Check} ne 'Auto') {
338 0 0       0 croak 'Invalid '.($c{Check} eq 'Column' ? 'column' : 'field')." reference (passed $with params instead of 1)";
339             }
340 117         675 return ($fld, $func, $opt);
341             }
342              
343             sub _substitute_placeholders {
344 27     27   41 my($class, $me) = @_;
345 27         38 my $num_placeholders = 0;
346 27 100       199 $_[2] =~ s/((?
  20         169  
347 27         66 return $num_placeholders;
348             }
349              
350             sub _build_val {
351 226     226   469 my($class, $me, $bind, $fld, $func, $opt) = @_;
352 226         309 my $extra = '';
353 226 100       531 $extra .= ' COLLATE '.$me->rdbh->quote($opt->{COLLATE}) if exists $opt->{COLLATE};
354 226 100       565 $extra .= ' AS '.$class->_qi($me, $opt->{AS}) if exists $opt->{AS};
355 226 100       645 $extra .= " $opt->{ORDER}" if exists $opt->{ORDER};
356              
357             my @ary = map {
358 226 100       392 if (!ref $_) {
  214 100       543  
    50          
    0          
359 115         202 push @$bind, $_;
360 115         289 '?';
361             } elsif (_isa($_, 'DBIx::DBO::Column')) {
362 97         265 $class->_build_col($me, $_);
363             } elsif (ref $_ eq 'SCALAR') {
364 2         6 $$_;
365             } elsif (_isa($_, 'DBIx::DBO::Query')) {
366 0         0 $_->_from($me->{build_data});
367             } else {
368 0         0 croak 'Invalid field: '.$_;
369             }
370             } @$fld;
371 226 100       3109 unless (defined $func) {
372 173 50       353 die "Number of placeholders and values don't match!" if @ary != 1;
373 173         1050 return $ary[0].$extra;
374             }
375             # Add one value to @ary to make sure the number of placeholders & values match
376 53         90 push @ary, 'Error';
377 53         197 $func =~ s/$placeholder/shift @ary/ego;
  41         92  
378             # At this point all the values should have been used and @ary must only have 1 item!
379 53 50       154 die "Number of placeholders and values don't match!" if @ary != 1;
380 53         301 return $func.$extra;
381             }
382              
383             # Construct the WHERE clause
384             sub _build_where {
385 51     51   78 my($class, $me) = @_;
386 51         173 my $h = $me->_build_data;
387 51 100       204 return $h->{where} if defined $h->{where};
388 36         51 undef @{$h->{Where_Bind}};
  36         105  
389 36         49 my @where;
390 36 100       129 push @where, $class->_build_quick_where($me, $h->{Where_Bind}, @{$h->{Quick_Where}}) if exists $h->{Quick_Where};
  16         84  
391 36 100       206 push @where, $class->_build_where_chunk($me, $h->{Where_Bind}, 'OR', $h->{Where_Data}) if exists $h->{Where_Data};
392 36         221 return $h->{where} = join ' AND ', @where;
393             }
394              
395             # Construct the WHERE contents of one set of parentheses
396             sub _build_where_chunk {
397 39     39   86 my($class, $me, $bind, $ag, $whs) = @_;
398 39         48 my @str;
399             # Make a copy so we can hack at it
400 39         124 my @whs = @$whs;
401 39         224 while (my $wh = shift @whs) {
402 61         87 my @ary;
403 61 100       142 if (ref $wh->[0]) {
404 9 100       43 @ary = $class->_build_where_chunk($me, $bind, $ag eq 'OR' ? 'AND' : 'OR', $wh);
405             } else {
406 52         189 @ary = $class->_build_where_piece($me, $bind, @$wh);
407 52         137 my($op, $fld, $fld_func, $fld_opt, $val, $val_func, $val_opt, $force) = @$wh;
408             # Group AND/OR'ed for same fld if $force or $op requires it
409 52 100 100     176 if ($ag eq ($force || _op_ag($op))) {
410 18         64 for (my $i = $#whs; $i >= 0; $i--) {
411             # Right now this starts with the last @whs and works backwards
412             # It splices when the ag is the correct AND/OR and the funcs match and all flds match
413 19 100 100     124 next if ref $whs[$i][0] or $ag ne ($whs[$i][7] || _op_ag($whs[$i][0]));
      100        
414 11     11   112 no warnings 'uninitialized';
  11         24  
  11         4434  
415 8 50       30 next if $whs[$i][2] ne $fld_func;
416 11     11   61 use warnings 'uninitialized';
  11         2114  
  11         48021  
417             # next unless $fld_func ~~ $whs[$i][2];
418 8         14 my $l = $whs[$i][1];
419 8 50       74 next if ((ref $l eq 'ARRAY' ? "@$l" : $l) ne (ref $fld eq 'ARRAY' ? "@$fld" : $fld));
    50          
    100          
420             # next unless $fld ~~ $whs[$i][1];
421 6         11 push @ary, $class->_build_where_piece($me, $bind, @{splice @whs, $i, 1});
  6         24  
422             }
423             }
424             }
425 61 100       318 push @str, @ary == 1 ? $ary[0] : '('.join(' '.$ag.' ', @ary).')';
426             }
427 39         120 return @str;
428             }
429              
430             sub _op_ag {
431 65 100 100 65   652 return 'OR' if $_[0] eq '=' or $_[0] eq 'IS' or $_[0] eq '<=>' or $_[0] eq 'IN' or $_[0] eq 'BETWEEN';
      66        
      100        
      100        
432 37 100 100     348 return 'AND' if $_[0] eq '<>' or $_[0] eq 'IS NOT' or $_[0] eq 'NOT IN' or $_[0] eq 'NOT BETWEEN';
      100        
      100        
433             }
434              
435             # Construct one WHERE expression
436             sub _build_where_piece {
437 58     58   127 my($class, $me, $bind, $op, $fld, $fld_func, $fld_opt, $val, $val_func, $val_opt) = @_;
438 58         218 $class->_build_val($me, $bind, $fld, $fld_func, $fld_opt)." $op ".$class->_build_val($me, $bind, $val, $val_func, $val_opt);
439             }
440              
441             # Construct one WHERE expression (simple)
442             sub _build_quick_where {
443 28 50   28   167 croak 'Wrong number of arguments' unless @_ & 1;
444 28         82 my($class, $me, $bind) = splice @_, 0, 3;
445 28         40 my @where;
446 28         117 while (my($col, $val) = splice @_, 0, 2) {
447             # FIXME: What about aliases in quick_where?
448 26         97 push @where, $class->_build_col($me, $class->_parse_col($me, $col)) . do {
449 25 100 100     1273 if (ref $val eq 'SCALAR' and $$val =~ /^\s*(?:NOT\s+)NULL\s*$/is) {
    100          
    100          
450 2         15 ' IS ';
451             } elsif (ref $val eq 'ARRAY') {
452 2 50       12 croak 'Invalid value argument, IN requires at least 1 value' unless @$val;
453 2         14 $val = { FUNC => '('.join(',', ('?') x @$val).')', VAL => $val };
454 2         13 ' IN ';
455             } elsif (defined $val) {
456 20         86 ' = ';
457             } else {
458 1         6 $val = \'NULL';
459 1         7 ' IS ';
460             }
461             } . $class->_build_val($me, $bind, $class->_parse_val($me, $val));
462             }
463 27         128 return join ' AND ', @where;
464             }
465              
466             sub _parse_set {
467 6 50   6   29 croak 'Wrong number of arguments' if @_ & 1;
468 6         19 my($class, $me, @arg) = @_;
469 6         9 my @update;
470             my %remove_duplicates;
471 6         20 while (@arg) {
472 8         35 my @val = $class->_parse_val($me, pop @arg);
473 8         31 my $col = $class->_parse_col($me, pop @arg);
474 8 100       70 unshift @update, $col, \@val unless $remove_duplicates{$col}++;
475             }
476 6         29 return @update;
477             }
478              
479             sub _build_set {
480 6     6   16 my($class, $me, @arg) = @_;
481 6         16 my $h = $me->_build_data;
482 6         17 undef @{$h->{Set_Bind}};
  6         23  
483 6         16 my @set;
484 6         17 while (@arg) {
485 7         25 push @set, $class->_build_col($me, shift @arg).' = '.$class->_build_val($me, $h->{Set_Bind}, @{shift @arg});
  7         204  
486             }
487 6         32 return join ', ', @set;
488             }
489              
490             sub _build_group {
491 51     51   91 my($class, $me) = @_;
492 51         151 my $h = $me->_build_data;
493 51 100       241 return $h->{group} if defined $h->{group};
494 20         38 undef @{$h->{Group_Bind}};
  20         60  
495 20         33 return $h->{group} = join ', ', map $class->_build_val($me, $h->{Group_Bind}, @$_), @{$h->{GroupBy}};
  20         115  
496             }
497              
498             # Construct the HAVING clause
499             sub _build_having {
500 50     50   90 my($class, $me) = @_;
501 50         130 my $h = $me->_build_data;
502 50 100       202 return $h->{having} if defined $h->{having};
503 26         44 undef @{$h->{Having_Bind}};
  26         58  
504 26         43 my @having;
505 26 100       83 push @having, $class->_build_where_chunk($me, $h->{Having_Bind}, 'OR', $h->{Having_Data}) if exists $h->{Having_Data};
506 26         130 return $h->{having} = join ' AND ', @having;
507             }
508              
509             sub _build_order {
510 51     51   72 my($class, $me) = @_;
511 51         154 my $h = $me->_build_data;
512 51 100       258 return $h->{order} if defined $h->{order};
513 24         28 undef @{$h->{Order_Bind}};
  24         54  
514 24         39 return $h->{order} = join ', ', map $class->_build_val($me, $h->{Order_Bind}, @$_), @{$h->{OrderBy}};
  24         129  
515             }
516              
517             sub _build_limit {
518 51     51   97 my($class, $me) = @_;
519 51         150 my $h = $me->_build_data;
520 51 100       200 return $h->{limit} if defined $h->{limit};
521 27 100       155 return $h->{limit} = '' unless defined $h->{LimitOffset};
522 7         23 $h->{limit} = 'LIMIT '.$h->{LimitOffset}[0];
523 7 100       33 $h->{limit} .= ' OFFSET '.$h->{LimitOffset}[1] if $h->{LimitOffset}[1];
524 7         32 return $h->{limit};
525             }
526              
527             sub _get_config {
528 751     751   1568 my($class, $opt, @confs) = @_;
529 751   100     5999 defined $_->{$opt} and return $_->{$opt} for @confs;
530 307         1445 return;
531             }
532              
533             sub _set_config {
534 123     123   290 my($class, $ref, $opt, $val) = @_;
535 123 50 66     501 croak "Invalid value for the 'OnRowUpdate' setting"
      66        
      33        
      33        
536             if $opt eq 'OnRowUpdate' and $val and $val ne 'empty' and $val ne 'simple' and $val ne 'reload';
537 123 100 100     839 croak "Invalid value for the 'UseHandle' setting"
      100        
      100        
538             if $opt eq 'UseHandle' and $val and $val ne 'read-only' and $val ne 'read-write';
539 122         241 my $old = $ref->{$opt};
540 122         261 $ref->{$opt} = $val;
541 122         462 return $old;
542             }
543              
544              
545             # Query methods
546             sub _rows {
547 1     1   3 my($class, $me) = @_;
548 1 50 33     4 $me->_sth and ($me->{sth}{Executed} or $me->run)
      33        
549             or croak $me->rdbh->errstr;
550 1         7 my $rows = $me->_sth->rows;
551 1 50       7 $me->{Row_Count} = $rows == -1 ? undef : $rows;
552             }
553              
554             sub _calc_found_rows {
555 1     1   2 my($class, $me) = @_;
556 1         4 local $me->{build_data}{limit} = '';
557 1         4 $me->{Found_Rows} = $me->count_rows;
558             }
559              
560              
561             # Table methods
562 0     0   0 sub _save_last_insert_id {
563             #my($class, $me, $sth) = @_;
564             # Should be provided in a DBD specific method
565             # It is called after insert and must return the autogenerated ID
566             #return $sth->{Database}->last_insert_id(undef, @$me{qw(Schema Name)}, undef);
567             }
568              
569             sub _fast_bulk_insert {
570 0     0   0 my($class, $me, $sql, $cols, %opt) = @_;
571              
572 0         0 my @vals;
573             my @bind;
574 0 0       0 if (ref $opt{rows}[0] eq 'ARRAY') {
575 0         0 for my $row (@{$opt{rows}}) {
  0         0  
576 0         0 push @vals, '('.join(', ', map $class->_build_val($me, \@bind, $class->_parse_val($me, $_)), @$row).')';
577             }
578             } else {
579 0         0 for my $row (@{$opt{rows}}) {
  0         0  
580 0         0 push @vals, '('.join(', ', map $class->_build_val($me, \@bind, $class->_parse_val($me, $_)), @$row{@$cols}).')';
581             }
582             }
583              
584 0         0 $sql .= join(",\n", @vals);
585 0         0 $class->_do($me, $sql, undef, @bind);
586             }
587              
588             sub _safe_bulk_insert {
589 4     4   13 my($class, $me, $sql, $cols, %opt) = @_;
590              
591             # TODO: Wrap in a transaction
592 4         7 my $rv;
593             my $sth;
594 4         9 my $prev_vals = '';
595 4 100       16 if (ref $opt{rows}[0] eq 'ARRAY') {
596 2         3 for my $row (@{$opt{rows}}) {
  2         5  
597 8         11 my @bind;
598 8         36 my $vals = '('.join(', ', map $class->_build_val($me, \@bind, $class->_parse_val($me, $_)), @$row).')';
599 8         34 $class->_sql($me, $sql.$vals, @bind);
600 8 100       23 if ($prev_vals ne $vals) {
601 2 50       9 $sth = $me->dbh->prepare($sql.$vals) or return undef;
602 2         176 $prev_vals = $vals;
603             }
604 8 50       954 $rv += $sth->execute(@bind) or return undef;
605             }
606             } else {
607 2         5 for my $row (@{$opt{rows}}) {
  2         5  
608 8         12 my @bind;
609 8         48 my $vals = '('.join(', ', map $class->_build_val($me, \@bind, $class->_parse_val($me, $_)), @$row{@$cols}).')';
610 8         42 $class->_sql($me, $sql.$vals, @bind);
611 8 100       31 if ($prev_vals ne $vals) {
612 2 50       9 $sth = $me->dbh->prepare($sql.$vals) or return undef;
613 2         125 $prev_vals = $vals;
614             }
615 8 50       1113 $rv += $sth->execute(@bind) or return undef;
616             }
617             }
618              
619 4   50     96 return $rv || '0E0';
620             }
621             *_bulk_insert = \&_safe_bulk_insert;
622              
623              
624             # Row methods
625             sub _reset_row_on_update {
626 4     4   14 my($class, $me, @update) = @_;
627 4   50     15 my $on_row_update = $me->config('OnRowUpdate') || 'simple';
628              
629 4 50       13 if ($on_row_update ne 'empty') {
630             # Set the row values if they are simple expressions
631 4         7 my @cant_update;
632 4         21 for (my $i = 0; $i < @update; $i += 2) {
633             # Keep a list of columns we can't update, and skip them
634             next if $cant_update[ $me->_column_idx($update[0]) ] = (
635 5 100 66     25 defined $update[1][1] or @{$update[1][0]} != 1 or (
636             ref $update[1][0][0] and (
637             not _isa($update[1][0][0], 'DBIx::DBO::Column')
638             or $cant_update[ $me->_column_idx($update[1][0][0]) ]
639             )
640             )
641             );
642 4         14 my($col, $val) = splice @update, $i, 2;
643 4         11 $val = $val->[0][0];
644 4 50       10 $val = $$me->{array}[ $me->_column_idx($val) ] if ref $val;
645 4         17 $$me->{array}[ $me->_column_idx($col) ] = $val;
646 4         15 $i -= 2;
647             }
648             # If we were able to update all the columns then return
649 4 100       21 grep $_, @cant_update or return;
650              
651 1 50       6 if ($on_row_update eq 'reload') {
652             # Attempt reload
653 1         3 my @cols = map $$me->{build_data}{Quick_Where}[$_ << 1], 0 .. $#{$$me->{build_data}{Quick_Where}} >> 1;
  1         8  
654 1         6 my @cidx = map $me->_column_idx($_), @cols;
655 1 50       6 unless (grep $cant_update[$_], @cidx) {
656 1         2 my %bd = %{$$me->{build_data}};
  1         14  
657 1         4 delete $bd{Where_Data};
658 1         2 delete $bd{where};
659 1         3 $bd{Quick_Where} = [map { $cols[$_] => $$me->{array}[ $cidx[$_] ] } 0 .. $#cols];
  1         4  
660 1         2 my($sql, @bind) = do {
661 1         3 local $$me->{build_data} = \%bd;
662 1         5 ($class->_build_sql_select($me), $class->_bind_params_select($me));
663             };
664 1         5 return $me->_load($sql, @bind);
665             }
666             }
667             }
668             # If we can't update or reload then empty the Row
669 0         0 undef $$me->{array};
670 0         0 $$me->{hash} = {};
671             }
672              
673             sub _build_data_matching_this_row {
674 5     5   13 my($class, $me) = @_;
675             # Identify the row by the PrimaryKeys if any, otherwise by all Columns
676 5         20 my @quick_where;
677 5         7 for my $tbl (@{$$me->{Tables}}) {
  5         14  
678 5 50       10 for my $col (map $tbl ** $_, @{$tbl->{ @{$tbl->{PrimaryKeys}} ? 'PrimaryKeys' : 'Columns' }}) {
  5         7  
  5         36  
679 5         21 my $i = $me->_column_idx($col);
680 5 50       23 defined $i or croak 'The '.$class->_qi($me, $tbl->{Name}, $col->[1]).' field needed to identify this row, was not included in this query';
681 5         25 push @quick_where, $col => $$me->{array}[$i];
682             }
683             }
684 5         33 my %h = (
685             Showing => $$me->{build_data}{Showing},
686             from => $$me->{build_data}{from},
687             Quick_Where => \@quick_where
688             );
689 5 100       17 $h{From_Bind} = $$me->{build_data}{From_Bind} if exists $$me->{build_data}{From_Bind};
690 5         23 return \%h;
691             }
692              
693              
694             # require the DBD module if it exists
695             my %inheritance;
696             sub _require_dbd_class {
697 22     22   64 my($class, $dbd) = @_;
698 22         65 my $dbd_class = $class.'::'.$dbd;
699              
700 22         49 my $rv;
701             my @warn;
702             {
703 22     1   36 local $SIG{__WARN__} = sub { push @warn, join '', @_ };
  22         214  
  1         7  
704 22         1677 $rv = eval "require $dbd_class";
705             }
706 22 100       117 if ($rv) {
707 12 50       44 warn @warn if @warn;
708             } else {
709 10         69 (my $file = $dbd_class.'.pm') =~ s'::'/'g;
710 10 100       226 if ($@ !~ / \Q$file\E in \@INC /) {
711 1         7 (my $err = $@) =~ s/\n.*$//; # Remove the last line
712 1         2 chomp @warn;
713 1         3 chomp $err;
714 1         3400 croak join "\n", @warn, $err, "Can't load $dbd driver";
715             }
716              
717 9         26 $@ = '';
718 9         25 delete $INC{$file};
719 9         71 $INC{$file} = 1;
720             }
721              
722             # Set the derived DBD class' inheritance
723 21 100       99 unless (exists $inheritance{$class}{$dbd}) {
724 11     11   94 no strict 'refs';
  11         26  
  11         3225  
725 10 50       149 unless (@{$dbd_class.'::ISA'}) {
  10         89  
726 10         21 my @isa = map $_->_require_dbd_class($dbd), grep $_->isa(__PACKAGE__), @{$class.'::ISA'};
  10         71  
727 10         23 @{$dbd_class.'::ISA'} = ($class, @isa);
  10         173  
728 10 100       137 if (@isa) {
729 1         7 mro::set_mro($dbd_class, 'c3');
730 1 50       6 Class::C3::initialize() if $] < 5.009_005;
731             }
732             }
733 10         29 push @CARP_NOT, $dbd_class;
734 10         29 $inheritance{$class}{$dbd} = $dbd_class;
735             }
736              
737 21         116 return $inheritance{$class}{$dbd};
738             }
739              
740             1;