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