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   # mangle the input sql as we will be replacing the selector
  99   $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
 100     or $self->throw_exception("Unrecognizable SELECT: $sql");
 101
 102   # get selectors, and scan the order_by (if any)
 103   my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
 104     = $self->_subqueried_limit_attrs ( $rs_attrs );
 105
 106   # make up an order if none exists
 107   my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order;
 108   my $rno_ord = $self->_order_by ($requested_order);
 109
 110   # this is the order supplement magic
 111   my $mid_sel = $out_sel;
 112   if ($extra_order_sel) {
 113     for my $extra_col (sort
 114       { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
 115       keys %$extra_order_sel
 116     ) {
 117       $in_sel .= sprintf (', %s AS %s',
 118         $extra_col,
 119         $extra_order_sel->{$extra_col},
 120       );
 121
 122       $mid_sel .= ', ' . $extra_order_sel->{$extra_col};
 123     }
 124   }
 125
 126   # and this is order re-alias magic
 127   for ($extra_order_sel, $alias_map) {
 128     for my $col (keys %$_) {
 129       my $re_col = quotemeta ($col);
 130       $rno_ord =~ s/$re_col/$_->{$col}/;
 131     }
 132   }
 133
 134   # whatever is left of the order_by (only where is processed at this point)
 135   my $group_having = $self->_parse_rs_attrs($rs_attrs);
 136
 137   my $qalias = $self->_quote ($rs_attrs->{alias});
 138   my $idx_name = $self->_quote ('rno__row__index');
 139
 140   $sql = <<EOS;
 141
 142 SELECT $out_sel FROM (
 143   SELECT $mid_sel, ROW_NUMBER() OVER( $rno_ord ) AS $idx_name FROM (
 144     SELECT $in_sel ${sql}${group_having}
 145   ) $qalias
 146 ) $qalias WHERE $idx_name >= ? AND $idx_name <= ?
 147
 148 EOS
 149    push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1], [ $self->__total_bindtype => $offset + $rows ];
 150
 151   return $sql;
 152 }
 153
 154 # some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) )
 155 sub _rno_default_order {
 156   return undef;
 157 }
 158
 159 =head2 SkipFirst
 160
 161  SELECT SKIP $offset FIRST $limit * FROM ...
 162
 163 Suported by B<Informix>, almost like LimitOffset. According to
 164 L<SQL::Abstract::Limit> C<... SKIP $offset LIMIT $limit ...> is also supported.
 165
 166 =cut
 167 sub _SkipFirst {
 168   my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
 169
 170   $sql =~ s/^ \s* SELECT \s+ //ix
 171     or $self->throw_exception("Unrecognizable SELECT: $sql");
 172
 173   return sprintf ('SELECT %s%s%s%s',
 174     $offset
 175       ? do {
 176          push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset];
 177          'SKIP ? '
 178       }
 179       : ''
 180     ,
 181     do {
 182        push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
 183        'FIRST ? '
 184     },
 185     $sql,
 186     $self->_parse_rs_attrs ($rs_attrs),
 187   );
 188 }
 189
 190 =head2 FirstSkip
 191
 192  SELECT FIRST $limit SKIP $offset * FROM ...
 193
 194 Supported by B<Firebird/Interbase>, reverse of SkipFirst. According to
 195 L<SQL::Abstract::Limit> C<... ROWS $limit TO $offset ...> is also supported.
 196
 197 =cut
 198 sub _FirstSkip {
 199   my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
 200
 201   $sql =~ s/^ \s* SELECT \s+ //ix
 202     or $self->throw_exception("Unrecognizable SELECT: $sql");
 203
 204   return sprintf ('SELECT %s%s%s%s',
 205     do {
 206        push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
 207        'FIRST ? '
 208     },
 209     $offset
 210       ? do {
 211          push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset];
 212          'SKIP ? '
 213       }
 214       : ''
 215     ,
 216     $sql,
 217     $self->_parse_rs_attrs ($rs_attrs),
 218   );
 219 }
 220
 221 =head2 RowNum
 222
 223  SELECT * FROM (
 224   SELECT *, ROWNUM rownum__index FROM (
 225    SELECT ...
 226   ) WHERE ROWNUM <= ($limit+$offset)
 227  ) WHERE rownum__index >= ($offset+1)
 228
 229 Supported by B<Oracle>.
 230
 231 =cut
 232 sub _RowNum {
 233   my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
 234
 235   # mangle the input sql as we will be replacing the selector
 236   $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
 237     or $self->throw_exception("Unrecognizable SELECT: $sql");
 238
 239   my ($insel, $outsel) = $self->_subqueried_limit_attrs ($rs_attrs);
 240
 241   my $qalias = $self->_quote ($rs_attrs->{alias});
 242   my $idx_name = $self->_quote ('rownum__index');
 243   my $order_group_having = $self->_parse_rs_attrs($rs_attrs);
 244
 245   if ($offset) {
 246
 247     push @{$self->{limit_bind}}, [ $self->__total_bindtype => $offset + $rows ], [ $self->__offset_bindtype => $offset + 1 ];
 248     $sql =<<"EOS";
 249 SELECT $outsel FROM (
 250   SELECT $outsel, ROWNUM $idx_name FROM (
 251     SELECT $insel ${sql}${order_group_having}
 252   ) $qalias WHERE ROWNUM <= ?
 253 ) $qalias WHERE $idx_name >= ?
 254 EOS
 255   }
 256   else {
 257     push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
 258     $sql =<<"EOS";
 259   SELECT $outsel FROM (
 260     SELECT $insel ${sql}${order_group_having}
 261   ) $qalias WHERE ROWNUM <= ?
 262 EOS
 263   }
 264
 265   return $sql;
 266 }
 267
 268 # used by _Top and _FetchFirst
 269 sub _prep_for_skimming_limit {
 270   my ( $self, $sql, $rs_attrs ) = @_;
 271
 272   # mangle the input sql as we will be replacing the selector
 273   $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
 274     or $self->throw_exception("Unrecognizable SELECT: $sql");
 275
 276   my %r = ( inner_sql => $sql );
 277
 278   # get selectors
 279   my ($alias_map, $extra_order_sel);
 280   ($r{in_sel}, $r{out_sel}, $alias_map, $extra_order_sel)
 281     = $self->_subqueried_limit_attrs ($rs_attrs);
 282
 283   my $requested_order = delete $rs_attrs->{order_by};
 284   $r{order_by_requested} = $self->_order_by ($requested_order);
 285
 286   # make up an order unless supplied
 287   my $inner_order = ($r{order_by_requested}
 288     ? $requested_order
 289     : [ map
 290       { "$rs_attrs->{alias}.$_" }
 291       ( $rs_attrs->{_rsroot_rsrc}->_pri_cols )
 292     ]
 293   );
 294
 295   # localise as we already have all the bind values we need
 296   {
 297     local $self->{order_bind};
 298     $r{order_by_inner} = $self->_order_by ($inner_order);
 299
 300     my @out_chunks;
 301     for my $ch ($self->_order_by_chunks ($inner_order)) {
 302       $ch = $ch->[0] if ref $ch eq 'ARRAY';
 303
 304       $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix;
 305       my $dir = uc ($1||'ASC');
 306
 307       push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' );
 308     }
 309
 310     $r{order_by_reversed} = $self->_order_by (\@out_chunks);
 311   }
 312
 313   # this is the order supplement magic
 314   $r{mid_sel} = $r{out_sel};
 315   if ($extra_order_sel) {
 316     for my $extra_col (sort
 317       { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
 318       keys %$extra_order_sel
 319     ) {
 320       $r{in_sel} .= sprintf (', %s AS %s',
 321         $extra_col,
 322         $extra_order_sel->{$extra_col},
 323       );
 324
 325       $r{mid_sel} .= ', ' . $extra_order_sel->{$extra_col};
 326     }
 327
 328     # since whatever order bindvals there are, they will be realiased
 329     # and need to show up in front of the entire initial inner subquery
 330     # *unshift* the selector bind stack to make this happen (horrible,
 331     # horrible, but we don't have another mechanism yet)
 332     unshift @{$self->{select_bind}}, @{$self->{order_bind}};
 333   }
 334
 335   # and this is order re-alias magic
 336   for my $map ($extra_order_sel, $alias_map) {
 337     for my $col (keys %$map) {
 338       my $re_col = quotemeta ($col);
 339       $_ =~ s/$re_col/$map->{$col}/
 340         for ($r{order_by_reversed}, $r{order_by_requested});
 341     }
 342   }
 343
 344   # generate the rest of the sql
 345   $r{grpby_having} = $self->_parse_rs_attrs ($rs_attrs);
 346
 347   $r{quoted_rs_alias} = $self->_quote ($rs_attrs->{alias});
 348
 349   \%r;
 350 }
 351
 352 =head2 Top
 353
 354  SELECT * FROM
 355
 356  SELECT TOP $limit FROM (
 357   SELECT TOP $limit FROM (
 358    SELECT TOP ($limit+$offset) ...
 359   ) ORDER BY $reversed_original_order
 360  ) ORDER BY $original_order
 361
 362 Unreliable Top-based implementation, supported by B<< MSSQL < 2005 >>.
 363
 364 =head3 CAVEAT
 365
 366 Due to its implementation, this limit dialect returns B<incorrect results>
 367 when $limit+$offset > total amount of rows in the resultset.
 368
 369 =cut
 370
 371 sub _Top {
 372   my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
 373
 374   my %l = %{ $self->_prep_for_skimming_limit($sql, $rs_attrs) };
 375
 376   $sql = sprintf ('SELECT TOP %u %s %s %s %s',
 377     $rows + ($offset||0),
 378     $l{in_sel},
 379     $l{inner_sql},
 380     $l{grpby_having},
 381     $l{order_by_inner},
 382   );
 383
 384   $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
 385     $rows,
 386     $l{mid_sel},
 387     $sql,
 388     $l{quoted_rs_alias},
 389     $l{order_by_reversed},
 390   ) if $offset;
 391
 392   $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
 393     $rows,
 394     $l{out_sel},
 395     $sql,
 396     $l{quoted_rs_alias},
 397     $l{order_by_requested},
 398   ) if ( ($offset && $l{order_by_requested}) || ($l{mid_sel} ne $l{out_sel}) );
 399
 400   return $sql;
 401 }
 402
 403 =head2 FetchFirst
 404
 405  SELECT * FROM
 406  (
 407  SELECT * FROM (
 408   SELECT * FROM (
 409    SELECT * FROM ...
 410   ) ORDER BY $reversed_original_order
 411     FETCH FIRST $limit ROWS ONLY
 412  ) ORDER BY $original_order
 413    FETCH FIRST $limit ROWS ONLY
 414  )
 415
 416 Unreliable FetchFirst-based implementation, supported by B<< IBM DB2 <= V5R3 >>.
 417
 418 =head3 CAVEAT
 419
 420 Due to its implementation, this limit dialect returns B<incorrect results>
 421 when $limit+$offset > total amount of rows in the resultset.
 422
 423 =cut
 424
 425 sub _FetchFirst {
 426   my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
 427
 428   my %l = %{ $self->_prep_for_skimming_limit($sql, $rs_attrs) };
 429
 430   $sql = sprintf ('SELECT %s %s %s %s FETCH FIRST %u ROWS ONLY',
 431     $l{in_sel},
 432     $l{inner_sql},
 433     $l{grpby_having},
 434     $l{order_by_inner},
 435     $rows + ($offset||0),
 436   );
 437
 438   $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
 439     $l{mid_sel},
 440     $sql,
 441     $l{quoted_rs_alias},
 442     $l{order_by_reversed},
 443     $rows,
 444   ) if $offset;
 445
 446   $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
 447     $l{out_sel},
 448     $sql,
 449     $l{quoted_rs_alias},
 450     $l{order_by_requested},
 451     $rows,
 452   ) if ( ($offset && $l{order_by_requested}) || ($l{mid_sel} ne $l{out_sel}) );
 453
 454   return $sql;
 455 }
 456
 457 =head2 RowCountOrGenericSubQ
 458
 459 This is not exactly a limit dialect, but more of a proxy for B<Sybase ASE>.
 460 If no $offset is supplied the limit is simply performed as:
 461
 462  SET ROWCOUNT $limit
 463  SELECT ...
 464  SET ROWCOUNT 0
 465
 466 Otherwise we fall back to L</GenericSubQ>
 467
 468 =cut
 469
 470 sub _RowCountOrGenericSubQ {
 471   my $self = shift;
 472   my ($sql, $rs_attrs, $rows, $offset) = @_;
 473
 474   return $self->_GenericSubQ(@_) if $offset;
 475
 476   return sprintf <<"EOF", $rows, $sql;
 477 SET ROWCOUNT %d
 478 %s
 479 SET ROWCOUNT 0
 480 EOF
 481 }
 482
 483 =head2 GenericSubQ
 484
 485  SELECT * FROM (
 486   SELECT ...
 487  )
 488  WHERE (
 489   SELECT COUNT(*) FROM $original_table cnt WHERE cnt.id < $original_table.id
 490  ) BETWEEN $offset AND ($offset+$rows-1)
 491
 492 This is the most evil limit "dialect" (more of a hack) for I<really> stupid
 493 databases. It works by ordering the set by some unique column, and calculating
 494 the amount of rows that have a less-er value (thus emulating a L</RowNum>-like
 495 index). Of course this implies the set can only be ordered by a single unique
 496 column. Also note that this technique can be and often is B<excruciatingly
 497 slow>.
 498
 499 Currently used by B<Sybase ASE>, due to lack of any other option.
 500
 501 =cut
 502 sub _GenericSubQ {
 503   my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
 504
 505   my $root_rsrc = $rs_attrs->{_rsroot_rsrc};
 506   my $root_tbl_name = $root_rsrc->name;
 507
 508   # mangle the input sql as we will be replacing the selector
 509   $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
 510     or $self->throw_exception("Unrecognizable SELECT: $sql");
 511
 512   my ($order_by, @rest) = do {
 513     local $self->{quote_char};
 514     $self->_order_by_chunks ($rs_attrs->{order_by})
 515   };
 516
 517   unless (
 518     $order_by
 519       &&
 520     ! @rest
 521       &&
 522     ( ! ref $order_by
 523         ||
 524       ( ref $order_by eq 'ARRAY' and @$order_by == 1 )
 525     )
 526   ) {
 527     $self->throw_exception (
 528       'Generic Subquery Limit does not work on resultsets without an order, or resultsets '
 529     . 'with complex order criteria (multicolumn and/or functions). Provide a single, '
 530     . 'unique-column order criteria.'
 531     );
 532   }
 533
 534   ($order_by) = @$order_by if ref $order_by;
 535
 536   $order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix;
 537   my $direction = lc ($1 || 'asc');
 538
 539   my ($unq_sort_col) = $order_by =~ /(?:^|\.)([^\.]+)$/;
 540
 541   my $inf = $root_rsrc->storage->_resolve_column_info (
 542     $rs_attrs->{from}, [$order_by, $unq_sort_col]
 543   );
 544
 545   my $ord_colinfo = $inf->{$order_by} || $self->throw_exception("Unable to determine source of order-criteria '$order_by'");
 546
 547   if ($ord_colinfo->{-result_source}->name ne $root_tbl_name) {
 548     $self->throw_exception(sprintf
 549       "Generic Subquery Limit order criteria can be only based on the root-source '%s'"
 550     . " (aliased as '%s')", $root_rsrc->source_name, $rs_attrs->{alias},
 551     );
 552   }
 553
 554   # make sure order column is qualified
 555   $order_by = "$rs_attrs->{alias}.$order_by"
 556     unless $order_by =~ /^$rs_attrs->{alias}\./;
 557
 558   my $is_u;
 559   my $ucs = { $root_rsrc->unique_constraints };
 560   for (values %$ucs ) {
 561     if (@$_ == 1 && "$rs_attrs->{alias}.$_->[0]" eq $order_by) {
 562       $is_u++;
 563       last;
 564     }
 565   }
 566   $self->throw_exception(
 567     "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
 568   ) unless $is_u;
 569
 570   my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
 571     = $self->_subqueried_limit_attrs ($rs_attrs);
 572
 573   my $cmp_op = $direction eq 'desc' ? '>' : '<';
 574   my $count_tbl_alias = 'rownum__emulation';
 575
 576   my $order_sql = $self->_order_by (delete $rs_attrs->{order_by});
 577   my $group_having_sql = $self->_parse_rs_attrs($rs_attrs);
 578
 579   # add the order supplement (if any) as this is what will be used for the outer WHERE
 580   $in_sel .= ", $_" for keys %{$extra_order_sel||{}};
 581
 582   $sql = sprintf (<<EOS,
 583 SELECT $out_sel
 584   FROM (
 585     SELECT $in_sel ${sql}${group_having_sql}
 586   ) %s
 587 WHERE ( SELECT COUNT(*) FROM %s %s WHERE %s $cmp_op %s ) %s
 588 $order_sql
 589 EOS
 590     ( map { $self->_quote ($_) } (
 591       $rs_attrs->{alias},
 592       $root_tbl_name,
 593       $count_tbl_alias,
 594       "$count_tbl_alias.$unq_sort_col",
 595       $order_by,
 596     )),
 597     $offset
 598       ? do {
 599          push @{$self->{limit_bind}},
 600             [ $self->__offset_bindtype => $offset ], [ $self->__total_bindtype => $offset + $rows - 1];
 601          'BETWEEN ? AND ?';
 602         }
 603       : do {
 604          push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
 605          '< ?';
 606          }
 607     ,
 608   );
 609
 610   return $sql;
 611 }
 612
 613
 614 # !!! THIS IS ALSO HORRIFIC !!! /me ashamed
 615 #
 616 # Generates inner/outer select lists for various limit dialects
 617 # which result in one or more subqueries (e.g. RNO, Top, RowNum)
 618 # Any non-root-table columns need to have their table qualifier
 619 # turned into a column alias (otherwise names in subqueries clash
 620 # and/or lose their source table)
 621 #
 622 # Returns inner/outer strings of SQL QUOTED selectors with aliases
 623 # (to be used in whatever select statement), and an alias index hashref
 624 # of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used for string-subst
 625 # higher up).
 626 # If an order_by is supplied, the inner select needs to bring out columns
 627 # used in implicit (non-selected) orders, and the order condition itself
 628 # needs to be realiased to the proper names in the outer query. Thus we
 629 # also return a hashref (order doesn't matter) of QUOTED EXTRA-SEL =>
 630 # QUOTED ALIAS pairs, which is a list of extra selectors that do *not*
 631 # exist in the original select list
 632 sub _subqueried_limit_attrs {
 633   my ($self, $rs_attrs) = @_;
 634
 635   $self->throw_exception(
 636     'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
 637   ) unless ref ($rs_attrs) eq 'HASH';
 638
 639   my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} );
 640
 641   # correlate select and as, build selection index
 642   my (@sel, $in_sel_index);
 643   for my $i (0 .. $#{$rs_attrs->{select}}) {
 644
 645     my $s = $rs_attrs->{select}[$i];
 646     my $sql_sel = $self->_recurse_fields ($s);
 647     my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef;
 648
 649     push @sel, {
 650       sql => $sql_sel,
 651       unquoted_sql => do { local $self->{quote_char}; $self->_recurse_fields ($s) },
 652       as =>
 653         $sql_alias
 654           ||
 655         $rs_attrs->{as}[$i]
 656           ||
 657         $self->throw_exception("Select argument $i ($s) without corresponding 'as'")
 658       ,
 659     };
 660
 661     $in_sel_index->{$sql_sel}++;
 662     $in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias;
 663
 664     # record unqualified versions too, so we do not have
 665     # to reselect the same column twice (in qualified and
 666     # unqualified form)
 667     if (! ref $s && $sql_sel =~ / $re_sep (.+) $/x) {
 668       $in_sel_index->{$1}++;
 669     }
 670   }
 671
 672
 673   # re-alias and remove any name separators from aliases,
 674   # unless we are dealing with the current source alias
 675   # (which will transcend the subqueries as it is necessary
 676   # for possible further chaining)
 677   my (@in_sel, @out_sel, %renamed);
 678   for my $node (@sel) {
 679     if (
 680       $node->{as} =~ / (?<! ^ $re_alias ) \. /x
 681         or
 682       $node->{unquoted_sql} =~ / (?<! ^ $re_alias ) $re_sep /x
 683     ) {
 684       $node->{as} = $self->_unqualify_colname($node->{as});
 685       my $quoted_as = $self->_quote($node->{as});
 686       push @in_sel, sprintf '%s AS %s', $node->{sql}, $quoted_as;
 687       push @out_sel, $quoted_as;
 688       $renamed{$node->{sql}} = $quoted_as;
 689     }
 690     else {
 691       push @in_sel, $node->{sql};
 692       push @out_sel, $self->_quote ($node->{as});
 693     }
 694   }
 695
 696   # see if the order gives us anything
 697   my %extra_order_sel;
 698   for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
 699     # order with bind
 700     $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
 701     $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
 702
 703     next if $in_sel_index->{$chunk};
 704
 705     $extra_order_sel{$chunk} ||= $self->_quote (
 706       'ORDER__BY__' . scalar keys %extra_order_sel
 707     );
 708   }
 709
 710   return (
 711     (map { join (', ', @$_ ) } (
 712       \@in_sel,
 713       \@out_sel)
 714     ),
 715     \%renamed,
 716     keys %extra_order_sel ? \%extra_order_sel : (),
 717   );
 718 }
 719
 720 sub _unqualify_colname {
 721   my ($self, $fqcn) = @_;
 722   $fqcn =~ s/ \. /__/xg;
 723   return $fqcn;
 724 }
 725
 726 1;
 727
 728 =head1 AUTHORS
 729
 730 See L<DBIx::Class/CONTRIBUTORS>.
 731
 732 =head1 LICENSE
 733
 734 You may distribute this code under the same terms as Perl itself.
 735
 736 =cut