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