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