make _determine_driver more reentrant
[dbsrgits/DBIx-Class-Historic.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 (not ref($table) or ref($table) eq 'SCALAR') {
333     $table = $self->_quote($table);
334   }
335
336   local $self->{rownum_hack_count} = 1
337     if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
338   @rest = (-1) unless defined $rest[0];
339   croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
340     # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
341   my ($sql, @where_bind) = $self->SUPER::select(
342     $table, $self->_recurse_fields($fields), $where, $order, @rest
343   );
344   if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
345     $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
346   }
347
348   return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
349 }
350
351 # Quotes table names, and handles default inserts
352 sub insert {
353   my $self = shift;
354   my $table = shift;
355   $table = $self->_quote($table);
356
357   # SQLA will emit INSERT INTO $table ( ) VALUES ( )
358   # which is sadly understood only by MySQL. Change default behavior here,
359   # until SQLA2 comes with proper dialect support
360   if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
361     return "INSERT INTO ${table} DEFAULT VALUES"
362   }
363
364   $self->SUPER::insert($table, @_);
365 }
366
367 # Just quotes table names.
368 sub update {
369   my $self = shift;
370   my $table = shift;
371   $table = $self->_quote($table);
372   $self->SUPER::update($table, @_);
373 }
374
375 # Just quotes table names.
376 sub delete {
377   my $self = shift;
378   my $table = shift;
379   $table = $self->_quote($table);
380   $self->SUPER::delete($table, @_);
381 }
382
383 sub _emulate_limit {
384   my $self = shift;
385   if ($_[3] == -1) {
386     return $_[1].$self->_order_by($_[2]);
387   } else {
388     return $self->SUPER::_emulate_limit(@_);
389   }
390 }
391
392 sub _recurse_fields {
393   my ($self, $fields, $params) = @_;
394   my $ref = ref $fields;
395   return $self->_quote($fields) unless $ref;
396   return $$fields if $ref eq 'SCALAR';
397
398   if ($ref eq 'ARRAY') {
399     return join(', ', map {
400       $self->_recurse_fields($_)
401         .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
402           ? ' AS col'.$self->{rownum_hack_count}++
403           : '')
404       } @$fields);
405   }
406   elsif ($ref eq 'HASH') {
407     my %hash = %$fields;
408     my ($select, $as);
409
410     if ($hash{-select}) {
411       $select = $self->_recurse_fields (delete $hash{-select});
412       $as = $self->_quote (delete $hash{-as});
413     }
414     else {
415       my ($func, $args) = each %hash;
416       delete $hash{$func};
417
418       if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
419         croak (
420           'The select => { distinct => ... } syntax is not supported for multiple columns.'
421          .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
422          .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
423         );
424       }
425       $select = sprintf ('%s( %s )',
426         $self->_sqlcase($func),
427         $self->_recurse_fields($args)
428       );
429     }
430
431     # there should be nothing left
432     if (keys %hash) {
433       croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
434     }
435
436     $select .= " AS $as" if $as;
437     return $select;
438   }
439   # Is the second check absolutely necessary?
440   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
441     return $self->_fold_sqlbind( $fields );
442   }
443   else {
444     croak($ref . qq{ unexpected in _recurse_fields()})
445   }
446 }
447
448 sub _order_by {
449   my ($self, $arg) = @_;
450
451   if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
452
453     my $ret = '';
454
455     if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
456       $ret = $self->_sqlcase(' group by ') . $g;
457     }
458
459     if (defined $arg->{having}) {
460       my ($frag, @bind) = $self->_recurse_where($arg->{having});
461       push(@{$self->{having_bind}}, @bind);
462       $ret .= $self->_sqlcase(' having ').$frag;
463     }
464
465     if (defined $arg->{order_by}) {
466       my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
467       push(@{$self->{order_bind}}, @bind);
468       $ret .= $frag;
469     }
470
471     return $ret;
472   }
473   else {
474     my ($sql, @bind) = $self->SUPER::_order_by ($arg);
475     push(@{$self->{order_bind}}, @bind);
476     return $sql;
477   }
478 }
479
480 sub _order_directions {
481   my ($self, $order) = @_;
482
483   # strip bind values - none of the current _order_directions users support them
484   return $self->SUPER::_order_directions( [ map
485     { ref $_ ? $_->[0] : $_ }
486     $self->_order_by_chunks ($order)
487   ]);
488 }
489
490 sub _table {
491   my ($self, $from) = @_;
492   if (ref $from eq 'ARRAY') {
493     return $self->_recurse_from(@$from);
494   } elsif (ref $from eq 'HASH') {
495     return $self->_make_as($from);
496   } else {
497     return $from; # would love to quote here but _table ends up getting called
498                   # twice during an ->select without a limit clause due to
499                   # the way S::A::Limit->select works. should maybe consider
500                   # bypassing this and doing S::A::select($self, ...) in
501                   # our select method above. meantime, quoting shims have
502                   # been added to select/insert/update/delete here
503   }
504 }
505
506 sub _recurse_from {
507   my ($self, $from, @join) = @_;
508   my @sqlf;
509   push(@sqlf, $self->_make_as($from));
510   foreach my $j (@join) {
511     my ($to, $on) = @$j;
512
513     # check whether a join type exists
514     my $join_clause = '';
515     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
516     if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
517       $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
518     } else {
519       $join_clause = ' JOIN ';
520     }
521     push(@sqlf, $join_clause);
522
523     if (ref $to eq 'ARRAY') {
524       push(@sqlf, '(', $self->_recurse_from(@$to), ')');
525     } else {
526       push(@sqlf, $self->_make_as($to));
527     }
528     push(@sqlf, ' ON ', $self->_join_condition($on));
529   }
530   return join('', @sqlf);
531 }
532
533 sub _fold_sqlbind {
534   my ($self, $sqlbind) = @_;
535
536   my @sqlbind = @$$sqlbind; # copy
537   my $sql = shift @sqlbind;
538   push @{$self->{from_bind}}, @sqlbind;
539
540   return $sql;
541 }
542
543 sub _make_as {
544   my ($self, $from) = @_;
545   return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
546                         : ref $_ eq 'REF'    ? $self->_fold_sqlbind($_)
547                         : $self->_quote($_))
548                        } reverse each %{$self->_skip_options($from)});
549 }
550
551 sub _skip_options {
552   my ($self, $hash) = @_;
553   my $clean_hash = {};
554   $clean_hash->{$_} = $hash->{$_}
555     for grep {!/^-/} keys %$hash;
556   return $clean_hash;
557 }
558
559 sub _join_condition {
560   my ($self, $cond) = @_;
561   if (ref $cond eq 'HASH') {
562     my %j;
563     for (keys %$cond) {
564       my $v = $cond->{$_};
565       if (ref $v) {
566         croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
567             if ref($v) ne 'SCALAR';
568         $j{$_} = $v;
569       }
570       else {
571         my $x = '= '.$self->_quote($v); $j{$_} = \$x;
572       }
573     };
574     return scalar($self->_recurse_where(\%j));
575   } elsif (ref $cond eq 'ARRAY') {
576     return join(' OR ', map { $self->_join_condition($_) } @$cond);
577   } else {
578     die "Can't handle this yet!";
579   }
580 }
581
582 sub _quote {
583   my ($self, $label) = @_;
584   return '' unless defined $label;
585   return $$label if ref($label) eq 'SCALAR';
586   return "*" if $label eq '*';
587   return $label unless $self->{quote_char};
588   if(ref $self->{quote_char} eq "ARRAY"){
589     return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
590       if !defined $self->{name_sep};
591     my $sep = $self->{name_sep};
592     return join($self->{name_sep},
593         map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1]  }
594        split(/\Q$sep\E/,$label));
595   }
596   return $self->SUPER::_quote($label);
597 }
598
599 sub limit_dialect {
600     my $self = shift;
601     $self->{limit_dialect} = shift if @_;
602     return $self->{limit_dialect};
603 }
604
605 # Set to an array-ref to specify separate left and right quotes for table names.
606 # A single scalar is equivalen to [ $char, $char ]
607 sub quote_char {
608     my $self = shift;
609     $self->{quote_char} = shift if @_;
610     return $self->{quote_char};
611 }
612
613 # Character separating quoted table names.
614 sub name_sep {
615     my $self = shift;
616     $self->{name_sep} = shift if @_;
617     return $self->{name_sep};
618 }
619
620 1;