lib/SQL/Abstract.pm

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