File Coverage

blib/lib/SQL/Abstract.pm
Criterion Covered Total %
statement 581 663 87.6
branch 194 254 76.3
condition 98 138 71.0
subroutine 121 139 87.0
pod 10 12 83.3
total 1004 1206 83.2


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