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