File Coverage

blib/lib/SQL/Abstract.pm
Criterion Covered Total %
statement 584 666 87.6
branch 194 254 76.3
condition 100 141 70.9
subroutine 122 140 87.1
pod 10 12 83.3
total 1010 1213 83.2


line stmt bran cond sub pod time code
1             package SQL::Abstract; # see doc at end of file
2              
3 14     14   343679 use strict;
  14         112  
  14         385  
4 14     14   68 use warnings;
  14         28  
  14         312  
5 14     14   63 use Carp ();
  14         24  
  14         204  
6 14     14   67 use List::Util ();
  14         22  
  14         188  
7 14     14   71 use Scalar::Util ();
  14         27  
  14         735  
8              
9 14     14   61 use Exporter 'import';
  14         28  
  14         1525  
10             our @EXPORT_OK = qw(is_plain_value is_literal_value);
11              
12             BEGIN {
13 14 50   14   72 if ($] < 5.009_005) {
14 0         0 require MRO::Compat;
15             }
16             else {
17 14         62 require mro;
18             }
19              
20             *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
21             ? sub () { 0 }
22             : sub () { 1 }
23 14 50       6704 ;
24             }
25              
26             #======================================================================
27             # GLOBALS
28             #======================================================================
29              
30             our $VERSION = '1.87';
31              
32             # This would confuse some packagers
33             $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
34              
35             our $AUTOLOAD;
36              
37             # special operators (-in, -between). May be extended/overridden by user.
38             # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
39             my @BUILTIN_SPECIAL_OPS = (
40             {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'},
41             {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'},
42             {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'},
43             {regex => qr/^ value $/ix, handler => '_where_op_VALUE'},
44             {regex => qr/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'},
45             );
46              
47             # unaryish operators - key maps to handler
48             my @BUILTIN_UNARY_OPS = (
49             # the digits are backcompat stuff
50             { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
51             { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
52             { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
53             { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
54             { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
55             { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
56             );
57              
58             #======================================================================
59             # DEBUGGING AND ERROR REPORTING
60             #======================================================================
61              
62             sub _debug {
63 1160 50   1160   2200 return unless $_[0]->{debug}; shift; # a little faster
  0         0  
64 0         0 my $func = (caller(1))[3];
65 0         0 warn "[$func] ", @_, "\n";
66             }
67              
68             sub belch (@) {
69 148     148 0 497 my($func) = (caller(1))[3];
70 148         7302 Carp::carp "[$func] Warning: ", @_;
71             }
72              
73             sub puke (@) {
74 116     116 0 340 my($func) = (caller(1))[3];
75 116         4885 Carp::croak "[$func] Fatal: ", @_;
76             }
77              
78             sub is_literal_value ($) {
79 13         39 ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
80 50 100 66 50 1 1699 : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
  9 100       31  
81             : undef;
82             }
83              
84             # FIXME XSify - this can be done so much more efficiently
85             sub is_plain_value ($) {
86 14     14   100 no strict 'refs';
  14         28  
  14         125057  
87             ! length ref $_[0] ? \($_[0])
88             : (
89             ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
90             and
91             exists $_[0]->{-value}
92             ) ? \($_[0]->{-value})
93             : (
94             # reuse @_ for even moar speedz
95             defined ( $_[1] = Scalar::Util::blessed $_[0] )
96             and
97             # deliberately not using Devel::OverloadInfo - the checks we are
98             # intersted in are much more limited than the fullblown thing, and
99             # this is a very hot piece of code
100             (
101             # simply using ->can('(""') can leave behind stub methods that
102             # break actually using the overload later (see L
103             # found while resolving method "%s" overloading "%s" in package
104             # "%s"> and the source of overload::mycan())
105             #
106             # either has stringification which DBI SHOULD prefer out of the box
107             grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
108             or
109             # has nummification or boolification, AND fallback is *not* disabled
110             (
111             SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
112             and
113             (
114             grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
115             or
116             grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
117             )
118             and
119             (
120             # no fallback specified at all
121             ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
122             or
123             # fallback explicitly undef
124             ! defined ${"$_[3]::()"}
125             or
126             # explicitly true
127 47 100 66 47 1 18454 !! ${"$_[3]::()"}
    100 100        
    100          
128             )
129             )
130             )
131             ) ? \($_[0])
132             : undef;
133             }
134              
135              
136              
137             #======================================================================
138             # NEW
139             #======================================================================
140              
141             sub new {
142 611     611 1 8462 my $self = shift;
143 611   33     1971 my $class = ref($self) || $self;
144 611 100       1929 my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
  101         284  
145              
146             # choose our case by keeping an option around
147 611 100 100     1517 delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
148              
149             # default logic for interpreting arrayrefs
150 611 100       1236 $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
151              
152             # how to return bind vars
153 611   100     1924 $opt{bindtype} ||= 'normal';
154              
155             # default comparison is "=", but can be overridden
156 611   100     1989 $opt{cmp} ||= '=';
157              
158             # try to recognize which are the 'equality' and 'inequality' ops
159             # (temporary quickfix (in 2007), should go through a more seasoned API)
160 611         3371 $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix;
161 611         1339 $opt{inequality_op} = qr/^( != | <> )$/ix;
162              
163 611         1221 $opt{like_op} = qr/^ (is\s+)? r?like $/xi;
164 611         1112 $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi;
165              
166             # SQL booleans
167 611   50     2135 $opt{sqltrue} ||= '1=1';
168 611   50     1726 $opt{sqlfalse} ||= '0=1';
169              
170             # special operators
171 611   100     1898 $opt{special_ops} ||= [];
172             # regexes are applied in order, thus push after user-defines
173 611         722 push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
  611         1474  
174              
175             # unary operators
176 611   50     1829 $opt{unary_ops} ||= [];
177 611         683 push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
  611         1166  
178              
179             # rudimentary sanity-check for user supplied bits treated as functions/operators
180             # If a purported function matches this regular expression, an exception is thrown.
181             # Literal SQL is *NOT* subject to this check, only functions (and column names
182             # when quoting is not in effect)
183              
184             # FIXME
185             # need to guard against ()'s in column names too, but this will break tons of
186             # hacks... ideas anyone?
187 611   33     2283 $opt{injection_guard} ||= qr/
188             \;
189             |
190             ^ \s* go \s
191             /xmi;
192              
193 611         1626 return bless \%opt, $class;
194             }
195              
196              
197             sub _assert_pass_injection_guard {
198 1802 100   1802   10490 if ($_[1] =~ $_[0]->{injection_guard}) {
199 5         15 my $class = ref $_[0];
200 5         34 puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
201             . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
202             . "{injection_guard} attribute to ${class}->new()"
203             }
204             }
205              
206              
207             #======================================================================
208             # INSERT methods
209             #======================================================================
210              
211             sub insert {
212 49     49 1 3509 my $self = shift;
213 49         104 my $table = $self->_table(shift);
214 49   50     278 my $data = shift || return;
215 49         68 my $options = shift;
216              
217 49         107 my $method = $self->_METHOD_FOR_refkind("_insert", $data);
218 49         102 my ($sql, @bind) = $self->$method($data);
219 47         93 $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
220              
221 47 100       104 if ($options->{returning}) {
222 10         21 my ($s, @b) = $self->_insert_returning($options);
223 10         19 $sql .= $s;
224 10         13 push @bind, @b;
225             }
226              
227 47 50       266 return wantarray ? ($sql, @bind) : $sql;
228             }
229              
230             # So that subclasses can override INSERT ... RETURNING separately from
231             # UPDATE and DELETE (e.g. DBIx::Class::SQLMaker::Oracle does this)
232 10     10   19 sub _insert_returning { shift->_returning(@_) }
233              
234             sub _returning {
235 22     22   36 my ($self, $options) = @_;
236              
237 22         32 my $f = $options->{returning};
238              
239             my $fieldlist = $self->_SWITCH_refkind($f, {
240 6     6   10 ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
  14         24  
241 8     8   15 SCALAR => sub {$self->_quote($f)},
242 8     8   18 SCALARREF => sub {$$f},
243 22         124 });
244 22         103 return $self->_sqlcase(' returning ') . $fieldlist;
245             }
246              
247             sub _insert_HASHREF { # explicit list of fields and then values
248 28     28   65 my ($self, $data) = @_;
249              
250 28         120 my @fields = sort keys %$data;
251              
252 28         89 my ($sql, @bind) = $self->_insert_values($data);
253              
254             # assemble SQL
255 26         81 $_ = $self->_quote($_) foreach @fields;
256 26         80 $sql = "( ".join(", ", @fields).") ".$sql;
257              
258 26         72 return ($sql, @bind);
259             }
260              
261             sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
262 21     21   41 my ($self, $data) = @_;
263              
264             # no names (arrayref) so can't generate bindtype
265 21 50       43 $self->{bindtype} ne 'columns'
266             or belch "can't do 'columns' bindtype when called with arrayref";
267              
268 21         33 my (@values, @all_bind);
269 21         37 foreach my $value (@$data) {
270 156         218 my ($values, @bind) = $self->_insert_value(undef, $value);
271 156         223 push @values, $values;
272 156         242 push @all_bind, @bind;
273             }
274 21         38 my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
275 21         71 return ($sql, @all_bind);
276             }
277              
278             sub _insert_ARRAYREFREF { # literal SQL with bind
279 0     0   0 my ($self, $data) = @_;
280              
281 0         0 my ($sql, @bind) = @${$data};
  0         0  
282 0         0 $self->_assert_bindval_matches_bindtype(@bind);
283              
284 0         0 return ($sql, @bind);
285             }
286              
287              
288             sub _insert_SCALARREF { # literal SQL without bind
289 0     0   0 my ($self, $data) = @_;
290              
291 0         0 return ($$data);
292             }
293              
294             sub _insert_values {
295 28     28   42 my ($self, $data) = @_;
296              
297 28         44 my (@values, @all_bind);
298 28         74 foreach my $column (sort keys %$data) {
299 95         179 my ($values, @bind) = $self->_insert_value($column, $data->{$column});
300 93         144 push @values, $values;
301 93         139 push @all_bind, @bind;
302             }
303 26         61 my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
304 26         92 return ($sql, @all_bind);
305             }
306              
307             sub _insert_value {
308 251     251   348 my ($self, $column, $v) = @_;
309              
310 251         266 my (@values, @all_bind);
311             $self->_SWITCH_refkind($v, {
312              
313             ARRAYREF => sub {
314 5 100   5   13 if ($self->{array_datatypes}) { # if array datatype are activated
315 4         5 push @values, '?';
316 4         9 push @all_bind, $self->_bindtype($column, $v);
317             }
318             else { # else literal SQL with bind
319 1         3 my ($sql, @bind) = @$v;
320 1         3 $self->_assert_bindval_matches_bindtype(@bind);
321 1         1 push @values, $sql;
322 1         3 push @all_bind, @bind;
323             }
324             },
325              
326             ARRAYREFREF => sub { # literal SQL with bind
327 11     11   20 my ($sql, @bind) = @${$v};
  11         27  
328 11         25 $self->_assert_bindval_matches_bindtype(@bind);
329 9         16 push @values, $sql;
330 9         17 push @all_bind, @bind;
331             },
332              
333             # THINK: anything useful to do with a HASHREF ?
334             HASHREF => sub { # (nothing, but old SQLA passed it through)
335             #TODO in SQLA >= 2.0 it will die instead
336 2     2   12 belch "HASH ref as bind value in insert is not supported";
337 2         1897 push @values, '?';
338 2         6 push @all_bind, $self->_bindtype($column, $v);
339             },
340              
341             SCALARREF => sub { # literal SQL without bind
342 6     6   15 push @values, $$v;
343             },
344              
345             SCALAR_or_UNDEF => sub {
346 227     227   291 push @values, '?';
347 227         324 push @all_bind, $self->_bindtype($column, $v);
348             },
349              
350 251         1698 });
351              
352 249         1399 my $sql = join(", ", @values);
353 249         592 return ($sql, @all_bind);
354             }
355              
356              
357              
358             #======================================================================
359             # UPDATE methods
360             #======================================================================
361              
362              
363             sub update {
364 38     38 1 1554 my $self = shift;
365 38         95 my $table = $self->_table(shift);
366 38   50     223 my $data = shift || return;
367 38         59 my $where = shift;
368 38         49 my $options = shift;
369              
370             # first build the 'SET' part of the sql statement
371 38 50       98 puke "Unsupported data type specified to \$sql->update"
372             unless ref $data eq 'HASH';
373              
374 38         84 my ($sql, @all_bind) = $self->_update_set_values($data);
375 36         75 $sql = $self->_sqlcase('update ') . $table . $self->_sqlcase(' set ')
376             . $sql;
377              
378 36 100       99 if ($where) {
379 30         69 my($where_sql, @where_bind) = $self->where($where);
380 30         66 $sql .= $where_sql;
381 30         59 push @all_bind, @where_bind;
382             }
383              
384 36 100       79 if ($options->{returning}) {
385 6         14 my ($returning_sql, @returning_bind) = $self->_update_returning($options);
386 6         12 $sql .= $returning_sql;
387 6         11 push @all_bind, @returning_bind;
388             }
389              
390 36 50       263 return wantarray ? ($sql, @all_bind) : $sql;
391             }
392              
393             sub _update_set_values {
394 38     38   70 my ($self, $data) = @_;
395              
396 38         45 my (@set, @all_bind);
397 38         152 for my $k (sort keys %$data) {
398 78         128 my $v = $data->{$k};
399 78         106 my $r = ref $v;
400 78         141 my $label = $self->_quote($k);
401              
402             $self->_SWITCH_refkind($v, {
403             ARRAYREF => sub {
404 4 50   4   8 if ($self->{array_datatypes}) { # array datatype
405 4         8 push @set, "$label = ?";
406 4         8 push @all_bind, $self->_bindtype($k, $v);
407             }
408             else { # literal SQL with bind
409 0         0 my ($sql, @bind) = @$v;
410 0         0 $self->_assert_bindval_matches_bindtype(@bind);
411 0         0 push @set, "$label = $sql";
412 0         0 push @all_bind, @bind;
413             }
414             },
415             ARRAYREFREF => sub { # literal SQL with bind
416 10     10   10 my ($sql, @bind) = @${$v};
  10         25  
417 10         25 $self->_assert_bindval_matches_bindtype(@bind);
418 8         20 push @set, "$label = $sql";
419 8         70 push @all_bind, @bind;
420             },
421             SCALARREF => sub { # literal SQL without bind
422 0     0   0 push @set, "$label = $$v";
423             },
424             HASHREF => sub {
425 4     4   12 my ($op, $arg, @rest) = %$v;
426              
427 4 50 33     31 puke 'Operator calls in update must be in the form { -op => $arg }'
428             if (@rest or not $op =~ /^\-(.+)/);
429              
430 4         10 local $self->{_nested_func_lhs} = $k;
431 4         14 my ($sql, @bind) = $self->_where_unary_op($1, $arg);
432              
433 4         16 push @set, "$label = $sql";
434 4         54 push @all_bind, @bind;
435             },
436             SCALAR_or_UNDEF => sub {
437 60     60   117 push @set, "$label = ?";
438 60         111 push @all_bind, $self->_bindtype($k, $v);
439             },
440 78         726 });
441             }
442              
443             # generate sql
444 36         98 my $sql = join ', ', @set;
445              
446 36         120 return ($sql, @all_bind);
447             }
448              
449             # So that subclasses can override UPDATE ... RETURNING separately from
450             # INSERT and DELETE
451 6     6   13 sub _update_returning { shift->_returning(@_) }
452              
453              
454              
455             #======================================================================
456             # SELECT
457             #======================================================================
458              
459              
460             sub select {
461 102     102 1 13247 my $self = shift;
462 102         244 my $table = $self->_table(shift);
463 102   50     632 my $fields = shift || '*';
464 102         156 my $where = shift;
465 102         127 my $order = shift;
466              
467 102         223 my ($fields_sql, @bind) = $self->_select_fields($fields);
468              
469 102         223 my ($where_sql, @where_bind) = $self->where($where, $order);
470 89         176 push @bind, @where_bind;
471              
472 89         151 my $sql = join(' ', $self->_sqlcase('select'), $fields_sql,
473             $self->_sqlcase('from'), $table)
474             . $where_sql;
475              
476 89 100       592 return wantarray ? ($sql, @bind) : $sql;
477             }
478              
479             sub _select_fields {
480 102     102   176 my ($self, $fields) = @_;
481 102 100       276 return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields
  22         36  
482             : $fields;
483             }
484              
485             #======================================================================
486             # DELETE
487             #======================================================================
488              
489              
490             sub delete {
491 10     10 1 423 my $self = shift;
492 10         24 my $table = $self->_table(shift);
493 10         52 my $where = shift;
494 10         15 my $options = shift;
495              
496 10         22 my($where_sql, @bind) = $self->where($where);
497 10         20 my $sql = $self->_sqlcase('delete from ') . $table . $where_sql;
498              
499 10 100       23 if ($options->{returning}) {
500 6         13 my ($returning_sql, @returning_bind) = $self->_delete_returning($options);
501 6         12 $sql .= $returning_sql;
502 6         9 push @bind, @returning_bind;
503             }
504              
505 10 50       56 return wantarray ? ($sql, @bind) : $sql;
506             }
507              
508             # So that subclasses can override DELETE ... RETURNING separately from
509             # INSERT and UPDATE
510 6     6   13 sub _delete_returning { shift->_returning(@_) }
511              
512              
513              
514             #======================================================================
515             # WHERE: entry point
516             #======================================================================
517              
518              
519              
520             # Finally, a separate routine just to handle WHERE clauses
521             sub where {
522 619     619 1 21622 my ($self, $where, $order) = @_;
523              
524             # where ?
525 619         1222 my ($sql, @bind) = $self->_recurse_where($where);
526 509 100 66     1846 $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : '';
527              
528             # order by?
529 509 100       994 if ($order) {
530 50         103 my ($order_sql, @order_bind) = $self->_order_by($order);
531 50         98 $sql .= $order_sql;
532 50         74 push @bind, @order_bind;
533             }
534              
535 509 50       2305 return wantarray ? ($sql, @bind) : $sql;
536             }
537              
538              
539             sub _recurse_where {
540 1471     1471   2201 my ($self, $where, $logic) = @_;
541              
542             # dispatch on appropriate method according to refkind of $where
543 1471         2564 my $method = $self->_METHOD_FOR_refkind("_where", $where);
544              
545 1471         2924 my ($sql, @bind) = $self->$method($where, $logic);
546              
547             # DBIx::Class used to call _recurse_where in scalar context
548             # something else might too...
549 1347 50       2673 if (wantarray) {
550 1347         4151 return ($sql, @bind);
551             }
552             else {
553 0         0 belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
554 0         0 return $sql;
555             }
556             }
557              
558              
559              
560             #======================================================================
561             # WHERE: top-level ARRAYREF
562             #======================================================================
563              
564              
565             sub _where_ARRAYREF {
566 395     395   650 my ($self, $where, $logic) = @_;
567              
568 395   66     1075 $logic = uc($logic || $self->{logic});
569 395 50 66     1109 $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
570              
571 395         722 my @clauses = @$where;
572              
573 395         492 my (@sql_clauses, @all_bind);
574             # need to use while() so can shift() for pairs
575 395         662 while (@clauses) {
576 688         1009 my $el = shift @clauses;
577              
578 688 100 100     2100 $el = undef if (defined $el and ! length $el);
579              
580             # switch according to kind of $el and get corresponding ($sql, @bind)
581             my ($sql, @bind) = $self->_SWITCH_refkind($el, {
582              
583             # skip empty elements, otherwise get invalid trailing AND stuff
584 15 50   15   55 ARRAYREF => sub {$self->_recurse_where($el) if @$el},
585              
586             ARRAYREFREF => sub {
587 1     1   3 my ($s, @b) = @$$el;
588 1         3 $self->_assert_bindval_matches_bindtype(@b);
589 1         2 ($s, @b);
590             },
591              
592 273 100   273   766 HASHREF => sub {$self->_recurse_where($el, 'and') if %$el},
593              
594 0     0   0 SCALARREF => sub { ($$el); },
595              
596             SCALAR => sub {
597             # top-level arrayref with scalars, recurse in pairs
598 347     347   842 $self->_recurse_where({$el => shift(@clauses)})
599             },
600              
601 52     52   87 UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" },
602 688         5982 });
603              
604 624 100       3962 if ($sql) {
605 623         953 push @sql_clauses, $sql;
606 623         1378 push @all_bind, @bind;
607             }
608             }
609              
610 331         591 return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind);
611             }
612              
613             #======================================================================
614             # WHERE: top-level ARRAYREFREF
615             #======================================================================
616              
617             sub _where_ARRAYREFREF {
618 6     6   12 my ($self, $where) = @_;
619 6         17 my ($sql, @bind) = @$$where;
620 6         19 $self->_assert_bindval_matches_bindtype(@bind);
621 6         14 return ($sql, @bind);
622             }
623              
624             #======================================================================
625             # WHERE: top-level HASHREF
626             #======================================================================
627              
628             sub _where_HASHREF {
629 1164     1164   1682 my ($self, $where) = @_;
630 1164         1401 my (@sql_clauses, @all_bind);
631              
632 1164         3496 for my $k (sort keys %$where) {
633 1392         1952 my $v = $where->{$k};
634              
635             # ($k => $v) is either a special unary op or a regular hashpair
636 1392         1517 my ($sql, @bind) = do {
637 1392 100       2792 if ($k =~ /^-./) {
638             # put the operator in canonical form
639 225         289 my $op = $k;
640 225         437 $op = substr $op, 1; # remove initial dash
641 225         619 $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
642 225         362 $op =~ s/\s+/ /g; # compress whitespace
643              
644             # so that -not_foo works correctly
645 225         321 $op =~ s/^not_/NOT /i;
646              
647 225         656 $self->_debug("Unary OP(-$op) within hashref, recursing...");
648 225         473 my ($s, @b) = $self->_where_unary_op($op, $v);
649              
650             # top level vs nested
651             # we assume that handled unary ops will take care of their ()s
652             $s = "($s)" unless (
653 505     505   1908 List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}
  201         514  
654             or
655 201 50 66     716 ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k )
      66        
656             );
657 201         734 ($s, @b);
658             }
659             else {
660 1167 100       1950 if (! length $k) {
661 44 100       82 if (is_literal_value ($v) ) {
662 20         34 belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
663             }
664             else {
665 24         41 puke "Supplying an empty left hand side argument is not supported in hash-pairs";
666             }
667             }
668              
669 1143         16241 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
670 1143         2075 $self->$method($k, $v);
671             }
672             };
673              
674 1312         2249 push @sql_clauses, $sql;
675 1312         2414 push @all_bind, @bind;
676             }
677              
678 1084         2283 return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
679             }
680              
681             sub _where_unary_op {
682 446     446   820 my ($self, $op, $rhs) = @_;
683              
684             # top level special ops are illegal in general
685             # this includes the -ident/-value ops (dual purpose unary and special)
686             puke "Illegal use of top-level '-$op'"
687 446 100 100 1028   1268 if ! defined $self->{_nested_func_lhs} and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
  1028         2700  
  207         550  
688              
689 444 100   1873   1322 if (my $op_entry = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
  1873         4883  
  444         983  
690 204         342 my $handler = $op_entry->{handler};
691              
692 204 50       381 if (not ref $handler) {
    0          
693 204 100       652 if ($op =~ s/ [_\s]? \d+ $//x ) {
694 9         25 belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
695             . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
696             }
697 204         2685 return $self->$handler($op, $rhs);
698             }
699             elsif (ref $handler eq 'CODE') {
700 0         0 return $handler->($self, $op, $rhs);
701             }
702             else {
703 0         0 puke "Illegal handler for operator $op - expecting a method name or a coderef";
704             }
705             }
706              
707 240         1067 $self->_debug("Generic unary OP: $op - recursing as function");
708              
709 240         499 $self->_assert_pass_injection_guard($op);
710              
711             my ($sql, @bind) = $self->_SWITCH_refkind($rhs, {
712             SCALAR => sub {
713             puke "Illegal use of top-level '-$op'"
714 207 50   207   394 unless defined $self->{_nested_func_lhs};
715              
716             return (
717             $self->_convert('?'),
718 207         354 $self->_bindtype($self->{_nested_func_lhs}, $rhs)
719             );
720             },
721             FALLBACK => sub {
722 31     31   87 $self->_recurse_where($rhs)
723             },
724 238         1411 });
725              
726 236         1084 $sql = sprintf('%s %s',
727             $self->_sqlcase($op),
728             $sql,
729             );
730              
731 236         676 return ($sql, @bind);
732             }
733              
734             sub _where_op_ANDOR {
735 146     146   262 my ($self, $op, $v) = @_;
736              
737             $self->_SWITCH_refkind($v, {
738             ARRAYREF => sub {
739 76     76   162 return $self->_where_ARRAYREF($v, $op);
740             },
741              
742             HASHREF => sub {
743             return ($op =~ /^or/i)
744 70 100   70   304 ? $self->_where_ARRAYREF([ map { $_ => $v->{$_} } (sort keys %$v) ], $op)
  67         205  
745             : $self->_where_HASHREF($v);
746             },
747              
748             SCALARREF => sub {
749 0 0   0   0 puke "-$op => \\\$scalar makes little sense, use " .
750             ($op =~ /^or/i
751             ? '[ \$scalar, \%rest_of_conditions ] instead'
752             : '-and => [ \$scalar, \%rest_of_conditions ] instead'
753             );
754             },
755              
756             ARRAYREFREF => sub {
757 0 0   0   0 puke "-$op => \\[...] makes little sense, use " .
758             ($op =~ /^or/i
759             ? '[ \[...], \%rest_of_conditions ] instead'
760             : '-and => [ \[...], \%rest_of_conditions ] instead'
761             );
762             },
763              
764             SCALAR => sub { # permissively interpreted as SQL
765 0     0   0 puke "-$op => \$value makes little sense, use -bool => \$value instead";
766             },
767              
768             UNDEF => sub {
769 0     0   0 puke "-$op => undef not supported";
770             },
771 146         1354 });
772             }
773              
774             sub _where_op_NEST {
775 26     26   53 my ($self, $op, $v) = @_;
776              
777             $self->_SWITCH_refkind($v, {
778              
779             SCALAR => sub { # permissively interpreted as SQL
780 0     0   0 belch "literal SQL should be -nest => \\'scalar' "
781             . "instead of -nest => 'scalar' ";
782 0         0 return ($v);
783             },
784              
785             UNDEF => sub {
786 0     0   0 puke "-$op => undef not supported";
787             },
788              
789             FALLBACK => sub {
790 26     26   51 $self->_recurse_where($v);
791             },
792              
793 26         161 });
794             }
795              
796              
797             sub _where_op_BOOL {
798 24     24   43 my ($self, $op, $v) = @_;
799              
800             my ($s, @b) = $self->_SWITCH_refkind($v, {
801             SCALAR => sub { # interpreted as SQL column
802 14     14   25 $self->_convert($self->_quote($v));
803             },
804              
805             UNDEF => sub {
806 0     0   0 puke "-$op => undef not supported";
807             },
808              
809             FALLBACK => sub {
810 10     10   19 $self->_recurse_where($v);
811             },
812 24         181 });
813              
814 24 100       145 $s = "(NOT $s)" if $op =~ /^not/i;
815 24         78 ($s, @b);
816             }
817              
818              
819             sub _where_op_IDENT {
820 8     8   13 my $self = shift;
821 8         22 my ($op, $rhs) = splice @_, -2;
822 8 100 66     42 if (! defined $rhs or length ref $rhs) {
823 2         9 puke "-$op requires a single plain scalar argument (a quotable identifier)";
824             }
825              
826             # in case we are called as a top level special op (no '=')
827 6         10 my $lhs = shift;
828              
829 6         17 $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
830              
831 6 100       28 return $lhs
832             ? "$lhs = $rhs"
833             : $rhs
834             ;
835             }
836              
837             sub _where_op_VALUE {
838 12     12   22 my $self = shift;
839 12         28 my ($op, $rhs) = splice @_, -2;
840              
841             # in case we are called as a top level special op (no '=')
842 12         22 my $lhs = shift;
843              
844             # special-case NULL
845 12 100       27 if (! defined $rhs) {
846 4 50       14 return defined $lhs
847             ? $self->_convert($self->_quote($lhs)) . ' IS NULL'
848             : undef
849             ;
850             }
851              
852             my @bind =
853             $self->_bindtype(
854 8 100       33 (defined $lhs ? $lhs : $self->{_nested_func_lhs}),
855             $rhs,
856             )
857             ;
858              
859 8 100       51 return $lhs
860             ? (
861             $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
862             @bind
863             )
864             : (
865             $self->_convert('?'),
866             @bind,
867             )
868             ;
869             }
870              
871             sub _where_hashpair_ARRAYREF {
872 46     46   95 my ($self, $k, $v) = @_;
873              
874 46 100       95 if (@$v) {
875 45         104 my @v = @$v; # need copy because of shift below
876 45         159 $self->_debug("ARRAY($k) means distribute over elements");
877              
878             # put apart first element if it is an operator (-and, -or)
879 45 100 66     266 my $op = (
880             (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix)
881             ? shift @v
882             : ''
883             );
884 45         417 my @distributed = map { {$k => $_} } @v;
  104         227  
885              
886 45 100       98 if ($op) {
887 22         61 $self->_debug("OP($op) reinjected into the distributed array");
888 22         45 unshift @distributed, $op;
889             }
890              
891 45 100       91 my $logic = $op ? substr($op, 1) : '';
892              
893 45         116 return $self->_recurse_where(\@distributed, $logic);
894             }
895             else {
896 1         5 $self->_debug("empty ARRAY($k) means 0=1");
897 1         3 return ($self->{sqlfalse});
898             }
899             }
900              
901             sub _where_hashpair_HASHREF {
902 583     583   1058 my ($self, $k, $v, $logic) = @_;
903 583   100     1789 $logic ||= 'and';
904              
905             local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs}
906             ? $self->{_nested_func_lhs}
907 583 100       1510 : $k
908             ;
909              
910 583         743 my ($all_sql, @all_bind);
911              
912 583         1430 for my $orig_op (sort keys %$v) {
913 590         870 my $val = $v->{$orig_op};
914              
915             # put the operator in canonical form
916 590         744 my $op = $orig_op;
917              
918             # FIXME - we need to phase out dash-less ops
919 590         1338 $op =~ s/^-//; # remove possible initial dash
920 590         1910 $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
921 590         1307 $op =~ s/\s+/ /g; # compress whitespace
922              
923 590         1309 $self->_assert_pass_injection_guard($op);
924              
925             # fixup is_not
926 588         942 $op =~ s/^is_not/IS NOT/i;
927              
928             # so that -not_foo works correctly
929 588         805 $op =~ s/^not_/NOT /i;
930              
931             # another retarded special case: foo => { $op => { -value => undef } }
932 588 100 100     1518 if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) {
      100        
      100        
933 28         42 $val = undef;
934             }
935              
936 588         735 my ($sql, @bind);
937              
938             # CASE: col-value logic modifiers
939 588 100       2297 if ($orig_op =~ /^ \- (and|or) $/xi) {
    100          
940 1         4 ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1);
941             }
942             # CASE: special operators like -in or -between
943 2617     2617   7289 elsif (my $special_op = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
  587         1696  
944 137         255 my $handler = $special_op->{handler};
945 137 50       326 if (! $handler) {
    100          
    50          
946 0         0 puke "No handler supplied for special operator $orig_op";
947             }
948             elsif (not ref $handler) {
949 134         404 ($sql, @bind) = $self->$handler($k, $op, $val);
950             }
951             elsif (ref $handler eq 'CODE') {
952 3         8 ($sql, @bind) = $handler->($self, $k, $op, $val);
953             }
954             else {
955 0         0 puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef";
956             }
957             }
958             else {
959             $self->_SWITCH_refkind($val, {
960              
961             ARRAYREF => sub { # CASE: col => {op => \@vals}
962 149     149   333 ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
963             },
964              
965             ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind)
966 10     10   22 my ($sub_sql, @sub_bind) = @$$val;
967 10         28 $self->_assert_bindval_matches_bindtype(@sub_bind);
968 8         18 $sql = join ' ', $self->_convert($self->_quote($k)),
969             $self->_sqlcase($op),
970             $sub_sql;
971 8         25 @bind = @sub_bind;
972             },
973              
974             UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
975             my $is =
976             $op =~ /^not$/i ? 'is not' # legacy
977             : $op =~ $self->{equality_op} ? 'is'
978             : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
979             : $op =~ $self->{inequality_op} ? 'is not'
980 77 50 50 77   797 : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
    100 50        
    100          
    100          
    100          
981             : puke "unexpected operator '$orig_op' with undef operand";
982              
983 77         58839 $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
984             },
985              
986             FALLBACK => sub { # CASE: col => {op/func => $stuff}
987 214     214   476 ($sql, @bind) = $self->_where_unary_op($op, $val);
988              
989             $sql = join(' ',
990             $self->_convert($self->_quote($k)),
991 212 50       421 $self->{_nested_func_lhs} eq $k ? $sql : "($sql)", # top level vs nested
992             );
993             },
994 450         4937 });
995             }
996              
997 561 100 66     44098 ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql;
998 561         1276 push @all_bind, @bind;
999             }
1000 554         1801 return ($all_sql, @all_bind);
1001             }
1002              
1003             sub _where_field_IS {
1004 40     40   84 my ($self, $k, $op, $v) = @_;
1005              
1006             my ($s) = $self->_SWITCH_refkind($v, {
1007             UNDEF => sub {
1008             join ' ',
1009             $self->_convert($self->_quote($k)),
1010 40     40   85 map { $self->_sqlcase($_)} ($op, 'null')
  80         128  
1011             },
1012             FALLBACK => sub {
1013 0     0   0 puke "$op can only take undef as argument";
1014             },
1015 40         229 });
1016              
1017 40         231 $s;
1018             }
1019              
1020             sub _where_field_op_ARRAYREF {
1021 149     149   354 my ($self, $k, $op, $vals) = @_;
1022              
1023 149         303 my @vals = @$vals; #always work on a copy
1024              
1025 149 100       350 if (@vals) {
1026             $self->_debug(sprintf '%s means multiple elements: [ %s ]',
1027             $vals,
1028 106 100       191 join(', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
  152         824  
1029             );
1030              
1031             # see if the first element is an -and/-or op
1032 106         148 my $logic;
1033 106 100 100     331 if (defined $vals[0] && $vals[0] =~ /^ - (AND|OR) $/ix) {
1034 2         7 $logic = uc $1;
1035 2         16 shift @vals;
1036             }
1037              
1038             # a long standing API wart - an attempt to change this behavior during
1039             # the 1.50 series failed *spectacularly*. Warn instead and leave the
1040             # behavior as is
1041 106 100 66     628 if (
      100        
      100        
      100        
1042             @vals > 1
1043             and
1044             (!$logic or $logic eq 'OR')
1045             and
1046             ($op =~ $self->{inequality_op} or $op =~ $self->{not_like_op})
1047             ) {
1048 36         75 my $o = uc($op);
1049 36         106 belch "A multi-element arrayref as an argument to the inequality op '$o' "
1050             . 'is technically equivalent to an always-true 1=1 (you probably wanted '
1051             . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
1052             ;
1053             }
1054              
1055             # distribute $op over each remaining member of @vals, append logic if exists
1056 106         35768 return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
  150         517  
1057              
1058             }
1059             else {
1060             # try to DWIM on equality operators
1061             return
1062             $op =~ $self->{equality_op} ? $self->{sqlfalse}
1063             : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse}
1064             : $op =~ $self->{inequality_op} ? $self->{sqltrue}
1065             : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue}
1066 43 100 33     487 : puke "operator '$op' applied on an empty array (field '$k')";
    100 33        
    100          
    50          
1067             }
1068             }
1069              
1070              
1071             sub _where_hashpair_SCALARREF {
1072 32     32   59 my ($self, $k, $v) = @_;
1073 32         119 $self->_debug("SCALAR($k) means literal SQL: $$v");
1074 32         65 my $sql = $self->_quote($k) . " " . $$v;
1075 32         85 return ($sql);
1076             }
1077              
1078             # literal SQL with bind
1079             sub _where_hashpair_ARRAYREFREF {
1080 27     27   67 my ($self, $k, $v) = @_;
1081 27         61 $self->_debug("REF($k) means literal SQL: @${$v}");
  27         120  
1082 27         74 my ($sql, @bind) = @$$v;
1083 27         79 $self->_assert_bindval_matches_bindtype(@bind);
1084 25         55 $sql = $self->_quote($k) . " " . $sql;
1085 25         74 return ($sql, @bind );
1086             }
1087              
1088             # literal SQL without bind
1089             sub _where_hashpair_SCALAR {
1090 440     440   661 my ($self, $k, $v) = @_;
1091 440         1451 $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
1092             my $sql = join ' ', $self->_convert($self->_quote($k)),
1093 440         782 $self->_sqlcase($self->{cmp}),
1094             $self->_convert('?');
1095 439         916 my @bind = $self->_bindtype($k, $v);
1096 439         1192 return ($sql, @bind);
1097             }
1098              
1099              
1100             sub _where_hashpair_UNDEF {
1101 16     16   36 my ($self, $k, $v) = @_;
1102 16         64 $self->_debug("UNDEF($k) means IS NULL");
1103 16         52 my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
1104 16         45 return ($sql);
1105             }
1106              
1107             #======================================================================
1108             # WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF)
1109             #======================================================================
1110              
1111              
1112             sub _where_SCALARREF {
1113 6     6   14 my ($self, $where) = @_;
1114              
1115             # literal sql
1116 6         20 $self->_debug("SCALAR(*top) means literal SQL: $$where");
1117 6         13 return ($$where);
1118             }
1119              
1120              
1121             sub _where_SCALAR {
1122 0     0   0 my ($self, $where) = @_;
1123              
1124             # literal sql
1125 0         0 $self->_debug("NOREF(*top) means literal SQL: $where");
1126 0         0 return ($where);
1127             }
1128              
1129              
1130             sub _where_UNDEF {
1131 46     46   72 my ($self) = @_;
1132 46         69 return ();
1133             }
1134              
1135              
1136             #======================================================================
1137             # WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
1138             #======================================================================
1139              
1140              
1141             sub _where_field_BETWEEN {
1142 45     45   94 my ($self, $k, $op, $vals) = @_;
1143              
1144 45         72 my ($label, $and, $placeholder);
1145 45         95 $label = $self->_convert($self->_quote($k));
1146 45         91 $and = ' ' . $self->_sqlcase('and') . ' ';
1147 45         79 $placeholder = $self->_convert('?');
1148 45         78 $op = $self->_sqlcase($op);
1149              
1150 45         85 my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
1151              
1152             my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
1153             ARRAYREFREF => sub {
1154 5     5   12 my ($s, @b) = @$$vals;
1155 5         17 $self->_assert_bindval_matches_bindtype(@b);
1156 5         12 ($s, @b);
1157             },
1158             SCALARREF => sub {
1159 3     3   7 return $$vals;
1160             },
1161             ARRAYREF => sub {
1162 35 100   35   83 puke $invalid_args if @$vals != 2;
1163              
1164 28         38 my (@all_sql, @all_bind);
1165 28         48 foreach my $val (@$vals) {
1166             my ($sql, @bind) = $self->_SWITCH_refkind($val, {
1167             SCALAR => sub {
1168 39         75 return ($placeholder, $self->_bindtype($k, $val) );
1169             },
1170             SCALARREF => sub {
1171 6         16 return $$val;
1172             },
1173             ARRAYREFREF => sub {
1174 4         8 my ($sql, @bind) = @$$val;
1175 4         11 $self->_assert_bindval_matches_bindtype(@bind);
1176 4         10 return ($sql, @bind);
1177             },
1178             HASHREF => sub {
1179 2         16 my ($func, $arg, @rest) = %$val;
1180 2 50 33     15 puke "Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN"
1181             if (@rest or $func !~ /^ \- (.+)/x);
1182 2         9 $self->_where_unary_op($1 => $arg);
1183             },
1184             FALLBACK => sub {
1185 3         5 puke $invalid_args,
1186             },
1187 54         411 });
1188 51         310 push @all_sql, $sql;
1189 51         99 push @all_bind, @bind;
1190             }
1191              
1192             return (
1193 25         100 (join $and, @all_sql),
1194             @all_bind
1195             );
1196             },
1197             FALLBACK => sub {
1198 2     2   6 puke $invalid_args,
1199             },
1200 45         394 });
1201              
1202 33         276 my $sql = "( $label $op $clause )";
1203 33         93 return ($sql, @bind)
1204             }
1205              
1206              
1207             sub _where_field_IN {
1208 37     37   105 my ($self, $k, $op, $vals) = @_;
1209              
1210             # backwards compatibility: if scalar, force into an arrayref
1211 37 100 100     149 $vals = [$vals] if defined $vals && ! ref $vals;
1212              
1213 37         96 my ($label) = $self->_convert($self->_quote($k));
1214 37         76 my ($placeholder) = $self->_convert('?');
1215 37         69 $op = $self->_sqlcase($op);
1216              
1217             my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
1218             ARRAYREF => sub { # list of choices
1219 25 100   25   100 if (@$vals) { # nonempty list
1220 22         57 my (@all_sql, @all_bind);
1221              
1222 22         44 for my $val (@$vals) {
1223             my ($sql, @bind) = $self->_SWITCH_refkind($val, {
1224             SCALAR => sub {
1225 57         147 return ($placeholder, $val);
1226             },
1227             SCALARREF => sub {
1228 1         3 return $$val;
1229             },
1230             ARRAYREFREF => sub {
1231 1         5 my ($sql, @bind) = @$$val;
1232 1         4 $self->_assert_bindval_matches_bindtype(@bind);
1233 1         3 return ($sql, @bind);
1234             },
1235             HASHREF => sub {
1236 1         4 my ($func, $arg, @rest) = %$val;
1237 1 50 33     9 puke "Only simple { -func => arg } functions accepted as sub-arguments to IN"
1238             if (@rest or $func !~ /^ \- (.+)/x);
1239 1         4 $self->_where_unary_op($1 => $arg);
1240             },
1241             UNDEF => sub {
1242 4         18 puke(
1243             'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
1244             . "-$op operator was given an undef-containing list: !!!AUDIT YOUR CODE "
1245             . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
1246             . 'will emit the logically correct SQL instead of raising this exception)'
1247             );
1248             },
1249 64         437 });
1250 60         335 push @all_sql, $sql;
1251 60         112 push @all_bind, @bind;
1252             }
1253              
1254             return (
1255 18         116 sprintf('%s %s ( %s )',
1256             $label,
1257             $op,
1258             join(', ', @all_sql)
1259             ),
1260             $self->_bindtype($k, @all_bind),
1261             );
1262             }
1263             else { # empty list: some databases won't understand "IN ()", so DWIM
1264 3 100       13 my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
1265 3         7 return ($sql);
1266             }
1267             },
1268              
1269             SCALARREF => sub { # literal SQL
1270 4     4   7 my $sql = $self->_open_outer_paren($$vals);
1271 4         14 return ("$label $op ( $sql )");
1272             },
1273             ARRAYREFREF => sub { # literal SQL with bind
1274 7     7   22 my ($sql, @bind) = @$$vals;
1275 7         22 $self->_assert_bindval_matches_bindtype(@bind);
1276 5         13 $sql = $self->_open_outer_paren($sql);
1277 5         25 return ("$label $op ( $sql )", @bind);
1278             },
1279              
1280             UNDEF => sub {
1281 1     1   3 puke "Argument passed to the '$op' operator can not be undefined";
1282             },
1283              
1284             FALLBACK => sub {
1285 0     0   0 puke "special op $op requires an arrayref (or scalarref/arrayref-ref)";
1286             },
1287 37         442 });
1288              
1289 30         378 return ($sql, @bind);
1290             }
1291              
1292             # Some databases (SQLite) treat col IN (1, 2) different from
1293             # col IN ( (1, 2) ). Use this to strip all outer parens while
1294             # adding them back in the corresponding method
1295             sub _open_outer_paren {
1296 9     9   20 my ($self, $sql) = @_;
1297              
1298 9         48 while (my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs) {
1299              
1300             # there are closing parens inside, need the heavy duty machinery
1301             # to reevaluate the extraction starting from $sql (full reevaluation)
1302 7 100       31 if ($inner =~ /\)/) {
1303 6         1674 require Text::Balanced;
1304              
1305 6         29253 my (undef, $remainder) = do {
1306             # idiotic design - writes to $@ but *DOES NOT* throw exceptions
1307 6         9 local $@;
1308 6         40 Text::Balanced::extract_bracketed($sql, '()', qr/\s*/);
1309             };
1310              
1311             # the entire expression needs to be a balanced bracketed thing
1312             # (after an extract no remainder sans trailing space)
1313 6 100 66     1080 last if defined $remainder and $remainder =~ /\S/;
1314             }
1315              
1316 6         32 $sql = $inner;
1317             }
1318              
1319 9         22 $sql;
1320             }
1321              
1322              
1323             #======================================================================
1324             # ORDER BY
1325             #======================================================================
1326              
1327             sub _order_by {
1328 52     52   1203 my ($self, $arg) = @_;
1329              
1330 52         64 my (@sql, @bind);
1331 52         95 for my $c ($self->_order_by_chunks($arg) ) {
1332             $self->_SWITCH_refkind($c, {
1333 38     38   141 SCALAR => sub { push @sql, $c },
1334 52     52   75 ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
  52         160  
1335 90         362 });
1336             }
1337              
1338 50 100       376 my $sql = @sql
1339             ? sprintf('%s %s',
1340             $self->_sqlcase(' order by'),
1341             join(', ', @sql)
1342             )
1343             : ''
1344             ;
1345              
1346 50 50       165 return wantarray ? ($sql, @bind) : $sql;
1347             }
1348              
1349             sub _order_by_chunks {
1350 177     177   273 my ($self, $arg) = @_;
1351              
1352             return $self->_SWITCH_refkind($arg, {
1353              
1354             ARRAYREF => sub {
1355 47     47   122 map { $self->_order_by_chunks($_ ) } @$arg;
  87         152  
1356             },
1357              
1358             ARRAYREFREF => sub {
1359 10     10   20 my ($s, @b) = @$$arg;
1360 10         24 $self->_assert_bindval_matches_bindtype(@b);
1361 10         28 [ $s, @b ];
1362             },
1363              
1364 76     76   130 SCALAR => sub {$self->_quote($arg)},
1365              
1366 0     0   0 UNDEF => sub {return () },
1367              
1368 4     4   21 SCALARREF => sub {$$arg}, # literal SQL, no quoting
1369              
1370             HASHREF => sub {
1371             # get first pair in hash
1372 40     40   100 my ($key, $val, @rest) = %$arg;
1373              
1374 40 50       70 return () unless $key;
1375              
1376 40 100 66     218 if (@rest or not $key =~ /^-(desc|asc)/i) {
1377 2         7 puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
1378             }
1379              
1380 38         84 my $direction = $1;
1381              
1382 38         57 my @ret;
1383 38         64 for my $c ($self->_order_by_chunks($val)) {
1384 50         72 my ($sql, @bind);
1385              
1386             $self->_SWITCH_refkind($c, {
1387             SCALAR => sub {
1388 42         64 $sql = $c;
1389             },
1390             ARRAYREF => sub {
1391 8         19 ($sql, @bind) = @$c;
1392             },
1393 50         235 });
1394              
1395 50         179 $sql = $sql . ' ' . $self->_sqlcase($direction);
1396              
1397 50         144 push @ret, [ $sql, @bind];
1398             }
1399              
1400 38         432 return @ret;
1401             },
1402 177         1693 });
1403             }
1404              
1405              
1406             #======================================================================
1407             # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
1408             #======================================================================
1409              
1410             sub _table {
1411 199     199   258 my $self = shift;
1412 199         295 my $from = shift;
1413             $self->_SWITCH_refkind($from, {
1414 4     4   9 ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
  10         16  
1415 195     195   367 SCALAR => sub {$self->_quote($from)},
1416 0     0   0 SCALARREF => sub {$$from},
1417 199         1327 });
1418             }
1419              
1420              
1421             #======================================================================
1422             # UTILITY FUNCTIONS
1423             #======================================================================
1424              
1425             # highly optimized, as it's called way too often
1426             sub _quote {
1427             # my ($self, $label) = @_;
1428              
1429 1462 100   1462   2525 return '' unless defined $_[1];
1430 1458 100       2310 return ${$_[1]} if ref($_[1]) eq 'SCALAR';
  2         7  
1431              
1432             $_[0]->{quote_char} or
1433 1456 100       3162 ($_[0]->_assert_pass_injection_guard($_[1]), return $_[1]);
1434              
1435 484         740 my $qref = ref $_[0]->{quote_char};
1436             my ($l, $r) =
1437             !$qref ? ($_[0]->{quote_char}, $_[0]->{quote_char})
1438 484 0       1095 : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
  0 50       0  
1439             : puke "Unsupported quote_char format: $_[0]->{quote_char}";
1440              
1441 484   66     1205 my $esc = $_[0]->{escape_char} || $r;
1442              
1443             # parts containing * are naturally unquoted
1444             return join($_[0]->{name_sep}||'', map
1445 487         1628 +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ),
  487         2216  
1446 484 50 100     2323 ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
    100          
1447             );
1448             }
1449              
1450              
1451             # Conversion, if applicable
1452             sub _convert {
1453             #my ($self, $arg) = @_;
1454 1553 100   1553   2706 if ($_[0]->{convert}) {
1455 38         79 return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
1456             }
1457 1515         3155 return $_[1];
1458             }
1459              
1460             # And bindtype
1461             sub _bindtype {
1462             #my ($self, $col, @vals) = @_;
1463             # called often - tighten code
1464             return $_[0]->{bindtype} eq 'columns'
1465 1043 100   1043   3805 ? map {[$_[1], $_]} @_[2 .. $#_]
  100         448  
1466             : @_[2 .. $#_]
1467             ;
1468             }
1469              
1470             # Dies if any element of @bind is not in [colname => value] format
1471             # if bindtype is 'columns'.
1472             sub _assert_bindval_matches_bindtype {
1473             # my ($self, @bind) = @_;
1474 95     95   135 my $self = shift;
1475 95 100       213 if ($self->{bindtype} eq 'columns') {
1476 30         49 for (@_) {
1477 31 100 66     147 if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
      66        
1478 10         21 puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
1479             }
1480             }
1481             }
1482             }
1483              
1484             sub _join_sql_clauses {
1485 1422     1422   2280 my ($self, $logic, $clauses_aref, $bind_aref) = @_;
1486              
1487 1422 100       2715 if (@$clauses_aref > 1) {
    50          
1488 358         609 my $join = " " . $self->_sqlcase($logic) . " ";
1489 358         854 my $sql = '( ' . join($join, @$clauses_aref) . ' )';
1490 358         1771 return ($sql, @$bind_aref);
1491             }
1492             elsif (@$clauses_aref) {
1493 1064         3321 return ($clauses_aref->[0], @$bind_aref); # no parentheses
1494             }
1495             else {
1496 0         0 return (); # if no SQL, ignore @$bind_aref
1497             }
1498             }
1499              
1500              
1501             # Fix SQL case, if so requested
1502             sub _sqlcase {
1503             # LDNOTE: if $self->{case} is true, then it contains 'lower', so we
1504             # don't touch the argument ... crooked logic, but let's not change it!
1505 2318 100   2318   6873 return $_[0]->{case} ? $_[1] : uc($_[1]);
1506             }
1507              
1508              
1509             #======================================================================
1510             # DISPATCHING FROM REFKIND
1511             #======================================================================
1512              
1513             sub _refkind {
1514 5392     5392   6560 my ($self, $data) = @_;
1515              
1516 5392 100       8727 return 'UNDEF' unless defined $data;
1517              
1518             # blessed objects are treated like scalars
1519 5140 100       10611 my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1520              
1521 5140 100       9079 return 'SCALAR' unless $ref;
1522              
1523 3166         3538 my $n_steps = 1;
1524 3166         5394 while ($ref eq 'REF') {
1525 108         150 $data = $$data;
1526 108 100       231 $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1527 108 100       247 $n_steps++ if $ref;
1528             }
1529              
1530 3166   100     8957 return ($ref||'SCALAR') . ('REF' x $n_steps);
1531             }
1532              
1533             sub _try_refkind {
1534 5379     5379   6948 my ($self, $data) = @_;
1535 5379         7439 my @try = ($self->_refkind($data));
1536 5379 100 100     14173 push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
1537 5379         6432 push @try, 'FALLBACK';
1538 5379         9663 return \@try;
1539             }
1540              
1541             sub _METHOD_FOR_refkind {
1542 2663     2663   4159 my ($self, $meth_prefix, $data) = @_;
1543              
1544 2663         2817 my $method;
1545 2663         2870 for (@{$self->_try_refkind($data)}) {
  2663         3704  
1546 2663 50       9245 $method = $self->can($meth_prefix."_".$_)
1547             and last;
1548             }
1549              
1550 2663   33     6702 return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
1551             }
1552              
1553              
1554             sub _SWITCH_refkind {
1555 2716     2716   4704 my ($self, $data, $dispatch_table) = @_;
1556              
1557 2716         2883 my $coderef;
1558 2716         2861 for (@{$self->_try_refkind($data)}) {
  2716         4027  
1559 3526 100       6801 $coderef = $dispatch_table->{$_}
1560             and last;
1561             }
1562              
1563 2716 50       4995 puke "no dispatch entry for ".$self->_refkind($data)
1564             unless $coderef;
1565              
1566 2716         3645 $coderef->();
1567             }
1568              
1569              
1570              
1571              
1572             #======================================================================
1573             # VALUES, GENERATE, AUTOLOAD
1574             #======================================================================
1575              
1576             # LDNOTE: original code from nwiger, didn't touch code in that section
1577             # I feel the AUTOLOAD stuff should not be the default, it should
1578             # only be activated on explicit demand by user.
1579              
1580             sub values {
1581 6     6 1 6914 my $self = shift;
1582 6   50     15 my $data = shift || return;
1583 6 50       16 puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
1584             unless ref $data eq 'HASH';
1585              
1586 6         9 my @all_bind;
1587 6         27 foreach my $k (sort keys %$data) {
1588 37         50 my $v = $data->{$k};
1589             $self->_SWITCH_refkind($v, {
1590             ARRAYREF => sub {
1591 1 50   1   3 if ($self->{array_datatypes}) { # array datatype
1592 0         0 push @all_bind, $self->_bindtype($k, $v);
1593             }
1594             else { # literal SQL with bind
1595 1         3 my ($sql, @bind) = @$v;
1596 1         4 $self->_assert_bindval_matches_bindtype(@bind);
1597 1         5 push @all_bind, @bind;
1598             }
1599             },
1600             ARRAYREFREF => sub { # literal SQL with bind
1601 1     1   2 my ($sql, @bind) = @${$v};
  1         3  
1602 1         2 $self->_assert_bindval_matches_bindtype(@bind);
1603 1         5 push @all_bind, @bind;
1604             },
1605       2     SCALARREF => sub { # literal SQL without bind
1606             },
1607             SCALAR_or_UNDEF => sub {
1608 33     33   51 push @all_bind, $self->_bindtype($k, $v);
1609             },
1610 37         211 });
1611             }
1612              
1613 6         33 return @all_bind;
1614             }
1615              
1616             sub generate {
1617 0     0 1 0 my $self = shift;
1618              
1619 0         0 my(@sql, @sqlq, @sqlv);
1620              
1621 0         0 for (@_) {
1622 0         0 my $ref = ref $_;
1623 0 0       0 if ($ref eq 'HASH') {
    0          
    0          
1624 0         0 for my $k (sort keys %$_) {
1625 0         0 my $v = $_->{$k};
1626 0         0 my $r = ref $v;
1627 0         0 my $label = $self->_quote($k);
1628 0 0       0 if ($r eq 'ARRAY') {
    0          
1629             # literal SQL with bind
1630 0         0 my ($sql, @bind) = @$v;
1631 0         0 $self->_assert_bindval_matches_bindtype(@bind);
1632 0         0 push @sqlq, "$label = $sql";
1633 0         0 push @sqlv, @bind;
1634             } elsif ($r eq 'SCALAR') {
1635             # literal SQL without bind
1636 0         0 push @sqlq, "$label = $$v";
1637             } else {
1638 0         0 push @sqlq, "$label = ?";
1639 0         0 push @sqlv, $self->_bindtype($k, $v);
1640             }
1641             }
1642 0         0 push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
1643             } elsif ($ref eq 'ARRAY') {
1644             # unlike insert(), assume these are ONLY the column names, i.e. for SQL
1645 0         0 for my $v (@$_) {
1646 0         0 my $r = ref $v;
1647 0 0       0 if ($r eq 'ARRAY') { # literal SQL with bind
    0          
1648 0         0 my ($sql, @bind) = @$v;
1649 0         0 $self->_assert_bindval_matches_bindtype(@bind);
1650 0         0 push @sqlq, $sql;
1651 0         0 push @sqlv, @bind;
1652             } elsif ($r eq 'SCALAR') { # literal SQL without bind
1653             # embedded literal SQL
1654 0         0 push @sqlq, $$v;
1655             } else {
1656 0         0 push @sqlq, '?';
1657 0         0 push @sqlv, $v;
1658             }
1659             }
1660 0         0 push @sql, '(' . join(', ', @sqlq) . ')';
1661             } elsif ($ref eq 'SCALAR') {
1662             # literal SQL
1663 0         0 push @sql, $$_;
1664             } else {
1665             # strings get case twiddled
1666 0         0 push @sql, $self->_sqlcase($_);
1667             }
1668             }
1669              
1670 0         0 my $sql = join ' ', @sql;
1671              
1672             # this is pretty tricky
1673             # if ask for an array, return ($stmt, @bind)
1674             # otherwise, s/?/shift @sqlv/ to put it inline
1675 0 0       0 if (wantarray) {
1676 0         0 return ($sql, @sqlv);
1677             } else {
1678 0         0 1 while $sql =~ s/\?/my $d = shift(@sqlv);
  0         0  
1679 0 0       0 ref $d ? $d->[1] : $d/e;
1680 0         0 return $sql;
1681             }
1682             }
1683              
1684              
1685 611     611   170433 sub DESTROY { 1 }
1686              
1687             sub AUTOLOAD {
1688             # This allows us to check for a local, then _form, attr
1689 0     0     my $self = shift;
1690 0           my($name) = $AUTOLOAD =~ /.*::(.+)/;
1691 0           return $self->generate($name, @_);
1692             }
1693              
1694             1;
1695              
1696              
1697              
1698             __END__