add a comment
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / SQLAHacks.pm
1 package # Hide from PAUSE
2   DBIx::Class::SQLAHacks;
3
4 # This module is a subclass of SQL::Abstract::Limit and includes a number
5 # of DBIC-specific workarounds, not yet suitable for inclusion into the
6 # SQLA core
7
8 use base qw/SQL::Abstract::Limit/;
9 use strict;
10 use warnings;
11 use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
12
13 BEGIN {
14   # reinstall the carp()/croak() functions imported into SQL::Abstract
15   # as Carp and Carp::Clan do not like each other much
16   no warnings qw/redefine/;
17   no strict qw/refs/;
18   for my $f (qw/carp croak/) {
19
20     my $orig = \&{"SQL::Abstract::$f"};
21     *{"SQL::Abstract::$f"} = sub {
22
23       local $Carp::CarpLevel = 1;   # even though Carp::Clan ignores this, $orig will not
24
25       if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
26         __PACKAGE__->can($f)->(@_);
27       }
28       else {
29         $orig->(@_);
30       }
31     }
32   }
33 }
34
35
36 # Tries to determine limit dialect.
37 #
38 sub new {
39   my $self = shift->SUPER::new(@_);
40
41   # This prevents the caching of $dbh in S::A::L, I believe
42   # If limit_dialect is a ref (like a $dbh), go ahead and replace
43   #   it with what it resolves to:
44   $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
45     if ref $self->{limit_dialect};
46
47   $self;
48 }
49
50 # Some databases (sqlite) do not handle multiple parenthesis
51 # around in/between arguments. A tentative x IN ( (1, 2 ,3) )
52 # is interpreted as x IN 1 or something similar.
53 #
54 # Since we currently do not have access to the SQLA AST, resort
55 # to barbaric mutilation of any SQL supplied in literal form
56 sub _strip_outer_paren {
57   my ($self, $arg) = @_;
58
59   return $self->_SWITCH_refkind ($arg, {
60     ARRAYREFREF => sub {
61       $$arg->[0] = __strip_outer_paren ($$arg->[0]);
62       return $arg;
63     },
64     SCALARREF => sub {
65       return \__strip_outer_paren( $$arg );
66     },
67     FALLBACK => sub {
68       return $arg
69     },
70   });
71 }
72
73 sub __strip_outer_paren {
74   my $sql = shift;
75
76   if ($sql and not ref $sql) {
77     while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
78       $sql = $1;
79     }
80   }
81
82   return $sql;
83 }
84
85 sub _where_field_IN {
86   my ($self, $lhs, $op, $rhs) = @_;
87   $rhs = $self->_strip_outer_paren ($rhs);
88   return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
89 }
90
91 sub _where_field_BETWEEN {
92   my ($self, $lhs, $op, $rhs) = @_;
93   $rhs = $self->_strip_outer_paren ($rhs);
94   return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
95 }
96
97 # Slow but ANSI standard Limit/Offset support. DB2 uses this
98 sub _RowNumberOver {
99   my ($self, $sql, $order, $rows, $offset ) = @_;
100
101   $offset += 1;
102   my $last = $rows + $offset - 1;
103   my ( $order_by ) = $self->_order_by( $order );
104
105   $sql = <<"SQL";
106 SELECT * FROM
107 (
108    SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
109       $sql
110       $order_by
111    ) Q1
112 ) Q2
113 WHERE ROW_NUM BETWEEN $offset AND $last
114
115 SQL
116
117   return $sql;
118 }
119
120 # Crappy Top based Limit/Offset support. MSSQL uses this currently,
121 # but may have to switch to RowNumberOver one day
122 sub _Top {
123   my ( $self, $sql, $order, $rows, $offset ) = @_;
124
125   # mangle the input sql so it can be properly aliased in the outer queries
126   $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix
127     or croak "Unrecognizable SELECT: $sql";
128   my $sql_select = $1;
129   my @sql_select = split (/\s*,\s*/, $sql_select);
130
131   # we can't support subqueries (in fact MSSQL can't) - croak
132   if (@sql_select != @{$self->{_dbic_rs_attrs}{select}}) {
133     croak (sprintf (
134       'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while '
135     . 'the resultset select attribure contains %d elements: %s',
136       scalar @sql_select,
137       scalar @{$self->{_dbic_rs_attrs}{select}},
138       $sql_select,
139     ));
140   }
141
142   my $name_sep = $self->name_sep || '.';
143   my $esc_name_sep = "\Q$name_sep\E";
144   my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x;
145
146   my $rs_alias = $self->{_dbic_rs_attrs}{alias};
147   my $quoted_rs_alias = $self->_quote ($rs_alias);
148
149   # construct the new select lists, rename(alias) some columns if necessary
150   my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
151
152   for (@{$self->{_dbic_rs_attrs}{select}}) {
153     next if ref $_;
154     my ($table, $orig_colname) = ( $_ =~ $col_re );
155     next unless $table;
156     $seen_names{$orig_colname}++;
157   }
158
159   for my $i (0 .. $#sql_select) {
160
161     my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i];
162     my $colsel_sql = $sql_select[$i];
163
164     # this may or may not work (in case of a scalarref or something)
165     my ($table, $orig_colname) = ( $colsel_arg =~ $col_re );
166
167     my $quoted_alias;
168     # do not attempt to understand non-scalar selects - alias numerically
169     if (ref $colsel_arg) {
170       $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) );
171     }
172     # column name seen more than once - alias it
173     elsif ($orig_colname &&
174           ($seen_names{$orig_colname} && $seen_names{$orig_colname} > 1) ) {
175       $quoted_alias = $self->_quote ("${table}__${orig_colname}");
176     }
177
178     # we did rename - make a record and adjust
179     if ($quoted_alias) {
180       # alias inner
181       push @inner_select, "$colsel_sql AS $quoted_alias";
182
183       # push alias to outer
184       push @outer_select, $quoted_alias;
185
186       # Any aliasing accumulated here will be considered
187       # both for inner and outer adjustments of ORDER BY
188       $self->__record_alias (
189         \%col_aliases,
190         $quoted_alias,
191         $colsel_arg,
192         $table ? $orig_colname : undef,
193       );
194     }
195
196     # otherwise just leave things intact inside, and use the abbreviated one outside
197     # (as we do not have table names anymore)
198     else {
199       push @inner_select, $colsel_sql;
200
201       my $outer_quoted = $self->_quote ($orig_colname);  # it was not a duplicate so should just work
202       push @outer_select, $outer_quoted;
203       $self->__record_alias (
204         \%outer_col_aliases,
205         $outer_quoted,
206         $colsel_arg,
207         $table ? $orig_colname : undef,
208       );
209     }
210   }
211
212   my $outer_select = join (', ', @outer_select );
213   my $inner_select = join (', ', @inner_select );
214
215   %outer_col_aliases = (%outer_col_aliases, %col_aliases);
216
217   # deal with order
218   croak '$order supplied to SQLAHacks limit emulators must be a hash'
219     if (ref $order ne 'HASH');
220
221   $order = { %$order }; #copy
222
223   my $req_order = $order->{order_by};
224
225   # examine normalized version, collapses nesting
226   my $limit_order;
227   if (scalar $self->_order_by_chunks ($req_order)) {
228     $limit_order = $req_order;
229   }
230   else {
231     $limit_order = [ map
232       { join ('', $rs_alias, $name_sep, $_ ) }
233       ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
234     ];
235   }
236
237   my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
238   my $order_by_requested = $self->_order_by ($req_order);
239
240   # generate the rest
241   delete $order->{order_by};
242   my $grpby_having = $self->_order_by ($order);
243
244   # short circuit for counts - the ordering complexity is needless
245   if ($self->{_dbic_rs_attrs}{-for_count_only}) {
246     return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
247   }
248
249   # we can't really adjust the order_by columns, as introspection is lacking
250   # resort to simple substitution
251   for my $col (keys %outer_col_aliases) {
252     for ($order_by_requested, $order_by_outer) {
253       $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
254     }
255   }
256   for my $col (keys %col_aliases) {
257     $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g;
258   }
259
260
261   my $inner_lim = $rows + $offset;
262
263   $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
264
265   if ($offset) {
266     $sql = <<"SQL";
267
268     SELECT TOP $rows $outer_select FROM
269     (
270       $sql
271     ) $quoted_rs_alias
272     $order_by_outer
273 SQL
274
275   }
276
277   if ($order_by_requested) {
278     $sql = <<"SQL";
279
280     SELECT $outer_select FROM
281       ( $sql ) $quoted_rs_alias
282     $order_by_requested
283 SQL
284
285   }
286
287   $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line
288   return $sql;
289 }
290
291 # action at a distance to shorten Top code above
292 sub __record_alias {
293   my ($self, $register, $alias, $fqcol, $col) = @_;
294
295   # record qualified name
296   $register->{$fqcol} = $alias;
297   $register->{$self->_quote($fqcol)} = $alias;
298
299   return unless $col;
300
301   # record unqualified name, undef (no adjustment) if a duplicate is found
302   if (exists $register->{$col}) {
303     $register->{$col} = undef;
304   }
305   else {
306     $register->{$col} = $alias;
307   }
308
309   $register->{$self->_quote($col)} = $register->{$col};
310 }
311
312
313
314 # While we're at it, this should make LIMIT queries more efficient,
315 #  without digging into things too deeply
316 sub _find_syntax {
317   my ($self, $syntax) = @_;
318   return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
319 }
320
321 my $for_syntax = {
322   update => 'FOR UPDATE',
323   shared => 'FOR SHARE',
324 };
325 # Quotes table names, handles "limit" dialects (e.g. where rownum between x and
326 # y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
327 sub select {
328   my ($self, $table, $fields, $where, $order, @rest) = @_;
329
330   $self->{"${_}_bind"} = [] for (qw/having from order/);
331
332   if (ref $table eq 'SCALAR') {
333     $table = $$table;
334   }
335   elsif (not ref $table) {
336     $table = $self->_quote($table);
337   }
338   local $self->{rownum_hack_count} = 1
339     if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
340   @rest = (-1) unless defined $rest[0];
341   croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
342     # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
343   my ($sql, @where_bind) = $self->SUPER::select(
344     $table, $self->_recurse_fields($fields), $where, $order, @rest
345   );
346   if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
347     $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
348   }
349
350   return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
351 }
352
353 # Quotes table names, and handles default inserts
354 sub insert {
355   my $self = shift;
356   my $table = shift;
357   $table = $self->_quote($table) unless ref($table);
358
359   # SQLA will emit INSERT INTO $table ( ) VALUES ( )
360   # which is sadly understood only by MySQL. Change default behavior here,
361   # until SQLA2 comes with proper dialect support
362   if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
363     return "INSERT INTO ${table} DEFAULT VALUES"
364   }
365
366   $self->SUPER::insert($table, @_);
367 }
368
369 # Just quotes table names.
370 sub update {
371   my $self = shift;
372   my $table = shift;
373   $table = $self->_quote($table) unless ref($table);
374   $self->SUPER::update($table, @_);
375 }
376
377 # Just quotes table names.
378 sub delete {
379   my $self = shift;
380   my $table = shift;
381   $table = $self->_quote($table) unless ref($table);
382   $self->SUPER::delete($table, @_);
383 }
384
385 sub _emulate_limit {
386   my $self = shift;
387   if ($_[3] == -1) {
388     return $_[1].$self->_order_by($_[2]);
389   } else {
390     return $self->SUPER::_emulate_limit(@_);
391   }
392 }
393
394 sub _recurse_fields {
395   my ($self, $fields, $params) = @_;
396   my $ref = ref $fields;
397   return $self->_quote($fields) unless $ref;
398   return $$fields if $ref eq 'SCALAR';
399
400   if ($ref eq 'ARRAY') {
401     return join(', ', map {
402       $self->_recurse_fields($_)
403         .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
404           ? ' AS col'.$self->{rownum_hack_count}++
405           : '')
406       } @$fields);
407   }
408   elsif ($ref eq 'HASH') {
409     my %hash = %$fields;
410     my ($select, $as);
411
412     if ($hash{-select}) {
413       $select = $self->_recurse_fields (delete $hash{-select});
414       $as = $self->_quote (delete $hash{-as});
415     }
416     else {
417       my ($func, $args) = each %hash;
418       delete $hash{$func};
419
420       if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
421         croak (
422           'The select => { distinct => ... } syntax is not supported for multiple columns.'
423          .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
424          .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
425         );
426       }
427       $select = sprintf ('%s( %s )',
428         $self->_sqlcase($func),
429         $self->_recurse_fields($args)
430       );
431     }
432
433     # there should be nothing left
434     if (keys %hash) {
435       croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
436     }
437
438     $select .= " AS $as" if $as;
439     return $select;
440   }
441   # Is the second check absolutely necessary?
442   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
443     return $self->_fold_sqlbind( $fields );
444   }
445   else {
446     croak($ref . qq{ unexpected in _recurse_fields()})
447   }
448 }
449
450 sub _order_by {
451   my ($self, $arg) = @_;
452
453   if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
454
455     my $ret = '';
456
457     if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
458       $ret = $self->_sqlcase(' group by ') . $g;
459     }
460
461     if (defined $arg->{having}) {
462       my ($frag, @bind) = $self->_recurse_where($arg->{having});
463       push(@{$self->{having_bind}}, @bind);
464       $ret .= $self->_sqlcase(' having ').$frag;
465     }
466
467     if (defined $arg->{order_by}) {
468       my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
469       push(@{$self->{order_bind}}, @bind);
470       $ret .= $frag;
471     }
472
473     return $ret;
474   }
475   else {
476     my ($sql, @bind) = $self->SUPER::_order_by ($arg);
477     push(@{$self->{order_bind}}, @bind);
478     return $sql;
479   }
480 }
481
482 sub _order_directions {
483   my ($self, $order) = @_;
484
485   # strip bind values - none of the current _order_directions users support them
486   return $self->SUPER::_order_directions( [ map
487     { ref $_ ? $_->[0] : $_ }
488     $self->_order_by_chunks ($order)
489   ]);
490 }
491
492 sub _table {
493   my ($self, $from) = @_;
494   if (ref $from eq 'ARRAY') {
495     return $self->_recurse_from(@$from);
496   } elsif (ref $from eq 'HASH') {
497     return $self->_make_as($from);
498   } else {
499     return $from; # would love to quote here but _table ends up getting called
500                   # twice during an ->select without a limit clause due to
501                   # the way S::A::Limit->select works. should maybe consider
502                   # bypassing this and doing S::A::select($self, ...) in
503                   # our select method above. meantime, quoting shims have
504                   # been added to select/insert/update/delete here
505   }
506 }
507
508 sub _recurse_from {
509   my ($self, $from, @join) = @_;
510   my @sqlf;
511   push(@sqlf, $self->_make_as($from));
512   foreach my $j (@join) {
513     my ($to, $on) = @$j;
514
515     # check whether a join type exists
516     my $join_clause = '';
517     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
518     if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
519       $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
520     } else {
521       $join_clause = ' JOIN ';
522     }
523     push(@sqlf, $join_clause);
524
525     if (ref $to eq 'ARRAY') {
526       push(@sqlf, '(', $self->_recurse_from(@$to), ')');
527     } else {
528       push(@sqlf, $self->_make_as($to));
529     }
530     push(@sqlf, ' ON ', $self->_join_condition($on));
531   }
532   return join('', @sqlf);
533 }
534
535 sub _fold_sqlbind {
536   my ($self, $sqlbind) = @_;
537
538   my @sqlbind = @$$sqlbind; # copy
539   my $sql = shift @sqlbind;
540   push @{$self->{from_bind}}, @sqlbind;
541
542   return $sql;
543 }
544
545 sub _make_as {
546   my ($self, $from) = @_;
547   return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
548                         : ref $_ eq 'REF'    ? $self->_fold_sqlbind($_)
549                         : $self->_quote($_))
550                        } reverse each %{$self->_skip_options($from)});
551 }
552
553 sub _skip_options {
554   my ($self, $hash) = @_;
555   my $clean_hash = {};
556   $clean_hash->{$_} = $hash->{$_}
557     for grep {!/^-/} keys %$hash;
558   return $clean_hash;
559 }
560
561 sub _join_condition {
562   my ($self, $cond) = @_;
563   if (ref $cond eq 'HASH') {
564     my %j;
565     for (keys %$cond) {
566       my $v = $cond->{$_};
567       if (ref $v) {
568         croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
569             if ref($v) ne 'SCALAR';
570         $j{$_} = $v;
571       }
572       else {
573         my $x = '= '.$self->_quote($v); $j{$_} = \$x;
574       }
575     };
576     return scalar($self->_recurse_where(\%j));
577   } elsif (ref $cond eq 'ARRAY') {
578     return join(' OR ', map { $self->_join_condition($_) } @$cond);
579   } else {
580     die "Can't handle this yet!";
581   }
582 }
583
584 sub _quote {
585   my ($self, $label) = @_;
586   return '' unless defined $label;
587   return "*" if $label eq '*';
588   return $label unless $self->{quote_char};
589   if(ref $self->{quote_char} eq "ARRAY"){
590     return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
591       if !defined $self->{name_sep};
592     my $sep = $self->{name_sep};
593     return join($self->{name_sep},
594         map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1]  }
595        split(/\Q$sep\E/,$label));
596   }
597   return $self->SUPER::_quote($label);
598 }
599
600 sub limit_dialect {
601     my $self = shift;
602     $self->{limit_dialect} = shift if @_;
603     return $self->{limit_dialect};
604 }
605
606 # Set to an array-ref to specify separate left and right quotes for table names.
607 # A single scalar is equivalen to [ $char, $char ]
608 sub quote_char {
609     my $self = shift;
610     $self->{quote_char} = shift if @_;
611     return $self->{quote_char};
612 }
613
614 # Character separating quoted table names.
615 sub name_sep {
616     my $self = shift;
617     $self->{name_sep} = shift if @_;
618     return $self->{name_sep};
619 }
620
621 1;