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 {
 198   my %part_map = (
 199      month        => 'm',
 200      day_of_month => 'd',
 201      year         => 'Y',
 202   );
 203
 204   sub _datetime_sql { "STRFTIME('$part_map{$_[1]}', $_[2])" }
 205 }
 206
 207 sub _datetime_diff_sql {
 208    my ($self, $part, $left, $right) = @_;
 209    '(' .
 210       $self->_datetime_sql($part, $left)
 211        . ' - ' .
 212       $self->_datetime_sql($part, $right)
 213    . ')'
 214 }
 215
 216 sub _where_op_GET_DATETIME {
 217   my ($self) = @_;
 218
 219   my ($k, $op, $vals);
 220
 221   if (@_ == 3) {
 222      $op = $_[1];
 223      $vals = $_[2];
 224      $k = '';
 225   } elsif (@_ == 4) {
 226      $k = $_[1];
 227      $op = $_[2];
 228      $vals = $_[3];
 229   }
 230
 231   croak 'args to -dt_get must be an arrayref' unless ref $vals eq 'ARRAY';
 232   croak 'first arg to -dt_get must be a scalar' unless !ref $vals->[0];
 233
 234   my $part = $vals->[0];
 235   my $val  = $vals->[1];
 236
 237   my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 238      SCALAR => sub {
 239        return ($self->_convert('?'), $self->_bindtype($k, $val) );
 240      },
 241      SCALARREF => sub {
 242        return $$val;
 243      },
 244      ARRAYREFREF => sub {
 245        my ($sql, @bind) = @$$val;
 246        $self->_assert_bindval_matches_bindtype(@bind);
 247        return ($sql, @bind);
 248      },
 249      HASHREF => sub {
 250        my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 251        $self->$method('', $val);
 252      }
 253   });
 254
 255   return $self->_datetime_sql($part, $sql), @bind;
 256 }
 257
 258 for my $part (qw(month day year)) {
 259    no strict 'refs';
 260    my $name = '_where_op_GET_DATETIME_' . uc($part);
 261    *{$name} = subname "DBIx::Class::SQLMaker::$name", sub {
 262      my $self = shift;
 263      my ($op, $rhs) = splice @_, -2;
 264
 265      my $lhs = shift;
 266
 267      return $self->_where_op_GET_DATETIME($op, $lhs, [$part, $rhs])
 268    }
 269 }
 270
 271 sub _where_op_DIFF_DATETIME {
 272   my ($self) = @_;
 273
 274   my ($k, $op, $vals);
 275
 276   if (@_ == 3) {
 277      $op = $_[1];
 278      $vals = $_[2];
 279      $k = '';
 280   } elsif (@_ == 4) {
 281      $k = $_[1];
 282      $op = $_[2];
 283      $vals = $_[3];
 284   }
 285
 286   croak 'args to -dt_diff must be an arrayref' unless ref $vals eq 'ARRAY';
 287   croak 'first arg to -dt_diff must be a scalar' unless !ref $vals->[0];
 288   croak '-dt_diff must have two more arguments' unless scalar @$vals == 3;
 289
 290   my ($part, @val) = @$vals;
 291   my $placeholder = $self->_convert('?');
 292
 293   my (@all_sql, @all_bind);
 294   foreach my $val (@val) {
 295     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 296        SCALAR => sub {
 297          return ($placeholder, $self->_bindtype($k, $val) );
 298        },
 299        SCALARREF => sub {
 300          return $$val;
 301        },
 302        ARRAYREFREF => sub {
 303          my ($sql, @bind) = @$$val;
 304          $self->_assert_bindval_matches_bindtype(@bind);
 305          return ($sql, @bind);
 306        },
 307        HASHREF => sub {
 308          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 309          $self->$method('', $val);
 310        }
 311     });
 312     push @all_sql, $sql;
 313     push @all_bind, @bind;
 314   }
 315
 316   return $self->_datetime_diff_sql($part, $all_sql[0], $all_sql[1]), @all_bind
 317 }
 318
 319 sub _where_op_VALUE {
 320   my $self = shift;
 321   my ($op, $rhs) = splice @_, -2;
 322
 323   # in case we are called as a top level special op (no '=')
 324   my $lhs = shift;
 325
 326   my @bind = [
 327     ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
 328     $rhs
 329   ];
 330
 331   return $lhs
 332     ? (
 333       $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
 334       @bind
 335     )
 336     : (
 337       $self->_convert('?'),
 338       @bind,
 339     )
 340   ;
 341 }
 342
 343 sub _where_op_NEST {
 344   carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
 345       .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
 346   );
 347
 348   shift->next::method(@_);
 349 }
 350
 351 # Handle limit-dialect selection
 352 sub select {
 353   my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
 354
 355
 356   $fields = $self->_recurse_fields($fields);
 357
 358   if (defined $offset) {
 359     $self->throw_exception('A supplied offset must be a non-negative integer')
 360       if ( $offset =~ /\D/ or $offset < 0 );
 361   }
 362   $offset ||= 0;
 363
 364   if (defined $limit) {
 365     $self->throw_exception('A supplied limit must be a positive integer')
 366       if ( $limit =~ /\D/ or $limit <= 0 );
 367   }
 368   elsif ($offset) {
 369     $limit = $self->__max_int;
 370   }
 371
 372
 373   my ($sql, @bind);
 374   if ($limit) {
 375     # this is legacy code-flow from SQLA::Limit, it is not set in stone
 376
 377     ($sql, @bind) = $self->next::method ($table, $fields, $where);
 378
 379     my $limiter =
 380       $self->can ('emulate_limit')  # also backcompat hook from SQLA::Limit
 381         ||
 382       do {
 383         my $dialect = $self->limit_dialect
 384           or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
 385         $self->can ("_$dialect")
 386           or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
 387       }
 388     ;
 389
 390     $sql = $self->$limiter (
 391       $sql,
 392       { %{$rs_attrs||{}}, _selector_sql => $fields },
 393       $limit,
 394       $offset
 395     );
 396   }
 397   else {
 398     ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
 399   }
 400
 401   push @{$self->{where_bind}}, @bind;
 402
 403 # this *must* be called, otherwise extra binds will remain in the sql-maker
 404   my @all_bind = $self->_assemble_binds;
 405
 406   $sql .= $self->_lock_select ($rs_attrs->{for})
 407     if $rs_attrs->{for};
 408
 409   return wantarray ? ($sql, @all_bind) : $sql;
 410 }
 411
 412 sub _assemble_binds {
 413   my $self = shift;
 414   return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where group having order limit/);
 415 }
 416
 417 my $for_syntax = {
 418   update => 'FOR UPDATE',
 419   shared => 'FOR SHARE',
 420 };
 421 sub _lock_select {
 422   my ($self, $type) = @_;
 423   my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
 424   return " $sql";
 425 }
 426
 427 # Handle default inserts
 428 sub insert {
 429 # optimized due to hotttnesss
 430 #  my ($self, $table, $data, $options) = @_;
 431
 432   # SQLA will emit INSERT INTO $table ( ) VALUES ( )
 433   # which is sadly understood only by MySQL. Change default behavior here,
 434   # until SQLA2 comes with proper dialect support
 435   if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
 436     my @bind;
 437     my $sql = sprintf(
 438       'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
 439     );
 440
 441     if ( ($_[3]||{})->{returning} ) {
 442       my $s;
 443       ($s, @bind) = $_[0]->_insert_returning ($_[3]);
 444       $sql .= $s;
 445     }
 446
 447     return ($sql, @bind);
 448   }
 449
 450   next::method(@_);
 451 }
 452
 453 sub _recurse_fields {
 454   my ($self, $fields, $depth) = @_;
 455   $depth ||= 0;
 456   my $ref = ref $fields;
 457   return $self->_quote($fields) unless $ref;
 458   return $$fields if $ref eq 'SCALAR';
 459
 460   if ($ref eq 'ARRAY') {
 461     return join(', ', map { $self->_recurse_fields($_, $depth + 1) } @$fields)
 462       if $depth != 1;
 463
 464     my ($sql, @bind) = $self->_recurse_where({@$fields});
 465
 466     push @{$self->{select_bind}}, @bind;
 467     return $sql;
 468   }
 469   elsif ($ref eq 'HASH') {
 470     my %hash = %$fields;  # shallow copy
 471
 472     my $as = delete $hash{-as};   # if supplied
 473
 474     my ($func, $args, @toomany) = %hash;
 475
 476     # there should be only one pair
 477     if (@toomany) {
 478       $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
 479     }
 480
 481     if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
 482       $self->throw_exception (
 483         'The select => { distinct => ... } syntax is not supported for multiple columns.'
 484        .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
 485        .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
 486       );
 487     }
 488
 489     my $select = sprintf ('%s( %s )%s',
 490       $self->_sqlcase($func),
 491       $self->_recurse_fields($args, $depth + 1),
 492       $as
 493         ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
 494         : ''
 495     );
 496
 497     return $select;
 498   }
 499   # Is the second check absolutely necessary?
 500   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
 501     push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
 502     return $$fields->[0];
 503   }
 504   else {
 505     $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
 506   }
 507 }
 508
 509
 510 # this used to be a part of _order_by but is broken out for clarity.
 511 # What we have been doing forever is hijacking the $order arg of
 512 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
 513 # then pretty much the entire resultset attr-hash, as more and more
 514 # things in the SQLA space need to have mopre info about the $rs they
 515 # create SQL for. The alternative would be to keep expanding the
 516 # signature of _select with more and more positional parameters, which
 517 # is just gross. All hail SQLA2!
 518 sub _parse_rs_attrs {
 519   my ($self, $arg) = @_;
 520
 521   my $sql = '';
 522
 523   if ($arg->{group_by}) {
 524     # horible horrible, waiting for refactor
 525     local $self->{select_bind};
 526     if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
 527       $sql .= $self->_sqlcase(' group by ') . $g;
 528       push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
 529     }
 530   }
 531
 532   if (defined $arg->{having}) {
 533     my ($frag, @bind) = $self->_recurse_where($arg->{having});
 534     push(@{$self->{having_bind}}, @bind);
 535     $sql .= $self->_sqlcase(' having ') . $frag;
 536   }
 537
 538   if (defined $arg->{order_by}) {
 539     $sql .= $self->_order_by ($arg->{order_by});
 540   }
 541
 542   return $sql;
 543 }
 544
 545 sub _order_by {
 546   my ($self, $arg) = @_;
 547
 548   # check that we are not called in legacy mode (order_by as 4th argument)
 549   if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
 550     return $self->_parse_rs_attrs ($arg);
 551   }
 552   else {
 553     my ($sql, @bind) = $self->next::method($arg);
 554     push @{$self->{order_bind}}, @bind;
 555     return $sql;
 556   }
 557 }
 558
 559 sub _table {
 560 # optimized due to hotttnesss
 561 #  my ($self, $from) = @_;
 562   if (my $ref = ref $_[1] ) {
 563     if ($ref eq 'ARRAY') {
 564       return $_[0]->_recurse_from(@{$_[1]});
 565     }
 566     elsif ($ref eq 'HASH') {
 567       return $_[0]->_recurse_from($_[1]);
 568     }
 569     elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
 570       my ($sql, @bind) = @{ ${$_[1]} };
 571       push @{$_[0]->{from_bind}}, @bind;
 572       return $sql
 573     }
 574   }
 575   return $_[0]->next::method ($_[1]);
 576 }
 577
 578 sub _generate_join_clause {
 579     my ($self, $join_type) = @_;
 580
 581     $join_type = $self->{_default_jointype}
 582       if ! defined $join_type;
 583
 584     return sprintf ('%s JOIN ',
 585       $join_type ?  $self->_sqlcase($join_type) : ''
 586     );
 587 }
 588
 589 sub _where_op_FUNC {
 590   my ($self) = @_;
 591
 592   my ($k, $vals);
 593
 594   if (@_ == 3) {
 595      # $_[1] gets set to "op"
 596      $vals = $_[2];
 597      $k = '';
 598   } elsif (@_ == 4) {
 599      $k = $_[1];
 600      # $_[2] gets set to "op"
 601      $vals = $_[3];
 602   }
 603
 604   my $label       = $self->_convert($self->_quote($k));
 605   my $placeholder = $self->_convert('?');
 606
 607   croak '-func must be an array' unless ref $vals eq 'ARRAY';
 608   croak 'first arg for -func must be a scalar' unless !ref $vals->[0];
 609
 610   my ($func,@rest_of_vals) = @$vals;
 611
 612   $self->_assert_pass_injection_guard($func);
 613
 614   my (@all_sql, @all_bind);
 615   foreach my $val (@rest_of_vals) {
 616     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 617        SCALAR => sub {
 618          return ($placeholder, $self->_bindtype($k, $val) );
 619        },
 620        SCALARREF => sub {
 621          return $$val;
 622        },
 623        ARRAYREFREF => sub {
 624          my ($sql, @bind) = @$$val;
 625          $self->_assert_bindval_matches_bindtype(@bind);
 626          return ($sql, @bind);
 627        },
 628        HASHREF => sub {
 629          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 630          $self->$method('', $val);
 631        }
 632     });
 633     push @all_sql, $sql;
 634     push @all_bind, @bind;
 635   }
 636
 637   my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
 638
 639   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 640   return ($sql, @bind)
 641 }
 642
 643 sub _where_op_OP {
 644   my ($self) = @_;
 645
 646   my ($k, $vals);
 647
 648   if (@_ == 3) {
 649      # $_[1] gets set to "op"
 650      $vals = $_[2];
 651      $k = '';
 652   } elsif (@_ == 4) {
 653      $k = $_[1];
 654      # $_[2] gets set to "op"
 655      $vals = $_[3];
 656   }
 657
 658   my $label       = $self->_convert($self->_quote($k));
 659   my $placeholder = $self->_convert('?');
 660
 661   croak 'argument to -op must be an arrayref' unless ref $vals eq 'ARRAY';
 662   croak 'first arg for -op must be a scalar' unless !ref $vals->[0];
 663
 664   my ($op, @rest_of_vals) = @$vals;
 665
 666   $self->_assert_pass_injection_guard($op);
 667
 668   my (@all_sql, @all_bind);
 669   foreach my $val (@rest_of_vals) {
 670     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 671        SCALAR => sub {
 672          return ($placeholder, $self->_bindtype($k, $val) );
 673        },
 674        SCALARREF => sub {
 675          return $$val;
 676        },
 677        ARRAYREFREF => sub {
 678          my ($sql, @bind) = @$$val;
 679          $self->_assert_bindval_matches_bindtype(@bind);
 680          return ($sql, @bind);
 681        },
 682        HASHREF => sub {
 683          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 684          $self->$method('', $val);
 685        }
 686     });
 687     push @all_sql, $sql;
 688     push @all_bind, @bind;
 689   }
 690
 691   my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
 692
 693   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 694   return ($sql, @bind)
 695 }
 696
 697 sub _recurse_from {
 698   my $self = shift;
 699
 700   return join (' ', $self->_gen_from_blocks(@_) );
 701 }
 702
 703 sub _gen_from_blocks {
 704   my ($self, $from, @joins) = @_;
 705
 706   my @fchunks = $self->_from_chunk_to_sql($from);
 707
 708   for (@joins) {
 709     my ($to, $on) = @$_;
 710
 711     # check whether a join type exists
 712     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
 713     my $join_type;
 714     if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
 715       $join_type = $to_jt->{-join_type};
 716       $join_type =~ s/^\s+ | \s+$//xg;
 717     }
 718
 719     my @j = $self->_generate_join_clause( $join_type );
 720
 721     if (ref $to eq 'ARRAY') {
 722       push(@j, '(', $self->_recurse_from(@$to), ')');
 723     }
 724     else {
 725       push(@j, $self->_from_chunk_to_sql($to));
 726     }
 727
 728     my ($sql, @bind) = $self->_join_condition($on);
 729     push(@j, ' ON ', $sql);
 730     push @{$self->{from_bind}}, @bind;
 731
 732     push @fchunks, join '', @j;
 733   }
 734
 735   return @fchunks;
 736 }
 737
 738 sub _from_chunk_to_sql {
 739   my ($self, $fromspec) = @_;
 740
 741   return join (' ', $self->_SWITCH_refkind($fromspec, {
 742     SCALARREF => sub {
 743       $$fromspec;
 744     },
 745     ARRAYREFREF => sub {
 746       push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
 747       $$fromspec->[0];
 748     },
 749     HASHREF => sub {
 750       my ($as, $table, $toomuch) = ( map
 751         { $_ => $fromspec->{$_} }
 752         ( grep { $_ !~ /^\-/ } keys %$fromspec )
 753       );
 754
 755       $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
 756         if defined $toomuch;
 757
 758       ($self->_from_chunk_to_sql($table), $self->_quote($as) );
 759     },
 760     SCALAR => sub {
 761       $self->_quote($fromspec);
 762     },
 763   }));
 764 }
 765
 766 sub _join_condition {
 767   my ($self, $cond) = @_;
 768
 769   # Backcompat for the old days when a plain hashref
 770   # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
 771   # Once things settle we should start warning here so that
 772   # folks unroll their hacks
 773   if (
 774     ref $cond eq 'HASH'
 775       and
 776     keys %$cond == 1
 777       and
 778     (keys %$cond)[0] =~ /\./
 779       and
 780     ! ref ( (values %$cond)[0] )
 781   ) {
 782     $cond = { keys %$cond => { -ident => values %$cond } }
 783   }
 784   elsif ( ref $cond eq 'ARRAY' ) {
 785     # do our own ORing so that the hashref-shim above is invoked
 786     my @parts;
 787     my @binds;
 788     foreach my $c (@$cond) {
 789       my ($sql, @bind) = $self->_join_condition($c);
 790       push @binds, @bind;
 791       push @parts, $sql;
 792     }
 793     return join(' OR ', @parts), @binds;
 794   }
 795
 796   return $self->_recurse_where($cond);
 797 }
 798
 799 1;
 800
 801 =head1 OPERATORS
 802
 803 =head2 -ident
 804
 805 Used to explicitly specify an SQL identifier. Takes a plain string as value
 806 which is then invariably treated as a column name (and is being properly
 807 quoted if quoting has been requested). Most useful for comparison of two
 808 columns:
 809
 810     my %where = (
 811         priority => { '<', 2 },
 812         requestor => { -ident => 'submitter' }
 813     );
 814
 815 which results in:
 816
 817     $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
 818     @bind = ('2');
 819
 820 =head2 -value
 821
 822 The -value operator signals that the argument to the right is a raw bind value.
 823 It will be passed straight to DBI, without invoking any of the SQL::Abstract
 824 condition-parsing logic. This allows you to, for example, pass an array as a
 825 column value for databases that support array datatypes, e.g.:
 826
 827     my %where = (
 828         array => { -value => [1, 2, 3] }
 829     );
 830
 831 which results in:
 832
 833     $stmt = 'WHERE array = ?';
 834     @bind = ([1, 2, 3]);
 835
 836 =head1 AUTHORS
 837
 838 See L<DBIx::Class/CONTRIBUTORS>.
 839
 840 =head1 LICENSE
 841
 842 You may distribute this code under the same terms as Perl itself.
 843
 844 =cut