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/);
  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   );
 140
 141   push @{$self->{special_ops}}, @extra_dbic_syntax;
 142   push @{$self->{unary_ops}}, @extra_dbic_syntax;
 143
 144   $self;
 145 }
 146
 147 sub _where_op_IDENT {
 148   my $self = shift;
 149   my ($op, $rhs) = splice @_, -2;
 150   if (ref $rhs) {
 151     $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
 152   }
 153
 154   # in case we are called as a top level special op (no '=')
 155   my $lhs = shift;
 156
 157   $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
 158
 159   return $lhs
 160     ? "$lhs = $rhs"
 161     : $rhs
 162   ;
 163 }
 164
 165 sub _where_op_VALUE {
 166   my $self = shift;
 167   my ($op, $rhs) = splice @_, -2;
 168
 169   # in case we are called as a top level special op (no '=')
 170   my $lhs = shift;
 171
 172   my @bind = [
 173     ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
 174     $rhs
 175   ];
 176
 177   return $lhs
 178     ? (
 179       $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
 180       @bind
 181     )
 182     : (
 183       $self->_convert('?'),
 184       @bind,
 185     )
 186   ;
 187 }
 188
 189 sub _where_op_NEST {
 190   carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
 191       .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
 192   );
 193
 194   shift->next::method(@_);
 195 }
 196
 197 # Handle limit-dialect selection
 198 sub select {
 199   my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
 200
 201
 202   $fields = $self->_recurse_fields($fields);
 203
 204   if (defined $offset) {
 205     $self->throw_exception('A supplied offset must be a non-negative integer')
 206       if ( $offset =~ /\D/ or $offset < 0 );
 207   }
 208   $offset ||= 0;
 209
 210   if (defined $limit) {
 211     $self->throw_exception('A supplied limit must be a positive integer')
 212       if ( $limit =~ /\D/ or $limit <= 0 );
 213   }
 214   elsif ($offset) {
 215     $limit = $self->__max_int;
 216   }
 217
 218
 219   my ($sql, @bind);
 220   if ($limit) {
 221     # this is legacy code-flow from SQLA::Limit, it is not set in stone
 222
 223     ($sql, @bind) = $self->next::method ($table, $fields, $where);
 224
 225     my $limiter =
 226       $self->can ('emulate_limit')  # also backcompat hook from SQLA::Limit
 227         ||
 228       do {
 229         my $dialect = $self->limit_dialect
 230           or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
 231         $self->can ("_$dialect")
 232           or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
 233       }
 234     ;
 235
 236     $sql = $self->$limiter (
 237       $sql,
 238       { %{$rs_attrs||{}}, _selector_sql => $fields },
 239       $limit,
 240       $offset
 241     );
 242   }
 243   else {
 244     ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
 245   }
 246
 247   push @{$self->{where_bind}}, @bind;
 248
 249 # this *must* be called, otherwise extra binds will remain in the sql-maker
 250   my @all_bind = $self->_assemble_binds;
 251
 252   $sql .= $self->_lock_select ($rs_attrs->{for})
 253     if $rs_attrs->{for};
 254
 255   return wantarray ? ($sql, @all_bind) : $sql;
 256 }
 257
 258 sub _assemble_binds {
 259   my $self = shift;
 260   return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where group having order limit/);
 261 }
 262
 263 my $for_syntax = {
 264   update => 'FOR UPDATE',
 265   shared => 'FOR SHARE',
 266 };
 267 sub _lock_select {
 268   my ($self, $type) = @_;
 269   my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
 270   return " $sql";
 271 }
 272
 273 # Handle default inserts
 274 sub insert {
 275 # optimized due to hotttnesss
 276 #  my ($self, $table, $data, $options) = @_;
 277
 278   # SQLA will emit INSERT INTO $table ( ) VALUES ( )
 279   # which is sadly understood only by MySQL. Change default behavior here,
 280   # until SQLA2 comes with proper dialect support
 281   if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
 282     my @bind;
 283     my $sql = sprintf(
 284       'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
 285     );
 286
 287     if ( ($_[3]||{})->{returning} ) {
 288       my $s;
 289       ($s, @bind) = $_[0]->_insert_returning ($_[3]);
 290       $sql .= $s;
 291     }
 292
 293     return ($sql, @bind);
 294   }
 295
 296   next::method(@_);
 297 }
 298
 299 sub _recurse_fields {
 300   my ($self, $fields, $depth) = @_;
 301   $depth ||= 0;
 302   my $ref = ref $fields;
 303   return $self->_quote($fields) unless $ref;
 304   return $$fields if $ref eq 'SCALAR';
 305
 306   if ($ref eq 'ARRAY') {
 307     return join(', ', map { $self->_recurse_fields($_, $depth + 1) } @$fields)
 308       if $depth != 1;
 309
 310     my ($sql, @bind) = $self->_recurse_where({@$fields});
 311
 312     push @{$self->{select_bind}}, @bind;
 313     return $sql;
 314   }
 315   elsif ($ref eq 'HASH') {
 316     my %hash = %$fields;  # shallow copy
 317
 318     my $as = delete $hash{-as};   # if supplied
 319
 320     my ($func, $args, @toomany) = %hash;
 321
 322     # there should be only one pair
 323     if (@toomany) {
 324       $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
 325     }
 326
 327     if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
 328       $self->throw_exception (
 329         'The select => { distinct => ... } syntax is not supported for multiple columns.'
 330        .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
 331        .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
 332       );
 333     }
 334
 335     my $select = sprintf ('%s( %s )%s',
 336       $self->_sqlcase($func),
 337       $self->_recurse_fields($args, $depth + 1),
 338       $as
 339         ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
 340         : ''
 341     );
 342
 343     return $select;
 344   }
 345   # Is the second check absolutely necessary?
 346   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
 347     push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
 348     return $$fields->[0];
 349   }
 350   else {
 351     $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
 352   }
 353 }
 354
 355
 356 # this used to be a part of _order_by but is broken out for clarity.
 357 # What we have been doing forever is hijacking the $order arg of
 358 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
 359 # then pretty much the entire resultset attr-hash, as more and more
 360 # things in the SQLA space need to have mopre info about the $rs they
 361 # create SQL for. The alternative would be to keep expanding the
 362 # signature of _select with more and more positional parameters, which
 363 # is just gross. All hail SQLA2!
 364 sub _parse_rs_attrs {
 365   my ($self, $arg) = @_;
 366
 367   my $sql = '';
 368
 369   if ($arg->{group_by}) {
 370     # horible horrible, waiting for refactor
 371     local $self->{select_bind};
 372     if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
 373       $sql .= $self->_sqlcase(' group by ') . $g;
 374       push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
 375     }
 376   }
 377
 378   if (defined $arg->{having}) {
 379     my ($frag, @bind) = $self->_recurse_where($arg->{having});
 380     push(@{$self->{having_bind}}, @bind);
 381     $sql .= $self->_sqlcase(' having ') . $frag;
 382   }
 383
 384   if (defined $arg->{order_by}) {
 385     $sql .= $self->_order_by ($arg->{order_by});
 386   }
 387
 388   return $sql;
 389 }
 390
 391 sub _order_by {
 392   my ($self, $arg) = @_;
 393
 394   # check that we are not called in legacy mode (order_by as 4th argument)
 395   if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
 396     return $self->_parse_rs_attrs ($arg);
 397   }
 398   else {
 399     my ($sql, @bind) = $self->next::method($arg);
 400     push @{$self->{order_bind}}, @bind;
 401     return $sql;
 402   }
 403 }
 404
 405 sub _table {
 406 # optimized due to hotttnesss
 407 #  my ($self, $from) = @_;
 408   if (my $ref = ref $_[1] ) {
 409     if ($ref eq 'ARRAY') {
 410       return $_[0]->_recurse_from(@{$_[1]});
 411     }
 412     elsif ($ref eq 'HASH') {
 413       return $_[0]->_recurse_from($_[1]);
 414     }
 415     elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
 416       my ($sql, @bind) = @{ ${$_[1]} };
 417       push @{$_[0]->{from_bind}}, @bind;
 418       return $sql
 419     }
 420   }
 421   return $_[0]->next::method ($_[1]);
 422 }
 423
 424 sub _generate_join_clause {
 425     my ($self, $join_type) = @_;
 426
 427     $join_type = $self->{_default_jointype}
 428       if ! defined $join_type;
 429
 430     return sprintf ('%s JOIN ',
 431       $join_type ?  $self->_sqlcase($join_type) : ''
 432     );
 433 }
 434
 435 sub _where_op_FUNC {
 436   my ($self) = @_;
 437
 438   my ($k, $vals);
 439
 440   if (@_ == 3) {
 441      # $_[1] gets set to "op"
 442      $vals = $_[2];
 443      $k = '';
 444   } elsif (@_ == 4) {
 445      $k = $_[1];
 446      # $_[2] gets set to "op"
 447      $vals = $_[3];
 448   }
 449
 450   my $label       = $self->_convert($self->_quote($k));
 451   my $placeholder = $self->_convert('?');
 452
 453   croak '-func must be an array' unless ref $vals eq 'ARRAY';
 454   croak 'first arg for -func must be a scalar' unless !ref $vals->[0];
 455
 456   my ($func,@rest_of_vals) = @$vals;
 457
 458   $self->_assert_pass_injection_guard($func);
 459
 460   my (@all_sql, @all_bind);
 461   foreach my $val (@rest_of_vals) {
 462     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 463        SCALAR => sub {
 464          return ($placeholder, $self->_bindtype($k, $val) );
 465        },
 466        SCALARREF => sub {
 467          return $$val;
 468        },
 469        ARRAYREFREF => sub {
 470          my ($sql, @bind) = @$$val;
 471          $self->_assert_bindval_matches_bindtype(@bind);
 472          return ($sql, @bind);
 473        },
 474        HASHREF => sub {
 475          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 476          $self->$method('', $val);
 477        }
 478     });
 479     push @all_sql, $sql;
 480     push @all_bind, @bind;
 481   }
 482
 483   my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
 484
 485   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 486   return ($sql, @bind)
 487 }
 488
 489 sub _where_op_OP {
 490   my ($self) = @_;
 491
 492   my ($k, $vals);
 493
 494   if (@_ == 3) {
 495      # $_[1] gets set to "op"
 496      $vals = $_[2];
 497      $k = '';
 498   } elsif (@_ == 4) {
 499      $k = $_[1];
 500      # $_[2] gets set to "op"
 501      $vals = $_[3];
 502   }
 503
 504   my $label       = $self->_convert($self->_quote($k));
 505   my $placeholder = $self->_convert('?');
 506
 507   croak 'argument to -op must be an arrayref' unless ref $vals eq 'ARRAY';
 508   croak 'first arg for -op must be a scalar' unless !ref $vals->[0];
 509
 510   my ($op, @rest_of_vals) = @$vals;
 511
 512   $self->_assert_pass_injection_guard($op);
 513
 514   my (@all_sql, @all_bind);
 515   foreach my $val (@rest_of_vals) {
 516     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 517        SCALAR => sub {
 518          return ($placeholder, $self->_bindtype($k, $val) );
 519        },
 520        SCALARREF => sub {
 521          return $$val;
 522        },
 523        ARRAYREFREF => sub {
 524          my ($sql, @bind) = @$$val;
 525          $self->_assert_bindval_matches_bindtype(@bind);
 526          return ($sql, @bind);
 527        },
 528        HASHREF => sub {
 529          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 530          $self->$method('', $val);
 531        }
 532     });
 533     push @all_sql, $sql;
 534     push @all_bind, @bind;
 535   }
 536
 537   my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
 538
 539   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 540   return ($sql, @bind)
 541 }
 542
 543 sub _recurse_from {
 544   my $self = shift;
 545
 546   return join (' ', $self->_gen_from_blocks(@_) );
 547 }
 548
 549 sub _gen_from_blocks {
 550   my ($self, $from, @joins) = @_;
 551
 552   my @fchunks = $self->_from_chunk_to_sql($from);
 553
 554   for (@joins) {
 555     my ($to, $on) = @$_;
 556
 557     # check whether a join type exists
 558     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
 559     my $join_type;
 560     if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
 561       $join_type = $to_jt->{-join_type};
 562       $join_type =~ s/^\s+ | \s+$//xg;
 563     }
 564
 565     my @j = $self->_generate_join_clause( $join_type );
 566
 567     if (ref $to eq 'ARRAY') {
 568       push(@j, '(', $self->_recurse_from(@$to), ')');
 569     }
 570     else {
 571       push(@j, $self->_from_chunk_to_sql($to));
 572     }
 573
 574     my ($sql, @bind) = $self->_join_condition($on);
 575     push(@j, ' ON ', $sql);
 576     push @{$self->{from_bind}}, @bind;
 577
 578     push @fchunks, join '', @j;
 579   }
 580
 581   return @fchunks;
 582 }
 583
 584 sub _from_chunk_to_sql {
 585   my ($self, $fromspec) = @_;
 586
 587   return join (' ', $self->_SWITCH_refkind($fromspec, {
 588     SCALARREF => sub {
 589       $$fromspec;
 590     },
 591     ARRAYREFREF => sub {
 592       push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
 593       $$fromspec->[0];
 594     },
 595     HASHREF => sub {
 596       my ($as, $table, $toomuch) = ( map
 597         { $_ => $fromspec->{$_} }
 598         ( grep { $_ !~ /^\-/ } keys %$fromspec )
 599       );
 600
 601       $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
 602         if defined $toomuch;
 603
 604       ($self->_from_chunk_to_sql($table), $self->_quote($as) );
 605     },
 606     SCALAR => sub {
 607       $self->_quote($fromspec);
 608     },
 609   }));
 610 }
 611
 612 sub _join_condition {
 613   my ($self, $cond) = @_;
 614
 615   # Backcompat for the old days when a plain hashref
 616   # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
 617   # Once things settle we should start warning here so that
 618   # folks unroll their hacks
 619   if (
 620     ref $cond eq 'HASH'
 621       and
 622     keys %$cond == 1
 623       and
 624     (keys %$cond)[0] =~ /\./
 625       and
 626     ! ref ( (values %$cond)[0] )
 627   ) {
 628     $cond = { keys %$cond => { -ident => values %$cond } }
 629   }
 630   elsif ( ref $cond eq 'ARRAY' ) {
 631     # do our own ORing so that the hashref-shim above is invoked
 632     my @parts;
 633     my @binds;
 634     foreach my $c (@$cond) {
 635       my ($sql, @bind) = $self->_join_condition($c);
 636       push @binds, @bind;
 637       push @parts, $sql;
 638     }
 639     return join(' OR ', @parts), @binds;
 640   }
 641
 642   return $self->_recurse_where($cond);
 643 }
 644
 645 1;
 646
 647 =head1 OPERATORS
 648
 649 =head2 -ident
 650
 651 Used to explicitly specify an SQL identifier. Takes a plain string as value
 652 which is then invariably treated as a column name (and is being properly
 653 quoted if quoting has been requested). Most useful for comparison of two
 654 columns:
 655
 656     my %where = (
 657         priority => { '<', 2 },
 658         requestor => { -ident => 'submitter' }
 659     );
 660
 661 which results in:
 662
 663     $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
 664     @bind = ('2');
 665
 666 =head2 -value
 667
 668 The -value operator signals that the argument to the right is a raw bind value.
 669 It will be passed straight to DBI, without invoking any of the SQL::Abstract
 670 condition-parsing logic. This allows you to, for example, pass an array as a
 671 column value for databases that support array datatypes, e.g.:
 672
 673     my %where = (
 674         array => { -value => [1, 2, 3] }
 675     );
 676
 677 which results in:
 678
 679     $stmt = 'WHERE array = ?';
 680     @bind = ([1, 2, 3]);
 681
 682 =head1 AUTHORS
 683
 684 See L<DBIx::Class/CONTRIBUTORS>.
 685
 686 =head1 LICENSE
 687
 688 You may distribute this code under the same terms as Perl itself.
 689
 690 =cut