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) = @_;
 301   my $ref = ref $fields;
 302   return $self->_quote($fields) unless $ref;
 303   return $$fields if $ref eq 'SCALAR';
 304
 305   if ($ref eq 'ARRAY') {
 306     return join(', ', map { $self->_recurse_fields($_) } @$fields);
 307   }
 308   elsif ($ref eq 'HASH') {
 309     my %hash = %$fields;  # shallow copy
 310
 311     my $as = delete $hash{-as};   # if supplied
 312
 313     my ($func, $args, @toomany) = %hash;
 314
 315     # there should be only one pair
 316     if (@toomany) {
 317       $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
 318     }
 319
 320     if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
 321       $self->throw_exception (
 322         'The select => { distinct => ... } syntax is not supported for multiple columns.'
 323        .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
 324        .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
 325       );
 326     }
 327
 328     my $select = sprintf ('%s( %s )%s',
 329       $self->_sqlcase($func),
 330       $self->_recurse_fields($args),
 331       $as
 332         ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
 333         : ''
 334     );
 335
 336     return $select;
 337   }
 338   # Is the second check absolutely necessary?
 339   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
 340     push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
 341     return $$fields->[0];
 342   }
 343   else {
 344     $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
 345   }
 346 }
 347
 348
 349 # this used to be a part of _order_by but is broken out for clarity.
 350 # What we have been doing forever is hijacking the $order arg of
 351 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
 352 # then pretty much the entire resultset attr-hash, as more and more
 353 # things in the SQLA space need to have mopre info about the $rs they
 354 # create SQL for. The alternative would be to keep expanding the
 355 # signature of _select with more and more positional parameters, which
 356 # is just gross. All hail SQLA2!
 357 sub _parse_rs_attrs {
 358   my ($self, $arg) = @_;
 359
 360   my $sql = '';
 361
 362   if ($arg->{group_by}) {
 363     # horible horrible, waiting for refactor
 364     local $self->{select_bind};
 365     if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
 366       $sql .= $self->_sqlcase(' group by ') . $g;
 367       push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
 368     }
 369   }
 370
 371   if (defined $arg->{having}) {
 372     my ($frag, @bind) = $self->_recurse_where($arg->{having});
 373     push(@{$self->{having_bind}}, @bind);
 374     $sql .= $self->_sqlcase(' having ') . $frag;
 375   }
 376
 377   if (defined $arg->{order_by}) {
 378     $sql .= $self->_order_by ($arg->{order_by});
 379   }
 380
 381   return $sql;
 382 }
 383
 384 sub _order_by {
 385   my ($self, $arg) = @_;
 386
 387   # check that we are not called in legacy mode (order_by as 4th argument)
 388   if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
 389     return $self->_parse_rs_attrs ($arg);
 390   }
 391   else {
 392     my ($sql, @bind) = $self->next::method($arg);
 393     push @{$self->{order_bind}}, @bind;
 394     return $sql;
 395   }
 396 }
 397
 398 sub _table {
 399 # optimized due to hotttnesss
 400 #  my ($self, $from) = @_;
 401   if (my $ref = ref $_[1] ) {
 402     if ($ref eq 'ARRAY') {
 403       return $_[0]->_recurse_from(@{$_[1]});
 404     }
 405     elsif ($ref eq 'HASH') {
 406       return $_[0]->_recurse_from($_[1]);
 407     }
 408     elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
 409       my ($sql, @bind) = @{ ${$_[1]} };
 410       push @{$_[0]->{from_bind}}, @bind;
 411       return $sql
 412     }
 413   }
 414   return $_[0]->next::method ($_[1]);
 415 }
 416
 417 sub _generate_join_clause {
 418     my ($self, $join_type) = @_;
 419
 420     $join_type = $self->{_default_jointype}
 421       if ! defined $join_type;
 422
 423     return sprintf ('%s JOIN ',
 424       $join_type ?  $self->_sqlcase($join_type) : ''
 425     );
 426 }
 427
 428 sub _where_op_FUNC {
 429   my ($self) = @_;
 430
 431   my ($k, $vals);
 432
 433   if (@_ == 3) {
 434      # $_[1] gets set to "op"
 435      $vals = $_[2];
 436      $k = '';
 437   } elsif (@_ == 4) {
 438      $k = $_[1];
 439      # $_[2] gets set to "op"
 440      $vals = $_[3];
 441   }
 442
 443   my $label       = $self->_convert($self->_quote($k));
 444   my $placeholder = $self->_convert('?');
 445
 446   croak '-func must be an array' unless ref $vals eq 'ARRAY';
 447   croak 'first arg for -func must be a scalar' unless !ref $vals->[0];
 448
 449   my ($func,@rest_of_vals) = @$vals;
 450
 451   $self->_assert_pass_injection_guard($func);
 452
 453   my (@all_sql, @all_bind);
 454   foreach my $val (@rest_of_vals) {
 455     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 456        SCALAR => sub {
 457          return ($placeholder, $self->_bindtype($k, $val) );
 458        },
 459        SCALARREF => sub {
 460          return $$val;
 461        },
 462        ARRAYREFREF => sub {
 463          my ($sql, @bind) = @$$val;
 464          $self->_assert_bindval_matches_bindtype(@bind);
 465          return ($sql, @bind);
 466        },
 467        HASHREF => sub {
 468          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 469          $self->$method('', $val);
 470        }
 471     });
 472     push @all_sql, $sql;
 473     push @all_bind, @bind;
 474   }
 475
 476   my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
 477
 478   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 479   return ($sql, @bind)
 480 }
 481
 482 sub _where_op_OP {
 483   my ($self) = @_;
 484
 485   my ($k, $vals);
 486
 487   if (@_ == 3) {
 488      # $_[1] gets set to "op"
 489      $vals = $_[2];
 490      $k = '';
 491   } elsif (@_ == 4) {
 492      $k = $_[1];
 493      # $_[2] gets set to "op"
 494      $vals = $_[3];
 495   }
 496
 497   my $label       = $self->_convert($self->_quote($k));
 498   my $placeholder = $self->_convert('?');
 499
 500   croak 'argument to -op must be an arrayref' unless ref $vals eq 'ARRAY';
 501   croak 'first arg for -op must be a scalar' unless !ref $vals->[0];
 502
 503   my ($op, @rest_of_vals) = @$vals;
 504
 505   $self->_assert_pass_injection_guard($op);
 506
 507   my (@all_sql, @all_bind);
 508   foreach my $val (@rest_of_vals) {
 509     my ($sql, @bind) = $self->_SWITCH_refkind($val, {
 510        SCALAR => sub {
 511          return ($placeholder, $self->_bindtype($k, $val) );
 512        },
 513        SCALARREF => sub {
 514          return $$val;
 515        },
 516        ARRAYREFREF => sub {
 517          my ($sql, @bind) = @$$val;
 518          $self->_assert_bindval_matches_bindtype(@bind);
 519          return ($sql, @bind);
 520        },
 521        HASHREF => sub {
 522          my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
 523          $self->$method('', $val);
 524        }
 525     });
 526     push @all_sql, $sql;
 527     push @all_bind, @bind;
 528   }
 529
 530   my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
 531
 532   my $sql = $k ? "( $label = $clause )" : "( $clause )";
 533   return ($sql, @bind)
 534 }
 535
 536 sub _recurse_from {
 537   my $self = shift;
 538
 539   return join (' ', $self->_gen_from_blocks(@_) );
 540 }
 541
 542 sub _gen_from_blocks {
 543   my ($self, $from, @joins) = @_;
 544
 545   my @fchunks = $self->_from_chunk_to_sql($from);
 546
 547   for (@joins) {
 548     my ($to, $on) = @$_;
 549
 550     # check whether a join type exists
 551     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
 552     my $join_type;
 553     if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
 554       $join_type = $to_jt->{-join_type};
 555       $join_type =~ s/^\s+ | \s+$//xg;
 556     }
 557
 558     my @j = $self->_generate_join_clause( $join_type );
 559
 560     if (ref $to eq 'ARRAY') {
 561       push(@j, '(', $self->_recurse_from(@$to), ')');
 562     }
 563     else {
 564       push(@j, $self->_from_chunk_to_sql($to));
 565     }
 566
 567     my ($sql, @bind) = $self->_join_condition($on);
 568     push(@j, ' ON ', $sql);
 569     push @{$self->{from_bind}}, @bind;
 570
 571     push @fchunks, join '', @j;
 572   }
 573
 574   return @fchunks;
 575 }
 576
 577 sub _from_chunk_to_sql {
 578   my ($self, $fromspec) = @_;
 579
 580   return join (' ', $self->_SWITCH_refkind($fromspec, {
 581     SCALARREF => sub {
 582       $$fromspec;
 583     },
 584     ARRAYREFREF => sub {
 585       push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
 586       $$fromspec->[0];
 587     },
 588     HASHREF => sub {
 589       my ($as, $table, $toomuch) = ( map
 590         { $_ => $fromspec->{$_} }
 591         ( grep { $_ !~ /^\-/ } keys %$fromspec )
 592       );
 593
 594       $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
 595         if defined $toomuch;
 596
 597       ($self->_from_chunk_to_sql($table), $self->_quote($as) );
 598     },
 599     SCALAR => sub {
 600       $self->_quote($fromspec);
 601     },
 602   }));
 603 }
 604
 605 sub _join_condition {
 606   my ($self, $cond) = @_;
 607
 608   # Backcompat for the old days when a plain hashref
 609   # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
 610   # Once things settle we should start warning here so that
 611   # folks unroll their hacks
 612   if (
 613     ref $cond eq 'HASH'
 614       and
 615     keys %$cond == 1
 616       and
 617     (keys %$cond)[0] =~ /\./
 618       and
 619     ! ref ( (values %$cond)[0] )
 620   ) {
 621     $cond = { keys %$cond => { -ident => values %$cond } }
 622   }
 623   elsif ( ref $cond eq 'ARRAY' ) {
 624     # do our own ORing so that the hashref-shim above is invoked
 625     my @parts;
 626     my @binds;
 627     foreach my $c (@$cond) {
 628       my ($sql, @bind) = $self->_join_condition($c);
 629       push @binds, @bind;
 630       push @parts, $sql;
 631     }
 632     return join(' OR ', @parts), @binds;
 633   }
 634
 635   return $self->_recurse_where($cond);
 636 }
 637
 638 1;
 639
 640 =head1 OPERATORS
 641
 642 =head2 -ident
 643
 644 Used to explicitly specify an SQL identifier. Takes a plain string as value
 645 which is then invariably treated as a column name (and is being properly
 646 quoted if quoting has been requested). Most useful for comparison of two
 647 columns:
 648
 649     my %where = (
 650         priority => { '<', 2 },
 651         requestor => { -ident => 'submitter' }
 652     );
 653
 654 which results in:
 655
 656     $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
 657     @bind = ('2');
 658
 659 =head2 -value
 660
 661 The -value operator signals that the argument to the right is a raw bind value.
 662 It will be passed straight to DBI, without invoking any of the SQL::Abstract
 663 condition-parsing logic. This allows you to, for example, pass an array as a
 664 column value for databases that support array datatypes, e.g.:
 665
 666     my %where = (
 667         array => { -value => [1, 2, 3] }
 668     );
 669
 670 which results in:
 671
 672     $stmt = 'WHERE array = ?';
 673     @bind = ([1, 2, 3]);
 674
 675 =head1 AUTHORS
 676
 677 See L<DBIx::Class/CONTRIBUTORS>.
 678
 679 =head1 LICENSE
 680
 681 You may distribute this code under the same terms as Perl itself.
 682
 683 =cut