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