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