lib/DBIx/Class/SQLMaker.pm

   1 package DBIx::Class::SQLMaker;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
   9
  10 =head1 DESCRIPTION
  11
  12 This module is a subclass of L<SQL::Abstract> and includes a number of
  13 DBIC-specific workarounds, not yet suitable for inclusion into the
  14 L<SQL::Abstract> core. It also provides all (and more than) the functionality
  15 of L<SQL::Abstract::Limit>, see L<DBIx::Class::SQLMaker::LimitDialects> for
  16 more info.
  17
  18 Currently the enhancements to L<SQL::Abstract> are:
  19
  20 =over
  21
  22 =item * Support for C<JOIN> statements (via extended C<table/from> support)
  23
  24 =item * Support of functions in C<SELECT> lists
  25
  26 =item * C<GROUP BY>/C<HAVING> support (via extensions to the order_by parameter)
  27
  28 =item * Support of C<...FOR UPDATE> type of select statement modifiers
  29
  30 =item * The L</-ident> operator
  31
  32 =item * The L</-value> operator
  33
  34 =item * Date Functions:
  35
  36 Note that for the following functions use different functions for different
  37 RDBMS'.  See the SQLMaker docs for your database to see what functions are
  38 used.
  39
  40 =over
  41
  42 =item * -dt => $date_time_obj
  43
  44 This function will convert the passed datetime to whatever format the current
  45 database prefers
  46
  47 =item * -dt_diff => [$unit, \'foo.date_from', \'foo.date_to']
  48
  49 This function will diff two dates and return the units requested. Note that
  50 it correctly recurses if you pass it something like a function or a date value.
  51 Also note that not all RDBMS' are equal; some units supported on some databases
  52 and some are supported on others.  See the documentation for the SQLMaker class
  53 for your database.
  54
  55 =item * -dt_get => [$part, \'foo.date_col']
  56
  57 This function will extract the passed part from the passed column.  Note that
  58 it correctly recurses if you pass it something like a function or a date value.
  59 Also note that not all RDBMS' are equal; some parts supported on some databases
  60 and some are supported on others.  See the documentation for the SQLMaker class
  61 for your database.
  62
  63 =item * -dt_year => \'foo.date_col'
  64
  65 A shortcut for -dt_get => [year => ...]
  66
  67 =item * -dt_month => \'foo.date_col'
  68
  69 A shortcut for -dt_get => [month => ...]
  70
  71 =item * -dt_day => \'foo.date_col'
  72
  73 A shortcut for -dt_get => [day_of_month => ...]
  74
  75 =item * -dt_hour => \'foo.date_col'
  76
  77 A shortcut for -dt_get => [hour => ...]
  78
  79 =item * -dt_minute => \'foo.date_col'
  80
  81 A shortcut for -dt_get => [minute => ...]
  82
  83 =item * -dt_second => \'foo.date_col'
  84
  85 A shortcut for -dt_get => [second => ...]
  86
  87 =back
  88
  89 =back
  90
  91 Another operator is C<-func> that allows you to call SQL functions with
  92 arguments. It receives an array reference containing the function name
  93 as the 0th argument and the other arguments being its parameters. For example:
  94
  95     my %where = {
  96       -func => ['substr', 'Hello', 50, 5],
  97     };
  98
  99 Would give you:
 100
 101    $stmt = "WHERE (substr(?,?,?))";
 102    @bind = ("Hello", 50, 5);
 103
 104 Yet another operator is C<-op> that allows you to use SQL operators. It
 105 receives an array reference containing the operator 0th argument and the other
 106 arguments being its operands. For example:
 107
 108     my %where = {
 109       foo => { -op => ['+', \'bar', 50, 5] },
 110     };
 111
 112 Would give you:
 113
 114    $stmt = "WHERE (foo = bar + ? + ?)";
 115    @bind = (50, 5);
 116
 117 =cut
 118
 119 use base qw/
 120   DBIx::Class::SQLMaker::LimitDialects
 121   SQL::Abstract
 122   DBIx::Class
 123 /;
 124 use mro 'c3';
 125
 126 use Sub::Name 'subname';
 127 use DBIx::Class::Carp;
 128 use DBIx::Class::Exception;
 129 use namespace::clean;
 130
 131 __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect datetime_parser/);
 132
 133 # for when I need a normalized l/r pair
 134 sub _quote_chars {
 135   map
 136     { defined $_ ? $_ : '' }
 137     ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
 138   ;
 139 }
 140
 141 # FIXME when we bring in the storage weaklink, check its schema
 142 # weaklink and channel through $schema->throw_exception
 143 sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
 144
 145 BEGIN {
 146   # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
 147   # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
 148   no warnings qw/redefine/;
 149
 150   *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
 151     my($func) = (caller(1))[3];
 152     carp "[$func] Warning: ", @_;
 153   };
 154
 155   *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
 156     my($func) = (caller(1))[3];
 157     __PACKAGE__->throw_exception("[$func] Fatal: " . join ('',  @_));
 158   };
 159
 160   # Current SQLA pollutes its namespace - clean for the time being
 161   namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
 162 }
 163
 164 # the "oh noes offset/top without limit" constant
 165 # limited to 31 bits for sanity (and consistency,
 166 # since it may be handed to the like of sprintf %u)
 167 #
 168 # Also *some* builds of SQLite fail the test
 169 #   some_column BETWEEN ? AND ?: 1, 4294967295
 170 # with the proper integer bind attrs
 171 #
 172 # Implemented as a method, since ::Storage::DBI also
 173 # refers to it (i.e. for the case of software_limit or
 174 # as the value to abuse with MSSQL ordered subqueries)
 175 sub __max_int () { 0x7FFFFFFF };
 176
 177 # poor man's de-qualifier
 178 sub _quote {
 179   $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
 180     ? $_[1] =~ / ([^\.]+) $ /x
 181     : $_[1]
 182   );
 183 }
 184
 185 sub new {
 186   my $self = shift->next::method(@_);
 187
 188   # use the same coderefs, they are prepared to handle both cases
 189   my @extra_dbic_syntax = (
 190     { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
 191     { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
 192     { regex => qr/^ func  $/ix, handler => '_where_op_FUNC'  },
 193     { regex => qr/^ op    $/ix, handler => '_where_op_OP'    },
 194     { regex => qr/^ dt    $/xi, handler => '_where_op_CONVERT_DATETIME' },
 195     { regex => qr/^ dt_get $/xi, handler => '_where_op_GET_DATETIME' },
 196     { regex => qr/^ dt_diff $/xi, handler => '_where_op_DIFF_DATETIME' },
 197     map +{ regex => qr/^ dt_$_ $/xi, handler => '_where_op_GET_DATETIME_'.uc($_) },
 198       qw(year month day)
 199   );
 200
 201   push @{$self->{special_ops}}, @extra_dbic_syntax;
 202   push @{$self->{unary_ops}}, @extra_dbic_syntax;
 203
 204   $self;
 205 }
 206
 207 sub _where_op_IDENT {
 208   my $self = shift;
 209   my ($op, $rhs) = splice @_, -2;
 210   if (ref $rhs) {
 211     $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
 212   }
 213
 214   # in case we are called as a top level special op (no '=')
 215   my $lhs = shift;
 216
 217   $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
 218
 219   return $lhs
 220     ? "$lhs = $rhs"
 221     : $rhs
 222   ;
 223 }
 224
 225 sub _where_op_CONVERT_DATETIME {
 226   my $self = shift;
 227   my ($op, $rhs) = splice @_, -2;
 228   croak "-$op takes a DateTime only" unless ref $rhs  && $rhs->isa('DateTime');
 229
 230   # in case we are called as a top level special op (no '=')
 231   my $lhs = shift;
 232
 233   $rhs = $self->datetime_parser->format_datetime($rhs);
 234
 235   my @bind = [
 236     ($lhs || $self->{_nested_func_lhs} || undef),
 237     $rhs
 238   ];
 239
 240   return $lhs
 241     ? (
 242       $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
 243       @bind
 244     )
 245     : (
 246       $self->_convert('?'),
 247       @bind
 248     )
 249   ;
 250 }
 251
 252 sub _unsupported_date_extraction {
 253    "date part extraction not supported for part \"$_[1]\" with database \"$_[2]\""
 254 }
 255
 256 sub _unsupported_date_diff {
 257    "date diff not supported for part \"$_[1]\" with database \"$_[2]\""
 258 }
 259
 260 sub _datetime_sql { die 'date part extraction not implemented for this database' }
 261
 262 sub _datetime_diff_sql { die 'date diffing not implemented for this database' }
 263
 264 sub _where_op_GET_DATETIME {
 265   my ($self) = @_;
 266
 267   my ($k, $op, $vals);
 268
 269   if (@_ == 3) {
 270      $op = $_[1];
 271      $vals = $_[2];
 272      $k = '';
 273   } elsif (@_ == 4) {
 274      $k = $_[1];
 275      $op = $_[2];
 276      $vals = $_[3];
 277   }
 278
 279   croak 'args to -dt_get must be an arrayref' unless ref $vals eq 'ARRAY';
 280   croak 'first arg to -dt_get must be a scalar' unless !ref $vals->[0];
 281
 282   my $part = $vals->[0];
 283   my $val  = $vals->[1];
 284
 285   my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 286      SCALAR => sub {
 287        return ($self->_convert('?'), $self->_bindtype($k, $val) );
 288      },
 289      SCALARREF => sub {
 290        return $$val;
 291      },
 292      ARRAYREFREF => sub {
 293        my ($sql, @bind) = @$$val;
 294        $self->_assert_bindval_matches_bindtype(@bind);
 295        return ($sql, @bind);
 296      },
 297      HASHREF => sub {
 298        my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 299        $self->$method('', $val);
 300      }
 301   });
 302
 303   return $self->_datetime_sql($part, $sql), @bind;
 304 }
 305
 306 for my $part (qw(month day year)) {
 307    no strict 'refs';
 308    my $name = '_where_op_GET_DATETIME_' . uc($part);
 309    *{$name} = subname "DBIx::Class::SQLMaker::$name", sub {
 310      my $self = shift;
 311      my ($op, $rhs) = splice @_, -2;
 312
 313      my $lhs = shift;
 314
 315      return $self->_where_op_GET_DATETIME($op, $lhs, [$part, $rhs])
 316    }
 317 }
 318
 319 sub _where_op_DIFF_DATETIME {
 320   my ($self) = @_;
 321
 322   my ($k, $op, $vals);
 323
 324   if (@_ == 3) {
 325      $op = $_[1];
 326      $vals = $_[2];
 327      $k = '';
 328   } elsif (@_ == 4) {
 329      $k = $_[1];
 330      $op = $_[2];
 331      $vals = $_[3];
 332   }
 333
 334   croak 'args to -dt_diff must be an arrayref' unless ref $vals eq 'ARRAY';
 335   croak 'first arg to -dt_diff must be a scalar' unless !ref $vals->[0];
 336   croak '-dt_diff must have two more arguments' unless scalar @$vals == 3;
 337
 338   my ($part, @val) = @$vals;
 339   my $placeholder = $self->_convert('?');
 340
 341   my (@all_sql, @all_bind);
 342   foreach my $val (@val) {
 343     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 344        SCALAR => sub {
 345          return ($placeholder, $self->_bindtype($k, $val) );
 346        },
 347        SCALARREF => sub {
 348          return $$val;
 349        },
 350        ARRAYREFREF => sub {
 351          my ($sql, @bind) = @$$val;
 352          $self->_assert_bindval_matches_bindtype(@bind);
 353          return ($sql, @bind);
 354        },
 355        HASHREF => sub {
 356          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 357          $self->$method('', $val);
 358        }
 359     });
 360     push @all_sql, $sql;
 361     push @all_bind, @bind;
 362   }
 363
 364   return $self->_datetime_diff_sql($part, $all_sql[0], $all_sql[1]), @all_bind
 365 }
 366
 367 sub _where_op_VALUE {
 368   my $self = shift;
 369   my ($op, $rhs) = splice @_, -2;
 370
 371   # in case we are called as a top level special op (no '=')
 372   my $lhs = shift;
 373
 374   my @bind = [
 375     ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
 376     $rhs
 377   ];
 378
 379   return $lhs
 380     ? (
 381       $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
 382       @bind
 383     )
 384     : (
 385       $self->_convert('?'),
 386       @bind,
 387     )
 388   ;
 389 }
 390
 391 sub _where_op_NEST {
 392   carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
 393       .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
 394   );
 395
 396   shift->next::method(@_);
 397 }
 398
 399 # Handle limit-dialect selection
 400 sub select {
 401   my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
 402
 403
 404   $fields = $self->_recurse_fields($fields);
 405
 406   if (defined $offset) {
 407     $self->throw_exception('A supplied offset must be a non-negative integer')
 408       if ( $offset =~ /\D/ or $offset < 0 );
 409   }
 410   $offset ||= 0;
 411
 412   if (defined $limit) {
 413     $self->throw_exception('A supplied limit must be a positive integer')
 414       if ( $limit =~ /\D/ or $limit <= 0 );
 415   }
 416   elsif ($offset) {
 417     $limit = $self->__max_int;
 418   }
 419
 420
 421   my ($sql, @bind);
 422   if ($limit) {
 423     # this is legacy code-flow from SQLA::Limit, it is not set in stone
 424
 425     ($sql, @bind) = $self->next::method ($table, $fields, $where);
 426
 427     my $limiter =
 428       $self->can ('emulate_limit')  # also backcompat hook from SQLA::Limit
 429         ||
 430       do {
 431         my $dialect = $self->limit_dialect
 432           or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
 433         $self->can ("_$dialect")
 434           or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
 435       }
 436     ;
 437
 438     $sql = $self->$limiter (
 439       $sql,
 440       { %{$rs_attrs||{}}, _selector_sql => $fields },
 441       $limit,
 442       $offset
 443     );
 444   }
 445   else {
 446     ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
 447   }
 448
 449   push @{$self->{where_bind}}, @bind;
 450
 451 # this *must* be called, otherwise extra binds will remain in the sql-maker
 452   my @all_bind = $self->_assemble_binds;
 453
 454   $sql .= $self->_lock_select ($rs_attrs->{for})
 455     if $rs_attrs->{for};
 456
 457   return wantarray ? ($sql, @all_bind) : $sql;
 458 }
 459
 460 sub _assemble_binds {
 461   my $self = shift;
 462   return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where group having order limit/);
 463 }
 464
 465 my $for_syntax = {
 466   update => 'FOR UPDATE',
 467   shared => 'FOR SHARE',
 468 };
 469 sub _lock_select {
 470   my ($self, $type) = @_;
 471   my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
 472   return " $sql";
 473 }
 474
 475 # Handle default inserts
 476 sub insert {
 477 # optimized due to hotttnesss
 478 #  my ($self, $table, $data, $options) = @_;
 479
 480   # SQLA will emit INSERT INTO $table ( ) VALUES ( )
 481   # which is sadly understood only by MySQL. Change default behavior here,
 482   # until SQLA2 comes with proper dialect support
 483   if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
 484     my @bind;
 485     my $sql = sprintf(
 486       'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
 487     );
 488
 489     if ( ($_[3]||{})->{returning} ) {
 490       my $s;
 491       ($s, @bind) = $_[0]->_insert_returning ($_[3]);
 492       $sql .= $s;
 493     }
 494
 495     return ($sql, @bind);
 496   }
 497
 498   next::method(@_);
 499 }
 500
 501 sub _recurse_fields {
 502   my ($self, $fields, $depth) = @_;
 503   $depth ||= 0;
 504   my $ref = ref $fields;
 505   return $self->_quote($fields) unless $ref;
 506   return $$fields if $ref eq 'SCALAR';
 507
 508   if ($ref eq 'ARRAY') {
 509     return join(', ', map { $self->_recurse_fields($_, $depth + 1) } @$fields)
 510       if $depth != 1;
 511
 512     my ($sql, @bind) = $self->_recurse_where({@$fields});
 513
 514     push @{$self->{select_bind}}, @bind;
 515     return $sql;
 516   }
 517   elsif ($ref eq 'HASH') {
 518     my %hash = %$fields;  # shallow copy
 519
 520     my $as = delete $hash{-as};   # if supplied
 521
 522     my ($func, $args, @toomany) = %hash;
 523
 524     # there should be only one pair
 525     if (@toomany) {
 526       $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
 527     }
 528
 529     if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
 530       $self->throw_exception (
 531         'The select => { distinct => ... } syntax is not supported for multiple columns.'
 532        .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
 533        .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
 534       );
 535     }
 536
 537     my $select = sprintf ('%s( %s )%s',
 538       $self->_sqlcase($func),
 539       $self->_recurse_fields($args, $depth + 1),
 540       $as
 541         ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
 542         : ''
 543     );
 544
 545     return $select;
 546   }
 547   # Is the second check absolutely necessary?
 548   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
 549     push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
 550     return $$fields->[0];
 551   }
 552   else {
 553     $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
 554   }
 555 }
 556
 557
 558 # this used to be a part of _order_by but is broken out for clarity.
 559 # What we have been doing forever is hijacking the $order arg of
 560 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
 561 # then pretty much the entire resultset attr-hash, as more and more
 562 # things in the SQLA space need to have mopre info about the $rs they
 563 # create SQL for. The alternative would be to keep expanding the
 564 # signature of _select with more and more positional parameters, which
 565 # is just gross. All hail SQLA2!
 566 sub _parse_rs_attrs {
 567   my ($self, $arg) = @_;
 568
 569   my $sql = '';
 570
 571   if ($arg->{group_by}) {
 572     # horible horrible, waiting for refactor
 573     local $self->{select_bind};
 574     if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
 575       $sql .= $self->_sqlcase(' group by ') . $g;
 576       push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
 577     }
 578   }
 579
 580   if (defined $arg->{having}) {
 581     my ($frag, @bind) = $self->_recurse_where($arg->{having});
 582     push(@{$self->{having_bind}}, @bind);
 583     $sql .= $self->_sqlcase(' having ') . $frag;
 584   }
 585
 586   if (defined $arg->{order_by}) {
 587     $sql .= $self->_order_by ($arg->{order_by});
 588   }
 589
 590   return $sql;
 591 }
 592
 593 sub _order_by {
 594   my ($self, $arg) = @_;
 595
 596   # check that we are not called in legacy mode (order_by as 4th argument)
 597   if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
 598     return $self->_parse_rs_attrs ($arg);
 599   }
 600   else {
 601     my ($sql, @bind) = $self->next::method($arg);
 602     push @{$self->{order_bind}}, @bind;
 603     return $sql;
 604   }
 605 }
 606
 607 sub _table {
 608 # optimized due to hotttnesss
 609 #  my ($self, $from) = @_;
 610   if (my $ref = ref $_[1] ) {
 611     if ($ref eq 'ARRAY') {
 612       return $_[0]->_recurse_from(@{$_[1]});
 613     }
 614     elsif ($ref eq 'HASH') {
 615       return $_[0]->_recurse_from($_[1]);
 616     }
 617     elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
 618       my ($sql, @bind) = @{ ${$_[1]} };
 619       push @{$_[0]->{from_bind}}, @bind;
 620       return $sql
 621     }
 622   }
 623   return $_[0]->next::method ($_[1]);
 624 }
 625
 626 sub _generate_join_clause {
 627     my ($self, $join_type) = @_;
 628
 629     $join_type = $self->{_default_jointype}
 630       if ! defined $join_type;
 631
 632     return sprintf ('%s JOIN ',
 633       $join_type ?  $self->_sqlcase($join_type) : ''
 634     );
 635 }
 636
 637 sub _where_op_FUNC {
 638   my ($self) = @_;
 639
 640   my ($k, $vals);
 641
 642   if (@_ == 3) {
 643      # $_[1] gets set to "op"
 644      $vals = $_[2];
 645      $k = '';
 646   } elsif (@_ == 4) {
 647      $k = $_[1];
 648      # $_[2] gets set to "op"
 649      $vals = $_[3];
 650   }
 651
 652   my $label       = $self->_convert($self->_quote($k));
 653   my $placeholder = $self->_convert('?');
 654
 655   croak '-func must be an array' unless ref $vals eq 'ARRAY';
 656   croak 'first arg for -func must be a scalar' unless !ref $vals->[0];
 657
 658   my ($func,@rest_of_vals) = @$vals;
 659
 660   $self->_assert_pass_injection_guard($func);
 661
 662   my (@all_sql, @all_bind);
 663   foreach my $val (@rest_of_vals) {
 664     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 665        SCALAR => sub {
 666          return ($placeholder, $self->_bindtype($k, $val) );
 667        },
 668        SCALARREF => sub {
 669          return $$val;
 670        },
 671        ARRAYREFREF => sub {
 672          my ($sql, @bind) = @$$val;
 673          $self->_assert_bindval_matches_bindtype(@bind);
 674          return ($sql, @bind);
 675        },
 676        HASHREF => sub {
 677          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 678          $self->$method('', $val);
 679        }
 680     });
 681     push @all_sql, $sql;
 682     push @all_bind, @bind;
 683   }
 684
 685   my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
 686
 687   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 688   return ($sql, @bind)
 689 }
 690
 691 sub _where_op_OP {
 692   my ($self) = @_;
 693
 694   my ($k, $vals);
 695
 696   if (@_ == 3) {
 697      # $_[1] gets set to "op"
 698      $vals = $_[2];
 699      $k = '';
 700   } elsif (@_ == 4) {
 701      $k = $_[1];
 702      # $_[2] gets set to "op"
 703      $vals = $_[3];
 704   }
 705
 706   my $label       = $self->_convert($self->_quote($k));
 707   my $placeholder = $self->_convert('?');
 708
 709   croak 'argument to -op must be an arrayref' unless ref $vals eq 'ARRAY';
 710   croak 'first arg for -op must be a scalar' unless !ref $vals->[0];
 711
 712   my ($op, @rest_of_vals) = @$vals;
 713
 714   $self->_assert_pass_injection_guard($op);
 715
 716   my (@all_sql, @all_bind);
 717   foreach my $val (@rest_of_vals) {
 718     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 719        SCALAR => sub {
 720          return ($placeholder, $self->_bindtype($k, $val) );
 721        },
 722        SCALARREF => sub {
 723          return $$val;
 724        },
 725        ARRAYREFREF => sub {
 726          my ($sql, @bind) = @$$val;
 727          $self->_assert_bindval_matches_bindtype(@bind);
 728          return ($sql, @bind);
 729        },
 730        HASHREF => sub {
 731          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 732          $self->$method('', $val);
 733        }
 734     });
 735     push @all_sql, $sql;
 736     push @all_bind, @bind;
 737   }
 738
 739   my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
 740
 741   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 742   return ($sql, @bind)
 743 }
 744
 745 sub _recurse_from {
 746   my $self = shift;
 747
 748   return join (' ', $self->_gen_from_blocks(@_) );
 749 }
 750
 751 sub _gen_from_blocks {
 752   my ($self, $from, @joins) = @_;
 753
 754   my @fchunks = $self->_from_chunk_to_sql($from);
 755
 756   for (@joins) {
 757     my ($to, $on) = @$_;
 758
 759     # check whether a join type exists
 760     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
 761     my $join_type;
 762     if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
 763       $join_type = $to_jt->{-join_type};
 764       $join_type =~ s/^\s+ | \s+$//xg;
 765     }
 766
 767     my @j = $self->_generate_join_clause( $join_type );
 768
 769     if (ref $to eq 'ARRAY') {
 770       push(@j, '(', $self->_recurse_from(@$to), ')');
 771     }
 772     else {
 773       push(@j, $self->_from_chunk_to_sql($to));
 774     }
 775
 776     my ($sql, @bind) = $self->_join_condition($on);
 777     push(@j, ' ON ', $sql);
 778     push @{$self->{from_bind}}, @bind;
 779
 780     push @fchunks, join '', @j;
 781   }
 782
 783   return @fchunks;
 784 }
 785
 786 sub _from_chunk_to_sql {
 787   my ($self, $fromspec) = @_;
 788
 789   return join (' ', $self->_SWITCH_refkind($fromspec, {
 790     SCALARREF => sub {
 791       $$fromspec;
 792     },
 793     ARRAYREFREF => sub {
 794       push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
 795       $$fromspec->[0];
 796     },
 797     HASHREF => sub {
 798       my ($as, $table, $toomuch) = ( map
 799         { $_ => $fromspec->{$_} }
 800         ( grep { $_ !~ /^\-/ } keys %$fromspec )
 801       );
 802
 803       $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
 804         if defined $toomuch;
 805
 806       ($self->_from_chunk_to_sql($table), $self->_quote($as) );
 807     },
 808     SCALAR => sub {
 809       $self->_quote($fromspec);
 810     },
 811   }));
 812 }
 813
 814 sub _join_condition {
 815   my ($self, $cond) = @_;
 816
 817   # Backcompat for the old days when a plain hashref
 818   # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
 819   # Once things settle we should start warning here so that
 820   # folks unroll their hacks
 821   if (
 822     ref $cond eq 'HASH'
 823       and
 824     keys %$cond == 1
 825       and
 826     (keys %$cond)[0] =~ /\./
 827       and
 828     ! ref ( (values %$cond)[0] )
 829   ) {
 830     $cond = { keys %$cond => { -ident => values %$cond } }
 831   }
 832   elsif ( ref $cond eq 'ARRAY' ) {
 833     # do our own ORing so that the hashref-shim above is invoked
 834     my @parts;
 835     my @binds;
 836     foreach my $c (@$cond) {
 837       my ($sql, @bind) = $self->_join_condition($c);
 838       push @binds, @bind;
 839       push @parts, $sql;
 840     }
 841     return join(' OR ', @parts), @binds;
 842   }
 843
 844   return $self->_recurse_where($cond);
 845 }
 846
 847 1;
 848
 849 =head1 OPERATORS
 850
 851 =head2 -ident
 852
 853 Used to explicitly specify an SQL identifier. Takes a plain string as value
 854 which is then invariably treated as a column name (and is being properly
 855 quoted if quoting has been requested). Most useful for comparison of two
 856 columns:
 857
 858     my %where = (
 859         priority => { '<', 2 },
 860         requestor => { -ident => 'submitter' }
 861     );
 862
 863 which results in:
 864
 865     $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
 866     @bind = ('2');
 867
 868 =head2 -value
 869
 870 The -value operator signals that the argument to the right is a raw bind value.
 871 It will be passed straight to DBI, without invoking any of the SQL::Abstract
 872 condition-parsing logic. This allows you to, for example, pass an array as a
 873 column value for databases that support array datatypes, e.g.:
 874
 875     my %where = (
 876         array => { -value => [1, 2, 3] }
 877     );
 878
 879 which results in:
 880
 881     $stmt = 'WHERE array = ?';
 882     @bind = ([1, 2, 3]);
 883
 884 =head1 AUTHORS
 885
 886 See L<DBIx::Class/CONTRIBUTORS>.
 887
 888 =head1 LICENSE
 889
 890 You may distribute this code under the same terms as Perl itself.
 891
 892 =cut