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