Use variables to simplify grocking the parenthesis unroller rules
[scpubgit/Q-Branch.git] / lib / SQL / Abstract.pm
CommitLineData
96449e8e 1package SQL::Abstract; # see doc at end of file
2
96449e8e 3use strict;
4use warnings;
9d9d5bd6 5use Carp ();
312d830b 6use List::Util ();
7use Scalar::Util ();
96449e8e 8
9#======================================================================
10# GLOBALS
11#======================================================================
12
4c120a34 13our $VERSION = '1.77';
7479e27e 14
22f1a437 15# This would confuse some packagers
c520207b 16$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
96449e8e 17
18our $AUTOLOAD;
19
20# special operators (-in, -between). May be extended/overridden by user.
21# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
22my @BUILTIN_SPECIAL_OPS = (
b8db59b8 23 {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'},
24 {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'},
cc422895 25 {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'},
26 {regex => qr/^ value $/ix, handler => '_where_op_VALUE'},
b9b5a0b1 27 {regex => qr/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'},
96449e8e 28);
29
97a920ef 30# unaryish operators - key maps to handler
59f23b3d 31my @BUILTIN_UNARY_OPS = (
a47b433a 32 # the digits are backcompat stuff
b8db59b8 33 { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
34 { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
35 { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
36 { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
cc422895 37 { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
b9b5a0b1 38 { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
59f23b3d 39);
97a920ef 40
96449e8e 41#======================================================================
42# DEBUGGING AND ERROR REPORTING
43#======================================================================
44
45sub _debug {
46 return unless $_[0]->{debug}; shift; # a little faster
47 my $func = (caller(1))[3];
48 warn "[$func] ", @_, "\n";
49}
50
51sub belch (@) {
52 my($func) = (caller(1))[3];
9d9d5bd6 53 Carp::carp "[$func] Warning: ", @_;
96449e8e 54}
55
56sub puke (@) {
57 my($func) = (caller(1))[3];
9d9d5bd6 58 Carp::croak "[$func] Fatal: ", @_;
96449e8e 59}
60
61
62#======================================================================
63# NEW
64#======================================================================
65
66sub new {
67 my $self = shift;
68 my $class = ref($self) || $self;
69 my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
70
71 # choose our case by keeping an option around
72 delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
73
74 # default logic for interpreting arrayrefs
ef559da3 75 $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
96449e8e 76
77 # how to return bind vars
96449e8e 78 $opt{bindtype} ||= 'normal';
79
80 # default comparison is "=", but can be overridden
81 $opt{cmp} ||= '=';
82
3af02ccb 83 # try to recognize which are the 'equality' and 'inequality' ops
3cdadcbe 84 # (temporary quickfix (in 2007), should go through a more seasoned API)
85 $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix;
86 $opt{inequality_op} = qr/^( != | <> )$/ix;
87
88 $opt{like_op} = qr/^ (is\s+)? r?like $/xi;
89 $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi;
96449e8e 90
91 # SQL booleans
92 $opt{sqltrue} ||= '1=1';
93 $opt{sqlfalse} ||= '0=1';
94
9d48860e 95 # special operators
96449e8e 96 $opt{special_ops} ||= [];
b6251592 97 # regexes are applied in order, thus push after user-defines
96449e8e 98 push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
99
9d48860e 100 # unary operators
59f23b3d 101 $opt{unary_ops} ||= [];
102 push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
103
3af02ccb 104 # rudimentary sanity-check for user supplied bits treated as functions/operators
b6251592 105 # If a purported function matches this regular expression, an exception is thrown.
106 # Literal SQL is *NOT* subject to this check, only functions (and column names
107 # when quoting is not in effect)
96449e8e 108
b6251592 109 # FIXME
110 # need to guard against ()'s in column names too, but this will break tons of
111 # hacks... ideas anyone?
112 $opt{injection_guard} ||= qr/
113 \;
114 |
115 ^ \s* go \s
116 /xmi;
96449e8e 117
b6251592 118 return bless \%opt, $class;
119}
96449e8e 120
170e6c33 121
122sub _assert_pass_injection_guard {
123 if ($_[1] =~ $_[0]->{injection_guard}) {
124 my $class = ref $_[0];
125 puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
126 . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
127 . "{injection_guard} attribute to ${class}->new()"
128 }
129}
130
131
96449e8e 132#======================================================================
133# INSERT methods
134#======================================================================
135
136sub insert {
02288357 137 my $self = shift;
138 my $table = $self->_table(shift);
139 my $data = shift || return;
140 my $options = shift;
96449e8e 141
142 my $method = $self->_METHOD_FOR_refkind("_insert", $data);
02288357 143 my ($sql, @bind) = $self->$method($data);
96449e8e 144 $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
02288357 145
e82e648a 146 if ($options->{returning}) {
147 my ($s, @b) = $self->_insert_returning ($options);
148 $sql .= $s;
149 push @bind, @b;
02288357 150 }
151
96449e8e 152 return wantarray ? ($sql, @bind) : $sql;
153}
154
6b1fe79d 155sub _insert_returning {
e82e648a 156 my ($self, $options) = @_;
6b1fe79d 157
e82e648a 158 my $f = $options->{returning};
159
160 my $fieldlist = $self->_SWITCH_refkind($f, {
161 ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
162 SCALAR => sub {$self->_quote($f)},
163 SCALARREF => sub {$$f},
6b1fe79d 164 });
e82e648a 165 return $self->_sqlcase(' returning ') . $fieldlist;
6b1fe79d 166}
167
96449e8e 168sub _insert_HASHREF { # explicit list of fields and then values
169 my ($self, $data) = @_;
170
171 my @fields = sort keys %$data;
172
fe3ae272 173 my ($sql, @bind) = $self->_insert_values($data);
96449e8e 174
175 # assemble SQL
176 $_ = $self->_quote($_) foreach @fields;
177 $sql = "( ".join(", ", @fields).") ".$sql;
178
179 return ($sql, @bind);
180}
181
182sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
183 my ($self, $data) = @_;
184
185 # no names (arrayref) so can't generate bindtype
186 $self->{bindtype} ne 'columns'
187 or belch "can't do 'columns' bindtype when called with arrayref";
188
fe3ae272 189 # fold the list of values into a hash of column name - value pairs
190 # (where the column names are artificially generated, and their
191 # lexicographical ordering keep the ordering of the original list)
192 my $i = "a"; # incremented values will be in lexicographical order
193 my $data_in_hash = { map { ($i++ => $_) } @$data };
194
195 return $self->_insert_values($data_in_hash);
196}
197
198sub _insert_ARRAYREFREF { # literal SQL with bind
199 my ($self, $data) = @_;
200
201 my ($sql, @bind) = @${$data};
202 $self->_assert_bindval_matches_bindtype(@bind);
203
204 return ($sql, @bind);
205}
206
207
208sub _insert_SCALARREF { # literal SQL without bind
209 my ($self, $data) = @_;
210
211 return ($$data);
212}
213
214sub _insert_values {
215 my ($self, $data) = @_;
216
96449e8e 217 my (@values, @all_bind);
fe3ae272 218 foreach my $column (sort keys %$data) {
219 my $v = $data->{$column};
96449e8e 220
221 $self->_SWITCH_refkind($v, {
222
9d48860e 223 ARRAYREF => sub {
96449e8e 224 if ($self->{array_datatypes}) { # if array datatype are activated
225 push @values, '?';
fe3ae272 226 push @all_bind, $self->_bindtype($column, $v);
96449e8e 227 }
228 else { # else literal SQL with bind
229 my ($sql, @bind) = @$v;
fe3ae272 230 $self->_assert_bindval_matches_bindtype(@bind);
96449e8e 231 push @values, $sql;
232 push @all_bind, @bind;
233 }
234 },
235
236 ARRAYREFREF => sub { # literal SQL with bind
237 my ($sql, @bind) = @${$v};
fe3ae272 238 $self->_assert_bindval_matches_bindtype(@bind);
96449e8e 239 push @values, $sql;
240 push @all_bind, @bind;
241 },
242
9d48860e 243 # THINK : anything useful to do with a HASHREF ?
5db47f9f 244 HASHREF => sub { # (nothing, but old SQLA passed it through)
245 #TODO in SQLA >= 2.0 it will die instead
246 belch "HASH ref as bind value in insert is not supported";
247 push @values, '?';
fe3ae272 248 push @all_bind, $self->_bindtype($column, $v);
5db47f9f 249 },
96449e8e 250
251 SCALARREF => sub { # literal SQL without bind
252 push @values, $$v;
253 },
254
255 SCALAR_or_UNDEF => sub {
256 push @values, '?';
fe3ae272 257 push @all_bind, $self->_bindtype($column, $v);
96449e8e 258 },
259
260 });
261
262 }
263
264 my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
265 return ($sql, @all_bind);
266}
267
268
96449e8e 269
270#======================================================================
271# UPDATE methods
272#======================================================================
273
274
275sub update {
276 my $self = shift;
277 my $table = $self->_table(shift);
278 my $data = shift || return;
279 my $where = shift;
280
281 # first build the 'SET' part of the sql statement
282 my (@set, @all_bind);
283 puke "Unsupported data type specified to \$sql->update"
284 unless ref $data eq 'HASH';
285
286 for my $k (sort keys %$data) {
287 my $v = $data->{$k};
288 my $r = ref $v;
289 my $label = $self->_quote($k);
290
291 $self->_SWITCH_refkind($v, {
9d48860e 292 ARRAYREF => sub {
96449e8e 293 if ($self->{array_datatypes}) { # array datatype
294 push @set, "$label = ?";
295 push @all_bind, $self->_bindtype($k, $v);
296 }
297 else { # literal SQL with bind
298 my ($sql, @bind) = @$v;
fe3ae272 299 $self->_assert_bindval_matches_bindtype(@bind);
96449e8e 300 push @set, "$label = $sql";
fe3ae272 301 push @all_bind, @bind;
96449e8e 302 }
303 },
304 ARRAYREFREF => sub { # literal SQL with bind
305 my ($sql, @bind) = @${$v};
fe3ae272 306 $self->_assert_bindval_matches_bindtype(@bind);
96449e8e 307 push @set, "$label = $sql";
fe3ae272 308 push @all_bind, @bind;
96449e8e 309 },
310 SCALARREF => sub { # literal SQL without bind
311 push @set, "$label = $$v";
0ec3aec7 312 },
313 HASHREF => sub {
314 my ($op, $arg, @rest) = %$v;
315
316 puke 'Operator calls in update must be in the form { -op => $arg }'
317 if (@rest or not $op =~ /^\-(.+)/);
318
319 local $self->{_nested_func_lhs} = $k;
320 my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
321
322 push @set, "$label = $sql";
323 push @all_bind, @bind;
324 },
96449e8e 325 SCALAR_or_UNDEF => sub {
326 push @set, "$label = ?";
327 push @all_bind, $self->_bindtype($k, $v);
328 },
329 });
330 }
331
332 # generate sql
333 my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
334 . join ', ', @set;
335
336 if ($where) {
337 my($where_sql, @where_bind) = $self->where($where);
338 $sql .= $where_sql;
339 push @all_bind, @where_bind;
340 }
341
342 return wantarray ? ($sql, @all_bind) : $sql;
343}
344
345
346
347
348#======================================================================
349# SELECT
350#======================================================================
351
352
353sub select {
354 my $self = shift;
355 my $table = $self->_table(shift);
356 my $fields = shift || '*';
357 my $where = shift;
358 my $order = shift;
359
360 my($where_sql, @bind) = $self->where($where, $order);
361
362 my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields
363 : $fields;
9d48860e 364 my $sql = join(' ', $self->_sqlcase('select'), $f,
96449e8e 365 $self->_sqlcase('from'), $table)
366 . $where_sql;
367
9d48860e 368 return wantarray ? ($sql, @bind) : $sql;
96449e8e 369}
370
371#======================================================================
372# DELETE
373#======================================================================
374
375
376sub delete {
377 my $self = shift;
378 my $table = $self->_table(shift);
379 my $where = shift;
380
381
382 my($where_sql, @bind) = $self->where($where);
383 my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql;
384
9d48860e 385 return wantarray ? ($sql, @bind) : $sql;
96449e8e 386}
387
388
389#======================================================================
390# WHERE: entry point
391#======================================================================
392
393
394
395# Finally, a separate routine just to handle WHERE clauses
396sub where {
397 my ($self, $where, $order) = @_;
398
399 # where ?
400 my ($sql, @bind) = $self->_recurse_where($where);
401 $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
402
403 # order by?
404 if ($order) {
405 $sql .= $self->_order_by($order);
406 }
407
9d48860e 408 return wantarray ? ($sql, @bind) : $sql;
96449e8e 409}
410
411
412sub _recurse_where {
413 my ($self, $where, $logic) = @_;
414
415 # dispatch on appropriate method according to refkind of $where
416 my $method = $self->_METHOD_FOR_refkind("_where", $where);
311b2151 417
9d48860e 418 my ($sql, @bind) = $self->$method($where, $logic);
311b2151 419
9d48860e 420 # DBIx::Class directly calls _recurse_where in scalar context, so
311b2151 421 # we must implement it, even if not in the official API
9d48860e 422 return wantarray ? ($sql, @bind) : $sql;
96449e8e 423}
424
425
426
427#======================================================================
428# WHERE: top-level ARRAYREF
429#======================================================================
430
431
432sub _where_ARRAYREF {
5e1d09d5 433 my ($self, $where, $logic) = @_;
96449e8e 434
5e1d09d5 435 $logic = uc($logic || $self->{logic});
96449e8e 436 $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
437
438 my @clauses = @$where;
439
96449e8e 440 my (@sql_clauses, @all_bind);
96449e8e 441 # need to use while() so can shift() for pairs
9d48860e 442 while (my $el = shift @clauses) {
96449e8e 443
444 # switch according to kind of $el and get corresponding ($sql, @bind)
445 my ($sql, @bind) = $self->_SWITCH_refkind($el, {
446
447 # skip empty elements, otherwise get invalid trailing AND stuff
448 ARRAYREF => sub {$self->_recurse_where($el) if @$el},
449
c94a6c93 450 ARRAYREFREF => sub {
451 my ($s, @b) = @$$el;
452 $self->_assert_bindval_matches_bindtype(@b);
453 ($s, @b);
454 },
474e3335 455
96449e8e 456 HASHREF => sub {$self->_recurse_where($el, 'and') if %$el},
96449e8e 457
458 SCALARREF => sub { ($$el); },
459
460 SCALAR => sub {# top-level arrayref with scalars, recurse in pairs
461 $self->_recurse_where({$el => shift(@clauses)})},
462
463 UNDEF => sub {puke "not supported : UNDEF in arrayref" },
464 });
465
4b7b6026 466 if ($sql) {
467 push @sql_clauses, $sql;
468 push @all_bind, @bind;
469 }
96449e8e 470 }
471
472 return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind);
473}
474
474e3335 475#======================================================================
476# WHERE: top-level ARRAYREFREF
477#======================================================================
96449e8e 478
474e3335 479sub _where_ARRAYREFREF {
480 my ($self, $where) = @_;
c94a6c93 481 my ($sql, @bind) = @$$where;
482 $self->_assert_bindval_matches_bindtype(@bind);
474e3335 483 return ($sql, @bind);
484}
96449e8e 485
486#======================================================================
487# WHERE: top-level HASHREF
488#======================================================================
489
490sub _where_HASHREF {
491 my ($self, $where) = @_;
492 my (@sql_clauses, @all_bind);
493
2281c758 494 for my $k (sort keys %$where) {
96449e8e 495 my $v = $where->{$k};
496
2281c758 497 # ($k => $v) is either a special unary op or a regular hashpair
498 my ($sql, @bind) = do {
499 if ($k =~ /^-./) {
500 # put the operator in canonical form
501 my $op = $k;
b8db59b8 502 $op = substr $op, 1; # remove initial dash
2281c758 503 $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
b8db59b8 504 $op =~ s/\s+/ /g; # compress whitespace
505
506 # so that -not_foo works correctly
507 $op =~ s/^not_/NOT /i;
2281c758 508
509 $self->_debug("Unary OP(-$op) within hashref, recursing...");
0ec3aec7 510 my ($s, @b) = $self->_where_unary_op ($op, $v);
511
512 # top level vs nested
513 # we assume that handled unary ops will take care of their ()s
514 $s = "($s)" unless (
515 List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}
516 or
517 defined($self->{_nested_func_lhs}) && ($self->{_nested_func_lhs} eq $k)
518 );
519 ($s, @b);
2281c758 520 }
521 else {
522 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
523 $self->$method($k, $v);
524 }
525 };
96449e8e 526
527 push @sql_clauses, $sql;
528 push @all_bind, @bind;
529 }
530
531 return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
532}
533
0ec3aec7 534sub _where_unary_op {
2281c758 535 my ($self, $op, $rhs) = @_;
96449e8e 536
0ec3aec7 537 if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) {
538 my $handler = $op_entry->{handler};
539
540 if (not ref $handler) {
541 if ($op =~ s/ [_\s]? \d+ $//x ) {
542 belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
543 . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
544 }
545 return $self->$handler ($op, $rhs);
546 }
547 elsif (ref $handler eq 'CODE') {
548 return $handler->($self, $op, $rhs);
549 }
550 else {
551 puke "Illegal handler for operator $op - expecting a method name or a coderef";
552 }
553 }
554
3d86e3b1 555 $self->_debug("Generic unary OP: $op - recursing as function");
0ec3aec7 556
170e6c33 557 $self->_assert_pass_injection_guard($op);
b6251592 558
2281c758 559 my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
560 SCALAR => sub {
a7661cfc 561 puke "Illegal use of top-level '$op'"
562 unless $self->{_nested_func_lhs};
563
564 return (
565 $self->_convert('?'),
566 $self->_bindtype($self->{_nested_func_lhs}, $rhs)
567 );
2281c758 568 },
569 FALLBACK => sub {
570 $self->_recurse_where ($rhs)
571 },
572 });
96449e8e 573
953d164e 574 $sql = sprintf ('%s %s',
2281c758 575 $self->_sqlcase($op),
953d164e 576 $sql,
2281c758 577 );
96449e8e 578
2281c758 579 return ($sql, @bind);
97a920ef 580}
581
582sub _where_op_ANDOR {
2281c758 583 my ($self, $op, $v) = @_;
97a920ef 584
585 $self->_SWITCH_refkind($v, {
586 ARRAYREF => sub {
587 return $self->_where_ARRAYREF($v, $op);
588 },
589
590 HASHREF => sub {
59f23b3d 591 return ( $op =~ /^or/i )
97a920ef 592 ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op )
593 : $self->_where_HASHREF($v);
594 },
595
9d48860e 596 SCALARREF => sub {
48d9f5f8 597 puke "-$op => \\\$scalar makes little sense, use " .
a0d6d323 598 ($op =~ /^or/i
48d9f5f8 599 ? '[ \$scalar, \%rest_of_conditions ] instead'
600 : '-and => [ \$scalar, \%rest_of_conditions ] instead'
601 );
97a920ef 602 },
603
604 ARRAYREFREF => sub {
48d9f5f8 605 puke "-$op => \\[...] makes little sense, use " .
a0d6d323 606 ($op =~ /^or/i
48d9f5f8 607 ? '[ \[...], \%rest_of_conditions ] instead'
608 : '-and => [ \[...], \%rest_of_conditions ] instead'
609 );
97a920ef 610 },
611
612 SCALAR => sub { # permissively interpreted as SQL
48d9f5f8 613 puke "-$op => \$value makes little sense, use -bool => \$value instead";
97a920ef 614 },
615
616 UNDEF => sub {
617 puke "-$op => undef not supported";
618 },
619 });
620}
621
622sub _where_op_NEST {
9d48860e 623 my ($self, $op, $v) = @_;
97a920ef 624
96449e8e 625 $self->_SWITCH_refkind($v, {
626
96449e8e 627 SCALAR => sub { # permissively interpreted as SQL
01a01e57 628 belch "literal SQL should be -nest => \\'scalar' "
629 . "instead of -nest => 'scalar' ";
9d48860e 630 return ($v);
96449e8e 631 },
632
633 UNDEF => sub {
634 puke "-$op => undef not supported";
635 },
e9501094 636
637 FALLBACK => sub {
638 $self->_recurse_where ($v);
639 },
640
96449e8e 641 });
642}
643
644
97a920ef 645sub _where_op_BOOL {
9d48860e 646 my ($self, $op, $v) = @_;
97a920ef 647
b8db59b8 648 my ($s, @b) = $self->_SWITCH_refkind($v, {
649 SCALAR => sub { # interpreted as SQL column
650 $self->_convert($self->_quote($v));
651 },
ef03f1bc 652
b8db59b8 653 UNDEF => sub {
654 puke "-$op => undef not supported";
655 },
97a920ef 656
b8db59b8 657 FALLBACK => sub {
658 $self->_recurse_where ($v);
659 },
660 });
ef03f1bc 661
b8db59b8 662 $s = "(NOT $s)" if $op =~ /^not/i;
663 ($s, @b);
97a920ef 664}
665
666
cc422895 667sub _where_op_IDENT {
668 my $self = shift;
669 my ($op, $rhs) = splice @_, -2;
670 if (ref $rhs) {
671 puke "-$op takes a single scalar argument (a quotable identifier)";
672 }
673
674 # in case we are called as a top level special op (no '=')
675 my $lhs = shift;
676
677 $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
678
679 return $lhs
680 ? "$lhs = $rhs"
681 : $rhs
682 ;
683}
684
685sub _where_op_VALUE {
686 my $self = shift;
687 my ($op, $rhs) = splice @_, -2;
688
689 # in case we are called as a top level special op (no '=')
690 my $lhs = shift;
691
692 my @bind =
693 $self->_bindtype (
694 ($lhs || $self->{_nested_func_lhs}),
695 $rhs,
696 )
697 ;
698
699 return $lhs
700 ? (
701 $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
702 @bind
703 )
704 : (
705 $self->_convert('?'),
706 @bind,
707 )
708 ;
709}
710
96449e8e 711sub _where_hashpair_ARRAYREF {
712 my ($self, $k, $v) = @_;
713
714 if( @$v ) {
715 my @v = @$v; # need copy because of shift below
716 $self->_debug("ARRAY($k) means distribute over elements");
717
718 # put apart first element if it is an operator (-and, -or)
e3cecb45 719 my $op = (
720 (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix)
721 ? shift @v
722 : ''
04d940de 723 );
96449e8e 724 my @distributed = map { {$k => $_} } @v;
04d940de 725
726 if ($op) {
727 $self->_debug("OP($op) reinjected into the distributed array");
728 unshift @distributed, $op;
729 }
730
f67591bf 731 my $logic = $op ? substr($op, 1) : '';
96449e8e 732
f67591bf 733 return $self->_recurse_where(\@distributed, $logic);
9d48860e 734 }
96449e8e 735 else {
96449e8e 736 $self->_debug("empty ARRAY($k) means 0=1");
737 return ($self->{sqlfalse});
738 }
739}
740
741sub _where_hashpair_HASHREF {
eb49170d 742 my ($self, $k, $v, $logic) = @_;
743 $logic ||= 'and';
96449e8e 744
a7661cfc 745 local $self->{_nested_func_lhs} = $self->{_nested_func_lhs};
a7661cfc 746
eb49170d 747 my ($all_sql, @all_bind);
96449e8e 748
a47b433a 749 for my $orig_op (sort keys %$v) {
750 my $val = $v->{$orig_op};
96449e8e 751
752 # put the operator in canonical form
a47b433a 753 my $op = $orig_op;
b8db59b8 754
755 # FIXME - we need to phase out dash-less ops
756 $op =~ s/^-//; # remove possible initial dash
a47b433a 757 $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
b8db59b8 758 $op =~ s/\s+/ /g; # compress whitespace
759
170e6c33 760 $self->_assert_pass_injection_guard($op);
b6251592 761
b9b5a0b1 762 # fixup is_not
763 $op =~ s/^is_not/IS NOT/i;
764
b8db59b8 765 # so that -not_foo works correctly
766 $op =~ s/^not_/NOT /i;
96449e8e 767
768 my ($sql, @bind);
769
2281c758 770 # CASE: col-value logic modifiers
771 if ( $orig_op =~ /^ \- (and|or) $/xi ) {
772 ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1);
773 }
96449e8e 774 # CASE: special operators like -in or -between
312d830b 775 elsif ( my $special_op = List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}} ) {
3a2e1a5e 776 my $handler = $special_op->{handler};
777 if (! $handler) {
a47b433a 778 puke "No handler supplied for special operator $orig_op";
3a2e1a5e 779 }
780 elsif (not ref $handler) {
781 ($sql, @bind) = $self->$handler ($k, $op, $val);
782 }
783 elsif (ref $handler eq 'CODE') {
784 ($sql, @bind) = $handler->($self, $k, $op, $val);
785 }
786 else {
a47b433a 787 puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef";
3a2e1a5e 788 }
96449e8e 789 }
96449e8e 790 else {
cf838930 791 $self->_SWITCH_refkind($val, {
792
793 ARRAYREF => sub { # CASE: col => {op => \@vals}
794 ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
795 },
796
fe3ae272 797 ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind)
b3be7bd0 798 my ($sub_sql, @sub_bind) = @$$val;
fe3ae272 799 $self->_assert_bindval_matches_bindtype(@sub_bind);
b3be7bd0 800 $sql = join ' ', $self->_convert($self->_quote($k)),
801 $self->_sqlcase($op),
802 $sub_sql;
fe3ae272 803 @bind = @sub_bind;
b3be7bd0 804 },
805
cf838930 806 UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
3cdadcbe 807 my $is =
40f2f231 808 $op =~ /^not$/i ? 'is not' # legacy
809 : $op =~ $self->{equality_op} ? 'is'
3cdadcbe 810 : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
811 : $op =~ $self->{inequality_op} ? 'is not'
812 : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
813 : puke "unexpected operator '$orig_op' with undef operand";
814
cf838930 815 $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
816 },
a47b433a 817
2281c758 818 FALLBACK => sub { # CASE: col => {op/func => $stuff}
07936978 819
953d164e 820 # retain for proper column type bind
821 $self->{_nested_func_lhs} ||= $k;
07936978 822
0ec3aec7 823 ($sql, @bind) = $self->_where_unary_op ($op, $val);
953d164e 824
825 $sql = join (' ',
826 $self->_convert($self->_quote($k)),
827 $self->{_nested_func_lhs} eq $k ? $sql : "($sql)", # top level vs nested
828 );
cf838930 829 },
830 });
96449e8e 831 }
832
eb49170d 833 ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql;
96449e8e 834 push @all_bind, @bind;
835 }
eb49170d 836 return ($all_sql, @all_bind);
96449e8e 837}
838
b9b5a0b1 839sub _where_field_IS {
840 my ($self, $k, $op, $v) = @_;
841
842 my ($s) = $self->_SWITCH_refkind($v, {
843 UNDEF => sub {
844 join ' ',
845 $self->_convert($self->_quote($k)),
846 map { $self->_sqlcase($_)} ($op, 'null')
847 },
848 FALLBACK => sub {
849 puke "$op can only take undef as argument";
850 },
851 });
96449e8e 852
b9b5a0b1 853 $s;
854}
96449e8e 855
856sub _where_field_op_ARRAYREF {
857 my ($self, $k, $op, $vals) = @_;
858
ce261791 859 my @vals = @$vals; #always work on a copy
860
861 if(@vals) {
bd6a65ca 862 $self->_debug(sprintf '%s means multiple elements: [ %s ]',
863 $vals,
864 join (', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
865 );
96449e8e 866
4030915f 867 # see if the first element is an -and/-or op
868 my $logic;
bd6a65ca 869 if (defined $vals[0] && $vals[0] =~ /^ - ( AND|OR ) $/ix) {
4030915f 870 $logic = uc $1;
ce261791 871 shift @vals;
4030915f 872 }
873
3cdadcbe 874 # a long standing API wart - an attempt to change this behavior during
875 # the 1.50 series failed *spectacularly*. Warn instead and leave the
876 # behavior as is
877 if (
878 @vals > 1
879 and
880 (!$logic or $logic eq 'OR')
881 and
882 ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} )
883 ) {
884 my $o = uc($op);
885 belch "A multi-element arrayref as an argument to the inequality op '$o' "
886 . 'is technically equivalent to an always-true 1=1 (you probably wanted '
887 . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
888 ;
889 }
890
ce261791 891 # distribute $op over each remaining member of @vals, append logic if exists
892 return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
4030915f 893
9d48860e 894 }
96449e8e 895 else {
9d48860e 896 # try to DWIM on equality operators
3cdadcbe 897 return
898 $op =~ $self->{equality_op} ? $self->{sqlfalse}
899 : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse}
900 : $op =~ $self->{inequality_op} ? $self->{sqltrue}
901 : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue}
902 : puke "operator '$op' applied on an empty array (field '$k')";
96449e8e 903 }
904}
905
906
907sub _where_hashpair_SCALARREF {
908 my ($self, $k, $v) = @_;
909 $self->_debug("SCALAR($k) means literal SQL: $$v");
910 my $sql = $self->_quote($k) . " " . $$v;
911 return ($sql);
912}
913
fe3ae272 914# literal SQL with bind
96449e8e 915sub _where_hashpair_ARRAYREFREF {
916 my ($self, $k, $v) = @_;
917 $self->_debug("REF($k) means literal SQL: @${$v}");
c94a6c93 918 my ($sql, @bind) = @$$v;
fe3ae272 919 $self->_assert_bindval_matches_bindtype(@bind);
96449e8e 920 $sql = $self->_quote($k) . " " . $sql;
96449e8e 921 return ($sql, @bind );
922}
923
fe3ae272 924# literal SQL without bind
96449e8e 925sub _where_hashpair_SCALAR {
926 my ($self, $k, $v) = @_;
927 $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
9d48860e 928 my $sql = join ' ', $self->_convert($self->_quote($k)),
929 $self->_sqlcase($self->{cmp}),
96449e8e 930 $self->_convert('?');
931 my @bind = $self->_bindtype($k, $v);
932 return ( $sql, @bind);
933}
934
935
936sub _where_hashpair_UNDEF {
937 my ($self, $k, $v) = @_;
938 $self->_debug("UNDEF($k) means IS NULL");
939 my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
940 return ($sql);
941}
942
943#======================================================================
944# WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF)
945#======================================================================
946
947
948sub _where_SCALARREF {
949 my ($self, $where) = @_;
950
951 # literal sql
952 $self->_debug("SCALAR(*top) means literal SQL: $$where");
953 return ($$where);
954}
955
956
957sub _where_SCALAR {
958 my ($self, $where) = @_;
959
960 # literal sql
961 $self->_debug("NOREF(*top) means literal SQL: $where");
962 return ($where);
963}
964
965
966sub _where_UNDEF {
967 my ($self) = @_;
968 return ();
969}
970
971
972#======================================================================
973# WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
974#======================================================================
975
976
977sub _where_field_BETWEEN {
978 my ($self, $k, $op, $vals) = @_;
979
4d8b3dc4 980 my ($label, $and, $placeholder);
cf02fc47 981 $label = $self->_convert($self->_quote($k));
982 $and = ' ' . $self->_sqlcase('and') . ' ';
983 $placeholder = $self->_convert('?');
96449e8e 984 $op = $self->_sqlcase($op);
985
7f54040f 986 my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
987
4d8b3dc4 988 my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
989 ARRAYREFREF => sub {
c94a6c93 990 my ($s, @b) = @$$vals;
991 $self->_assert_bindval_matches_bindtype(@b);
992 ($s, @b);
4d8b3dc4 993 },
994 SCALARREF => sub {
995 return $$vals;
996 },
997 ARRAYREF => sub {
7f54040f 998 puke $invalid_args if @$vals != 2;
4d8b3dc4 999
1000 my (@all_sql, @all_bind);
1001 foreach my $val (@$vals) {
1002 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
1003 SCALAR => sub {
5e5cbf51 1004 return ($placeholder, $self->_bindtype($k, $val) );
4d8b3dc4 1005 },
1006 SCALARREF => sub {
0336eddb 1007 return $$val;
4d8b3dc4 1008 },
1009 ARRAYREFREF => sub {
1010 my ($sql, @bind) = @$$val;
c94a6c93 1011 $self->_assert_bindval_matches_bindtype(@bind);
0336eddb 1012 return ($sql, @bind);
4d8b3dc4 1013 },
0336eddb 1014 HASHREF => sub {
1015 my ($func, $arg, @rest) = %$val;
1016 puke ("Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN")
1017 if (@rest or $func !~ /^ \- (.+)/x);
1018 local $self->{_nested_func_lhs} = $k;
0ec3aec7 1019 $self->_where_unary_op ($1 => $arg);
7f54040f 1020 },
1021 FALLBACK => sub {
1022 puke $invalid_args,
1023 },
4d8b3dc4 1024 });
1025 push @all_sql, $sql;
1026 push @all_bind, @bind;
1027 }
1028
1029 return (
1030 (join $and, @all_sql),
5e5cbf51 1031 @all_bind
4d8b3dc4 1032 );
1033 },
1034 FALLBACK => sub {
7f54040f 1035 puke $invalid_args,
4d8b3dc4 1036 },
1037 });
cf02fc47 1038
cf02fc47 1039 my $sql = "( $label $op $clause )";
96449e8e 1040 return ($sql, @bind)
1041}
1042
1043
1044sub _where_field_IN {
1045 my ($self, $k, $op, $vals) = @_;
1046
1047 # backwards compatibility : if scalar, force into an arrayref
1048 $vals = [$vals] if defined $vals && ! ref $vals;
1049
96449e8e 1050 my ($label) = $self->_convert($self->_quote($k));
1051 my ($placeholder) = $self->_convert('?');
96449e8e 1052 $op = $self->_sqlcase($op);
1053
8a0d798a 1054 my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
1055 ARRAYREF => sub { # list of choices
1056 if (@$vals) { # nonempty list
0336eddb 1057 my (@all_sql, @all_bind);
1058
1059 for my $val (@$vals) {
1060 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
1061 SCALAR => sub {
1062 return ($placeholder, $val);
1063 },
1064 SCALARREF => sub {
1065 return $$val;
1066 },
1067 ARRAYREFREF => sub {
1068 my ($sql, @bind) = @$$val;
1069 $self->_assert_bindval_matches_bindtype(@bind);
1070 return ($sql, @bind);
1071 },
1072 HASHREF => sub {
1073 my ($func, $arg, @rest) = %$val;
1074 puke ("Only simple { -func => arg } functions accepted as sub-arguments to IN")
1075 if (@rest or $func !~ /^ \- (.+)/x);
1076 local $self->{_nested_func_lhs} = $k;
0ec3aec7 1077 $self->_where_unary_op ($1 => $arg);
279eb282 1078 },
1079 UNDEF => sub {
032dfe20 1080 puke(
1081 'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
1082 . "-$op operator was given an undef-containing list: !!!AUDIT YOUR CODE "
1083 . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
1084 . 'will emit the logically correct SQL instead of raising this exception)'
1085 );
279eb282 1086 },
0336eddb 1087 });
1088 push @all_sql, $sql;
1089 push @all_bind, @bind;
1090 }
96449e8e 1091
88a89939 1092 return (
1093 sprintf ('%s %s ( %s )',
1094 $label,
1095 $op,
1096 join (', ', @all_sql)
1097 ),
1098 $self->_bindtype($k, @all_bind),
0336eddb 1099 );
8a0d798a 1100 }
1101 else { # empty list : some databases won't understand "IN ()", so DWIM
1102 my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
1103 return ($sql);
1104 }
1105 },
1106
4a1f01a3 1107 SCALARREF => sub { # literal SQL
1108 my $sql = $self->_open_outer_paren ($$vals);
1109 return ("$label $op ( $sql )");
1110 },
8a0d798a 1111 ARRAYREFREF => sub { # literal SQL with bind
1112 my ($sql, @bind) = @$$vals;
fe3ae272 1113 $self->_assert_bindval_matches_bindtype(@bind);
4a1f01a3 1114 $sql = $self->_open_outer_paren ($sql);
8a0d798a 1115 return ("$label $op ( $sql )", @bind);
1116 },
1117
ff8ca6b4 1118 UNDEF => sub {
1119 puke "Argument passed to the '$op' operator can not be undefined";
1120 },
1121
8a0d798a 1122 FALLBACK => sub {
ff8ca6b4 1123 puke "special op $op requires an arrayref (or scalarref/arrayref-ref)";
8a0d798a 1124 },
1125 });
1126
1127 return ($sql, @bind);
96449e8e 1128}
1129
4a1f01a3 1130# Some databases (SQLite) treat col IN (1, 2) different from
1131# col IN ( (1, 2) ). Use this to strip all outer parens while
1132# adding them back in the corresponding method
1133sub _open_outer_paren {
1134 my ($self, $sql) = @_;
171a709f 1135 $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
4a1f01a3 1136 return $sql;
1137}
1138
96449e8e 1139
96449e8e 1140#======================================================================
1141# ORDER BY
1142#======================================================================
1143
1144sub _order_by {
1145 my ($self, $arg) = @_;
1146
f267b646 1147 my (@sql, @bind);
1148 for my $c ($self->_order_by_chunks ($arg) ) {
1149 $self->_SWITCH_refkind ($c, {
1150 SCALAR => sub { push @sql, $c },
1151 ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
1152 });
1153 }
1154
1155 my $sql = @sql
1156 ? sprintf ('%s %s',
1157 $self->_sqlcase(' order by'),
1158 join (', ', @sql)
1159 )
1160 : ''
1161 ;
1162
1163 return wantarray ? ($sql, @bind) : $sql;
1164}
1165
1166sub _order_by_chunks {
1167 my ($self, $arg) = @_;
1168
1169 return $self->_SWITCH_refkind($arg, {
96449e8e 1170
1171 ARRAYREF => sub {
f267b646 1172 map { $self->_order_by_chunks ($_ ) } @$arg;
96449e8e 1173 },
1174
c94a6c93 1175 ARRAYREFREF => sub {
1176 my ($s, @b) = @$$arg;
1177 $self->_assert_bindval_matches_bindtype(@b);
1178 [ $s, @b ];
1179 },
f267b646 1180
96449e8e 1181 SCALAR => sub {$self->_quote($arg)},
f267b646 1182
1183 UNDEF => sub {return () },
1184
96449e8e 1185 SCALARREF => sub {$$arg}, # literal SQL, no quoting
96449e8e 1186
f267b646 1187 HASHREF => sub {
5e436130 1188 # get first pair in hash
1189 my ($key, $val, @rest) = %$arg;
1190
1191 return () unless $key;
1192
1193 if ( @rest or not $key =~ /^-(desc|asc)/i ) {
1194 puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
f267b646 1195 }
5e436130 1196
1197 my $direction = $1;
96449e8e 1198
e9bd3547 1199 my @ret;
f267b646 1200 for my $c ($self->_order_by_chunks ($val)) {
e9bd3547 1201 my ($sql, @bind);
96449e8e 1202
f267b646 1203 $self->_SWITCH_refkind ($c, {
1204 SCALAR => sub {
e9bd3547 1205 $sql = $c;
f267b646 1206 },
1207 ARRAYREF => sub {
e9bd3547 1208 ($sql, @bind) = @$c;
f267b646 1209 },
1210 });
96449e8e 1211
5e436130 1212 $sql = $sql . ' ' . $self->_sqlcase($direction);
96449e8e 1213
e9bd3547 1214 push @ret, [ $sql, @bind];
1215 }
96449e8e 1216
e9bd3547 1217 return @ret;
f267b646 1218 },
1219 });
96449e8e 1220}
1221
1222
96449e8e 1223#======================================================================
1224# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
1225#======================================================================
1226
1227sub _table {
1228 my $self = shift;
1229 my $from = shift;
1230 $self->_SWITCH_refkind($from, {
1231 ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
1232 SCALAR => sub {$self->_quote($from)},
1233 SCALARREF => sub {$$from},
96449e8e 1234 });
1235}
1236
1237
1238#======================================================================
1239# UTILITY FUNCTIONS
1240#======================================================================
1241
955e77ca 1242# highly optimized, as it's called way too often
96449e8e 1243sub _quote {
955e77ca 1244 # my ($self, $label) = @_;
96449e8e 1245
955e77ca 1246 return '' unless defined $_[1];
955e77ca 1247 return ${$_[1]} if ref($_[1]) eq 'SCALAR';
96449e8e 1248
b6251592 1249 unless ($_[0]->{quote_char}) {
170e6c33 1250 $_[0]->_assert_pass_injection_guard($_[1]);
b6251592 1251 return $_[1];
1252 }
96449e8e 1253
07d7c35c 1254 my $qref = ref $_[0]->{quote_char};
955e77ca 1255 my ($l, $r);
07d7c35c 1256 if (!$qref) {
1257 ($l, $r) = ( $_[0]->{quote_char}, $_[0]->{quote_char} );
955e77ca 1258 }
07d7c35c 1259 elsif ($qref eq 'ARRAY') {
1260 ($l, $r) = @{$_[0]->{quote_char}};
955e77ca 1261 }
1262 else {
1263 puke "Unsupported quote_char format: $_[0]->{quote_char}";
1264 }
96449e8e 1265
07d7c35c 1266 # parts containing * are naturally unquoted
1267 return join( $_[0]->{name_sep}||'', map
955e77ca 1268 { $_ eq '*' ? $_ : $l . $_ . $r }
1269 ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
1270 );
96449e8e 1271}
1272
1273
1274# Conversion, if applicable
1275sub _convert ($) {
07d7c35c 1276 #my ($self, $arg) = @_;
07d7c35c 1277 if ($_[0]->{convert}) {
1278 return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
96449e8e 1279 }
07d7c35c 1280 return $_[1];
96449e8e 1281}
1282
1283# And bindtype
1284sub _bindtype (@) {
07d7c35c 1285 #my ($self, $col, @vals) = @_;
07d7c35c 1286 # called often - tighten code
1287 return $_[0]->{bindtype} eq 'columns'
1288 ? map {[$_[1], $_]} @_[2 .. $#_]
1289 : @_[2 .. $#_]
1290 ;
96449e8e 1291}
1292
fe3ae272 1293# Dies if any element of @bind is not in [colname => value] format
1294# if bindtype is 'columns'.
1295sub _assert_bindval_matches_bindtype {
c94a6c93 1296# my ($self, @bind) = @_;
1297 my $self = shift;
fe3ae272 1298 if ($self->{bindtype} eq 'columns') {
c94a6c93 1299 for (@_) {
1300 if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
3a06278c 1301 puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
fe3ae272 1302 }
1303 }
1304 }
1305}
1306
96449e8e 1307sub _join_sql_clauses {
1308 my ($self, $logic, $clauses_aref, $bind_aref) = @_;
1309
1310 if (@$clauses_aref > 1) {
1311 my $join = " " . $self->_sqlcase($logic) . " ";
1312 my $sql = '( ' . join($join, @$clauses_aref) . ' )';
1313 return ($sql, @$bind_aref);
1314 }
1315 elsif (@$clauses_aref) {
1316 return ($clauses_aref->[0], @$bind_aref); # no parentheses
1317 }
1318 else {
1319 return (); # if no SQL, ignore @$bind_aref
1320 }
1321}
1322
1323
1324# Fix SQL case, if so requested
1325sub _sqlcase {
96449e8e 1326 # LDNOTE: if $self->{case} is true, then it contains 'lower', so we
1327 # don't touch the argument ... crooked logic, but let's not change it!
07d7c35c 1328 return $_[0]->{case} ? $_[1] : uc($_[1]);
96449e8e 1329}
1330
1331
1332#======================================================================
1333# DISPATCHING FROM REFKIND
1334#======================================================================
1335
1336sub _refkind {
1337 my ($self, $data) = @_;
96449e8e 1338
955e77ca 1339 return 'UNDEF' unless defined $data;
1340
1341 # blessed objects are treated like scalars
1342 my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1343
1344 return 'SCALAR' unless $ref;
1345
1346 my $n_steps = 1;
1347 while ($ref eq 'REF') {
96449e8e 1348 $data = $$data;
955e77ca 1349 $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1350 $n_steps++ if $ref;
96449e8e 1351 }
1352
848556bc 1353 return ($ref||'SCALAR') . ('REF' x $n_steps);
96449e8e 1354}
1355
1356sub _try_refkind {
1357 my ($self, $data) = @_;
1358 my @try = ($self->_refkind($data));
1359 push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
1360 push @try, 'FALLBACK';
955e77ca 1361 return \@try;
96449e8e 1362}
1363
1364sub _METHOD_FOR_refkind {
1365 my ($self, $meth_prefix, $data) = @_;
f39eaa60 1366
1367 my $method;
955e77ca 1368 for (@{$self->_try_refkind($data)}) {
f39eaa60 1369 $method = $self->can($meth_prefix."_".$_)
1370 and last;
1371 }
1372
1373 return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
96449e8e 1374}
1375
1376
1377sub _SWITCH_refkind {
1378 my ($self, $data, $dispatch_table) = @_;
1379
f39eaa60 1380 my $coderef;
955e77ca 1381 for (@{$self->_try_refkind($data)}) {
f39eaa60 1382 $coderef = $dispatch_table->{$_}
1383 and last;
1384 }
1385
1386 puke "no dispatch entry for ".$self->_refkind($data)
1387 unless $coderef;
1388
96449e8e 1389 $coderef->();
1390}
1391
1392
1393
1394
1395#======================================================================
1396# VALUES, GENERATE, AUTOLOAD
1397#======================================================================
1398
1399# LDNOTE: original code from nwiger, didn't touch code in that section
1400# I feel the AUTOLOAD stuff should not be the default, it should
1401# only be activated on explicit demand by user.
1402
1403sub values {
1404 my $self = shift;
1405 my $data = shift || return;
1406 puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
1407 unless ref $data eq 'HASH';
bab725ce 1408
1409 my @all_bind;
1410 foreach my $k ( sort keys %$data ) {
1411 my $v = $data->{$k};
1412 $self->_SWITCH_refkind($v, {
9d48860e 1413 ARRAYREF => sub {
bab725ce 1414 if ($self->{array_datatypes}) { # array datatype
1415 push @all_bind, $self->_bindtype($k, $v);
1416 }
1417 else { # literal SQL with bind
1418 my ($sql, @bind) = @$v;
1419 $self->_assert_bindval_matches_bindtype(@bind);
1420 push @all_bind, @bind;
1421 }
1422 },
1423 ARRAYREFREF => sub { # literal SQL with bind
1424 my ($sql, @bind) = @${$v};
1425 $self->_assert_bindval_matches_bindtype(@bind);
1426 push @all_bind, @bind;
1427 },
1428 SCALARREF => sub { # literal SQL without bind
1429 },
1430 SCALAR_or_UNDEF => sub {
1431 push @all_bind, $self->_bindtype($k, $v);
1432 },
1433 });
1434 }
1435
1436 return @all_bind;
96449e8e 1437}
1438
1439sub generate {
1440 my $self = shift;
1441
1442 my(@sql, @sqlq, @sqlv);
1443
1444 for (@_) {
1445 my $ref = ref $_;
1446 if ($ref eq 'HASH') {
1447 for my $k (sort keys %$_) {
1448 my $v = $_->{$k};
1449 my $r = ref $v;
1450 my $label = $self->_quote($k);
1451 if ($r eq 'ARRAY') {
fe3ae272 1452 # literal SQL with bind
1453 my ($sql, @bind) = @$v;
1454 $self->_assert_bindval_matches_bindtype(@bind);
96449e8e 1455 push @sqlq, "$label = $sql";
fe3ae272 1456 push @sqlv, @bind;
96449e8e 1457 } elsif ($r eq 'SCALAR') {
fe3ae272 1458 # literal SQL without bind
96449e8e 1459 push @sqlq, "$label = $$v";
9d48860e 1460 } else {
96449e8e 1461 push @sqlq, "$label = ?";
1462 push @sqlv, $self->_bindtype($k, $v);
1463 }
1464 }
1465 push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
1466 } elsif ($ref eq 'ARRAY') {
1467 # unlike insert(), assume these are ONLY the column names, i.e. for SQL
1468 for my $v (@$_) {
1469 my $r = ref $v;
fe3ae272 1470 if ($r eq 'ARRAY') { # literal SQL with bind
1471 my ($sql, @bind) = @$v;
1472 $self->_assert_bindval_matches_bindtype(@bind);
1473 push @sqlq, $sql;
1474 push @sqlv, @bind;
1475 } elsif ($r eq 'SCALAR') { # literal SQL without bind
96449e8e 1476 # embedded literal SQL
1477 push @sqlq, $$v;
9d48860e 1478 } else {
96449e8e 1479 push @sqlq, '?';
1480 push @sqlv, $v;
1481 }
1482 }
1483 push @sql, '(' . join(', ', @sqlq) . ')';
1484 } elsif ($ref eq 'SCALAR') {
1485 # literal SQL
1486 push @sql, $$_;
1487 } else {
1488 # strings get case twiddled
1489 push @sql, $self->_sqlcase($_);
1490 }
1491 }
1492
1493 my $sql = join ' ', @sql;
1494
1495 # this is pretty tricky
1496 # if ask for an array, return ($stmt, @bind)
1497 # otherwise, s/?/shift @sqlv/ to put it inline
1498 if (wantarray) {
1499 return ($sql, @sqlv);
1500 } else {
1501 1 while $sql =~ s/\?/my $d = shift(@sqlv);
1502 ref $d ? $d->[1] : $d/e;
1503 return $sql;
1504 }
1505}
1506
1507
1508sub DESTROY { 1 }
1509
1510sub AUTOLOAD {
1511 # This allows us to check for a local, then _form, attr
1512 my $self = shift;
1513 my($name) = $AUTOLOAD =~ /.*::(.+)/;
1514 return $self->generate($name, @_);
1515}
1516
15171;
1518
1519
1520
1521__END__
32eab2da 1522
1523=head1 NAME
1524
1525SQL::Abstract - Generate SQL from Perl data structures
1526
1527=head1 SYNOPSIS
1528
1529 use SQL::Abstract;
1530
1531 my $sql = SQL::Abstract->new;
1532
521647e7 1533 my($stmt, @bind) = $sql->select($source, \@fields, \%where, \@order);
32eab2da 1534
1535 my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
1536
1537 my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where);
1538
1539 my($stmt, @bind) = $sql->delete($table, \%where);
1540
1541 # Then, use these in your DBI statements
1542 my $sth = $dbh->prepare($stmt);
1543 $sth->execute(@bind);
1544
1545 # Just generate the WHERE clause
abe72f94 1546 my($stmt, @bind) = $sql->where(\%where, \@order);
32eab2da 1547
1548 # Return values in the same order, for hashed queries
1549 # See PERFORMANCE section for more details
1550 my @bind = $sql->values(\%fieldvals);
1551
1552=head1 DESCRIPTION
1553
1554This module was inspired by the excellent L<DBIx::Abstract>.
1555However, in using that module I found that what I really wanted
1556to do was generate SQL, but still retain complete control over my
1557statement handles and use the DBI interface. So, I set out to
1558create an abstract SQL generation module.
1559
1560While based on the concepts used by L<DBIx::Abstract>, there are
1561several important differences, especially when it comes to WHERE
1562clauses. I have modified the concepts used to make the SQL easier
1563to generate from Perl data structures and, IMO, more intuitive.
1564The underlying idea is for this module to do what you mean, based
1565on the data structures you provide it. The big advantage is that
1566you don't have to modify your code every time your data changes,
1567as this module figures it out.
1568
1569To begin with, an SQL INSERT is as easy as just specifying a hash
1570of C<key=value> pairs:
1571
1572 my %data = (
1573 name => 'Jimbo Bobson',
1574 phone => '123-456-7890',
1575 address => '42 Sister Lane',
1576 city => 'St. Louis',
1577 state => 'Louisiana',
1578 );
1579
1580The SQL can then be generated with this:
1581
1582 my($stmt, @bind) = $sql->insert('people', \%data);
1583
1584Which would give you something like this:
1585
1586 $stmt = "INSERT INTO people
1587 (address, city, name, phone, state)
1588 VALUES (?, ?, ?, ?, ?)";
1589 @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson',
1590 '123-456-7890', 'Louisiana');
1591
1592These are then used directly in your DBI code:
1593
1594 my $sth = $dbh->prepare($stmt);
1595 $sth->execute(@bind);
1596
96449e8e 1597=head2 Inserting and Updating Arrays
1598
1599If your database has array types (like for example Postgres),
1600activate the special option C<< array_datatypes => 1 >>
9d48860e 1601when creating the C<SQL::Abstract> object.
96449e8e 1602Then you may use an arrayref to insert and update database array types:
1603
1604 my $sql = SQL::Abstract->new(array_datatypes => 1);
1605 my %data = (
1606 planets => [qw/Mercury Venus Earth Mars/]
1607 );
9d48860e 1608
96449e8e 1609 my($stmt, @bind) = $sql->insert('solar_system', \%data);
1610
1611This results in:
1612
1613 $stmt = "INSERT INTO solar_system (planets) VALUES (?)"
1614
1615 @bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
1616
1617
1618=head2 Inserting and Updating SQL
1619
1620In order to apply SQL functions to elements of your C<%data> you may
1621specify a reference to an arrayref for the given hash value. For example,
1622if you need to execute the Oracle C<to_date> function on a value, you can
1623say something like this:
32eab2da 1624
1625 my %data = (
1626 name => 'Bill',
96449e8e 1627 date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
9d48860e 1628 );
32eab2da 1629
1630The first value in the array is the actual SQL. Any other values are
1631optional and would be included in the bind values array. This gives
1632you:
1633
1634 my($stmt, @bind) = $sql->insert('people', \%data);
1635
9d48860e 1636 $stmt = "INSERT INTO people (name, date_entered)
32eab2da 1637 VALUES (?, to_date(?,'MM/DD/YYYY'))";
1638 @bind = ('Bill', '03/02/2003');
1639
1640An UPDATE is just as easy, all you change is the name of the function:
1641
1642 my($stmt, @bind) = $sql->update('people', \%data);
1643
1644Notice that your C<%data> isn't touched; the module will generate
1645the appropriately quirky SQL for you automatically. Usually you'll
1646want to specify a WHERE clause for your UPDATE, though, which is
1647where handling C<%where> hashes comes in handy...
1648
96449e8e 1649=head2 Complex where statements
1650
32eab2da 1651This module can generate pretty complicated WHERE statements
1652easily. For example, simple C<key=value> pairs are taken to mean
1653equality, and if you want to see if a field is within a set
1654of values, you can use an arrayref. Let's say we wanted to
1655SELECT some data based on this criteria:
1656
1657 my %where = (
1658 requestor => 'inna',
1659 worker => ['nwiger', 'rcwe', 'sfz'],
1660 status => { '!=', 'completed' }
1661 );
1662
1663 my($stmt, @bind) = $sql->select('tickets', '*', \%where);
1664
1665The above would give you something like this:
1666
1667 $stmt = "SELECT * FROM tickets WHERE
1668 ( requestor = ? ) AND ( status != ? )
1669 AND ( worker = ? OR worker = ? OR worker = ? )";
1670 @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
1671
1672Which you could then use in DBI code like so:
1673
1674 my $sth = $dbh->prepare($stmt);
1675 $sth->execute(@bind);
1676
1677Easy, eh?
1678
1679=head1 FUNCTIONS
1680
1681The functions are simple. There's one for each major SQL operation,
1682and a constructor you use first. The arguments are specified in a
9d48860e 1683similar order to each function (table, then fields, then a where
32eab2da 1684clause) to try and simplify things.
1685
83cab70b 1686
83cab70b 1687
32eab2da 1688
1689=head2 new(option => 'value')
1690
1691The C<new()> function takes a list of options and values, and returns
1692a new B<SQL::Abstract> object which can then be used to generate SQL
1693through the methods below. The options accepted are:
1694
1695=over
1696
1697=item case
1698
1699If set to 'lower', then SQL will be generated in all lowercase. By
1700default SQL is generated in "textbook" case meaning something like:
1701
1702 SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
1703
96449e8e 1704Any setting other than 'lower' is ignored.
1705
32eab2da 1706=item cmp
1707
1708This determines what the default comparison operator is. By default
1709it is C<=>, meaning that a hash like this:
1710
1711 %where = (name => 'nwiger', email => 'nate@wiger.org');
1712
1713Will generate SQL like this:
1714
1715 WHERE name = 'nwiger' AND email = 'nate@wiger.org'
1716
1717However, you may want loose comparisons by default, so if you set
1718C<cmp> to C<like> you would get SQL such as:
1719
1720 WHERE name like 'nwiger' AND email like 'nate@wiger.org'
1721
3af02ccb 1722You can also override the comparison on an individual basis - see
32eab2da 1723the huge section on L</"WHERE CLAUSES"> at the bottom.
1724
96449e8e 1725=item sqltrue, sqlfalse
1726
1727Expressions for inserting boolean values within SQL statements.
6e0c6552 1728By default these are C<1=1> and C<1=0>. They are used
1729by the special operators C<-in> and C<-not_in> for generating
1730correct SQL even when the argument is an empty array (see below).
96449e8e 1731
32eab2da 1732=item logic
1733
1734This determines the default logical operator for multiple WHERE
7cac25e6 1735statements in arrays or hashes. If absent, the default logic is "or"
1736for arrays, and "and" for hashes. This means that a WHERE
32eab2da 1737array of the form:
1738
1739 @where = (
9d48860e 1740 event_date => {'>=', '2/13/99'},
1741 event_date => {'<=', '4/24/03'},
32eab2da 1742 );
1743
7cac25e6 1744will generate SQL like this:
32eab2da 1745
1746 WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
1747
1748This is probably not what you want given this query, though (look
1749at the dates). To change the "OR" to an "AND", simply specify:
1750
1751 my $sql = SQL::Abstract->new(logic => 'and');
1752
1753Which will change the above C<WHERE> to:
1754
1755 WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
1756
96449e8e 1757The logic can also be changed locally by inserting
7cac25e6 1758a modifier in front of an arrayref :
96449e8e 1759
9d48860e 1760 @where = (-and => [event_date => {'>=', '2/13/99'},
7cac25e6 1761 event_date => {'<=', '4/24/03'} ]);
96449e8e 1762
1763See the L</"WHERE CLAUSES"> section for explanations.
1764
32eab2da 1765=item convert
1766
1767This will automatically convert comparisons using the specified SQL
1768function for both column and value. This is mostly used with an argument
1769of C<upper> or C<lower>, so that the SQL will have the effect of
1770case-insensitive "searches". For example, this:
1771
1772 $sql = SQL::Abstract->new(convert => 'upper');
1773 %where = (keywords => 'MaKe iT CAse inSeNSItive');
1774
1775Will turn out the following SQL:
1776
1777 WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive')
1778
1779The conversion can be C<upper()>, C<lower()>, or any other SQL function
1780that can be applied symmetrically to fields (actually B<SQL::Abstract> does
1781not validate this option; it will just pass through what you specify verbatim).
1782
1783=item bindtype
1784
1785This is a kludge because many databases suck. For example, you can't
1786just bind values using DBI's C<execute()> for Oracle C<CLOB> or C<BLOB> fields.
1787Instead, you have to use C<bind_param()>:
1788
1789 $sth->bind_param(1, 'reg data');
1790 $sth->bind_param(2, $lots, {ora_type => ORA_CLOB});
1791
1792The problem is, B<SQL::Abstract> will normally just return a C<@bind> array,
1793which loses track of which field each slot refers to. Fear not.
1794
1795If you specify C<bindtype> in new, you can determine how C<@bind> is returned.
1796Currently, you can specify either C<normal> (default) or C<columns>. If you
1797specify C<columns>, you will get an array that looks like this:
1798
1799 my $sql = SQL::Abstract->new(bindtype => 'columns');
1800 my($stmt, @bind) = $sql->insert(...);
1801
1802 @bind = (
1803 [ 'column1', 'value1' ],
1804 [ 'column2', 'value2' ],
1805 [ 'column3', 'value3' ],
1806 );
1807
1808You can then iterate through this manually, using DBI's C<bind_param()>.
e3f9dff4 1809
32eab2da 1810 $sth->prepare($stmt);
1811 my $i = 1;
1812 for (@bind) {
1813 my($col, $data) = @$_;
1814 if ($col eq 'details' || $col eq 'comments') {
1815 $sth->bind_param($i, $data, {ora_type => ORA_CLOB});
1816 } elsif ($col eq 'image') {
1817 $sth->bind_param($i, $data, {ora_type => ORA_BLOB});
1818 } else {
1819 $sth->bind_param($i, $data);
1820 }
1821 $i++;
1822 }
1823 $sth->execute; # execute without @bind now
1824
1825Now, why would you still use B<SQL::Abstract> if you have to do this crap?
1826Basically, the advantage is still that you don't have to care which fields
1827are or are not included. You could wrap that above C<for> loop in a simple
1828sub called C<bind_fields()> or something and reuse it repeatedly. You still
1829get a layer of abstraction over manual SQL specification.
1830
deb148a2 1831Note that if you set L</bindtype> to C<columns>, the C<\[$sql, @bind]>
1832construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
1833will expect the bind values in this format.
1834
32eab2da 1835=item quote_char
1836
1837This is the character that a table or column name will be quoted
9d48860e 1838with. By default this is an empty string, but you could set it to
32eab2da 1839the character C<`>, to generate SQL like this:
1840
1841 SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
1842
96449e8e 1843Alternatively, you can supply an array ref of two items, the first being the left
1844hand quote character, and the second the right hand quote character. For
1845example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes
1846that generates SQL like this:
1847
1848 SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%'
1849
9d48860e 1850Quoting is useful if you have tables or columns names that are reserved
96449e8e 1851words in your database's SQL dialect.
32eab2da 1852
1853=item name_sep
1854
1855This is the character that separates a table and column name. It is
1856necessary to specify this when the C<quote_char> option is selected,
1857so that tables and column names can be individually quoted like this:
1858
1859 SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
1860
b6251592 1861=item injection_guard
1862
1863A regular expression C<qr/.../> that is applied to any C<-function> and unquoted
1864column name specified in a query structure. This is a safety mechanism to avoid
1865injection attacks when mishandling user input e.g.:
1866
1867 my %condition_as_column_value_pairs = get_values_from_user();
1868 $sqla->select( ... , \%condition_as_column_value_pairs );
1869
1870If the expression matches an exception is thrown. Note that literal SQL
1871supplied via C<\'...'> or C<\['...']> is B<not> checked in any way.
1872
1873Defaults to checking for C<;> and the C<GO> keyword (TransactSQL)
1874
96449e8e 1875=item array_datatypes
32eab2da 1876
9d48860e 1877When this option is true, arrayrefs in INSERT or UPDATE are
1878interpreted as array datatypes and are passed directly
96449e8e 1879to the DBI layer.
1880When this option is false, arrayrefs are interpreted
1881as literal SQL, just like refs to arrayrefs
1882(but this behavior is for backwards compatibility; when writing
1883new queries, use the "reference to arrayref" syntax
1884for literal SQL).
32eab2da 1885
32eab2da 1886
96449e8e 1887=item special_ops
32eab2da 1888
9d48860e 1889Takes a reference to a list of "special operators"
96449e8e 1890to extend the syntax understood by L<SQL::Abstract>.
1891See section L</"SPECIAL OPERATORS"> for details.
32eab2da 1892
59f23b3d 1893=item unary_ops
1894
9d48860e 1895Takes a reference to a list of "unary operators"
59f23b3d 1896to extend the syntax understood by L<SQL::Abstract>.
1897See section L</"UNARY OPERATORS"> for details.
1898
32eab2da 1899
32eab2da 1900
96449e8e 1901=back
32eab2da 1902
02288357 1903=head2 insert($table, \@values || \%fieldvals, \%options)
32eab2da 1904
1905This is the simplest function. You simply give it a table name
1906and either an arrayref of values or hashref of field/value pairs.
1907It returns an SQL INSERT statement and a list of bind values.
96449e8e 1908See the sections on L</"Inserting and Updating Arrays"> and
1909L</"Inserting and Updating SQL"> for information on how to insert
1910with those data types.
32eab2da 1911
02288357 1912The optional C<\%options> hash reference may contain additional
1913options to generate the insert SQL. Currently supported options
1914are:
1915
1916=over 4
1917
1918=item returning
1919
1920Takes either a scalar of raw SQL fields, or an array reference of
1921field names, and adds on an SQL C<RETURNING> statement at the end.
1922This allows you to return data generated by the insert statement
1923(such as row IDs) without performing another C<SELECT> statement.
1924Note, however, this is not part of the SQL standard and may not
1925be supported by all database engines.
1926
1927=back
1928
32eab2da 1929=head2 update($table, \%fieldvals, \%where)
1930
1931This takes a table, hashref of field/value pairs, and an optional
86298391 1932hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
32eab2da 1933of bind values.
96449e8e 1934See the sections on L</"Inserting and Updating Arrays"> and
1935L</"Inserting and Updating SQL"> for information on how to insert
1936with those data types.
32eab2da 1937
96449e8e 1938=head2 select($source, $fields, $where, $order)
32eab2da 1939
9d48860e 1940This returns a SQL SELECT statement and associated list of bind values, as
96449e8e 1941specified by the arguments :
32eab2da 1942
96449e8e 1943=over
32eab2da 1944
96449e8e 1945=item $source
32eab2da 1946
9d48860e 1947Specification of the 'FROM' part of the statement.
96449e8e 1948The argument can be either a plain scalar (interpreted as a table
1949name, will be quoted), or an arrayref (interpreted as a list
1950of table names, joined by commas, quoted), or a scalarref
1951(literal table name, not quoted), or a ref to an arrayref
1952(list of literal table names, joined by commas, not quoted).
32eab2da 1953
96449e8e 1954=item $fields
32eab2da 1955
9d48860e 1956Specification of the list of fields to retrieve from
96449e8e 1957the source.
1958The argument can be either an arrayref (interpreted as a list
9d48860e 1959of field names, will be joined by commas and quoted), or a
96449e8e 1960plain scalar (literal SQL, not quoted).
521647e7 1961Please observe that this API is not as flexible as that of
1962the first argument C<$source>, for backwards compatibility reasons.
32eab2da 1963
96449e8e 1964=item $where
32eab2da 1965
96449e8e 1966Optional argument to specify the WHERE part of the query.
1967The argument is most often a hashref, but can also be
9d48860e 1968an arrayref or plain scalar --
96449e8e 1969see section L<WHERE clause|/"WHERE CLAUSES"> for details.
32eab2da 1970
96449e8e 1971=item $order
32eab2da 1972
96449e8e 1973Optional argument to specify the ORDER BY part of the query.
9d48860e 1974The argument can be a scalar, a hashref or an arrayref
96449e8e 1975-- see section L<ORDER BY clause|/"ORDER BY CLAUSES">
1976for details.
32eab2da 1977
96449e8e 1978=back
32eab2da 1979
32eab2da 1980
1981=head2 delete($table, \%where)
1982
86298391 1983This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
32eab2da 1984It returns an SQL DELETE statement and list of bind values.
1985
32eab2da 1986=head2 where(\%where, \@order)
1987
1988This is used to generate just the WHERE clause. For example,
1989if you have an arbitrary data structure and know what the
1990rest of your SQL is going to look like, but want an easy way
1991to produce a WHERE clause, use this. It returns an SQL WHERE
1992clause and list of bind values.
1993
32eab2da 1994
1995=head2 values(\%data)
1996
1997This just returns the values from the hash C<%data>, in the same
1998order that would be returned from any of the other above queries.
1999Using this allows you to markedly speed up your queries if you
2000are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
2001
32eab2da 2002=head2 generate($any, 'number', $of, \@data, $struct, \%types)
2003
2004Warning: This is an experimental method and subject to change.
2005
2006This returns arbitrarily generated SQL. It's a really basic shortcut.
2007It will return two different things, depending on return context:
2008
2009 my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
2010 my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
2011
2012These would return the following:
2013
2014 # First calling form
2015 $stmt = "CREATE TABLE test (?, ?)";
2016 @bind = (field1, field2);
2017
2018 # Second calling form
2019 $stmt_and_val = "CREATE TABLE test (field1, field2)";
2020
2021Depending on what you're trying to do, it's up to you to choose the correct
2022format. In this example, the second form is what you would want.
2023
2024By the same token:
2025
2026 $sql->generate('alter session', { nls_date_format => 'MM/YY' });
2027
2028Might give you:
2029
2030 ALTER SESSION SET nls_date_format = 'MM/YY'
2031
2032You get the idea. Strings get their case twiddled, but everything
2033else remains verbatim.
2034
32eab2da 2035=head1 WHERE CLAUSES
2036
96449e8e 2037=head2 Introduction
2038
32eab2da 2039This module uses a variation on the idea from L<DBIx::Abstract>. It
2040is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
2041module is that things in arrays are OR'ed, and things in hashes
2042are AND'ed.>
2043
2044The easiest way to explain is to show lots of examples. After
2045each C<%where> hash shown, it is assumed you used:
2046
2047 my($stmt, @bind) = $sql->where(\%where);
2048
2049However, note that the C<%where> hash can be used directly in any
2050of the other functions as well, as described above.
2051
96449e8e 2052=head2 Key-value pairs
2053
32eab2da 2054So, let's get started. To begin, a simple hash:
2055
2056 my %where = (
2057 user => 'nwiger',
2058 status => 'completed'
2059 );
2060
2061Is converted to SQL C<key = val> statements:
2062
2063 $stmt = "WHERE user = ? AND status = ?";
2064 @bind = ('nwiger', 'completed');
2065
2066One common thing I end up doing is having a list of values that
2067a field can be in. To do this, simply specify a list inside of
2068an arrayref:
2069
2070 my %where = (
2071 user => 'nwiger',
2072 status => ['assigned', 'in-progress', 'pending'];
2073 );
2074
2075This simple code will create the following:
9d48860e 2076
32eab2da 2077 $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
2078 @bind = ('nwiger', 'assigned', 'in-progress', 'pending');
2079
9d48860e 2080A field associated to an empty arrayref will be considered a
7cac25e6 2081logical false and will generate 0=1.
8a68b5be 2082
b864ba9b 2083=head2 Tests for NULL values
2084
2085If the value part is C<undef> then this is converted to SQL <IS NULL>
2086
2087 my %where = (
2088 user => 'nwiger',
2089 status => undef,
2090 );
2091
2092becomes:
2093
2094 $stmt = "WHERE user = ? AND status IS NULL";
2095 @bind = ('nwiger');
2096
e9614080 2097To test if a column IS NOT NULL:
2098
2099 my %where = (
2100 user => 'nwiger',
2101 status => { '!=', undef },
2102 );
cc422895 2103
6e0c6552 2104=head2 Specific comparison operators
96449e8e 2105
32eab2da 2106If you want to specify a different type of operator for your comparison,
2107you can use a hashref for a given column:
2108
2109 my %where = (
2110 user => 'nwiger',
2111 status => { '!=', 'completed' }
2112 );
2113
2114Which would generate:
2115
2116 $stmt = "WHERE user = ? AND status != ?";
2117 @bind = ('nwiger', 'completed');
2118
2119To test against multiple values, just enclose the values in an arrayref:
2120
96449e8e 2121 status => { '=', ['assigned', 'in-progress', 'pending'] };
2122
f2d5020d 2123Which would give you:
96449e8e 2124
2125 "WHERE status = ? OR status = ? OR status = ?"
2126
2127
2128The hashref can also contain multiple pairs, in which case it is expanded
32eab2da 2129into an C<AND> of its elements:
2130
2131 my %where = (
2132 user => 'nwiger',
2133 status => { '!=', 'completed', -not_like => 'pending%' }
2134 );
2135
2136 # Or more dynamically, like from a form
2137 $where{user} = 'nwiger';
2138 $where{status}{'!='} = 'completed';
2139 $where{status}{'-not_like'} = 'pending%';
2140
2141 # Both generate this
2142 $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
2143 @bind = ('nwiger', 'completed', 'pending%');
2144
96449e8e 2145
32eab2da 2146To get an OR instead, you can combine it with the arrayref idea:
2147
2148 my %where => (
2149 user => 'nwiger',
1a6f2a03 2150 priority => [ { '=', 2 }, { '>', 5 } ]
32eab2da 2151 );
2152
2153Which would generate:
2154
1a6f2a03 2155 $stmt = "WHERE ( priority = ? OR priority > ? ) AND user = ?";
2156 @bind = ('2', '5', 'nwiger');
32eab2da 2157
44b9e502 2158If you want to include literal SQL (with or without bind values), just use a
2159scalar reference or array reference as the value:
2160
2161 my %where = (
2162 date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
2163 date_expires => { '<' => \"now()" }
2164 );
2165
2166Which would generate:
2167
2168 $stmt = "WHERE date_entered > "to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
2169 @bind = ('11/26/2008');
2170
96449e8e 2171
2172=head2 Logic and nesting operators
2173
2174In the example above,
2175there is a subtle trap if you want to say something like
32eab2da 2176this (notice the C<AND>):
2177
2178 WHERE priority != ? AND priority != ?
2179
2180Because, in Perl you I<can't> do this:
2181
2182 priority => { '!=', 2, '!=', 1 }
2183
2184As the second C<!=> key will obliterate the first. The solution
2185is to use the special C<-modifier> form inside an arrayref:
2186
9d48860e 2187 priority => [ -and => {'!=', 2},
96449e8e 2188 {'!=', 1} ]
2189
32eab2da 2190
2191Normally, these would be joined by C<OR>, but the modifier tells it
2192to use C<AND> instead. (Hint: You can use this in conjunction with the
2193C<logic> option to C<new()> in order to change the way your queries
2194work by default.) B<Important:> Note that the C<-modifier> goes
2195B<INSIDE> the arrayref, as an extra first element. This will
2196B<NOT> do what you think it might:
2197
2198 priority => -and => [{'!=', 2}, {'!=', 1}] # WRONG!
2199
2200Here is a quick list of equivalencies, since there is some overlap:
2201
2202 # Same
2203 status => {'!=', 'completed', 'not like', 'pending%' }
2204 status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}]
2205
2206 # Same
2207 status => {'=', ['assigned', 'in-progress']}
2208 status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
2209 status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
2210
e3f9dff4 2211
2212
96449e8e 2213=head2 Special operators : IN, BETWEEN, etc.
2214
32eab2da 2215You can also use the hashref format to compare a list of fields using the
2216C<IN> comparison operator, by specifying the list as an arrayref:
2217
2218 my %where = (
2219 status => 'completed',
2220 reportid => { -in => [567, 2335, 2] }
2221 );
2222
2223Which would generate:
2224
2225 $stmt = "WHERE status = ? AND reportid IN (?,?,?)";
2226 @bind = ('completed', '567', '2335', '2');
2227
9d48860e 2228The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in
96449e8e 2229the same way.
2230
6e0c6552 2231If the argument to C<-in> is an empty array, 'sqlfalse' is generated
2232(by default : C<1=0>). Similarly, C<< -not_in => [] >> generates
2233'sqltrue' (by default : C<1=1>).
2234
e41c3bdd 2235In addition to the array you can supply a chunk of literal sql or
2236literal sql with bind:
6e0c6552 2237
e41c3bdd 2238 my %where = {
2239 customer => { -in => \[
2240 'SELECT cust_id FROM cust WHERE balance > ?',
2241 2000,
2242 ],
2243 status => { -in => \'SELECT status_codes FROM states' },
2244 };
6e0c6552 2245
e41c3bdd 2246would generate:
2247
2248 $stmt = "WHERE (
2249 customer IN ( SELECT cust_id FROM cust WHERE balance > ? )
2250 AND status IN ( SELECT status_codes FROM states )
2251 )";
2252 @bind = ('2000');
2253
0dfd2442 2254Finally, if the argument to C<-in> is not a reference, it will be
2255treated as a single-element array.
e41c3bdd 2256
2257Another pair of operators is C<-between> and C<-not_between>,
96449e8e 2258used with an arrayref of two values:
32eab2da 2259
2260 my %where = (
2261 user => 'nwiger',
2262 completion_date => {
2263 -not_between => ['2002-10-01', '2003-02-06']
2264 }
2265 );
2266
2267Would give you:
2268
2269 WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
2270
e41c3bdd 2271Just like with C<-in> all plausible combinations of literal SQL
2272are possible:
2273
2274 my %where = {
2275 start0 => { -between => [ 1, 2 ] },
2276 start1 => { -between => \["? AND ?", 1, 2] },
2277 start2 => { -between => \"lower(x) AND upper(y)" },
9d48860e 2278 start3 => { -between => [
e41c3bdd 2279 \"lower(x)",
2280 \["upper(?)", 'stuff' ],
2281 ] },
2282 };
2283
2284Would give you:
2285
2286 $stmt = "WHERE (
2287 ( start0 BETWEEN ? AND ? )
2288 AND ( start1 BETWEEN ? AND ? )
2289 AND ( start2 BETWEEN lower(x) AND upper(y) )
2290 AND ( start3 BETWEEN lower(x) AND upper(?) )
2291 )";
2292 @bind = (1, 2, 1, 2, 'stuff');
2293
2294
9d48860e 2295These are the two builtin "special operators"; but the
96449e8e 2296list can be expanded : see section L</"SPECIAL OPERATORS"> below.
2297
59f23b3d 2298=head2 Unary operators: bool
97a920ef 2299
2300If you wish to test against boolean columns or functions within your
2301database you can use the C<-bool> and C<-not_bool> operators. For
2302example to test the column C<is_user> being true and the column
827bb0eb 2303C<is_enabled> being false you would use:-
97a920ef 2304
2305 my %where = (
2306 -bool => 'is_user',
2307 -not_bool => 'is_enabled',
2308 );
2309
2310Would give you:
2311
277b5d3f 2312 WHERE is_user AND NOT is_enabled
97a920ef 2313
0b604e9d 2314If a more complex combination is required, testing more conditions,
2315then you should use the and/or operators:-
2316
2317 my %where = (
2318 -and => [
2319 -bool => 'one',
23401b81 2320 -not_bool => { two=> { -rlike => 'bar' } },
2321 -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] },
0b604e9d 2322 ],
2323 );
2324
2325Would give you:
2326
23401b81 2327 WHERE
2328 one
2329 AND
2330 (NOT two RLIKE ?)
2331 AND
2332 (NOT ( three = ? OR three > ? ))
97a920ef 2333
2334
107b72f1 2335=head2 Nested conditions, -and/-or prefixes
96449e8e 2336
32eab2da 2337So far, we've seen how multiple conditions are joined with a top-level
2338C<AND>. We can change this by putting the different conditions we want in
2339hashes and then putting those hashes in an array. For example:
2340
2341 my @where = (
2342 {
2343 user => 'nwiger',
2344 status => { -like => ['pending%', 'dispatched'] },
2345 },
2346 {
2347 user => 'robot',
2348 status => 'unassigned',
2349 }
2350 );
2351
2352This data structure would create the following:
2353
2354 $stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) )
2355 OR ( user = ? AND status = ? ) )";
2356 @bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
2357
107b72f1 2358
48d9f5f8 2359Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or>
2360to change the logic inside :
32eab2da 2361
2362 my @where = (
2363 -and => [
2364 user => 'nwiger',
48d9f5f8 2365 [
2366 -and => [ workhrs => {'>', 20}, geo => 'ASIA' ],
2367 -or => { workhrs => {'<', 50}, geo => 'EURO' },
32eab2da 2368 ],
2369 ],
2370 );
2371
2372That would yield:
2373
48d9f5f8 2374 WHERE ( user = ? AND (
2375 ( workhrs > ? AND geo = ? )
2376 OR ( workhrs < ? OR geo = ? )
2377 ) )
107b72f1 2378
cc422895 2379=head3 Algebraic inconsistency, for historical reasons
107b72f1 2380
7cac25e6 2381C<Important note>: when connecting several conditions, the C<-and->|C<-or>
2382operator goes C<outside> of the nested structure; whereas when connecting
2383several constraints on one column, the C<-and> operator goes
2384C<inside> the arrayref. Here is an example combining both features :
2385
2386 my @where = (
2387 -and => [a => 1, b => 2],
2388 -or => [c => 3, d => 4],
2389 e => [-and => {-like => 'foo%'}, {-like => '%bar'} ]
2390 )
2391
2392yielding
2393
9d48860e 2394 WHERE ( ( ( a = ? AND b = ? )
2395 OR ( c = ? OR d = ? )
7cac25e6 2396 OR ( e LIKE ? AND e LIKE ? ) ) )
2397
107b72f1 2398This difference in syntax is unfortunate but must be preserved for
2399historical reasons. So be careful : the two examples below would
2400seem algebraically equivalent, but they are not
2401
9d48860e 2402 {col => [-and => {-like => 'foo%'}, {-like => '%bar'}]}
107b72f1 2403 # yields : WHERE ( ( col LIKE ? AND col LIKE ? ) )
2404
9d48860e 2405 [-and => {col => {-like => 'foo%'}, {col => {-like => '%bar'}}]]
107b72f1 2406 # yields : WHERE ( ( col LIKE ? OR col LIKE ? ) )
2407
7cac25e6 2408
cc422895 2409=head2 Literal SQL and value type operators
96449e8e 2410
cc422895 2411The basic premise of SQL::Abstract is that in WHERE specifications the "left
2412side" is a column name and the "right side" is a value (normally rendered as
2413a placeholder). This holds true for both hashrefs and arrayref pairs as you
2414see in the L</WHERE CLAUSES> examples above. Sometimes it is necessary to
2415alter this behavior. There are several ways of doing so.
e9614080 2416
cc422895 2417=head3 -ident
2418
2419This is a virtual operator that signals the string to its right side is an
2420identifier (a column name) and not a value. For example to compare two
2421columns you would write:
32eab2da 2422
e9614080 2423 my %where = (
2424 priority => { '<', 2 },
cc422895 2425 requestor => { -ident => 'submitter' },
e9614080 2426 );
2427
2428which creates:
2429
2430 $stmt = "WHERE priority < ? AND requestor = submitter";
2431 @bind = ('2');
2432
cc422895 2433If you are maintaining legacy code you may see a different construct as
2434described in L</Deprecated usage of Literal SQL>, please use C<-ident> in new
2435code.
2436
2437=head3 -value
e9614080 2438
cc422895 2439This is a virtual operator that signals that the construct to its right side
2440is a value to be passed to DBI. This is for example necessary when you want
2441to write a where clause against an array (for RDBMS that support such
2442datatypes). For example:
e9614080 2443
32eab2da 2444 my %where = (
cc422895 2445 array => { -value => [1, 2, 3] }
32eab2da 2446 );
2447
cc422895 2448will result in:
32eab2da 2449
cc422895 2450 $stmt = 'WHERE array = ?';
2451 @bind = ([1, 2, 3]);
32eab2da 2452
cc422895 2453Note that if you were to simply say:
32eab2da 2454
2455 my %where = (
cc422895 2456 array => [1, 2, 3]
32eab2da 2457 );
2458
3af02ccb 2459the result would probably not be what you wanted:
cc422895 2460
2461 $stmt = 'WHERE array = ? OR array = ? OR array = ?';
2462 @bind = (1, 2, 3);
2463
2464=head3 Literal SQL
96449e8e 2465
cc422895 2466Finally, sometimes only literal SQL will do. To include a random snippet
2467of SQL verbatim, you specify it as a scalar reference. Consider this only
2468as a last resort. Usually there is a better way. For example:
96449e8e 2469
2470 my %where = (
cc422895 2471 priority => { '<', 2 },
2472 requestor => { -in => \'(SELECT name FROM hitmen)' },
96449e8e 2473 );
2474
cc422895 2475Would create:
96449e8e 2476
cc422895 2477 $stmt = "WHERE priority < ? AND requestor IN (SELECT name FROM hitmen)"
2478 @bind = (2);
2479
2480Note that in this example, you only get one bind parameter back, since
2481the verbatim SQL is passed as part of the statement.
2482
2483=head4 CAVEAT
2484
2485 Never use untrusted input as a literal SQL argument - this is a massive
2486 security risk (there is no way to check literal snippets for SQL
2487 injections and other nastyness). If you need to deal with untrusted input
2488 use literal SQL with placeholders as described next.
96449e8e 2489
cc422895 2490=head3 Literal SQL with placeholders and bind values (subqueries)
96449e8e 2491
2492If the literal SQL to be inserted has placeholders and bind values,
2493use a reference to an arrayref (yes this is a double reference --
2494not so common, but perfectly legal Perl). For example, to find a date
2495in Postgres you can use something like this:
2496
2497 my %where = (
2498 date_column => \[q/= date '2008-09-30' - ?::integer/, 10/]
2499 )
2500
2501This would create:
2502
d2a8fe1a 2503 $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )"
96449e8e 2504 @bind = ('10');
2505
deb148a2 2506Note that you must pass the bind values in the same format as they are returned
62552e7d 2507by L</where>. That means that if you set L</bindtype> to C<columns>, you must
26f2dca5 2508provide the bind values in the C<< [ column_meta => value ] >> format, where
2509C<column_meta> is an opaque scalar value; most commonly the column name, but
62552e7d 2510you can use any scalar value (including references and blessed references),
2511L<SQL::Abstract> will simply pass it through intact. So if C<bindtype> is set
2512to C<columns> the above example will look like:
deb148a2 2513
2514 my %where = (
2515 date_column => \[q/= date '2008-09-30' - ?::integer/, [ dummy => 10 ]/]
2516 )
96449e8e 2517
2518Literal SQL is especially useful for nesting parenthesized clauses in the
2519main SQL query. Here is a first example :
2520
2521 my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
2522 100, "foo%");
2523 my %where = (
2524 foo => 1234,
2525 bar => \["IN ($sub_stmt)" => @sub_bind],
2526 );
2527
2528This yields :
2529
9d48860e 2530 $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1
96449e8e 2531 WHERE c2 < ? AND c3 LIKE ?))";
2532 @bind = (1234, 100, "foo%");
2533
9d48860e 2534Other subquery operators, like for example C<"E<gt> ALL"> or C<"NOT IN">,
96449e8e 2535are expressed in the same way. Of course the C<$sub_stmt> and
9d48860e 2536its associated bind values can be generated through a former call
96449e8e 2537to C<select()> :
2538
2539 my ($sub_stmt, @sub_bind)
9d48860e 2540 = $sql->select("t1", "c1", {c2 => {"<" => 100},
96449e8e 2541 c3 => {-like => "foo%"}});
2542 my %where = (
2543 foo => 1234,
2544 bar => \["> ALL ($sub_stmt)" => @sub_bind],
2545 );
2546
2547In the examples above, the subquery was used as an operator on a column;
9d48860e 2548but the same principle also applies for a clause within the main C<%where>
96449e8e 2549hash, like an EXISTS subquery :
2550
9d48860e 2551 my ($sub_stmt, @sub_bind)
96449e8e 2552 = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
48d9f5f8 2553 my %where = ( -and => [
96449e8e 2554 foo => 1234,
48d9f5f8 2555 \["EXISTS ($sub_stmt)" => @sub_bind],
2556 ]);
96449e8e 2557
2558which yields
2559
9d48860e 2560 $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1
96449e8e 2561 WHERE c1 = ? AND c2 > t0.c0))";
2562 @bind = (1234, 1);
2563
2564
9d48860e 2565Observe that the condition on C<c2> in the subquery refers to
2566column C<t0.c0> of the main query : this is I<not> a bind
2567value, so we have to express it through a scalar ref.
96449e8e 2568Writing C<< c2 => {">" => "t0.c0"} >> would have generated
2569C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
2570what we wanted here.
2571
96449e8e 2572Finally, here is an example where a subquery is used
2573for expressing unary negation:
2574
9d48860e 2575 my ($sub_stmt, @sub_bind)
96449e8e 2576 = $sql->where({age => [{"<" => 10}, {">" => 20}]});
2577 $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
2578 my %where = (
2579 lname => {like => '%son%'},
48d9f5f8 2580 \["NOT ($sub_stmt)" => @sub_bind],
96449e8e 2581 );
2582
2583This yields
2584
2585 $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )"
2586 @bind = ('%son%', 10, 20)
2587
cc422895 2588=head3 Deprecated usage of Literal SQL
2589
2590Below are some examples of archaic use of literal SQL. It is shown only as
2591reference for those who deal with legacy code. Each example has a much
2592better, cleaner and safer alternative that users should opt for in new code.
2593
2594=over
2595
2596=item *
2597
2598 my %where = ( requestor => \'IS NOT NULL' )
2599
2600 $stmt = "WHERE requestor IS NOT NULL"
2601
2602This used to be the way of generating NULL comparisons, before the handling
2603of C<undef> got formalized. For new code please use the superior syntax as
2604described in L</Tests for NULL values>.
96449e8e 2605
cc422895 2606=item *
2607
2608 my %where = ( requestor => \'= submitter' )
2609
2610 $stmt = "WHERE requestor = submitter"
2611
2612This used to be the only way to compare columns. Use the superior L</-ident>
2613method for all new code. For example an identifier declared in such a way
2614will be properly quoted if L</quote_char> is properly set, while the legacy
2615form will remain as supplied.
2616
2617=item *
2618
2619 my %where = ( is_ready => \"", completed => { '>', '2012-12-21' } )
2620
2621 $stmt = "WHERE completed > ? AND is_ready"
2622 @bind = ('2012-12-21')
2623
2624Using an empty string literal used to be the only way to express a boolean.
2625For all new code please use the much more readable
2626L<-bool|/Unary operators: bool> operator.
2627
2628=back
96449e8e 2629
2630=head2 Conclusion
2631
32eab2da 2632These pages could go on for a while, since the nesting of the data
2633structures this module can handle are pretty much unlimited (the
2634module implements the C<WHERE> expansion as a recursive function
2635internally). Your best bet is to "play around" with the module a
2636little to see how the data structures behave, and choose the best
2637format for your data based on that.
2638
2639And of course, all the values above will probably be replaced with
2640variables gotten from forms or the command line. After all, if you
2641knew everything ahead of time, you wouldn't have to worry about
2642dynamically-generating SQL and could just hardwire it into your
2643script.
2644
86298391 2645=head1 ORDER BY CLAUSES
2646
9d48860e 2647Some functions take an order by clause. This can either be a scalar (just a
86298391 2648column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
1cfa1db3 2649or an array of either of the two previous forms. Examples:
2650
952f9e2d 2651 Given | Will Generate
1cfa1db3 2652 ----------------------------------------------------------
952f9e2d 2653 |
2654 \'colA DESC' | ORDER BY colA DESC
2655 |
2656 'colA' | ORDER BY colA
2657 |
2658 [qw/colA colB/] | ORDER BY colA, colB
2659 |
2660 {-asc => 'colA'} | ORDER BY colA ASC
2661 |
2662 {-desc => 'colB'} | ORDER BY colB DESC
2663 |
2664 ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
2665 |
855e6047 2666 { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC
952f9e2d 2667 |
2668 [ |
2669 { -asc => 'colA' }, | ORDER BY colA ASC, colB DESC,
2670 { -desc => [qw/colB/], | colC ASC, colD ASC
2671 { -asc => [qw/colC colD/],|
2672 ] |
2673 ===========================================================
86298391 2674
96449e8e 2675
2676
2677=head1 SPECIAL OPERATORS
2678
e3f9dff4 2679 my $sqlmaker = SQL::Abstract->new(special_ops => [
3a2e1a5e 2680 {
2681 regex => qr/.../,
e3f9dff4 2682 handler => sub {
2683 my ($self, $field, $op, $arg) = @_;
2684 ...
3a2e1a5e 2685 },
2686 },
2687 {
2688 regex => qr/.../,
2689 handler => 'method_name',
e3f9dff4 2690 },
2691 ]);
2692
9d48860e 2693A "special operator" is a SQL syntactic clause that can be
e3f9dff4 2694applied to a field, instead of a usual binary operator.
9d48860e 2695For example :
e3f9dff4 2696
2697 WHERE field IN (?, ?, ?)
2698 WHERE field BETWEEN ? AND ?
2699 WHERE MATCH(field) AGAINST (?, ?)
96449e8e 2700
e3f9dff4 2701Special operators IN and BETWEEN are fairly standard and therefore
3a2e1a5e 2702are builtin within C<SQL::Abstract> (as the overridable methods
2703C<_where_field_IN> and C<_where_field_BETWEEN>). For other operators,
2704like the MATCH .. AGAINST example above which is specific to MySQL,
2705you can write your own operator handlers - supply a C<special_ops>
2706argument to the C<new> method. That argument takes an arrayref of
2707operator definitions; each operator definition is a hashref with two
2708entries:
96449e8e 2709
e3f9dff4 2710=over
2711
2712=item regex
2713
2714the regular expression to match the operator
96449e8e 2715
e3f9dff4 2716=item handler
2717
3a2e1a5e 2718Either a coderef or a plain scalar method name. In both cases
2719the expected return is C<< ($sql, @bind) >>.
2720
2721When supplied with a method name, it is simply called on the
2722L<SQL::Abstract/> object as:
2723
2724 $self->$method_name ($field, $op, $arg)
2725
2726 Where:
2727
2728 $op is the part that matched the handler regex
2729 $field is the LHS of the operator
2730 $arg is the RHS
2731
2732When supplied with a coderef, it is called as:
2733
2734 $coderef->($self, $field, $op, $arg)
2735
e3f9dff4 2736
2737=back
2738
9d48860e 2739For example, here is an implementation
e3f9dff4 2740of the MATCH .. AGAINST syntax for MySQL
2741
2742 my $sqlmaker = SQL::Abstract->new(special_ops => [
9d48860e 2743
e3f9dff4 2744 # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
9d48860e 2745 {regex => qr/^match$/i,
e3f9dff4 2746 handler => sub {
2747 my ($self, $field, $op, $arg) = @_;
2748 $arg = [$arg] if not ref $arg;
2749 my $label = $self->_quote($field);
2750 my ($placeholder) = $self->_convert('?');
2751 my $placeholders = join ", ", (($placeholder) x @$arg);
2752 my $sql = $self->_sqlcase('match') . " ($label) "
2753 . $self->_sqlcase('against') . " ($placeholders) ";
2754 my @bind = $self->_bindtype($field, @$arg);
2755 return ($sql, @bind);
2756 }
2757 },
9d48860e 2758
e3f9dff4 2759 ]);
96449e8e 2760
2761
59f23b3d 2762=head1 UNARY OPERATORS
2763
112b5232 2764 my $sqlmaker = SQL::Abstract->new(unary_ops => [
59f23b3d 2765 {
2766 regex => qr/.../,
2767 handler => sub {
2768 my ($self, $op, $arg) = @_;
2769 ...
2770 },
2771 },
2772 {
2773 regex => qr/.../,
2774 handler => 'method_name',
2775 },
2776 ]);
2777
9d48860e 2778A "unary operator" is a SQL syntactic clause that can be
59f23b3d 2779applied to a field - the operator goes before the field
2780
2781You can write your own operator handlers - supply a C<unary_ops>
2782argument to the C<new> method. That argument takes an arrayref of
2783operator definitions; each operator definition is a hashref with two
2784entries:
2785
2786=over
2787
2788=item regex
2789
2790the regular expression to match the operator
2791
2792=item handler
2793
2794Either a coderef or a plain scalar method name. In both cases
2795the expected return is C<< $sql >>.
2796
2797When supplied with a method name, it is simply called on the
2798L<SQL::Abstract/> object as:
2799
2800 $self->$method_name ($op, $arg)
2801
2802 Where:
2803
2804 $op is the part that matched the handler regex
2805 $arg is the RHS or argument of the operator
2806
2807When supplied with a coderef, it is called as:
2808
2809 $coderef->($self, $op, $arg)
2810
2811
2812=back
2813
2814
32eab2da 2815=head1 PERFORMANCE
2816
2817Thanks to some benchmarking by Mark Stosberg, it turns out that
2818this module is many orders of magnitude faster than using C<DBIx::Abstract>.
2819I must admit this wasn't an intentional design issue, but it's a
2820byproduct of the fact that you get to control your C<DBI> handles
2821yourself.
2822
2823To maximize performance, use a code snippet like the following:
2824
2825 # prepare a statement handle using the first row
2826 # and then reuse it for the rest of the rows
2827 my($sth, $stmt);
2828 for my $href (@array_of_hashrefs) {
2829 $stmt ||= $sql->insert('table', $href);
2830 $sth ||= $dbh->prepare($stmt);
2831 $sth->execute($sql->values($href));
2832 }
2833
2834The reason this works is because the keys in your C<$href> are sorted
2835internally by B<SQL::Abstract>. Thus, as long as your data retains
2836the same structure, you only have to generate the SQL the first time
2837around. On subsequent queries, simply use the C<values> function provided
2838by this module to return your values in the correct order.
2839
b864ba9b 2840However this depends on the values having the same type - if, for
2841example, the values of a where clause may either have values
2842(resulting in sql of the form C<column = ?> with a single bind
2843value), or alternatively the values might be C<undef> (resulting in
2844sql of the form C<column IS NULL> with no bind value) then the
2845caching technique suggested will not work.
96449e8e 2846
32eab2da 2847=head1 FORMBUILDER
2848
2849If you use my C<CGI::FormBuilder> module at all, you'll hopefully
2850really like this part (I do, at least). Building up a complex query
2851can be as simple as the following:
2852
2853 #!/usr/bin/perl
2854
46dc2f3e 2855 use warnings;
2856 use strict;
2857
32eab2da 2858 use CGI::FormBuilder;
2859 use SQL::Abstract;
2860
2861 my $form = CGI::FormBuilder->new(...);
2862 my $sql = SQL::Abstract->new;
2863
2864 if ($form->submitted) {
2865 my $field = $form->field;
2866 my $id = delete $field->{id};
2867 my($stmt, @bind) = $sql->update('table', $field, {id => $id});
2868 }
2869
2870Of course, you would still have to connect using C<DBI> to run the
2871query, but the point is that if you make your form look like your
2872table, the actual query script can be extremely simplistic.
2873
2874If you're B<REALLY> lazy (I am), check out C<HTML::QuickTable> for
9d48860e 2875a fast interface to returning and formatting data. I frequently
32eab2da 2876use these three modules together to write complex database query
2877apps in under 50 lines.
2878
d8cc1792 2879=head1 REPO
2880
2881=over
2882
6d19fbf9 2883=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
d8cc1792 2884
6d19fbf9 2885=item * git: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
d8cc1792 2886
2887=back
32eab2da 2888
96449e8e 2889=head1 CHANGES
2890
2891Version 1.50 was a major internal refactoring of C<SQL::Abstract>.
2892Great care has been taken to preserve the I<published> behavior
2893documented in previous versions in the 1.* family; however,
9d48860e 2894some features that were previously undocumented, or behaved
96449e8e 2895differently from the documentation, had to be changed in order
2896to clarify the semantics. Hence, client code that was relying
9d48860e 2897on some dark areas of C<SQL::Abstract> v1.*
96449e8e 2898B<might behave differently> in v1.50.
32eab2da 2899
d2a8fe1a 2900The main changes are :
2901
96449e8e 2902=over
32eab2da 2903
9d48860e 2904=item *
32eab2da 2905
96449e8e 2906support for literal SQL through the C<< \ [$sql, bind] >> syntax.
2907
2908=item *
2909
145fbfc8 2910support for the { operator => \"..." } construct (to embed literal SQL)
2911
2912=item *
2913
9c37b9c0 2914support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values)
2915
2916=item *
2917
96449e8e 2918optional support for L<array datatypes|/"Inserting and Updating Arrays">
2919
9d48860e 2920=item *
96449e8e 2921
2922defensive programming : check arguments
2923
2924=item *
2925
2926fixed bug with global logic, which was previously implemented
7cac25e6 2927through global variables yielding side-effects. Prior versions would
96449e8e 2928interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >>
2929as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>.
2930Now this is interpreted
2931as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>.
2932
96449e8e 2933
2934=item *
2935
2936fixed semantics of _bindtype on array args
2937
9d48860e 2938=item *
96449e8e 2939
2940dropped the C<_anoncopy> of the %where tree. No longer necessary,
2941we just avoid shifting arrays within that tree.
2942
2943=item *
2944
2945dropped the C<_modlogic> function
2946
2947=back
32eab2da 2948
32eab2da 2949=head1 ACKNOWLEDGEMENTS
2950
2951There are a number of individuals that have really helped out with
2952this module. Unfortunately, most of them submitted bugs via CPAN
2953so I have no idea who they are! But the people I do know are:
2954
9d48860e 2955 Ash Berlin (order_by hash term support)
b643abe1 2956 Matt Trout (DBIx::Class support)
32eab2da 2957 Mark Stosberg (benchmarking)
2958 Chas Owens (initial "IN" operator support)
2959 Philip Collins (per-field SQL functions)
2960 Eric Kolve (hashref "AND" support)
2961 Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
2962 Dan Kubb (support for "quote_char" and "name_sep")
f5aab26e 2963 Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
48d9f5f8 2964 Laurent Dami (internal refactoring, extensible list of special operators, literal SQL)
dbdf7648 2965 Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests)
e96c510a 2966 Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests)
02288357 2967 Oliver Charles (support for "RETURNING" after "INSERT")
32eab2da 2968
2969Thanks!
2970
32eab2da 2971=head1 SEE ALSO
2972
86298391 2973L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>.
32eab2da 2974
32eab2da 2975=head1 AUTHOR
2976
b643abe1 2977Copyright (c) 2001-2007 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
2978
2979This module is actively maintained by Matt Trout <mst@shadowcatsystems.co.uk>
32eab2da 2980
abe72f94 2981For support, your best bet is to try the C<DBIx::Class> users mailing list.
2982While not an official support venue, C<DBIx::Class> makes heavy use of
2983C<SQL::Abstract>, and as such list members there are very familiar with
2984how to create queries.
2985
0d067ded 2986=head1 LICENSE
2987
d988ab87 2988This module is free software; you may copy this under the same
2989terms as perl itself (either the GNU General Public License or
2990the Artistic License)
32eab2da 2991
2992=cut
2993