lib/DBIx/Class/SQLMaker/LimitDialects.pm

   1 package DBIx::Class::SQLMaker::LimitDialects;
   2
   3 use warnings;
   4 use strict;
   5
   6 use List::Util 'first';
   7 use namespace::clean;
   8
   9 # constants are used not only here, but also in comparison tests
  10 sub __rows_bindtype () {
  11   +{ sqlt_datatype => 'integer' }
  12 }
  13 sub __offset_bindtype () {
  14   +{ sqlt_datatype => 'integer' }
  15 }
  16 sub __total_bindtype () {
  17   +{ sqlt_datatype => 'integer' }
  18 }
  19
  20 =head1 NAME
  21
  22 DBIx::Class::SQLMaker::LimitDialects - SQL::Abstract::Limit-like functionality for DBIx::Class::SQLMaker
  23
  24 =head1 DESCRIPTION
  25
  26 This module replicates a lot of the functionality originally found in
  27 L<SQL::Abstract::Limit>. While simple limits would work as-is, the more
  28 complex dialects that require e.g. subqueries could not be reliably
  29 implemented without taking full advantage of the metadata locked within
  30 L<DBIx::Class::ResultSource> classes. After reimplementation of close to
  31 80% of the L<SQL::Abstract::Limit> functionality it was deemed more
  32 practical to simply make an independent DBIx::Class-specific limit-dialect
  33 provider.
  34
  35 =head1 SQL LIMIT DIALECTS
  36
  37 Note that the actual implementations listed below never use C<*> literally.
  38 Instead proper re-aliasing of selectors and order criteria is done, so that
  39 the limit dialect are safe to use on joined resultsets with clashing column
  40 names.
  41
  42 Currently the provided dialects are:
  43
  44 =head2 LimitOffset
  45
  46  SELECT ... LIMIT $limit OFFSET $offset
  47
  48 Supported by B<PostgreSQL> and B<SQLite>
  49
  50 =cut
  51 sub _LimitOffset {
  52     my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
  53     $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT ?";
  54     push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
  55     if ($offset) {
  56       $sql .= " OFFSET ?";
  57       push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ];
  58     }
  59     return $sql;
  60 }
  61
  62 =head2 LimitXY
  63
  64  SELECT ... LIMIT $offset $limit
  65
  66 Supported by B<MySQL> and any L<SQL::Statement> based DBD
  67
  68 =cut
  69 sub _LimitXY {
  70     my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
  71     $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT ";
  72     if ($offset) {
  73       $sql .= '?, ';
  74       push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ];
  75     }
  76     $sql .= '?';
  77     push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
  78
  79     return $sql;
  80 }
  81
  82 =head2 RowNumberOver
  83
  84  SELECT * FROM (
  85   SELECT *, ROW_NUMBER() OVER( ORDER BY ... ) AS RNO__ROW__INDEX FROM (
  86    SELECT ...
  87   )
  88  ) WHERE RNO__ROW__INDEX BETWEEN ($offset+1) AND ($limit+$offset)
  89
  90
  91 ANSI standard Limit/Offset implementation. Supported by B<DB2> and
  92 B<< MSSQL >= 2005 >>.
  93
  94 =cut
  95 sub _RowNumberOver {
  96   my ($self, $sql, $rs_attrs, $rows, $offset ) = @_;
  97
  98   # get selectors, and scan the order_by (if any)
  99   my ($stripped_sql, $in_sel, $out_sel, $alias_map, $extra_order_sel)
 100     = $self->_subqueried_limit_attrs ( $sql, $rs_attrs );
 101
 102   # make up an order if none exists
 103   my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order;
 104   my $rno_ord = $self->_order_by ($requested_order);
 105
 106   # this is the order supplement magic
 107   my $mid_sel = $out_sel;
 108   if ($extra_order_sel) {
 109     for my $extra_col (sort
 110       { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
 111       keys %$extra_order_sel
 112     ) {
 113       $in_sel .= sprintf (', %s AS %s',
 114         $extra_col,
 115         $extra_order_sel->{$extra_col},
 116       );
 117     }
 118   }
 119
 120   # and this is order re-alias magic
 121   for ($extra_order_sel, $alias_map) {
 122     for my $col (keys %$_) {
 123       my $re_col = quotemeta ($col);
 124       $rno_ord =~ s/$re_col/$_->{$col}/;
 125     }
 126   }
 127
 128   # whatever is left of the order_by (only where is processed at this point)
 129   my $group_having = $self->_parse_rs_attrs($rs_attrs);
 130
 131   my $qalias = $self->_quote ($rs_attrs->{alias});
 132   my $idx_name = $self->_quote ('rno__row__index');
 133
 134   push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1], [ $self->__total_bindtype => $offset + $rows ];
 135
 136   return <<EOS;
 137
 138 SELECT $out_sel FROM (
 139   SELECT $mid_sel, ROW_NUMBER() OVER( $rno_ord ) AS $idx_name FROM (
 140     SELECT $in_sel ${stripped_sql}${group_having}
 141   ) $qalias
 142 ) $qalias WHERE $idx_name >= ? AND $idx_name <= ?
 143
 144 EOS
 145
 146 }
 147
 148 # some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) )
 149 sub _rno_default_order {
 150   return undef;
 151 }
 152
 153 =head2 SkipFirst
 154
 155  SELECT SKIP $offset FIRST $limit * FROM ...
 156
 157 Suported by B<Informix>, almost like LimitOffset. According to
 158 L<SQL::Abstract::Limit> C<... SKIP $offset LIMIT $limit ...> is also supported.
 159
 160 =cut
 161 sub _SkipFirst {
 162   my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
 163
 164   $sql =~ s/^ \s* SELECT \s+ //ix
 165     or $self->throw_exception("Unrecognizable SELECT: $sql");
 166
 167   return sprintf ('SELECT %s%s%s%s',
 168     $offset
 169       ? do {
 170          push @{$self->{pre_select_bind}}, [ $self->__offset_bindtype => $offset];
 171          'SKIP ? '
 172       }
 173       : ''
 174     ,
 175     do {
 176        push @{$self->{pre_select_bind}}, [ $self->__rows_bindtype => $rows ];
 177        'FIRST ? '
 178     },
 179     $sql,
 180     $self->_parse_rs_attrs ($rs_attrs),
 181   );
 182 }
 183
 184 =head2 FirstSkip
 185
 186  SELECT FIRST $limit SKIP $offset * FROM ...
 187
 188 Supported by B<Firebird/Interbase>, reverse of SkipFirst. According to
 189 L<SQL::Abstract::Limit> C<... ROWS $limit TO $offset ...> is also supported.
 190
 191 =cut
 192 sub _FirstSkip {
 193   my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
 194
 195   $sql =~ s/^ \s* SELECT \s+ //ix
 196     or $self->throw_exception("Unrecognizable SELECT: $sql");
 197
 198   return sprintf ('SELECT %s%s%s%s',
 199     do {
 200        push @{$self->{pre_select_bind}}, [ $self->__rows_bindtype => $rows ];
 201        'FIRST ? '
 202     },
 203     $offset
 204       ? do {
 205          push @{$self->{pre_select_bind}}, [ $self->__offset_bindtype => $offset];
 206          'SKIP ? '
 207       }
 208       : ''
 209     ,
 210     $sql,
 211     $self->_parse_rs_attrs ($rs_attrs),
 212   );
 213 }
 214
 215
 216 =head2 RowNum
 217
 218 Depending on the resultset attributes one of:
 219
 220  SELECT * FROM (
 221   SELECT *, ROWNUM rownum__index FROM (
 222    SELECT ...
 223   ) WHERE ROWNUM <= ($limit+$offset)
 224  ) WHERE rownum__index >= ($offset+1)
 225
 226 or
 227
 228  SELECT * FROM (
 229   SELECT *, ROWNUM rownum__index FROM (
 230     SELECT ...
 231   )
 232  ) WHERE rownum__index BETWEEN ($offset+1) AND ($limit+$offset)
 233
 234 or
 235
 236  SELECT * FROM (
 237     SELECT ...
 238   ) WHERE ROWNUM <= ($limit+1)
 239
 240 Supported by B<Oracle>.
 241
 242 =cut
 243 sub _RowNum {
 244   my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
 245
 246   my ($stripped_sql, $insel, $outsel) = $self->_subqueried_limit_attrs ($sql, $rs_attrs);
 247
 248   my $qalias = $self->_quote ($rs_attrs->{alias});
 249   my $idx_name = $self->_quote ('rownum__index');
 250   my $order_group_having = $self->_parse_rs_attrs($rs_attrs);
 251
 252
 253   # if no offset (e.g. first page) - we can skip one of the subqueries
 254   if (! $offset) {
 255     push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
 256
 257     return <<EOS;
 258 SELECT $outsel FROM (
 259   SELECT $insel ${stripped_sql}${order_group_having}
 260 ) $qalias WHERE ROWNUM <= ?
 261 EOS
 262   }
 263
 264   #
 265   # There are two ways to limit in Oracle, one vastly faster than the other
 266   # on large resultsets: https://decipherinfosys.wordpress.com/2007/08/09/paging-and-countstopkey-optimization/
 267   # However Oracle is retarded and does not preserve stable ROWNUM() values
 268   # when called twice in the same scope. Therefore unless the resultset is
 269   # ordered by a unique set of columns, it is not safe to use the faster
 270   # method, and the slower BETWEEN query is used instead
 271   #
 272   # FIXME - this is quite expensive, and does not perform caching of any sort
 273   # as soon as some of the DQ work becomes viable consider switching this
 274   # over
 275   if (
 276     $rs_attrs->{order_by}
 277       and
 278     $rs_attrs->{_rsroot_rsrc}->storage->_order_by_is_stable(
 279       $rs_attrs->{from}, $rs_attrs->{order_by}
 280     )
 281   ) {
 282     push @{$self->{limit_bind}}, [ $self->__total_bindtype => $offset + $rows ], [ $self->__offset_bindtype => $offset + 1 ];
 283
 284     return <<EOS;
 285 SELECT $outsel FROM (
 286   SELECT $outsel, ROWNUM $idx_name FROM (
 287     SELECT $insel ${stripped_sql}${order_group_having}
 288   ) $qalias WHERE ROWNUM <= ?
 289 ) $qalias WHERE $idx_name >= ?
 290 EOS
 291   }
 292   else {
 293     push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1 ], [ $self->__total_bindtype => $offset + $rows ];
 294
 295     return <<EOS;
 296 SELECT $outsel FROM (
 297   SELECT $outsel, ROWNUM $idx_name FROM (
 298     SELECT $insel ${stripped_sql}${order_group_having}
 299   ) $qalias
 300 ) $qalias WHERE $idx_name BETWEEN ? AND ?
 301 EOS
 302   }
 303 }
 304
 305 # used by _Top and _FetchFirst below
 306 sub _prep_for_skimming_limit {
 307   my ( $self, $sql, $rs_attrs ) = @_;
 308
 309   # get selectors
 310   my (%r, $alias_map, $extra_order_sel);
 311   ($r{inner_sql}, $r{in_sel}, $r{out_sel}, $alias_map, $extra_order_sel)
 312     = $self->_subqueried_limit_attrs ($sql, $rs_attrs);
 313
 314   my $requested_order = delete $rs_attrs->{order_by};
 315   $r{order_by_requested} = $self->_order_by ($requested_order);
 316
 317   # make up an order unless supplied or sanity check what we are given
 318   my $inner_order;
 319   if ($r{order_by_requested}) {
 320     $self->throw_exception (
 321       'Unable to safely perform "skimming type" limit with supplied unstable order criteria'
 322     ) unless $rs_attrs->{_rsroot_rsrc}->schema->storage->_order_by_is_stable(
 323       $rs_attrs->{from},
 324       $requested_order
 325     );
 326
 327     $inner_order = $requested_order;
 328   }
 329   else {
 330     $inner_order = [ map
 331       { "$rs_attrs->{alias}.$_" }
 332       ( @{
 333         $rs_attrs->{_rsroot_rsrc}->_identifying_column_set
 334           ||
 335         $self->throw_exception(sprintf(
 336           'Unable to auto-construct stable order criteria for "skimming type" limit '
 337         . "dialect based on source '%s'", $rs_attrs->{_rsroot_rsrc}->name) );
 338       } )
 339     ];
 340   }
 341
 342   # localise as we already have all the bind values we need
 343   {
 344     local $self->{order_bind};
 345     $r{order_by_inner} = $self->_order_by ($inner_order);
 346
 347     my @out_chunks;
 348     for my $ch ($self->_order_by_chunks ($inner_order)) {
 349       $ch = $ch->[0] if ref $ch eq 'ARRAY';
 350
 351       $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix;
 352       my $dir = uc ($1||'ASC');
 353
 354       push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' );
 355     }
 356
 357     $r{order_by_reversed} = $self->_order_by (\@out_chunks);
 358   }
 359
 360   # this is the order supplement magic
 361   $r{mid_sel} = $r{out_sel};
 362   if ($extra_order_sel) {
 363     for my $extra_col (sort
 364       { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
 365       keys %$extra_order_sel
 366     ) {
 367       $r{in_sel} .= sprintf (', %s AS %s',
 368         $extra_col,
 369         $extra_order_sel->{$extra_col},
 370       );
 371
 372       $r{mid_sel} .= ', ' . $extra_order_sel->{$extra_col};
 373     }
 374
 375     # Whatever order bindvals there are, they will be realiased and
 376     # need to show up in front of the entire initial inner subquery
 377     push @{$self->{pre_select_bind}}, @{$self->{order_bind}};
 378   }
 379
 380   # if this is a part of something bigger, we need to add back all
 381   # the extra order_by's, as they may be relied upon by the outside
 382   # of a prefetch or something
 383   if ($rs_attrs->{_is_internal_subuery} and keys %$extra_order_sel) {
 384     $r{out_sel} .= sprintf ", $extra_order_sel->{$_} AS $_"
 385       for sort
 386         { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
 387           grep { $_ !~ /[^\w\-]/ }  # ignore functions
 388           keys %$extra_order_sel
 389     ;
 390   }
 391
 392   # and this is order re-alias magic
 393   for my $map ($extra_order_sel, $alias_map) {
 394     for my $col (keys %$map) {
 395       my $re_col = quotemeta ($col);
 396       $_ =~ s/$re_col/$map->{$col}/
 397         for ($r{order_by_reversed}, $r{order_by_requested});
 398     }
 399   }
 400
 401   # generate the rest of the sql
 402   $r{grpby_having} = $self->_parse_rs_attrs ($rs_attrs);
 403
 404   $r{quoted_rs_alias} = $self->_quote ($rs_attrs->{alias});
 405
 406   \%r;
 407 }
 408
 409 =head2 Top
 410
 411  SELECT * FROM
 412
 413  SELECT TOP $limit FROM (
 414   SELECT TOP $limit FROM (
 415    SELECT TOP ($limit+$offset) ...
 416   ) ORDER BY $reversed_original_order
 417  ) ORDER BY $original_order
 418
 419 Unreliable Top-based implementation, supported by B<< MSSQL < 2005 >>.
 420
 421 =head3 CAVEAT
 422
 423 Due to its implementation, this limit dialect returns B<incorrect results>
 424 when $limit+$offset > total amount of rows in the resultset.
 425
 426 =cut
 427
 428 sub _Top {
 429   my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
 430
 431   my %l = %{ $self->_prep_for_skimming_limit($sql, $rs_attrs) };
 432
 433   $sql = sprintf ('SELECT TOP %u %s %s %s %s',
 434     $rows + ($offset||0),
 435     $l{in_sel},
 436     $l{inner_sql},
 437     $l{grpby_having},
 438     $l{order_by_inner},
 439   );
 440
 441   $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
 442     $rows,
 443     $l{mid_sel},
 444     $sql,
 445     $l{quoted_rs_alias},
 446     $l{order_by_reversed},
 447   ) if $offset;
 448
 449   $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
 450     $rows,
 451     $l{out_sel},
 452     $sql,
 453     $l{quoted_rs_alias},
 454     $l{order_by_requested},
 455   ) if ( ($offset && $l{order_by_requested}) || ($l{mid_sel} ne $l{out_sel}) );
 456
 457   return $sql;
 458 }
 459
 460 =head2 FetchFirst
 461
 462  SELECT * FROM
 463  (
 464  SELECT * FROM (
 465   SELECT * FROM (
 466    SELECT * FROM ...
 467   ) ORDER BY $reversed_original_order
 468     FETCH FIRST $limit ROWS ONLY
 469  ) ORDER BY $original_order
 470    FETCH FIRST $limit ROWS ONLY
 471  )
 472
 473 Unreliable FetchFirst-based implementation, supported by B<< IBM DB2 <= V5R3 >>.
 474
 475 =head3 CAVEAT
 476
 477 Due to its implementation, this limit dialect returns B<incorrect results>
 478 when $limit+$offset > total amount of rows in the resultset.
 479
 480 =cut
 481
 482 sub _FetchFirst {
 483   my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
 484
 485   my %l = %{ $self->_prep_for_skimming_limit($sql, $rs_attrs) };
 486
 487   $sql = sprintf ('SELECT %s %s %s %s FETCH FIRST %u ROWS ONLY',
 488     $l{in_sel},
 489     $l{inner_sql},
 490     $l{grpby_having},
 491     $l{order_by_inner},
 492     $rows + ($offset||0),
 493   );
 494
 495   $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
 496     $l{mid_sel},
 497     $sql,
 498     $l{quoted_rs_alias},
 499     $l{order_by_reversed},
 500     $rows,
 501   ) if $offset;
 502
 503   $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
 504     $l{out_sel},
 505     $sql,
 506     $l{quoted_rs_alias},
 507     $l{order_by_requested},
 508     $rows,
 509   ) if ( ($offset && $l{order_by_requested}) || ($l{mid_sel} ne $l{out_sel}) );
 510
 511   return $sql;
 512 }
 513
 514 =head2 RowCountOrGenericSubQ
 515
 516 This is not exactly a limit dialect, but more of a proxy for B<Sybase ASE>.
 517 If no $offset is supplied the limit is simply performed as:
 518
 519  SET ROWCOUNT $limit
 520  SELECT ...
 521  SET ROWCOUNT 0
 522
 523 Otherwise we fall back to L</GenericSubQ>
 524
 525 =cut
 526
 527 sub _RowCountOrGenericSubQ {
 528   my $self = shift;
 529   my ($sql, $rs_attrs, $rows, $offset) = @_;
 530
 531   return $self->_GenericSubQ(@_) if $offset;
 532
 533   return sprintf <<"EOF", $rows, $sql;
 534 SET ROWCOUNT %d
 535 %s
 536 SET ROWCOUNT 0
 537 EOF
 538 }
 539
 540 =head2 GenericSubQ
 541
 542  SELECT * FROM (
 543   SELECT ...
 544  )
 545  WHERE (
 546   SELECT COUNT(*) FROM $original_table cnt WHERE cnt.id < $original_table.id
 547  ) BETWEEN $offset AND ($offset+$rows-1)
 548
 549 This is the most evil limit "dialect" (more of a hack) for I<really> stupid
 550 databases. It works by ordering the set by some unique column, and calculating
 551 the amount of rows that have a less-er value (thus emulating a L</RowNum>-like
 552 index). Of course this implies the set can only be ordered by a single unique
 553 column. Also note that this technique can be and often is B<excruciatingly
 554 slow>.
 555
 556 Currently used by B<Sybase ASE>, due to lack of any other option.
 557
 558 =cut
 559 sub _GenericSubQ {
 560   my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
 561
 562   my $root_rsrc = $rs_attrs->{_rsroot_rsrc};
 563   my $root_tbl_name = $root_rsrc->name;
 564
 565   my ($first_order_by) = do {
 566     local $self->{quote_char};
 567     map { ref $_ ? $_->[0] : $_ } $self->_order_by_chunks ($rs_attrs->{order_by})
 568   } or $self->throw_exception (
 569     'Generic Subquery Limit does not work on resultsets without an order. Provide a single, '
 570   . 'unique-column order criteria.'
 571   );
 572
 573   $first_order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix;
 574   my $direction = lc ($1 || 'asc');
 575
 576   my ($first_ord_alias, $first_ord_col) = $first_order_by =~ /^ (?: ([^\.]+) \. )? ([^\.]+) $/x;
 577
 578   $self->throw_exception(sprintf
 579     "Generic Subquery Limit order criteria can be only based on the root-source '%s'"
 580   . " (aliased as '%s')", $root_rsrc->source_name, $rs_attrs->{alias},
 581   ) if ($first_ord_alias and $first_ord_alias ne $rs_attrs->{alias});
 582
 583   $first_ord_alias ||= $rs_attrs->{alias};
 584
 585   $self->throw_exception(
 586     "Generic Subquery Limit first order criteria '$first_ord_col' must be unique"
 587   ) unless $root_rsrc->_identifying_column_set([$first_ord_col]);
 588
 589   my ($stripped_sql, $in_sel, $out_sel, $alias_map, $extra_order_sel)
 590     = $self->_subqueried_limit_attrs ($sql, $rs_attrs);
 591
 592   my $cmp_op = $direction eq 'desc' ? '>' : '<';
 593   my $count_tbl_alias = 'rownum__emulation';
 594
 595   my $order_sql = $self->_order_by (delete $rs_attrs->{order_by});
 596   my $group_having_sql = $self->_parse_rs_attrs($rs_attrs);
 597
 598   # add the order supplement (if any) as this is what will be used for the outer WHERE
 599   $in_sel .= ", $_" for keys %{$extra_order_sel||{}};
 600
 601   my $rownum_cond;
 602   if ($offset) {
 603     $rownum_cond = 'BETWEEN ? AND ?';
 604
 605     push @{$self->{limit_bind}},
 606       [ $self->__offset_bindtype => $offset ],
 607       [ $self->__total_bindtype => $offset + $rows - 1]
 608     ;
 609   }
 610   else {
 611     $rownum_cond = '< ?';
 612
 613     push @{$self->{limit_bind}},
 614       [ $self->__rows_bindtype => $rows ]
 615     ;
 616   }
 617
 618   return sprintf ("
 619 SELECT $out_sel
 620   FROM (
 621     SELECT $in_sel ${stripped_sql}${group_having_sql}
 622   ) %s
 623 WHERE ( SELECT COUNT(*) FROM %s %s WHERE %s $cmp_op %s ) $rownum_cond
 624 $order_sql
 625   ", map { $self->_quote ($_) } (
 626     $rs_attrs->{alias},
 627     $root_tbl_name,
 628     $count_tbl_alias,
 629     "$count_tbl_alias.$first_ord_col",
 630     "$first_ord_alias.$first_ord_col",
 631   ));
 632 }
 633
 634
 635 # !!! THIS IS ALSO HORRIFIC !!! /me ashamed
 636 #
 637 # Generates inner/outer select lists for various limit dialects
 638 # which result in one or more subqueries (e.g. RNO, Top, RowNum)
 639 # Any non-root-table columns need to have their table qualifier
 640 # turned into a column alias (otherwise names in subqueries clash
 641 # and/or lose their source table)
 642 #
 643 # Returns mangled proto-sql, inner/outer strings of SQL QUOTED selectors
 644 # with aliases (to be used in whatever select statement), and an alias
 645 # index hashref of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used
 646 # for string-subst higher up).
 647 # If an order_by is supplied, the inner select needs to bring out columns
 648 # used in implicit (non-selected) orders, and the order condition itself
 649 # needs to be realiased to the proper names in the outer query. Thus we
 650 # also return a hashref (order doesn't matter) of QUOTED EXTRA-SEL =>
 651 # QUOTED ALIAS pairs, which is a list of extra selectors that do *not*
 652 # exist in the original select list
 653 sub _subqueried_limit_attrs {
 654   my ($self, $proto_sql, $rs_attrs) = @_;
 655
 656   $self->throw_exception(
 657     'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
 658   ) unless ref ($rs_attrs) eq 'HASH';
 659
 660   # mangle the input sql as we will be replacing the selector entirely
 661   unless (
 662     $rs_attrs->{_selector_sql}
 663       and
 664     $proto_sql =~ s/^ \s* SELECT \s* \Q$rs_attrs->{_selector_sql}//ix
 665   ) {
 666     $self->throw_exception("Unrecognizable SELECT: $proto_sql");
 667   }
 668
 669   my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} );
 670
 671   # insulate from the multiple _recurse_fields calls below
 672   local $self->{select_bind};
 673
 674   # correlate select and as, build selection index
 675   my (@sel, $in_sel_index);
 676   for my $i (0 .. $#{$rs_attrs->{select}}) {
 677
 678     my $s = $rs_attrs->{select}[$i];
 679     my $sql_sel = $self->_recurse_fields ($s);
 680     my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef;
 681
 682     push @sel, {
 683       sql => $sql_sel,
 684       unquoted_sql => do {
 685         local $self->{quote_char};
 686         $self->_recurse_fields ($s);
 687       },
 688       as =>
 689         $sql_alias
 690           ||
 691         $rs_attrs->{as}[$i]
 692           ||
 693         $self->throw_exception("Select argument $i ($s) without corresponding 'as'")
 694       ,
 695     };
 696
 697     $in_sel_index->{$sql_sel}++;
 698     $in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias;
 699
 700     # record unqualified versions too, so we do not have
 701     # to reselect the same column twice (in qualified and
 702     # unqualified form)
 703     if (! ref $s && $sql_sel =~ / $re_sep (.+) $/x) {
 704       $in_sel_index->{$1}++;
 705     }
 706   }
 707
 708
 709   # re-alias and remove any name separators from aliases,
 710   # unless we are dealing with the current source alias
 711   # (which will transcend the subqueries as it is necessary
 712   # for possible further chaining)
 713   my (@in_sel, @out_sel, %renamed);
 714   for my $node (@sel) {
 715     if (
 716       $node->{as} =~ / (?<! ^ $re_alias ) \. /x
 717         or
 718       $node->{unquoted_sql} =~ / (?<! ^ $re_alias ) $re_sep /x
 719     ) {
 720       $node->{as} = $self->_unqualify_colname($node->{as});
 721       my $quoted_as = $self->_quote($node->{as});
 722       push @in_sel, sprintf '%s AS %s', $node->{sql}, $quoted_as;
 723       push @out_sel, $quoted_as;
 724       $renamed{$node->{sql}} = $quoted_as;
 725     }
 726     else {
 727       push @in_sel, $node->{sql};
 728       push @out_sel, $self->_quote ($node->{as});
 729     }
 730   }
 731   # see if the order gives us anything
 732   my %extra_order_sel;
 733   for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
 734     # order with bind
 735     $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
 736     $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
 737
 738     next if $in_sel_index->{$chunk};
 739
 740     $extra_order_sel{$chunk} ||= $self->_quote (
 741       'ORDER__BY__' . scalar keys %extra_order_sel
 742     );
 743   }
 744
 745   return (
 746     $proto_sql,
 747     (map { join (', ', @$_ ) } (
 748       \@in_sel,
 749       \@out_sel)
 750     ),
 751     \%renamed,
 752     keys %extra_order_sel ? \%extra_order_sel : (),
 753   );
 754 }
 755
 756 sub _unqualify_colname {
 757   my ($self, $fqcn) = @_;
 758   $fqcn =~ s/ \. /__/xg;
 759   return $fqcn;
 760 }
 761
 762 1;
 763
 764 =head1 AUTHORS
 765
 766 See L<DBIx::Class/CONTRIBUTORS>.
 767
 768 =head1 LICENSE
 769
 770 You may distribute this code under the same terms as Perl itself.
 771
 772 =cut