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   311923 use strict;
  14         73  
  14         383  
4 14     14   65 use warnings;
  14         27  
  14         313  
5 14     14   60 use Carp ();
  14         22  
  14         223  
6 14     14   71 use List::Util ();
  14         22  
  14         196  
7 14     14   60 use Scalar::Util ();
  14         21  
  14         251  
8              
9 14     14   59 use Exporter 'import';
  14         21  
  14         1508  
10             our @EXPORT_OK = qw(is_plain_value is_literal_value);
11              
12             BEGIN {
13 14 50   14   73 if ($] < 5.009_005) {
14 0         0 require MRO::Compat;
15             }
16             else {
17 14         64 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       6494 ;
24             }
25              
26             #======================================================================
27             # GLOBALS
28             #======================================================================
29              
30             our $VERSION = '1.86';
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   2205 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 466 my($func) = (caller(1))[3];
70 148         7259 Carp::carp "[$func] Warning: ", @_;
71             }
72              
73             sub puke (@) {
74 116     116 0 341 my($func) = (caller(1))[3];
75 116         4862 Carp::croak "[$func] Fatal: ", @_;
76             }
77              
78             sub is_literal_value ($) {
79 13         42 ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
80 50 100 66 50 1 1490 : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
  9 100       27  
81             : undef;
82             }
83              
84             # FIXME XSify - this can be done so much more efficiently
85             sub is_plain_value ($) {
86 14     14   90 no strict 'refs';
  14         43  
  14         118342  
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 19013 !! ${"$_[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 8534 my $self = shift;
143 611   33     1934 my $class = ref($self) || $self;
144 611 100       1882 my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
  101         282  
145              
146             # choose our case by keeping an option around
147 611 100 100     1428 delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
148              
149             # default logic for interpreting arrayrefs
150 611 100       1261 $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
151              
152             # how to return bind vars
153 611   100     1964 $opt{bindtype} ||= 'normal';
154              
155             # default comparison is "=", but can be overridden
156 611   100     1786 $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         3265 $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix;
161 611         1414 $opt{inequality_op} = qr/^( != | <> )$/ix;
162              
163 611         1268 $opt{like_op} = qr/^ (is\s+)? r?like $/xi;
164 611         1065 $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi;
165              
166             # SQL booleans
167 611   50     2142 $opt{sqltrue} ||= '1=1';
168 611   50     1876 $opt{sqlfalse} ||= '0=1';
169              
170             # special operators
171 611   100     1971 $opt{special_ops} ||= [];
172             # regexes are applied in order, thus push after user-defines
173 611         721 push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
  611         1507  
174              
175             # unary operators
176 611   50     1929 $opt{unary_ops} ||= [];
177 611         693 push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
  611         1222  
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     2364 $opt{injection_guard} ||= qr/
188             \;
189             |
190             ^ \s* go \s
191             /xmi;
192              
193 611         1611 return bless \%opt, $class;
194             }
195              
196              
197             sub _assert_pass_injection_guard {
198 1802 100   1802   10043 if ($_[1] =~ $_[0]->{injection_guard}) {
199 5         8 my $class = ref $_[0];
200 5         18 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 3582 my $self = shift;
213 49         111 my $table = $self->_table(shift);
214 49   50     288 my $data = shift || return;
215 49         64 my $options = shift;
216              
217 49         106 my $method = $self->_METHOD_FOR_refkind("_insert", $data);
218 49         119 my ($sql, @bind) = $self->$method($data);
219 47         88 $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
220              
221 47 100       110 if ($options->{returning}) {
222 10         20 my ($s, @b) = $self->_insert_returning($options);
223 10         19 $sql .= $s;
224 10         15 push @bind, @b;
225             }
226              
227 47 50       286 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         30 my $f = $options->{returning};
238              
239             my $fieldlist = $self->_SWITCH_refkind($f, {
240 6     6   9 ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
  14         23  
241 8     8   16 SCALAR => sub {$self->_quote($f)},
242 8     8   19 SCALARREF => sub {$$f},
243 22         127 });
244 22         103 return $self->_sqlcase(' returning ') . $fieldlist;
245             }
246              
247             sub _insert_HASHREF { # explicit list of fields and then values
248 28     28   60 my ($self, $data) = @_;
249              
250 28         121 my @fields = sort keys %$data;
251              
252 28         78 my ($sql, @bind) = $self->_insert_values($data);
253              
254             # assemble SQL
255 26         65 $_ = $self->_quote($_) foreach @fields;
256 26         109 $sql = "( ".join(", ", @fields).") ".$sql;
257              
258 26         100 return ($sql, @bind);
259             }
260              
261             sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
262 21     21   35 my ($self, $data) = @_;
263              
264             # no names (arrayref) so can't generate bindtype
265 21 50       50 $self->{bindtype} ne 'columns'
266             or belch "can't do 'columns' bindtype when called with arrayref";
267              
268 21         35 my (@values, @all_bind);
269 21         36 foreach my $value (@$data) {
270 156         249 my ($values, @bind) = $self->_insert_value(undef, $value);
271 156         223 push @values, $values;
272 156         233 push @all_bind, @bind;
273             }
274 21         37 my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
275 21         82 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   46 my ($self, $data) = @_;
296              
297 28         35 my (@values, @all_bind);
298 28         71 foreach my $column (sort keys %$data) {
299 95         177 my ($values, @bind) = $self->_insert_value($column, $data->{$column});
300 93         140 push @values, $values;
301 93         137 push @all_bind, @bind;
302             }
303 26         73 my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
304 26         77 return ($sql, @all_bind);
305             }
306              
307             sub _insert_value {
308 251     251   349 my ($self, $column, $v) = @_;
309              
310 251         272 my (@values, @all_bind);
311             $self->_SWITCH_refkind($v, {
312              
313             ARRAYREF => sub {
314 5 100   5   9 if ($self->{array_datatypes}) { # if array datatype are activated
315 4         7 push @values, '?';
316 4         7 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         2 push @values, $sql;
322 1         2 push @all_bind, @bind;
323             }
324             },
325              
326             ARRAYREFREF => sub { # literal SQL with bind
327 11     11   17 my ($sql, @bind) = @${$v};
  11         27  
328 11         29 $self->_assert_bindval_matches_bindtype(@bind);
329 9         13 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   6 belch "HASH ref as bind value in insert is not supported";
337 2         1808 push @values, '?';
338 2         7 push @all_bind, $self->_bindtype($column, $v);
339             },
340              
341             SCALARREF => sub { # literal SQL without bind
342 6     6   14 push @values, $$v;
343             },
344              
345             SCALAR_or_UNDEF => sub {
346 227     227   293 push @values, '?';
347 227         345 push @all_bind, $self->_bindtype($column, $v);
348             },
349              
350 251         1752 });
351              
352 249         1387 my $sql = join(", ", @values);
353 249         608 return ($sql, @all_bind);
354             }
355              
356              
357              
358             #======================================================================
359             # UPDATE methods
360             #======================================================================
361              
362              
363             sub update {
364 38     38 1 1662 my $self = shift;
365 38         100 my $table = $self->_table(shift);
366 38   50     251 my $data = shift || return;
367 38         49 my $where = shift;
368 38         53 my $options = shift;
369              
370             # first build the 'SET' part of the sql statement
371 38 50       91 puke "Unsupported data type specified to \$sql->update"
372             unless ref $data eq 'HASH';
373              
374 38         101 my ($sql, @all_bind) = $self->_update_set_values($data);
375 36         85 $sql = $self->_sqlcase('update ') . $table . $self->_sqlcase(' set ')
376             . $sql;
377              
378 36 100       90 if ($where) {
379 30         69 my($where_sql, @where_bind) = $self->where($where);
380 30         73 $sql .= $where_sql;
381 30         58 push @all_bind, @where_bind;
382             }
383              
384 36 100       101 if ($options->{returning}) {
385 6         12 my ($returning_sql, @returning_bind) = $self->_update_returning($options);
386 6         11 $sql .= $returning_sql;
387 6         11 push @all_bind, @returning_bind;
388             }
389              
390 36 50       228 return wantarray ? ($sql, @all_bind) : $sql;
391             }
392              
393             sub _update_set_values {
394 38     38   59 my ($self, $data) = @_;
395              
396 38         59 my (@set, @all_bind);
397 38         158 for my $k (sort keys %$data) {
398 78         130 my $v = $data->{$k};
399 78         147 my $r = ref $v;
400 78         123 my $label = $self->_quote($k);
401              
402             $self->_SWITCH_refkind($v, {
403             ARRAYREF => sub {
404 4 50   4   12 if ($self->{array_datatypes}) { # array datatype
405 4         11 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   15 my ($sql, @bind) = @${$v};
  10         26  
417 10         26 $self->_assert_bindval_matches_bindtype(@bind);
418 8         17 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   21 my ($op, $arg, @rest) = %$v;
426              
427 4 50 33     28 puke 'Operator calls in update must be in the form { -op => $arg }'
428             if (@rest or not $op =~ /^\-(.+)/);
429              
430 4         11 local $self->{_nested_func_lhs} = $k;
431 4         14 my ($sql, @bind) = $self->_where_unary_op($1, $arg);
432              
433 4         18 push @set, "$label = $sql";
434 4         62 push @all_bind, @bind;
435             },
436             SCALAR_or_UNDEF => sub {
437 60     60   113 push @set, "$label = ?";
438 60         126 push @all_bind, $self->_bindtype($k, $v);
439             },
440 78         819 });
441             }
442              
443             # generate sql
444 36         90 my $sql = join ', ', @set;
445              
446 36         105 return ($sql, @all_bind);
447             }
448              
449             # So that subclasses can override UPDATE ... RETURNING separately from
450             # INSERT and DELETE
451 6     6   15 sub _update_returning { shift->_returning(@_) }
452              
453              
454              
455             #======================================================================
456             # SELECT
457             #======================================================================
458              
459              
460             sub select {
461 102     102 1 12428 my $self = shift;
462 102         225 my $table = $self->_table(shift);
463 102   50     638 my $fields = shift || '*';
464 102         157 my $where = shift;
465 102         121 my $order = shift;
466              
467 102         213 my ($fields_sql, @bind) = $self->_select_fields($fields);
468              
469 102         218 my ($where_sql, @where_bind) = $self->where($where, $order);
470 89         148 push @bind, @where_bind;
471              
472 89         155 my $sql = join(' ', $self->_sqlcase('select'), $fields_sql,
473             $self->_sqlcase('from'), $table)
474             . $where_sql;
475              
476 89 100       527 return wantarray ? ($sql, @bind) : $sql;
477             }
478              
479             sub _select_fields {
480 102     102   188 my ($self, $fields) = @_;
481 102 100       258 return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields
  22         39  
482             : $fields;
483             }
484              
485             #======================================================================
486             # DELETE
487             #======================================================================
488              
489              
490             sub delete {
491 10     10 1 431 my $self = shift;
492 10         25 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         21 my $sql = $self->_sqlcase('delete from ') . $table . $where_sql;
498              
499 10 100       24 if ($options->{returning}) {
500 6         13 my ($returning_sql, @returning_bind) = $self->_delete_returning($options);
501 6         11 $sql .= $returning_sql;
502 6         11 push @bind, @returning_bind;
503             }
504              
505 10 50       55 return wantarray ? ($sql, @bind) : $sql;
506             }
507              
508             # So that subclasses can override DELETE ... RETURNING separately from
509             # INSERT and UPDATE
510 6     6   12 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 21920 my ($self, $where, $order) = @_;
523              
524             # where ?
525 619         1165 my ($sql, @bind) = $self->_recurse_where($where);
526 509 100 66     1894 $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : '';
527              
528             # order by?
529 509 100       968 if ($order) {
530 50         105 my ($order_sql, @order_bind) = $self->_order_by($order);
531 50         95 $sql .= $order_sql;
532 50         79 push @bind, @order_bind;
533             }
534              
535 509 50       2300 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         2445 my $method = $self->_METHOD_FOR_refkind("_where", $where);
544              
545 1471         2792 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       2755 if (wantarray) {
550 1347         4106 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   703 my ($self, $where, $logic) = @_;
567              
568 395   66     1137 $logic = uc($logic || $self->{logic});
569 395 50 66     1189 $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
570              
571 395         728 my @clauses = @$where;
572              
573 395         547 my (@sql_clauses, @all_bind);
574             # need to use while() so can shift() for pairs
575 395         701 while (@clauses) {
576 688         965 my $el = shift @clauses;
577              
578 688 100 100     2065 $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   56 ARRAYREF => sub {$self->_recurse_where($el) if @$el},
585              
586             ARRAYREFREF => sub {
587 1     1   2 my ($s, @b) = @$$el;
588 1         4 $self->_assert_bindval_matches_bindtype(@b);
589 1         3 ($s, @b);
590             },
591              
592 273 100   273   788 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   829 $self->_recurse_where({$el => shift(@clauses)})
599             },
600              
601 52     52   99 UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" },
602 688         5948 });
603              
604 624 100       3956 if ($sql) {
605 623         923 push @sql_clauses, $sql;
606 623         1420 push @all_bind, @bind;
607             }
608             }
609              
610 331         704 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   13 my ($self, $where) = @_;
619 6         14 my ($sql, @bind) = @$$where;
620 6         17 $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   1736 my ($self, $where) = @_;
630 1164         1384 my (@sql_clauses, @all_bind);
631              
632 1164         3416 for my $k (sort keys %$where) {
633 1392         2073 my $v = $where->{$k};
634              
635             # ($k => $v) is either a special unary op or a regular hashpair
636 1392         1492 my ($sql, @bind) = do {
637 1392 100       2756 if ($k =~ /^-./) {
638             # put the operator in canonical form
639 225         325 my $op = $k;
640 225         429 $op = substr $op, 1; # remove initial dash
641 225         639 $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
642 225         359 $op =~ s/\s+/ /g; # compress whitespace
643              
644             # so that -not_foo works correctly
645 225         297 $op =~ s/^not_/NOT /i;
646              
647 225         675 $self->_debug("Unary OP(-$op) within hashref, recursing...");
648 225         496 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   1902 List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}
  201         528  
654             or
655 201 50 66     678 ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k )
      66        
656             );
657 201         727 ($s, @b);
658             }
659             else {
660 1167 100       1882 if (! length $k) {
661 44 100       83 if (is_literal_value ($v) ) {
662 20         39 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         37 puke "Supplying an empty left hand side argument is not supported in hash-pairs";
666             }
667             }
668              
669 1143         15624 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
670 1143         2105 $self->$method($k, $v);
671             }
672             };
673              
674 1312         2209 push @sql_clauses, $sql;
675 1312         2419 push @all_bind, @bind;
676             }
677              
678 1084         2464 return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
679             }
680              
681             sub _where_unary_op {
682 446     446   827 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   1366 if ! defined $self->{_nested_func_lhs} and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
  1028         2865  
  207         583  
688              
689 444 100   1873   1325 if (my $op_entry = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
  1873         4925  
  444         1089  
690 204         358 my $handler = $op_entry->{handler};
691              
692 204 50       359 if (not ref $handler) {
    0          
693 204 100       700 if ($op =~ s/ [_\s]? \d+ $//x ) {
694 9         30 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         2775 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         550 $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   382 unless defined $self->{_nested_func_lhs};
715              
716             return (
717             $self->_convert('?'),
718 207         395 $self->_bindtype($self->{_nested_func_lhs}, $rhs)
719             );
720             },
721             FALLBACK => sub {
722 31     31   75 $self->_recurse_where($rhs)
723             },
724 238         1357 });
725              
726 236         1462 $sql = sprintf('%s %s',
727             $self->_sqlcase($op),
728             $sql,
729             );
730              
731 236         667 return ($sql, @bind);
732             }
733              
734             sub _where_op_ANDOR {
735 146     146   271 my ($self, $op, $v) = @_;
736              
737             $self->_SWITCH_refkind($v, {
738             ARRAYREF => sub {
739 76     76   142 return $self->_where_ARRAYREF($v, $op);
740             },
741              
742             HASHREF => sub {
743             return ($op =~ /^or/i)
744 70 100   70   331 ? $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         1442 });
772             }
773              
774             sub _where_op_NEST {
775 26     26   55 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   48 $self->_recurse_where($v);
791             },
792              
793 26         188 });
794             }
795              
796              
797             sub _where_op_BOOL {
798 24     24   45 my ($self, $op, $v) = @_;
799              
800             my ($s, @b) = $self->_SWITCH_refkind($v, {
801             SCALAR => sub { # interpreted as SQL column
802 14     14   28 $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   21 $self->_recurse_where($v);
811             },
812 24         169 });
813              
814 24 100       167 $s = "(NOT $s)" if $op =~ /^not/i;
815 24         80 ($s, @b);
816             }
817              
818              
819             sub _where_op_IDENT {
820 8     8   10 my $self = shift;
821 8         18 my ($op, $rhs) = splice @_, -2;
822 8 100 66     43 if (! defined $rhs or length ref $rhs) {
823 2         8 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         9 my $lhs = shift;
828              
829 6         15 $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
830              
831 6 100       23 return $lhs
832             ? "$lhs = $rhs"
833             : $rhs
834             ;
835             }
836              
837             sub _where_op_VALUE {
838 12     12   17 my $self = shift;
839 12         27 my ($op, $rhs) = splice @_, -2;
840              
841             # in case we are called as a top level special op (no '=')
842 12         15 my $lhs = shift;
843              
844             # special-case NULL
845 12 100       33 if (! defined $rhs) {
846 4 50       11 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       30 (defined $lhs ? $lhs : $self->{_nested_func_lhs}),
855             $rhs,
856             )
857             ;
858              
859 8 100       25 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   94 my ($self, $k, $v) = @_;
873              
874 46 100       97 if (@$v) {
875 45         88 my @v = @$v; # need copy because of shift below
876 45         138 $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     272 my $op = (
880             (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix)
881             ? shift @v
882             : ''
883             );
884 45         89 my @distributed = map { {$k => $_} } @v;
  104         228  
885              
886 45 100       109 if ($op) {
887 22         62 $self->_debug("OP($op) reinjected into the distributed array");
888 22         43 unshift @distributed, $op;
889             }
890              
891 45 100       111 my $logic = $op ? substr($op, 1) : '';
892              
893 45         126 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   1152 my ($self, $k, $v, $logic) = @_;
903 583   100     1898 $logic ||= 'and';
904              
905             local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs}
906             ? $self->{_nested_func_lhs}
907 583 100       1537 : $k
908             ;
909              
910 583         831 my ($all_sql, @all_bind);
911              
912 583         1385 for my $orig_op (sort keys %$v) {
913 590         858 my $val = $v->{$orig_op};
914              
915             # put the operator in canonical form
916 590         800 my $op = $orig_op;
917              
918             # FIXME - we need to phase out dash-less ops
919 590         1366 $op =~ s/^-//; # remove possible initial dash
920 590         1846 $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
921 590         1264 $op =~ s/\s+/ /g; # compress whitespace
922              
923 590         1329 $self->_assert_pass_injection_guard($op);
924              
925             # fixup is_not
926 588         1029 $op =~ s/^is_not/IS NOT/i;
927              
928             # so that -not_foo works correctly
929 588         800 $op =~ s/^not_/NOT /i;
930              
931             # another retarded special case: foo => { $op => { -value => undef } }
932 588 100 100     1478 if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) {
      100        
      100        
933 28         45 $val = undef;
934             }
935              
936 588         747 my ($sql, @bind);
937              
938             # CASE: col-value logic modifiers
939 588 100       2194 if ($orig_op =~ /^ \- (and|or) $/xi) {
    100          
940 1         5 ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1);
941             }
942             # CASE: special operators like -in or -between
943 2617     2617   7473 elsif (my $special_op = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
  587         1736  
944 137         276 my $handler = $special_op->{handler};
945 137 50       322 if (! $handler) {
    100          
    50          
946 0         0 puke "No handler supplied for special operator $orig_op";
947             }
948             elsif (not ref $handler) {
949 134         385 ($sql, @bind) = $self->$handler($k, $op, $val);
950             }
951             elsif (ref $handler eq 'CODE') {
952 3         20 ($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   321 ($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   23 my ($sub_sql, @sub_bind) = @$$val;
967 10         25 $self->_assert_bindval_matches_bindtype(@sub_bind);
968 8         20 $sql = join ' ', $self->_convert($self->_quote($k)),
969             $self->_sqlcase($op),
970             $sub_sql;
971 8         23 @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   755 : $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         57516 $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
984             },
985              
986             FALLBACK => sub { # CASE: col => {op/func => $stuff}
987 214     214   521 ($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         4362 });
995             }
996              
997 561 100 66     43786 ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql;
998 561         1317 push @all_bind, @bind;
999             }
1000 554         1742 return ($all_sql, @all_bind);
1001             }
1002              
1003             sub _where_field_IS {
1004 40     40   83 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         122  
1011             },
1012             FALLBACK => sub {
1013 0     0   0 puke "$op can only take undef as argument";
1014             },
1015 40         218 });
1016              
1017 40         220 $s;
1018             }
1019              
1020             sub _where_field_op_ARRAYREF {
1021 149     149   333 my ($self, $k, $op, $vals) = @_;
1022              
1023 149         290 my @vals = @$vals; #always work on a copy
1024              
1025 149 100       385 if (@vals) {
1026             $self->_debug(sprintf '%s means multiple elements: [ %s ]',
1027             $vals,
1028 106 100       204 join(', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
  152         826  
1029             );
1030              
1031             # see if the first element is an -and/-or op
1032 106         146 my $logic;
1033 106 100 100     349 if (defined $vals[0] && $vals[0] =~ /^ - (AND|OR) $/ix) {
1034 2         9 $logic = uc $1;
1035 2         4 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     592 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         83 my $o = uc($op);
1049 36         127 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         35477 return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
  150         610  
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     488 : 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   77 my ($self, $k, $v) = @_;
1073 32         133 $self->_debug("SCALAR($k) means literal SQL: $$v");
1074 32         83 my $sql = $self->_quote($k) . " " . $$v;
1075 32         88 return ($sql);
1076             }
1077              
1078             # literal SQL with bind
1079             sub _where_hashpair_ARRAYREFREF {
1080 27     27   57 my ($self, $k, $v) = @_;
1081 27         71 $self->_debug("REF($k) means literal SQL: @${$v}");
  27         112  
1082 27         68 my ($sql, @bind) = @$$v;
1083 27         79 $self->_assert_bindval_matches_bindtype(@bind);
1084 25         56 $sql = $self->_quote($k) . " " . $sql;
1085 25         81 return ($sql, @bind );
1086             }
1087              
1088             # literal SQL without bind
1089             sub _where_hashpair_SCALAR {
1090 440     440   689 my ($self, $k, $v) = @_;
1091 440         1419 $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
1092             my $sql = join ' ', $self->_convert($self->_quote($k)),
1093 440         848 $self->_sqlcase($self->{cmp}),
1094             $self->_convert('?');
1095 439         974 my @bind = $self->_bindtype($k, $v);
1096 439         1183 return ($sql, @bind);
1097             }
1098              
1099              
1100             sub _where_hashpair_UNDEF {
1101 16     16   38 my ($self, $k, $v) = @_;
1102 16         48 $self->_debug("UNDEF($k) means IS NULL");
1103 16         53 my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
1104 16         46 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         23 $self->_debug("SCALAR(*top) means literal SQL: $$where");
1117 6         15 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   67 my ($self) = @_;
1132 46         71 return ();
1133             }
1134              
1135              
1136             #======================================================================
1137             # WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
1138             #======================================================================
1139              
1140              
1141             sub _where_field_BETWEEN {
1142 45     45   104 my ($self, $k, $op, $vals) = @_;
1143              
1144 45         67 my ($label, $and, $placeholder);
1145 45         97 $label = $self->_convert($self->_quote($k));
1146 45         95 $and = ' ' . $self->_sqlcase('and') . ' ';
1147 45         123 $placeholder = $self->_convert('?');
1148 45         77 $op = $self->_sqlcase($op);
1149              
1150 45         96 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   11 my ($s, @b) = @$$vals;
1155 5         12 $self->_assert_bindval_matches_bindtype(@b);
1156 5         13 ($s, @b);
1157             },
1158             SCALARREF => sub {
1159 3     3   30 return $$vals;
1160             },
1161             ARRAYREF => sub {
1162 35 100   35   141 puke $invalid_args if @$vals != 2;
1163              
1164 28         48 my (@all_sql, @all_bind);
1165 28         53 foreach my $val (@$vals) {
1166             my ($sql, @bind) = $self->_SWITCH_refkind($val, {
1167             SCALAR => sub {
1168 39         77 return ($placeholder, $self->_bindtype($k, $val) );
1169             },
1170             SCALARREF => sub {
1171 6         21 return $$val;
1172             },
1173             ARRAYREFREF => sub {
1174 4         11 my ($sql, @bind) = @$$val;
1175 4         12 $self->_assert_bindval_matches_bindtype(@bind);
1176 4         11 return ($sql, @bind);
1177             },
1178             HASHREF => sub {
1179 2         6 my ($func, $arg, @rest) = %$val;
1180 2 50 33     14 puke "Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN"
1181             if (@rest or $func !~ /^ \- (.+)/x);
1182 2         8 $self->_where_unary_op($1 => $arg);
1183             },
1184             FALLBACK => sub {
1185 3         7 puke $invalid_args,
1186             },
1187 54         438 });
1188 51         311 push @all_sql, $sql;
1189 51         104 push @all_bind, @bind;
1190             }
1191              
1192             return (
1193 25         95 (join $and, @all_sql),
1194             @all_bind
1195             );
1196             },
1197             FALLBACK => sub {
1198 2     2   3 puke $invalid_args,
1199             },
1200 45         440 });
1201              
1202 33         294 my $sql = "( $label $op $clause )";
1203 33         96 return ($sql, @bind)
1204             }
1205              
1206              
1207             sub _where_field_IN {
1208 37     37   135 my ($self, $k, $op, $vals) = @_;
1209              
1210             # backwards compatibility: if scalar, force into an arrayref
1211 37 100 100     197 $vals = [$vals] if defined $vals && ! ref $vals;
1212              
1213 37         101 my ($label) = $self->_convert($self->_quote($k));
1214 37         80 my ($placeholder) = $self->_convert('?');
1215 37         72 $op = $self->_sqlcase($op);
1216              
1217             my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
1218             ARRAYREF => sub { # list of choices
1219 25 100   25   74 if (@$vals) { # nonempty list
1220 22         91 my (@all_sql, @all_bind);
1221              
1222 22         69 for my $val (@$vals) {
1223             my ($sql, @bind) = $self->_SWITCH_refkind($val, {
1224             SCALAR => sub {
1225 57         120 return ($placeholder, $val);
1226             },
1227             SCALARREF => sub {
1228 1         4 return $$val;
1229             },
1230             ARRAYREFREF => sub {
1231 1         3 my ($sql, @bind) = @$$val;
1232 1         5 $self->_assert_bindval_matches_bindtype(@bind);
1233 1         2 return ($sql, @bind);
1234             },
1235             HASHREF => sub {
1236 1         3 my ($func, $arg, @rest) = %$val;
1237 1 50 33     7 puke "Only simple { -func => arg } functions accepted as sub-arguments to IN"
1238             if (@rest or $func !~ /^ \- (.+)/x);
1239 1         6 $self->_where_unary_op($1 => $arg);
1240             },
1241             UNDEF => sub {
1242 4         19 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         424 });
1250 60         345 push @all_sql, $sql;
1251 60         106 push @all_bind, @bind;
1252             }
1253              
1254             return (
1255 18         118 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       10 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   8 my $sql = $self->_open_outer_paren($$vals);
1271 4         18 return ("$label $op ( $sql )");
1272             },
1273             ARRAYREFREF => sub { # literal SQL with bind
1274 7     7   29 my ($sql, @bind) = @$$vals;
1275 7         23 $self->_assert_bindval_matches_bindtype(@bind);
1276 5         14 $sql = $self->_open_outer_paren($sql);
1277 5         24 return ("$label $op ( $sql )", @bind);
1278             },
1279              
1280             UNDEF => sub {
1281 1     1   4 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         471 });
1288              
1289 30         391 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   19 my ($self, $sql) = @_;
1297              
1298 9         49 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       20 if ($inner =~ /\)/) {
1303 6         1754 require Text::Balanced;
1304              
1305 6         28756 my (undef, $remainder) = do {
1306             # idiotic design - writes to $@ but *DOES NOT* throw exceptions
1307 6         8 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     1065 last if defined $remainder and $remainder =~ /\S/;
1314             }
1315              
1316 6         30 $sql = $inner;
1317             }
1318              
1319 9         21 $sql;
1320             }
1321              
1322              
1323             #======================================================================
1324             # ORDER BY
1325             #======================================================================
1326              
1327             sub _order_by {
1328 52     52   1137 my ($self, $arg) = @_;
1329              
1330 52         70 my (@sql, @bind);
1331 52         97 for my $c ($self->_order_by_chunks($arg) ) {
1332             $self->_SWITCH_refkind($c, {
1333 38     38   152 SCALAR => sub { push @sql, $c },
1334 52     52   77 ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
  52         157  
1335 90         382 });
1336             }
1337              
1338 50 100       389 my $sql = @sql
1339             ? sprintf('%s %s',
1340             $self->_sqlcase(' order by'),
1341             join(', ', @sql)
1342             )
1343             : ''
1344             ;
1345              
1346 50 50       166 return wantarray ? ($sql, @bind) : $sql;
1347             }
1348              
1349             sub _order_by_chunks {
1350 177     177   239 my ($self, $arg) = @_;
1351              
1352             return $self->_SWITCH_refkind($arg, {
1353              
1354             ARRAYREF => sub {
1355 47     47   109 map { $self->_order_by_chunks($_ ) } @$arg;
  87         159  
1356             },
1357              
1358             ARRAYREFREF => sub {
1359 10     10   22 my ($s, @b) = @$$arg;
1360 10         21 $self->_assert_bindval_matches_bindtype(@b);
1361 10         26 [ $s, @b ];
1362             },
1363              
1364 76     76   127 SCALAR => sub {$self->_quote($arg)},
1365              
1366 0     0   0 UNDEF => sub {return () },
1367              
1368 4     4   11 SCALARREF => sub {$$arg}, # literal SQL, no quoting
1369              
1370             HASHREF => sub {
1371             # get first pair in hash
1372 40     40   101 my ($key, $val, @rest) = %$arg;
1373              
1374 40 50       66 return () unless $key;
1375              
1376 40 100 66     205 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         93 my $direction = $1;
1381              
1382 38         43 my @ret;
1383 38         57 for my $c ($self->_order_by_chunks($val)) {
1384 50         65 my ($sql, @bind);
1385              
1386             $self->_SWITCH_refkind($c, {
1387             SCALAR => sub {
1388 42         57 $sql = $c;
1389             },
1390             ARRAYREF => sub {
1391 8         19 ($sql, @bind) = @$c;
1392             },
1393 50         231 });
1394              
1395 50         184 $sql = $sql . ' ' . $self->_sqlcase($direction);
1396              
1397 50         112 push @ret, [ $sql, @bind];
1398             }
1399              
1400 38         429 return @ret;
1401             },
1402 177         1633 });
1403             }
1404              
1405              
1406             #======================================================================
1407             # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
1408             #======================================================================
1409              
1410             sub _table {
1411 199     199   240 my $self = shift;
1412 199         282 my $from = shift;
1413             $self->_SWITCH_refkind($from, {
1414 4     4   7 ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
  10         16  
1415 195     195   369 SCALAR => sub {$self->_quote($from)},
1416 0     0   0 SCALARREF => sub {$$from},
1417 199         1266 });
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   2502 return '' unless defined $_[1];
1430 1458 100       2276 return ${$_[1]} if ref($_[1]) eq 'SCALAR';
  2         5  
1431              
1432             $_[0]->{quote_char} or
1433 1456 100       3103 ($_[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       1111 : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
  0 50       0  
1439             : puke "Unsupported quote_char format: $_[0]->{quote_char}";
1440              
1441 484   66     1350 my $esc = $_[0]->{escape_char} || $r;
1442              
1443             # parts containing * are naturally unquoted
1444             return join($_[0]->{name_sep}||'', map
1445 487         1701 +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ),
  487         2156  
1446 484 50 100     2282 ( $_[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   2739 if ($_[0]->{convert}) {
1455 38         52 return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
1456             }
1457 1515         3187 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   3838 ? map {[$_[1], $_]} @_[2 .. $#_]
  100         449  
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   132 my $self = shift;
1475 95 100       216 if ($self->{bindtype} eq 'columns') {
1476 30         52 for (@_) {
1477 31 100 66     155 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   2375 my ($self, $logic, $clauses_aref, $bind_aref) = @_;
1486              
1487 1422 100       2662 if (@$clauses_aref > 1) {
    50          
1488 358         567 my $join = " " . $self->_sqlcase($logic) . " ";
1489 358         926 my $sql = '( ' . join($join, @$clauses_aref) . ' )';
1490 358         1765 return ($sql, @$bind_aref);
1491             }
1492             elsif (@$clauses_aref) {
1493 1064         3196 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   6815 return $_[0]->{case} ? $_[1] : uc($_[1]);
1506             }
1507              
1508              
1509             #======================================================================
1510             # DISPATCHING FROM REFKIND
1511             #======================================================================
1512              
1513             sub _refkind {
1514 5392     5392   6561 my ($self, $data) = @_;
1515              
1516 5392 100       8405 return 'UNDEF' unless defined $data;
1517              
1518             # blessed objects are treated like scalars
1519 5140 100       10620 my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1520              
1521 5140 100       8972 return 'SCALAR' unless $ref;
1522              
1523 3166         3711 my $n_steps = 1;
1524 3166         5443 while ($ref eq 'REF') {
1525 108         159 $data = $$data;
1526 108 100       234 $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1527 108 100       245 $n_steps++ if $ref;
1528             }
1529              
1530 3166   100     9037 return ($ref||'SCALAR') . ('REF' x $n_steps);
1531             }
1532              
1533             sub _try_refkind {
1534 5379     5379   6771 my ($self, $data) = @_;
1535 5379         7636 my @try = ($self->_refkind($data));
1536 5379 100 100     13939 push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
1537 5379         6464 push @try, 'FALLBACK';
1538 5379         9870 return \@try;
1539             }
1540              
1541             sub _METHOD_FOR_refkind {
1542 2663     2663   3754 my ($self, $meth_prefix, $data) = @_;
1543              
1544 2663         2856 my $method;
1545 2663         2778 for (@{$self->_try_refkind($data)}) {
  2663         3670  
1546 2663 50       9494 $method = $self->can($meth_prefix."_".$_)
1547             and last;
1548             }
1549              
1550 2663   33     6718 return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
1551             }
1552              
1553              
1554             sub _SWITCH_refkind {
1555 2716     2716   4742 my ($self, $data, $dispatch_table) = @_;
1556              
1557 2716         2963 my $coderef;
1558 2716         2874 for (@{$self->_try_refkind($data)}) {
  2716         3887  
1559 3526 100       6738 $coderef = $dispatch_table->{$_}
1560             and last;
1561             }
1562              
1563 2716 50       4961 puke "no dispatch entry for ".$self->_refkind($data)
1564             unless $coderef;
1565              
1566 2716         3751 $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 6942 my $self = shift;
1582 6   50     14 my $data = shift || return;
1583 6 50       15 puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
1584             unless ref $data eq 'HASH';
1585              
1586 6         10 my @all_bind;
1587 6         28 foreach my $k (sort keys %$data) {
1588 37         49 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         2 my ($sql, @bind) = @$v;
1596 1         4 $self->_assert_bindval_matches_bindtype(@bind);
1597 1         6 push @all_bind, @bind;
1598             }
1599             },
1600             ARRAYREFREF => sub { # literal SQL with bind
1601 1     1   2 my ($sql, @bind) = @${$v};
  1         2  
1602 1         2 $self->_assert_bindval_matches_bindtype(@bind);
1603 1         4 push @all_bind, @bind;
1604             },
1605       2     SCALARREF => sub { # literal SQL without bind
1606             },
1607             SCALAR_or_UNDEF => sub {
1608 33     33   47 push @all_bind, $self->_bindtype($k, $v);
1609             },
1610 37         204 });
1611             }
1612              
1613 6         67 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   170676 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__