Added test cases for passing arrayref bind values to insert() and update() when the...
[scpubgit/Q-Branch.git] / lib / SQL / Abstract.pm
1 package SQL::Abstract; # see doc at end of file
2
3 # LDNOTE : this code is heavy refactoring from original SQLA.
4 # Several design decisions will need discussion during
5 # the test / diffusion / acceptance phase; those are marked with flag
6 # 'LDNOTE' (note by laurent.dami AT free.fr)
7
8 use Carp;
9 use strict;
10 use warnings;
11 use List::Util   qw/first/;
12 use Scalar::Util qw/blessed/;
13
14 #======================================================================
15 # GLOBALS
16 #======================================================================
17
18 our $VERSION  = '1.49_01';
19 $VERSION      = eval $VERSION; # numify for warning-free dev releases
20
21
22 our $AUTOLOAD;
23
24 # special operators (-in, -between). May be extended/overridden by user.
25 # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
26 my @BUILTIN_SPECIAL_OPS = (
27   {regex => qr/^(not )?between$/i, handler => \&_where_field_BETWEEN},
28   {regex => qr/^(not )?in$/i,      handler => \&_where_field_IN},
29 );
30
31 #======================================================================
32 # DEBUGGING AND ERROR REPORTING
33 #======================================================================
34
35 sub _debug {
36   return unless $_[0]->{debug}; shift; # a little faster
37   my $func = (caller(1))[3];
38   warn "[$func] ", @_, "\n";
39 }
40
41 sub belch (@) {
42   my($func) = (caller(1))[3];
43   carp "[$func] Warning: ", @_;
44 }
45
46 sub puke (@) {
47   my($func) = (caller(1))[3];
48   croak "[$func] Fatal: ", @_;
49 }
50
51
52 #======================================================================
53 # NEW
54 #======================================================================
55
56 sub new {
57   my $self = shift;
58   my $class = ref($self) || $self;
59   my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
60
61   # choose our case by keeping an option around
62   delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
63
64   # default logic for interpreting arrayrefs
65   $opt{logic} = uc $opt{logic} || 'OR';
66
67   # how to return bind vars
68   # LDNOTE: changed nwiger code : why this 'delete' ??
69   # $opt{bindtype} ||= delete($opt{bind_type}) || 'normal';
70   $opt{bindtype} ||= 'normal';
71
72   # default comparison is "=", but can be overridden
73   $opt{cmp} ||= '=';
74
75   # try to recognize which are the 'equality' and 'unequality' ops
76   # (temporary quickfix, should go through a more seasoned API)
77  $opt{equality_op}   = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
78  $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
79
80   # SQL booleans
81   $opt{sqltrue}  ||= '1=1';
82   $opt{sqlfalse} ||= '0=1';
83
84   # special operators 
85   $opt{special_ops} ||= [];
86   push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
87
88   return bless \%opt, $class;
89 }
90
91
92
93 #======================================================================
94 # INSERT methods
95 #======================================================================
96
97 sub insert {
98   my $self  = shift;
99   my $table = $self->_table(shift);
100   my $data  = shift || return;
101
102   my $method       = $self->_METHOD_FOR_refkind("_insert", $data);
103   my ($sql, @bind) = $self->$method($data); 
104   $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
105   return wantarray ? ($sql, @bind) : $sql;
106 }
107
108 sub _insert_HASHREF { # explicit list of fields and then values
109   my ($self, $data) = @_;
110
111   my @fields = sort keys %$data;
112
113   my ($sql, @bind);
114   { # get values (need temporary override of bindtype to avoid an error)
115     local $self->{bindtype} = 'normal'; 
116     ($sql, @bind) = $self->_insert_ARRAYREF([@{$data}{@fields}]);
117   }
118
119   # if necessary, transform values according to 'bindtype'
120   if ($self->{bindtype} eq 'columns') {
121     for my $i (0 .. $#fields) {
122       ($bind[$i]) = $self->_bindtype($fields[$i], $bind[$i]);
123     }
124   }
125
126   # assemble SQL
127   $_ = $self->_quote($_) foreach @fields;
128   $sql = "( ".join(", ", @fields).") ".$sql;
129
130   return ($sql, @bind);
131 }
132
133 sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
134   my ($self, $data) = @_;
135
136   # no names (arrayref) so can't generate bindtype
137   $self->{bindtype} ne 'columns'
138     or belch "can't do 'columns' bindtype when called with arrayref";
139
140   my (@values, @all_bind);
141   for my $v (@$data) {
142
143     $self->_SWITCH_refkind($v, {
144
145       ARRAYREF => sub { 
146         if ($self->{array_datatypes}) { # if array datatype are activated
147           push @values, '?';
148           push @all_bind, $v;
149         }
150         else {                          # else literal SQL with bind
151           my ($sql, @bind) = @$v;
152           push @values, $sql;
153           push @all_bind, @bind;
154         }
155       },
156
157       ARRAYREFREF => sub { # literal SQL with bind
158         my ($sql, @bind) = @${$v};
159         push @values, $sql;
160         push @all_bind, @bind;
161       },
162
163       # THINK : anything useful to do with a HASHREF ? 
164
165       SCALARREF => sub {  # literal SQL without bind
166         push @values, $$v;
167       },
168
169       SCALAR_or_UNDEF => sub {
170         push @values, '?';
171         push @all_bind, $v;
172       },
173
174      });
175
176   }
177
178   my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
179   return ($sql, @all_bind);
180 }
181
182
183 sub _insert_ARRAYREFREF { # literal SQL with bind
184   my ($self, $data) = @_;
185   return @${$data};
186 }
187
188
189 sub _insert_SCALARREF { # literal SQL without bind
190   my ($self, $data) = @_;
191
192   return ($$data);
193 }
194
195
196
197 #======================================================================
198 # UPDATE methods
199 #======================================================================
200
201
202 sub update {
203   my $self  = shift;
204   my $table = $self->_table(shift);
205   my $data  = shift || return;
206   my $where = shift;
207
208   # first build the 'SET' part of the sql statement
209   my (@set, @all_bind);
210   puke "Unsupported data type specified to \$sql->update"
211     unless ref $data eq 'HASH';
212
213   for my $k (sort keys %$data) {
214     my $v = $data->{$k};
215     my $r = ref $v;
216     my $label = $self->_quote($k);
217
218     $self->_SWITCH_refkind($v, {
219       ARRAYREF => sub { 
220         if ($self->{array_datatypes}) { # array datatype
221           push @set, "$label = ?";
222           push @all_bind, $self->_bindtype($k, $v);
223         }
224         else {                          # literal SQL with bind
225           my ($sql, @bind) = @$v;
226           push @set, "$label = $sql";
227           push @all_bind, $self->_bindtype($k, @bind);
228         }
229       },
230       ARRAYREFREF => sub { # literal SQL with bind
231         my ($sql, @bind) = @${$v};
232         push @set, "$label = $sql";
233         push @all_bind, $self->_bindtype($k, @bind);
234       },
235       SCALARREF => sub {  # literal SQL without bind
236         push @set, "$label = $$v";
237        },
238       SCALAR_or_UNDEF => sub {
239         push @set, "$label = ?";
240         push @all_bind, $self->_bindtype($k, $v);
241       },
242     });
243   }
244
245   # generate sql
246   my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
247           . join ', ', @set;
248
249   if ($where) {
250     my($where_sql, @where_bind) = $self->where($where);
251     $sql .= $where_sql;
252     push @all_bind, @where_bind;
253   }
254
255   return wantarray ? ($sql, @all_bind) : $sql;
256 }
257
258
259
260
261 #======================================================================
262 # SELECT
263 #======================================================================
264
265
266 sub select {
267   my $self   = shift;
268   my $table  = $self->_table(shift);
269   my $fields = shift || '*';
270   my $where  = shift;
271   my $order  = shift;
272
273   my($where_sql, @bind) = $self->where($where, $order);
274
275   my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields
276                                    : $fields;
277   my $sql = join(' ', $self->_sqlcase('select'), $f, 
278                       $self->_sqlcase('from'),   $table)
279           . $where_sql;
280
281   return wantarray ? ($sql, @bind) : $sql; 
282 }
283
284 #======================================================================
285 # DELETE
286 #======================================================================
287
288
289 sub delete {
290   my $self  = shift;
291   my $table = $self->_table(shift);
292   my $where = shift;
293
294
295   my($where_sql, @bind) = $self->where($where);
296   my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql;
297
298   return wantarray ? ($sql, @bind) : $sql; 
299 }
300
301
302 #======================================================================
303 # WHERE: entry point
304 #======================================================================
305
306
307
308 # Finally, a separate routine just to handle WHERE clauses
309 sub where {
310   my ($self, $where, $order) = @_;
311
312   # where ?
313   my ($sql, @bind) = $self->_recurse_where($where);
314   $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
315
316   # order by?
317   if ($order) {
318     $sql .= $self->_order_by($order);
319   }
320
321   return wantarray ? ($sql, @bind) : $sql; 
322 }
323
324
325 sub _recurse_where {
326   my ($self, $where, $logic) = @_;
327
328   # dispatch on appropriate method according to refkind of $where
329   my $method = $self->_METHOD_FOR_refkind("_where", $where);
330
331
332   my ($sql, @bind) =  $self->$method($where, $logic); 
333
334   # DBIx::Class directly calls _recurse_where in scalar context, so 
335   # we must implement it, even if not in the official API
336   return wantarray ? ($sql, @bind) : $sql; 
337 }
338
339
340
341 #======================================================================
342 # WHERE: top-level ARRAYREF
343 #======================================================================
344
345
346 sub _where_ARRAYREF {
347   my ($self, $where, $logic) = @_;
348
349   $logic = uc($logic || $self->{logic});
350   $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
351
352   my @clauses = @$where;
353
354   # if the array starts with [-and|or => ...], recurse with that logic
355   my $first   = $clauses[0] || '';
356   if ($first =~ /^-(and|or)/i) {
357     $logic = $1;
358     shift @clauses;
359     return $self->_where_ARRAYREF(\@clauses, $logic);
360   }
361
362   #otherwise..
363   my (@sql_clauses, @all_bind);
364
365   # need to use while() so can shift() for pairs
366   while (my $el = shift @clauses) { 
367
368     # switch according to kind of $el and get corresponding ($sql, @bind)
369     my ($sql, @bind) = $self->_SWITCH_refkind($el, {
370
371       # skip empty elements, otherwise get invalid trailing AND stuff
372       ARRAYREF  => sub {$self->_recurse_where($el)        if @$el},
373
374       HASHREF   => sub {$self->_recurse_where($el, 'and') if %$el},
375            # LDNOTE : previous SQLA code for hashrefs was creating a dirty
376            # side-effect: the first hashref within an array would change
377            # the global logic to 'AND'. So [ {cond1, cond2}, [cond3, cond4] ]
378            # was interpreted as "(cond1 AND cond2) OR (cond3 AND cond4)", 
379            # whereas it should be "(cond1 AND cond2) OR (cond3 OR cond4)".
380
381       SCALARREF => sub { ($$el);                                 },
382
383       SCALAR    => sub {# top-level arrayref with scalars, recurse in pairs
384                         $self->_recurse_where({$el => shift(@clauses)})},
385
386       UNDEF     => sub {puke "not supported : UNDEF in arrayref" },
387     });
388
389     if ($sql) {
390       push @sql_clauses, $sql;
391       push @all_bind, @bind;
392     }
393   }
394
395   return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind);
396 }
397
398
399
400 #======================================================================
401 # WHERE: top-level HASHREF
402 #======================================================================
403
404 sub _where_HASHREF {
405   my ($self, $where) = @_;
406   my (@sql_clauses, @all_bind);
407
408   # LDNOTE : don't really know why we need to sort keys
409   for my $k (sort keys %$where) { 
410     my $v = $where->{$k};
411
412     # ($k => $v) is either a special op or a regular hashpair
413     my ($sql, @bind) = ($k =~ /^-(.+)/) ? $self->_where_op_in_hash($1, $v)
414                                         : do {
415          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
416          $self->$method($k, $v);
417        };
418
419     push @sql_clauses, $sql;
420     push @all_bind, @bind;
421   }
422
423   return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
424 }
425
426
427 sub _where_op_in_hash {
428   my ($self, $op, $v) = @_; 
429
430   $op =~ /^(AND|OR|NEST)[_\d]*/i
431     or puke "unknown operator: -$op";
432   $op = uc($1); # uppercase, remove trailing digits
433   $self->_debug("OP(-$op) within hashref, recursing...");
434
435   $self->_SWITCH_refkind($v, {
436
437     ARRAYREF => sub {
438       # LDNOTE : should deprecate {-or => [...]} and {-and => [...]}
439       # because they are misleading; the only proper way would be
440       # -nest => [-or => ...], -nest => [-and ...]
441       return $self->_where_ARRAYREF($v, $op eq 'NEST' ? '' : $op);
442     },
443
444     HASHREF => sub {
445       if ($op eq 'OR') {
446         belch "-or => {...} should be -nest => [...]";
447         return $self->_where_ARRAYREF([%$v], 'OR');
448       } 
449       else {                  # NEST | AND
450         return $self->_where_HASHREF($v);
451       }
452     },
453
454     SCALARREF  => sub {         # literal SQL
455       $op eq 'NEST' 
456         or puke "-$op => \\\$scalar not supported, use -nest => ...";
457       return ($$v); 
458     },
459
460     ARRAYREFREF => sub {        # literal SQL
461       $op eq 'NEST' 
462         or puke "-$op => \\[..] not supported, use -nest => ...";
463       return @{${$v}};
464     },
465
466     SCALAR => sub { # permissively interpreted as SQL
467       $op eq 'NEST' 
468         or puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
469       belch "literal SQL should be -nest => \\'scalar' "
470           . "instead of -nest => 'scalar' ";
471       return ($v); 
472     },
473
474     UNDEF => sub {
475       puke "-$op => undef not supported";
476     },
477    });
478 }
479
480
481 sub _where_hashpair_ARRAYREF {
482   my ($self, $k, $v) = @_;
483
484   if( @$v ) {
485     my @v = @$v; # need copy because of shift below
486     $self->_debug("ARRAY($k) means distribute over elements");
487
488     # put apart first element if it is an operator (-and, -or)
489     my $op = $v[0] =~ /^-/ ? shift @v : undef;
490     $self->_debug("OP($op) reinjected into the distributed array") if $op;
491
492     my @distributed = map { {$k =>  $_} } @v;
493     unshift @distributed, $op if $op;
494
495     return $self->_recurse_where(\@distributed);
496   } 
497   else {
498     # LDNOTE : not sure of this one. What does "distribute over nothing" mean?
499     $self->_debug("empty ARRAY($k) means 0=1");
500     return ($self->{sqlfalse});
501   }
502 }
503
504 sub _where_hashpair_HASHREF {
505   my ($self, $k, $v) = @_;
506
507   my (@all_sql, @all_bind);
508
509   for my $op (sort keys %$v) {
510     my $val = $v->{$op};
511
512     # put the operator in canonical form
513     $op =~ s/^-//;       # remove initial dash
514     $op =~ tr/_/ /;      # underscores become spaces
515     $op =~ s/^\s+//;     # no initial space
516     $op =~ s/\s+$//;     # no final space
517     $op =~ s/\s+/ /;     # multiple spaces become one
518
519     my ($sql, @bind);
520
521     # CASE: special operators like -in or -between
522     my $special_op = first {$op =~ $_->{regex}} @{$self->{special_ops}};
523     if ($special_op) {
524       ($sql, @bind) = $special_op->{handler}->($self, $k, $op, $val);
525     }
526
527     # CASE: col => {op => \@vals}
528     elsif (ref $val eq 'ARRAY') {
529       ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
530     } 
531
532     # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
533     elsif (! defined($val)) {
534       my $is = ($op =~ $self->{equality_op})   ? 'is'     :
535                ($op =~ $self->{inequality_op}) ? 'is not' :
536            puke "unexpected operator '$op' with undef operand";
537       $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
538     }
539
540     # CASE: col => {op => $scalar}
541     else {
542       $sql  = join ' ', $self->_convert($self->_quote($k)),
543                         $self->_sqlcase($op),
544                         $self->_convert('?');
545       @bind = $self->_bindtype($k, $val);
546     }
547
548     push @all_sql, $sql;
549     push @all_bind, @bind;
550   }
551
552   return $self->_join_sql_clauses('and', \@all_sql, \@all_bind);
553 }
554
555
556
557 sub _where_field_op_ARRAYREF {
558   my ($self, $k, $op, $vals) = @_;
559
560   if(@$vals) {
561     $self->_debug("ARRAY($vals) means multiple elements: [ @$vals ]");
562
563
564
565     # LDNOTE : change the distribution logic when 
566     # $op =~ $self->{inequality_op}, because of Morgan laws : 
567     # with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate
568     # WHERE field != 22 OR  field != 33 : the user probably means 
569     # WHERE field != 22 AND field != 33.
570     my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR';
571
572     # distribute $op over each member of @$vals
573     return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals], $logic);
574
575   } 
576   else {
577     # try to DWIM on equality operators 
578     # LDNOTE : not 100% sure this is the correct thing to do ...
579     return ($self->{sqlfalse}) if $op =~ $self->{equality_op};
580     return ($self->{sqltrue})  if $op =~ $self->{inequality_op};
581
582     # otherwise
583     puke "operator '$op' applied on an empty array (field '$k')";
584   }
585 }
586
587
588 sub _where_hashpair_SCALARREF {
589   my ($self, $k, $v) = @_;
590   $self->_debug("SCALAR($k) means literal SQL: $$v");
591   my $sql = $self->_quote($k) . " " . $$v;
592   return ($sql);
593 }
594
595 sub _where_hashpair_ARRAYREFREF {
596   my ($self, $k, $v) = @_;
597   $self->_debug("REF($k) means literal SQL: @${$v}");
598   my ($sql, @bind) = @${$v};
599   $sql  = $self->_quote($k) . " " . $sql;
600   @bind = $self->_bindtype($k, @bind);
601   return ($sql, @bind );
602 }
603
604 sub _where_hashpair_SCALAR {
605   my ($self, $k, $v) = @_;
606   $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
607   my $sql = join ' ', $self->_convert($self->_quote($k)), 
608                       $self->_sqlcase($self->{cmp}), 
609                       $self->_convert('?');
610   my @bind =  $self->_bindtype($k, $v);
611   return ( $sql, @bind);
612 }
613
614
615 sub _where_hashpair_UNDEF {
616   my ($self, $k, $v) = @_;
617   $self->_debug("UNDEF($k) means IS NULL");
618   my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
619   return ($sql);
620 }
621
622 #======================================================================
623 # WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF)
624 #======================================================================
625
626
627 sub _where_SCALARREF {
628   my ($self, $where) = @_;
629
630   # literal sql
631   $self->_debug("SCALAR(*top) means literal SQL: $$where");
632   return ($$where);
633 }
634
635
636 sub _where_SCALAR {
637   my ($self, $where) = @_;
638
639   # literal sql
640   $self->_debug("NOREF(*top) means literal SQL: $where");
641   return ($where);
642 }
643
644
645 sub _where_UNDEF {
646   my ($self) = @_;
647   return ();
648 }
649
650
651 #======================================================================
652 # WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
653 #======================================================================
654
655
656 sub _where_field_BETWEEN {
657   my ($self, $k, $op, $vals) = @_;
658
659   ref $vals eq 'ARRAY' && @$vals == 2 
660     or puke "special op 'between' requires an arrayref of two values";
661
662   my ($label)       = $self->_convert($self->_quote($k));
663   my ($placeholder) = $self->_convert('?');
664   my $and           = $self->_sqlcase('and');
665   $op               = $self->_sqlcase($op);
666
667   my $sql  = "( $label $op $placeholder $and $placeholder )";
668   my @bind = $self->_bindtype($k, @$vals);
669   return ($sql, @bind)
670 }
671
672
673 sub _where_field_IN {
674   my ($self, $k, $op, $vals) = @_;
675
676   # backwards compatibility : if scalar, force into an arrayref
677   $vals = [$vals] if defined $vals && ! ref $vals;
678
679   ref $vals eq 'ARRAY'
680     or puke "special op 'in' requires an arrayref";
681
682   my ($label)       = $self->_convert($self->_quote($k));
683   my ($placeholder) = $self->_convert('?');
684   my $and           = $self->_sqlcase('and');
685   $op               = $self->_sqlcase($op);
686
687   if (@$vals) { # nonempty list
688     my $placeholders  = join ", ", (($placeholder) x @$vals);
689     my $sql           = "$label $op ( $placeholders )";
690     my @bind = $self->_bindtype($k, @$vals);
691
692     return ($sql, @bind);
693   }
694   else { # empty list : some databases won't understand "IN ()", so DWIM
695     my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
696     return ($sql);
697   }
698 }
699
700
701
702
703
704
705 #======================================================================
706 # ORDER BY
707 #======================================================================
708
709 sub _order_by {
710   my ($self, $arg) = @_;
711
712   # construct list of ordering instructions
713   my @order = $self->_SWITCH_refkind($arg, {
714
715     ARRAYREF => sub {
716       map {$self->_SWITCH_refkind($_, {
717               SCALAR    => sub {$self->_quote($_)},
718               UNDEF     => sub {},
719               SCALARREF => sub {$$_}, # literal SQL, no quoting
720               HASHREF   => sub {$self->_order_by_hash($_)}
721              }) } @$arg;
722     },
723
724     SCALAR    => sub {$self->_quote($arg)},
725     UNDEF     => sub {},
726     SCALARREF => sub {$$arg}, # literal SQL, no quoting
727     HASHREF   => sub {$self->_order_by_hash($arg)},
728
729   });
730
731   # build SQL
732   my $order = join ', ', @order;
733   return $order ? $self->_sqlcase(' order by')." $order" : '';
734 }
735
736
737 sub _order_by_hash {
738   my ($self, $hash) = @_;
739
740   # get first pair in hash
741   my ($key, $val) = each %$hash;
742
743   # check if one pair was found and no other pair in hash
744   $key && !(each %$hash)
745     or puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
746
747   my ($order) = ($key =~ /^-(desc|asc)/i)
748     or puke "invalid key in _order_by hash : $key";
749
750   return $self->_quote($val) ." ". $self->_sqlcase($order);
751 }
752
753
754
755 #======================================================================
756 # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
757 #======================================================================
758
759 sub _table  {
760   my $self = shift;
761   my $from = shift;
762   $self->_SWITCH_refkind($from, {
763     ARRAYREF     => sub {join ', ', map { $self->_quote($_) } @$from;},
764     SCALAR       => sub {$self->_quote($from)},
765     SCALARREF    => sub {$$from},
766     ARRAYREFREF  => sub {join ', ', @$from;},
767   });
768 }
769
770
771 #======================================================================
772 # UTILITY FUNCTIONS
773 #======================================================================
774
775 sub _quote {
776   my $self  = shift;
777   my $label = shift;
778
779   $label or puke "can't quote an empty label";
780
781   # left and right quote characters
782   my ($ql, $qr, @other) = $self->_SWITCH_refkind($self->{quote_char}, {
783     SCALAR   => sub {($self->{quote_char}, $self->{quote_char})},
784     ARRAYREF => sub {@{$self->{quote_char}}},
785     UNDEF    => sub {()},
786    });
787   not @other
788       or puke "quote_char must be an arrayref of 2 values";
789
790   # no quoting if no quoting chars
791   $ql or return $label;
792
793   # no quoting for literal SQL
794   return $$label if ref($label) eq 'SCALAR';
795
796   # separate table / column (if applicable)
797   my $sep = $self->{name_sep} || '';
798   my @to_quote = $sep ? split /\Q$sep\E/, $label : ($label);
799
800   # do the quoting, except for "*" or for `table`.*
801   my @quoted = map { $_ eq '*' ? $_: $ql.$_.$qr} @to_quote;
802
803   # reassemble and return. 
804   return join $sep, @quoted;
805 }
806
807
808 # Conversion, if applicable
809 sub _convert ($) {
810   my ($self, $arg) = @_;
811
812 # LDNOTE : modified the previous implementation below because
813 # it was not consistent : the first "return" is always an array,
814 # the second "return" is context-dependent. Anyway, _convert
815 # seems always used with just a single argument, so make it a 
816 # scalar function.
817 #     return @_ unless $self->{convert};
818 #     my $conv = $self->_sqlcase($self->{convert});
819 #     my @ret = map { $conv.'('.$_.')' } @_;
820 #     return wantarray ? @ret : $ret[0];
821   if ($self->{convert}) {
822     my $conv = $self->_sqlcase($self->{convert});
823     $arg = $conv.'('.$arg.')';
824   }
825   return $arg;
826 }
827
828 # And bindtype
829 sub _bindtype (@) {
830   my $self = shift;
831   my($col, @vals) = @_;
832
833   #LDNOTE : changed original implementation below because it did not make 
834   # sense when bindtype eq 'columns' and @vals > 1.
835 #  return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
836
837   return $self->{bindtype} eq 'columns' ? map {[$col, $_]} @vals : @vals;
838 }
839
840 sub _join_sql_clauses {
841   my ($self, $logic, $clauses_aref, $bind_aref) = @_;
842
843   if (@$clauses_aref > 1) {
844     my $join  = " " . $self->_sqlcase($logic) . " ";
845     my $sql = '( ' . join($join, @$clauses_aref) . ' )';
846     return ($sql, @$bind_aref);
847   }
848   elsif (@$clauses_aref) {
849     return ($clauses_aref->[0], @$bind_aref); # no parentheses
850   }
851   else {
852     return (); # if no SQL, ignore @$bind_aref
853   }
854 }
855
856
857 # Fix SQL case, if so requested
858 sub _sqlcase {
859   my $self = shift;
860
861   # LDNOTE: if $self->{case} is true, then it contains 'lower', so we
862   # don't touch the argument ... crooked logic, but let's not change it!
863   return $self->{case} ? $_[0] : uc($_[0]);
864 }
865
866
867 #======================================================================
868 # DISPATCHING FROM REFKIND
869 #======================================================================
870
871 sub _refkind {
872   my ($self, $data) = @_;
873   my $suffix = '';
874   my $ref;
875   my $n_steps = 0;
876
877   while (1) {
878     # blessed objects are treated like scalars
879     $ref = (blessed $data) ? '' : ref $data;
880     $n_steps += 1 if $ref;
881     last          if $ref ne 'REF';
882     $data = $$data;
883   }
884
885   my $base = $ref || (defined $data ? 'SCALAR' : 'UNDEF');
886
887   return $base . ('REF' x $n_steps);
888 }
889
890
891
892 sub _try_refkind {
893   my ($self, $data) = @_;
894   my @try = ($self->_refkind($data));
895   push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
896   push @try, 'FALLBACK';
897   return @try;
898 }
899
900 sub _METHOD_FOR_refkind {
901   my ($self, $meth_prefix, $data) = @_;
902   my $method = first {$_} map {$self->can($meth_prefix."_".$_)} 
903                               $self->_try_refkind($data)
904     or puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
905   return $method;
906 }
907
908
909 sub _SWITCH_refkind {
910   my ($self, $data, $dispatch_table) = @_;
911
912   my $coderef = first {$_} map {$dispatch_table->{$_}} 
913                                $self->_try_refkind($data)
914     or puke "no dispatch entry for ".$self->_refkind($data);
915   $coderef->();
916 }
917
918
919
920
921 #======================================================================
922 # VALUES, GENERATE, AUTOLOAD
923 #======================================================================
924
925 # LDNOTE: original code from nwiger, didn't touch code in that section
926 # I feel the AUTOLOAD stuff should not be the default, it should
927 # only be activated on explicit demand by user.
928
929 sub values {
930     my $self = shift;
931     my $data = shift || return;
932     puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
933         unless ref $data eq 'HASH';
934     return map { $self->_bindtype($_, $data->{$_}) } sort keys %$data;
935 }
936
937 sub generate {
938     my $self  = shift;
939
940     my(@sql, @sqlq, @sqlv);
941
942     for (@_) {
943         my $ref = ref $_;
944         if ($ref eq 'HASH') {
945             for my $k (sort keys %$_) {
946                 my $v = $_->{$k};
947                 my $r = ref $v;
948                 my $label = $self->_quote($k);
949                 if ($r eq 'ARRAY') {
950                     # SQL included for values
951                     my @bind = @$v;
952                     my $sql = shift @bind;
953                     push @sqlq, "$label = $sql";
954                     push @sqlv, $self->_bindtype($k, @bind);
955                 } elsif ($r eq 'SCALAR') {
956                     # embedded literal SQL
957                     push @sqlq, "$label = $$v";
958                 } else { 
959                     push @sqlq, "$label = ?";
960                     push @sqlv, $self->_bindtype($k, $v);
961                 }
962             }
963             push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
964         } elsif ($ref eq 'ARRAY') {
965             # unlike insert(), assume these are ONLY the column names, i.e. for SQL
966             for my $v (@$_) {
967                 my $r = ref $v;
968                 if ($r eq 'ARRAY') {
969                     my @val = @$v;
970                     push @sqlq, shift @val;
971                     push @sqlv, @val;
972                 } elsif ($r eq 'SCALAR') {
973                     # embedded literal SQL
974                     push @sqlq, $$v;
975                 } else { 
976                     push @sqlq, '?';
977                     push @sqlv, $v;
978                 }
979             }
980             push @sql, '(' . join(', ', @sqlq) . ')';
981         } elsif ($ref eq 'SCALAR') {
982             # literal SQL
983             push @sql, $$_;
984         } else {
985             # strings get case twiddled
986             push @sql, $self->_sqlcase($_);
987         }
988     }
989
990     my $sql = join ' ', @sql;
991
992     # this is pretty tricky
993     # if ask for an array, return ($stmt, @bind)
994     # otherwise, s/?/shift @sqlv/ to put it inline
995     if (wantarray) {
996         return ($sql, @sqlv);
997     } else {
998         1 while $sql =~ s/\?/my $d = shift(@sqlv);
999                              ref $d ? $d->[1] : $d/e;
1000         return $sql;
1001     }
1002 }
1003
1004
1005 sub DESTROY { 1 }
1006
1007 sub AUTOLOAD {
1008     # This allows us to check for a local, then _form, attr
1009     my $self = shift;
1010     my($name) = $AUTOLOAD =~ /.*::(.+)/;
1011     return $self->generate($name, @_);
1012 }
1013
1014 1;
1015
1016
1017
1018 __END__
1019
1020 =head1 NAME
1021
1022 SQL::Abstract - Generate SQL from Perl data structures
1023
1024 =head1 SYNOPSIS
1025
1026     use SQL::Abstract;
1027
1028     my $sql = SQL::Abstract->new;
1029
1030     my($stmt, @bind) = $sql->select($table, \@fields, \%where, \@order);
1031
1032     my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
1033
1034     my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where);
1035
1036     my($stmt, @bind) = $sql->delete($table, \%where);
1037
1038     # Then, use these in your DBI statements
1039     my $sth = $dbh->prepare($stmt);
1040     $sth->execute(@bind);
1041
1042     # Just generate the WHERE clause
1043     my($stmt, @bind) = $sql->where(\%where, \@order);
1044
1045     # Return values in the same order, for hashed queries
1046     # See PERFORMANCE section for more details
1047     my @bind = $sql->values(\%fieldvals);
1048
1049 =head1 DESCRIPTION
1050
1051 This module was inspired by the excellent L<DBIx::Abstract>.
1052 However, in using that module I found that what I really wanted
1053 to do was generate SQL, but still retain complete control over my
1054 statement handles and use the DBI interface. So, I set out to
1055 create an abstract SQL generation module.
1056
1057 While based on the concepts used by L<DBIx::Abstract>, there are
1058 several important differences, especially when it comes to WHERE
1059 clauses. I have modified the concepts used to make the SQL easier
1060 to generate from Perl data structures and, IMO, more intuitive.
1061 The underlying idea is for this module to do what you mean, based
1062 on the data structures you provide it. The big advantage is that
1063 you don't have to modify your code every time your data changes,
1064 as this module figures it out.
1065
1066 To begin with, an SQL INSERT is as easy as just specifying a hash
1067 of C<key=value> pairs:
1068
1069     my %data = (
1070         name => 'Jimbo Bobson',
1071         phone => '123-456-7890',
1072         address => '42 Sister Lane',
1073         city => 'St. Louis',
1074         state => 'Louisiana',
1075     );
1076
1077 The SQL can then be generated with this:
1078
1079     my($stmt, @bind) = $sql->insert('people', \%data);
1080
1081 Which would give you something like this:
1082
1083     $stmt = "INSERT INTO people
1084                     (address, city, name, phone, state)
1085                     VALUES (?, ?, ?, ?, ?)";
1086     @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson',
1087              '123-456-7890', 'Louisiana');
1088
1089 These are then used directly in your DBI code:
1090
1091     my $sth = $dbh->prepare($stmt);
1092     $sth->execute(@bind);
1093
1094 =head2 Inserting and Updating Arrays
1095
1096 If your database has array types (like for example Postgres),
1097 activate the special option C<< array_datatypes => 1 >>
1098 when creating the C<SQL::Abstract> object. 
1099 Then you may use an arrayref to insert and update database array types:
1100
1101     my $sql = SQL::Abstract->new(array_datatypes => 1);
1102     my %data = (
1103         planets => [qw/Mercury Venus Earth Mars/]
1104     );
1105   
1106     my($stmt, @bind) = $sql->insert('solar_system', \%data);
1107
1108 This results in:
1109
1110     $stmt = "INSERT INTO solar_system (planets) VALUES (?)"
1111
1112     @bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
1113
1114
1115 =head2 Inserting and Updating SQL
1116
1117 In order to apply SQL functions to elements of your C<%data> you may
1118 specify a reference to an arrayref for the given hash value. For example,
1119 if you need to execute the Oracle C<to_date> function on a value, you can
1120 say something like this:
1121
1122     my %data = (
1123         name => 'Bill',
1124         date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
1125     ); 
1126
1127 The first value in the array is the actual SQL. Any other values are
1128 optional and would be included in the bind values array. This gives
1129 you:
1130
1131     my($stmt, @bind) = $sql->insert('people', \%data);
1132
1133     $stmt = "INSERT INTO people (name, date_entered) 
1134                 VALUES (?, to_date(?,'MM/DD/YYYY'))";
1135     @bind = ('Bill', '03/02/2003');
1136
1137 An UPDATE is just as easy, all you change is the name of the function:
1138
1139     my($stmt, @bind) = $sql->update('people', \%data);
1140
1141 Notice that your C<%data> isn't touched; the module will generate
1142 the appropriately quirky SQL for you automatically. Usually you'll
1143 want to specify a WHERE clause for your UPDATE, though, which is
1144 where handling C<%where> hashes comes in handy...
1145
1146 =head2 Complex where statements
1147
1148 This module can generate pretty complicated WHERE statements
1149 easily. For example, simple C<key=value> pairs are taken to mean
1150 equality, and if you want to see if a field is within a set
1151 of values, you can use an arrayref. Let's say we wanted to
1152 SELECT some data based on this criteria:
1153
1154     my %where = (
1155        requestor => 'inna',
1156        worker => ['nwiger', 'rcwe', 'sfz'],
1157        status => { '!=', 'completed' }
1158     );
1159
1160     my($stmt, @bind) = $sql->select('tickets', '*', \%where);
1161
1162 The above would give you something like this:
1163
1164     $stmt = "SELECT * FROM tickets WHERE
1165                 ( requestor = ? ) AND ( status != ? )
1166                 AND ( worker = ? OR worker = ? OR worker = ? )";
1167     @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
1168
1169 Which you could then use in DBI code like so:
1170
1171     my $sth = $dbh->prepare($stmt);
1172     $sth->execute(@bind);
1173
1174 Easy, eh?
1175
1176 =head1 FUNCTIONS
1177
1178 The functions are simple. There's one for each major SQL operation,
1179 and a constructor you use first. The arguments are specified in a
1180 similar order to each function (table, then fields, then a where 
1181 clause) to try and simplify things.
1182
1183
1184
1185
1186 =head2 new(option => 'value')
1187
1188 The C<new()> function takes a list of options and values, and returns
1189 a new B<SQL::Abstract> object which can then be used to generate SQL
1190 through the methods below. The options accepted are:
1191
1192 =over
1193
1194 =item case
1195
1196 If set to 'lower', then SQL will be generated in all lowercase. By
1197 default SQL is generated in "textbook" case meaning something like:
1198
1199     SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
1200
1201 Any setting other than 'lower' is ignored.
1202
1203 =item cmp
1204
1205 This determines what the default comparison operator is. By default
1206 it is C<=>, meaning that a hash like this:
1207
1208     %where = (name => 'nwiger', email => 'nate@wiger.org');
1209
1210 Will generate SQL like this:
1211
1212     WHERE name = 'nwiger' AND email = 'nate@wiger.org'
1213
1214 However, you may want loose comparisons by default, so if you set
1215 C<cmp> to C<like> you would get SQL such as:
1216
1217     WHERE name like 'nwiger' AND email like 'nate@wiger.org'
1218
1219 You can also override the comparsion on an individual basis - see
1220 the huge section on L</"WHERE CLAUSES"> at the bottom.
1221
1222 =item sqltrue, sqlfalse
1223
1224 Expressions for inserting boolean values within SQL statements.
1225 By default these are C<1=1> and C<1=0>.
1226
1227 =item logic
1228
1229 This determines the default logical operator for multiple WHERE
1230 statements in arrays. By default it is "or", meaning that a WHERE
1231 array of the form:
1232
1233     @where = (
1234         event_date => {'>=', '2/13/99'}, 
1235         event_date => {'<=', '4/24/03'}, 
1236     );
1237
1238 Will generate SQL like this:
1239
1240     WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
1241
1242 This is probably not what you want given this query, though (look
1243 at the dates). To change the "OR" to an "AND", simply specify:
1244
1245     my $sql = SQL::Abstract->new(logic => 'and');
1246
1247 Which will change the above C<WHERE> to:
1248
1249     WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
1250
1251 The logic can also be changed locally by inserting
1252 an extra first element in the array :
1253
1254     @where = (-and => event_date => {'>=', '2/13/99'}, 
1255                       event_date => {'<=', '4/24/03'} );
1256
1257 See the L</"WHERE CLAUSES"> section for explanations.
1258
1259 =item convert
1260
1261 This will automatically convert comparisons using the specified SQL
1262 function for both column and value. This is mostly used with an argument
1263 of C<upper> or C<lower>, so that the SQL will have the effect of
1264 case-insensitive "searches". For example, this:
1265
1266     $sql = SQL::Abstract->new(convert => 'upper');
1267     %where = (keywords => 'MaKe iT CAse inSeNSItive');
1268
1269 Will turn out the following SQL:
1270
1271     WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive')
1272
1273 The conversion can be C<upper()>, C<lower()>, or any other SQL function
1274 that can be applied symmetrically to fields (actually B<SQL::Abstract> does
1275 not validate this option; it will just pass through what you specify verbatim).
1276
1277 =item bindtype
1278
1279 This is a kludge because many databases suck. For example, you can't
1280 just bind values using DBI's C<execute()> for Oracle C<CLOB> or C<BLOB> fields.
1281 Instead, you have to use C<bind_param()>:
1282
1283     $sth->bind_param(1, 'reg data');
1284     $sth->bind_param(2, $lots, {ora_type => ORA_CLOB});
1285
1286 The problem is, B<SQL::Abstract> will normally just return a C<@bind> array,
1287 which loses track of which field each slot refers to. Fear not.
1288
1289 If you specify C<bindtype> in new, you can determine how C<@bind> is returned.
1290 Currently, you can specify either C<normal> (default) or C<columns>. If you
1291 specify C<columns>, you will get an array that looks like this:
1292
1293     my $sql = SQL::Abstract->new(bindtype => 'columns');
1294     my($stmt, @bind) = $sql->insert(...);
1295
1296     @bind = (
1297         [ 'column1', 'value1' ],
1298         [ 'column2', 'value2' ],
1299         [ 'column3', 'value3' ],
1300     );
1301
1302 You can then iterate through this manually, using DBI's C<bind_param()>.
1303
1304     $sth->prepare($stmt);
1305     my $i = 1;
1306     for (@bind) {
1307         my($col, $data) = @$_;
1308         if ($col eq 'details' || $col eq 'comments') {
1309             $sth->bind_param($i, $data, {ora_type => ORA_CLOB});
1310         } elsif ($col eq 'image') {
1311             $sth->bind_param($i, $data, {ora_type => ORA_BLOB});
1312         } else {
1313             $sth->bind_param($i, $data);
1314         }
1315         $i++;
1316     }
1317     $sth->execute;      # execute without @bind now
1318
1319 Now, why would you still use B<SQL::Abstract> if you have to do this crap?
1320 Basically, the advantage is still that you don't have to care which fields
1321 are or are not included. You could wrap that above C<for> loop in a simple
1322 sub called C<bind_fields()> or something and reuse it repeatedly. You still
1323 get a layer of abstraction over manual SQL specification.
1324
1325 =item quote_char
1326
1327 This is the character that a table or column name will be quoted
1328 with.  By default this is an empty string, but you could set it to 
1329 the character C<`>, to generate SQL like this:
1330
1331   SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
1332
1333 Alternatively, you can supply an array ref of two items, the first being the left
1334 hand quote character, and the second the right hand quote character. For
1335 example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes
1336 that generates SQL like this:
1337
1338   SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%'
1339
1340 Quoting is useful if you have tables or columns names that are reserved 
1341 words in your database's SQL dialect.
1342
1343 =item name_sep
1344
1345 This is the character that separates a table and column name.  It is
1346 necessary to specify this when the C<quote_char> option is selected,
1347 so that tables and column names can be individually quoted like this:
1348
1349   SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
1350
1351 =item array_datatypes
1352
1353 When this option is true, arrayrefs in INSERT or UPDATE are 
1354 interpreted as array datatypes and are passed directly 
1355 to the DBI layer.
1356 When this option is false, arrayrefs are interpreted
1357 as literal SQL, just like refs to arrayrefs
1358 (but this behavior is for backwards compatibility; when writing
1359 new queries, use the "reference to arrayref" syntax
1360 for literal SQL).
1361
1362
1363 =item special_ops
1364
1365 Takes a reference to a list of "special operators" 
1366 to extend the syntax understood by L<SQL::Abstract>.
1367 See section L</"SPECIAL OPERATORS"> for details.
1368
1369
1370
1371 =back
1372
1373 =head2 insert($table, \@values || \%fieldvals)
1374
1375 This is the simplest function. You simply give it a table name
1376 and either an arrayref of values or hashref of field/value pairs.
1377 It returns an SQL INSERT statement and a list of bind values.
1378 See the sections on L</"Inserting and Updating Arrays"> and
1379 L</"Inserting and Updating SQL"> for information on how to insert
1380 with those data types.
1381
1382 =head2 update($table, \%fieldvals, \%where)
1383
1384 This takes a table, hashref of field/value pairs, and an optional
1385 hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
1386 of bind values.
1387 See the sections on L</"Inserting and Updating Arrays"> and
1388 L</"Inserting and Updating SQL"> for information on how to insert
1389 with those data types.
1390
1391 =head2 select($source, $fields, $where, $order)
1392
1393 This returns a SQL SELECT statement and associated list of bind values, as 
1394 specified by the arguments  :
1395
1396 =over
1397
1398 =item $source
1399
1400 Specification of the 'FROM' part of the statement. 
1401 The argument can be either a plain scalar (interpreted as a table
1402 name, will be quoted), or an arrayref (interpreted as a list
1403 of table names, joined by commas, quoted), or a scalarref
1404 (literal table name, not quoted), or a ref to an arrayref
1405 (list of literal table names, joined by commas, not quoted).
1406
1407 =item $fields
1408
1409 Specification of the list of fields to retrieve from 
1410 the source.
1411 The argument can be either an arrayref (interpreted as a list
1412 of field names, will be joined by commas and quoted), or a 
1413 plain scalar (literal SQL, not quoted).
1414 Please observe that this API is not as flexible as for
1415 the first argument C<$table>, for backwards compatibility reasons.
1416
1417 =item $where
1418
1419 Optional argument to specify the WHERE part of the query.
1420 The argument is most often a hashref, but can also be
1421 an arrayref or plain scalar -- 
1422 see section L<WHERE clause|/"WHERE CLAUSES"> for details.
1423
1424 =item $order
1425
1426 Optional argument to specify the ORDER BY part of the query.
1427 The argument can be a scalar, a hashref or an arrayref 
1428 -- see section L<ORDER BY clause|/"ORDER BY CLAUSES">
1429 for details.
1430
1431 =back
1432
1433
1434 =head2 delete($table, \%where)
1435
1436 This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
1437 It returns an SQL DELETE statement and list of bind values.
1438
1439 =head2 where(\%where, \@order)
1440
1441 This is used to generate just the WHERE clause. For example,
1442 if you have an arbitrary data structure and know what the
1443 rest of your SQL is going to look like, but want an easy way
1444 to produce a WHERE clause, use this. It returns an SQL WHERE
1445 clause and list of bind values.
1446
1447
1448 =head2 values(\%data)
1449
1450 This just returns the values from the hash C<%data>, in the same
1451 order that would be returned from any of the other above queries.
1452 Using this allows you to markedly speed up your queries if you
1453 are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
1454
1455 =head2 generate($any, 'number', $of, \@data, $struct, \%types)
1456
1457 Warning: This is an experimental method and subject to change.
1458
1459 This returns arbitrarily generated SQL. It's a really basic shortcut.
1460 It will return two different things, depending on return context:
1461
1462     my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
1463     my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
1464
1465 These would return the following:
1466
1467     # First calling form
1468     $stmt = "CREATE TABLE test (?, ?)";
1469     @bind = (field1, field2);
1470
1471     # Second calling form
1472     $stmt_and_val = "CREATE TABLE test (field1, field2)";
1473
1474 Depending on what you're trying to do, it's up to you to choose the correct
1475 format. In this example, the second form is what you would want.
1476
1477 By the same token:
1478
1479     $sql->generate('alter session', { nls_date_format => 'MM/YY' });
1480
1481 Might give you:
1482
1483     ALTER SESSION SET nls_date_format = 'MM/YY'
1484
1485 You get the idea. Strings get their case twiddled, but everything
1486 else remains verbatim.
1487
1488
1489
1490
1491 =head1 WHERE CLAUSES
1492
1493 =head2 Introduction
1494
1495 This module uses a variation on the idea from L<DBIx::Abstract>. It
1496 is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
1497 module is that things in arrays are OR'ed, and things in hashes
1498 are AND'ed.>
1499
1500 The easiest way to explain is to show lots of examples. After
1501 each C<%where> hash shown, it is assumed you used:
1502
1503     my($stmt, @bind) = $sql->where(\%where);
1504
1505 However, note that the C<%where> hash can be used directly in any
1506 of the other functions as well, as described above.
1507
1508 =head2 Key-value pairs
1509
1510 So, let's get started. To begin, a simple hash:
1511
1512     my %where  = (
1513         user   => 'nwiger',
1514         status => 'completed'
1515     );
1516
1517 Is converted to SQL C<key = val> statements:
1518
1519     $stmt = "WHERE user = ? AND status = ?";
1520     @bind = ('nwiger', 'completed');
1521
1522 One common thing I end up doing is having a list of values that
1523 a field can be in. To do this, simply specify a list inside of
1524 an arrayref:
1525
1526     my %where  = (
1527         user   => 'nwiger',
1528         status => ['assigned', 'in-progress', 'pending'];
1529     );
1530
1531 This simple code will create the following:
1532     
1533     $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
1534     @bind = ('nwiger', 'assigned', 'in-progress', 'pending');
1535
1536 An empty arrayref will be considered a logical false and
1537 will generate 0=1.
1538
1539 =head2 Key-value pairs
1540
1541 If you want to specify a different type of operator for your comparison,
1542 you can use a hashref for a given column:
1543
1544     my %where  = (
1545         user   => 'nwiger',
1546         status => { '!=', 'completed' }
1547     );
1548
1549 Which would generate:
1550
1551     $stmt = "WHERE user = ? AND status != ?";
1552     @bind = ('nwiger', 'completed');
1553
1554 To test against multiple values, just enclose the values in an arrayref:
1555
1556     status => { '!=', ['assigned', 'in-progress', 'pending'] };
1557
1558 Which would give you:
1559
1560     "WHERE status != ? AND status != ? AND status != ?"
1561
1562 Notice that since the operator was recognized as being a 'negative' 
1563 operator, the arrayref was interpreted with 'AND' logic (because
1564 of Morgan's laws). By contrast, the reverse
1565
1566     status => { '=', ['assigned', 'in-progress', 'pending'] };
1567
1568 would generate :
1569
1570     "WHERE status = ? OR status = ? OR status = ?"
1571
1572
1573 The hashref can also contain multiple pairs, in which case it is expanded
1574 into an C<AND> of its elements:
1575
1576     my %where  = (
1577         user   => 'nwiger',
1578         status => { '!=', 'completed', -not_like => 'pending%' }
1579     );
1580
1581     # Or more dynamically, like from a form
1582     $where{user} = 'nwiger';
1583     $where{status}{'!='} = 'completed';
1584     $where{status}{'-not_like'} = 'pending%';
1585
1586     # Both generate this
1587     $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
1588     @bind = ('nwiger', 'completed', 'pending%');
1589
1590
1591 To get an OR instead, you can combine it with the arrayref idea:
1592
1593     my %where => (
1594          user => 'nwiger',
1595          priority => [ {'=', 2}, {'!=', 1} ]
1596     );
1597
1598 Which would generate:
1599
1600     $stmt = "WHERE user = ? AND priority = ? OR priority != ?";
1601     @bind = ('nwiger', '2', '1');
1602
1603
1604 =head2 Logic and nesting operators
1605
1606 In the example above,
1607 there is a subtle trap if you want to say something like
1608 this (notice the C<AND>):
1609
1610     WHERE priority != ? AND priority != ?
1611
1612 Because, in Perl you I<can't> do this:
1613
1614     priority => { '!=', 2, '!=', 1 }
1615
1616 As the second C<!=> key will obliterate the first. The solution
1617 is to use the special C<-modifier> form inside an arrayref:
1618
1619     priority => [ -and => {'!=', 2}, 
1620                           {'!=', 1} ]
1621
1622
1623 Normally, these would be joined by C<OR>, but the modifier tells it
1624 to use C<AND> instead. (Hint: You can use this in conjunction with the
1625 C<logic> option to C<new()> in order to change the way your queries
1626 work by default.) B<Important:> Note that the C<-modifier> goes
1627 B<INSIDE> the arrayref, as an extra first element. This will
1628 B<NOT> do what you think it might:
1629
1630     priority => -and => [{'!=', 2}, {'!=', 1}]   # WRONG!
1631
1632 Here is a quick list of equivalencies, since there is some overlap:
1633
1634     # Same
1635     status => {'!=', 'completed', 'not like', 'pending%' }
1636     status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}]
1637
1638     # Same
1639     status => {'=', ['assigned', 'in-progress']}
1640     status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
1641     status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
1642
1643 In addition to C<-and> and C<-or>, there is also a special C<-nest>
1644 operator which adds an additional set of parens, to create a subquery.
1645 For example, to get something like this:
1646
1647     $stmt = "WHERE user = ? AND ( workhrs > ? OR geo = ? )";
1648     @bind = ('nwiger', '20', 'ASIA');
1649
1650 You would do:
1651
1652     my %where = (
1653          user => 'nwiger',
1654         -nest => [ workhrs => {'>', 20}, geo => 'ASIA' ],
1655     );
1656
1657 If you need several nested subexpressions, you can number
1658 the C<-nest> branches :
1659
1660     my %where = (
1661          user => 'nwiger',
1662         -nest1 => ...,
1663         -nest2 => ...,
1664         ...
1665     );
1666
1667
1668 =head2 Special operators : IN, BETWEEN, etc.
1669
1670 You can also use the hashref format to compare a list of fields using the
1671 C<IN> comparison operator, by specifying the list as an arrayref:
1672
1673     my %where  = (
1674         status   => 'completed',
1675         reportid => { -in => [567, 2335, 2] }
1676     );
1677
1678 Which would generate:
1679
1680     $stmt = "WHERE status = ? AND reportid IN (?,?,?)";
1681     @bind = ('completed', '567', '2335', '2');
1682
1683 The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in 
1684 the same way.
1685
1686 Another pair of operators is C<-between> and C<-not_between>, 
1687 used with an arrayref of two values:
1688
1689     my %where  = (
1690         user   => 'nwiger',
1691         completion_date => {
1692            -not_between => ['2002-10-01', '2003-02-06']
1693         }
1694     );
1695
1696 Would give you:
1697
1698     WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
1699
1700 These are the two builtin "special operators"; but the 
1701 list can be expanded : see section L</"SPECIAL OPERATORS"> below.
1702
1703 =head2 Nested conditions
1704
1705 So far, we've seen how multiple conditions are joined with a top-level
1706 C<AND>.  We can change this by putting the different conditions we want in
1707 hashes and then putting those hashes in an array. For example:
1708
1709     my @where = (
1710         {
1711             user   => 'nwiger',
1712             status => { -like => ['pending%', 'dispatched'] },
1713         },
1714         {
1715             user   => 'robot',
1716             status => 'unassigned',
1717         }
1718     );
1719
1720 This data structure would create the following:
1721
1722     $stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) )
1723                 OR ( user = ? AND status = ? ) )";
1724     @bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
1725
1726 This can be combined with the C<-nest> operator to properly group
1727 SQL statements:
1728
1729     my @where = (
1730          -and => [
1731             user => 'nwiger',
1732             -nest => [
1733                 ["-and", workhrs => {'>', 20}, geo => 'ASIA' ],
1734                 ["-and", workhrs => {'<', 50}, geo => 'EURO' ]
1735             ],
1736         ],
1737     );
1738
1739 That would yield:
1740
1741     WHERE ( user = ? AND 
1742           ( ( workhrs > ? AND geo = ? )
1743          OR ( workhrs < ? AND geo = ? ) ) )
1744
1745 =head2 Literal SQL
1746
1747 Finally, sometimes only literal SQL will do. If you want to include
1748 literal SQL verbatim, you can specify it as a scalar reference, namely:
1749
1750     my $inn = 'is Not Null';
1751     my %where = (
1752         priority => { '<', 2 },
1753         requestor => \$inn
1754     );
1755
1756 This would create:
1757
1758     $stmt = "WHERE priority < ? AND requestor is Not Null";
1759     @bind = ('2');
1760
1761 Note that in this example, you only get one bind parameter back, since
1762 the verbatim SQL is passed as part of the statement.
1763
1764 Of course, just to prove a point, the above can also be accomplished
1765 with this:
1766
1767     my %where = (
1768         priority  => { '<', 2 },
1769         requestor => { '!=', undef },
1770     );
1771
1772
1773 TMTOWTDI.
1774
1775 Conditions on boolean columns can be expressed in the 
1776 same way, passing a reference to an empty string :
1777
1778     my %where = (
1779         priority  => { '<', 2 },
1780         is_ready  => \"";
1781     );
1782
1783 which yields
1784
1785     $stmt = "WHERE priority < ? AND is_ready";
1786     @bind = ('2');
1787
1788
1789 =head2 Literal SQL with placeholders and bind values (subqueries)
1790
1791 If the literal SQL to be inserted has placeholders and bind values,
1792 use a reference to an arrayref (yes this is a double reference --
1793 not so common, but perfectly legal Perl). For example, to find a date
1794 in Postgres you can use something like this:
1795
1796     my %where = (
1797        date_column => \[q/= date '2008-09-30' - ?::integer/, 10/]
1798     )
1799
1800 This would create:
1801
1802     $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )"
1803     @bind = ('10');
1804
1805
1806 Literal SQL is especially useful for nesting parenthesized clauses in the
1807 main SQL query. Here is a first example :
1808
1809   my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
1810                                100, "foo%");
1811   my %where = (
1812     foo => 1234,
1813     bar => \["IN ($sub_stmt)" => @sub_bind],
1814   );
1815
1816 This yields :
1817
1818   $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1 
1819                                              WHERE c2 < ? AND c3 LIKE ?))";
1820   @bind = (1234, 100, "foo%");
1821
1822 Other subquery operators, like for example C<"E<gt> ALL"> or C<"NOT IN">, 
1823 are expressed in the same way. Of course the C<$sub_stmt> and
1824 its associated bind values can be generated through a former call 
1825 to C<select()> :
1826
1827   my ($sub_stmt, @sub_bind)
1828      = $sql->select("t1", "c1", {c2 => {"<" => 100}, 
1829                                  c3 => {-like => "foo%"}});
1830   my %where = (
1831     foo => 1234,
1832     bar => \["> ALL ($sub_stmt)" => @sub_bind],
1833   );
1834
1835 In the examples above, the subquery was used as an operator on a column;
1836 but the same principle also applies for a clause within the main C<%where> 
1837 hash, like an EXISTS subquery :
1838
1839   my ($sub_stmt, @sub_bind) 
1840      = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
1841   my %where = (
1842     foo   => 1234,
1843     -nest => \["EXISTS ($sub_stmt)" => @sub_bind],
1844   );
1845
1846 which yields
1847
1848   $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1 
1849                                         WHERE c1 = ? AND c2 > t0.c0))";
1850   @bind = (1234, 1);
1851
1852
1853 Observe that the condition on C<c2> in the subquery refers to 
1854 column C<t0.c0> of the main query : this is I<not> a bind 
1855 value, so we have to express it through a scalar ref. 
1856 Writing C<< c2 => {">" => "t0.c0"} >> would have generated
1857 C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
1858 what we wanted here.
1859
1860 Another use of the subquery technique is when some SQL clauses need
1861 parentheses, as it often occurs with some proprietary SQL extensions
1862 like for example fulltext expressions, geospatial expressions, 
1863 NATIVE clauses, etc. Here is an example of a fulltext query in MySQL :
1864
1865   my %where = (
1866     -nest => \["MATCH (col1, col2) AGAINST (?)" => qw/apples/]
1867   );
1868
1869 Finally, here is an example where a subquery is used
1870 for expressing unary negation:
1871
1872   my ($sub_stmt, @sub_bind) 
1873      = $sql->where({age => [{"<" => 10}, {">" => 20}]});
1874   $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
1875   my %where = (
1876         lname  => {like => '%son%'},
1877         -nest  => \["NOT ($sub_stmt)" => @sub_bind],
1878     );
1879
1880 This yields
1881
1882   $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )"
1883   @bind = ('%son%', 10, 20)
1884
1885
1886
1887 =head2 Conclusion
1888
1889 These pages could go on for a while, since the nesting of the data
1890 structures this module can handle are pretty much unlimited (the
1891 module implements the C<WHERE> expansion as a recursive function
1892 internally). Your best bet is to "play around" with the module a
1893 little to see how the data structures behave, and choose the best
1894 format for your data based on that.
1895
1896 And of course, all the values above will probably be replaced with
1897 variables gotten from forms or the command line. After all, if you
1898 knew everything ahead of time, you wouldn't have to worry about
1899 dynamically-generating SQL and could just hardwire it into your
1900 script.
1901
1902
1903
1904
1905 =head1 ORDER BY CLAUSES
1906
1907 Some functions take an order by clause. This can either be a scalar (just a 
1908 column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
1909 or an array of either of the two previous forms. Examples:
1910
1911              Given             |    Will Generate
1912     ----------------------------------------------------------
1913     \'colA DESC'               | ORDER BY colA DESC
1914     'colA'                     | ORDER BY colA
1915     [qw/colA colB/]            | ORDER BY colA, colB
1916     {-asc  => 'colA'}          | ORDER BY colA ASC
1917     {-desc => 'colB'}          | ORDER BY colB DESC
1918     [                          |
1919       {-asc  => 'colA'},       | ORDER BY colA ASC, colB DESC
1920       {-desc => 'colB'}        |
1921     ]                          |
1922     [colA => {-asc => 'colB'}] | ORDER BY colA, colB ASC
1923     ==========================================================
1924
1925
1926
1927 =head1 SPECIAL OPERATORS
1928
1929   my $sqlmaker = SQL::Abstract->new(special_ops => [
1930      {regex => qr/.../,
1931       handler => sub {
1932         my ($self, $field, $op, $arg) = @_;
1933         ...
1934         },
1935      },
1936    ]);
1937
1938 A "special operator" is a SQL syntactic clause that can be 
1939 applied to a field, instead of a usual binary operator.
1940 For example : 
1941
1942    WHERE field IN (?, ?, ?)
1943    WHERE field BETWEEN ? AND ?
1944    WHERE MATCH(field) AGAINST (?, ?)
1945
1946 Special operators IN and BETWEEN are fairly standard and therefore
1947 are builtin within C<SQL::Abstract>. For other operators,
1948 like the MATCH .. AGAINST example above which is 
1949 specific to MySQL, you can write your own operator handlers :
1950 supply a C<special_ops> argument to the C<new> method. 
1951 That argument takes an arrayref of operator definitions;
1952 each operator definition is a hashref with two entries
1953
1954 =over
1955
1956 =item regex
1957
1958 the regular expression to match the operator
1959
1960 =item handler
1961
1962 coderef that will be called when meeting that operator
1963 in the input tree. The coderef will be called with 
1964 arguments  C<< ($self, $field, $op, $arg) >>, and 
1965 should return a C<< ($sql, @bind) >> structure.
1966
1967 =back
1968
1969 For example, here is an implementation 
1970 of the MATCH .. AGAINST syntax for MySQL
1971
1972   my $sqlmaker = SQL::Abstract->new(special_ops => [
1973   
1974     # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
1975     {regex => qr/^match$/i, 
1976      handler => sub {
1977        my ($self, $field, $op, $arg) = @_;
1978        $arg = [$arg] if not ref $arg;
1979        my $label         = $self->_quote($field);
1980        my ($placeholder) = $self->_convert('?');
1981        my $placeholders  = join ", ", (($placeholder) x @$arg);
1982        my $sql           = $self->_sqlcase('match') . " ($label) "
1983                          . $self->_sqlcase('against') . " ($placeholders) ";
1984        my @bind = $self->_bindtype($field, @$arg);
1985        return ($sql, @bind);
1986        }
1987      },
1988   
1989   ]);
1990
1991
1992 =head1 PERFORMANCE
1993
1994 Thanks to some benchmarking by Mark Stosberg, it turns out that
1995 this module is many orders of magnitude faster than using C<DBIx::Abstract>.
1996 I must admit this wasn't an intentional design issue, but it's a
1997 byproduct of the fact that you get to control your C<DBI> handles
1998 yourself.
1999
2000 To maximize performance, use a code snippet like the following:
2001
2002     # prepare a statement handle using the first row
2003     # and then reuse it for the rest of the rows
2004     my($sth, $stmt);
2005     for my $href (@array_of_hashrefs) {
2006         $stmt ||= $sql->insert('table', $href);
2007         $sth  ||= $dbh->prepare($stmt);
2008         $sth->execute($sql->values($href));
2009     }
2010
2011 The reason this works is because the keys in your C<$href> are sorted
2012 internally by B<SQL::Abstract>. Thus, as long as your data retains
2013 the same structure, you only have to generate the SQL the first time
2014 around. On subsequent queries, simply use the C<values> function provided
2015 by this module to return your values in the correct order.
2016
2017
2018 =head1 FORMBUILDER
2019
2020 If you use my C<CGI::FormBuilder> module at all, you'll hopefully
2021 really like this part (I do, at least). Building up a complex query
2022 can be as simple as the following:
2023
2024     #!/usr/bin/perl
2025
2026     use CGI::FormBuilder;
2027     use SQL::Abstract;
2028
2029     my $form = CGI::FormBuilder->new(...);
2030     my $sql  = SQL::Abstract->new;
2031
2032     if ($form->submitted) {
2033         my $field = $form->field;
2034         my $id = delete $field->{id};
2035         my($stmt, @bind) = $sql->update('table', $field, {id => $id});
2036     }
2037
2038 Of course, you would still have to connect using C<DBI> to run the
2039 query, but the point is that if you make your form look like your
2040 table, the actual query script can be extremely simplistic.
2041
2042 If you're B<REALLY> lazy (I am), check out C<HTML::QuickTable> for
2043 a fast interface to returning and formatting data. I frequently 
2044 use these three modules together to write complex database query
2045 apps in under 50 lines.
2046
2047
2048 =head1 CHANGES
2049
2050 Version 1.50 was a major internal refactoring of C<SQL::Abstract>.
2051 Great care has been taken to preserve the I<published> behavior
2052 documented in previous versions in the 1.* family; however,
2053 some features that were previously undocumented, or behaved 
2054 differently from the documentation, had to be changed in order
2055 to clarify the semantics. Hence, client code that was relying
2056 on some dark areas of C<SQL::Abstract> v1.* 
2057 B<might behave differently> in v1.50.
2058
2059 The main changes are :
2060
2061 =over
2062
2063 =item * 
2064
2065 support for literal SQL through the C<< \ [$sql, bind] >> syntax.
2066
2067 =item *
2068
2069 added -nest1, -nest2 or -nest_1, -nest_2, ...
2070
2071 =item *
2072
2073 optional support for L<array datatypes|/"Inserting and Updating Arrays">
2074
2075 =item * 
2076
2077 defensive programming : check arguments
2078
2079 =item *
2080
2081 fixed bug with global logic, which was previously implemented
2082 through global variables yielding side-effects. Prior versons would
2083 interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >>
2084 as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>.
2085 Now this is interpreted
2086 as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>.
2087
2088 =item *
2089
2090 C<-and> / C<-or> operators are no longer accepted
2091 in the middle of an arrayref : they are
2092 only admitted if in first position.
2093
2094 =item *
2095
2096 changed logic for distributing an op over arrayrefs
2097
2098 =item *
2099
2100 fixed semantics of  _bindtype on array args
2101
2102 =item * 
2103
2104 dropped the C<_anoncopy> of the %where tree. No longer necessary,
2105 we just avoid shifting arrays within that tree.
2106
2107 =item *
2108
2109 dropped the C<_modlogic> function
2110
2111 =back
2112
2113
2114
2115 =head1 ACKNOWLEDGEMENTS
2116
2117 There are a number of individuals that have really helped out with
2118 this module. Unfortunately, most of them submitted bugs via CPAN
2119 so I have no idea who they are! But the people I do know are:
2120
2121     Ash Berlin (order_by hash term support) 
2122     Matt Trout (DBIx::Class support)
2123     Mark Stosberg (benchmarking)
2124     Chas Owens (initial "IN" operator support)
2125     Philip Collins (per-field SQL functions)
2126     Eric Kolve (hashref "AND" support)
2127     Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
2128     Dan Kubb (support for "quote_char" and "name_sep")
2129     Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
2130     Laurent Dami (internal refactoring, multiple -nest, extensible list of special operators, literal SQL)
2131
2132 Thanks!
2133
2134 =head1 SEE ALSO
2135
2136 L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>.
2137
2138 =head1 AUTHOR
2139
2140 Copyright (c) 2001-2007 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
2141
2142 This module is actively maintained by Matt Trout <mst@shadowcatsystems.co.uk>
2143
2144 For support, your best bet is to try the C<DBIx::Class> users mailing list.
2145 While not an official support venue, C<DBIx::Class> makes heavy use of
2146 C<SQL::Abstract>, and as such list members there are very familiar with
2147 how to create queries.
2148
2149 This module is free software; you may copy this under the terms of
2150 the GNU General Public License, or the Artistic License, copies of
2151 which should have accompanied your Perl kit.
2152
2153 =cut
2154