Applied patch from kados regarding use of a DateTime::Format class to validate
[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 && ($seen_names{$orig_colname} > 1) ) {
174       $quoted_alias = $self->_quote ("${table}__${orig_colname}");
175     }
176
177     # we did rename - make a record and adjust
178     if ($quoted_alias) {
179       # alias inner
180       push @inner_select, "$colsel_sql AS $quoted_alias";
181
182       # push alias to outer
183       push @outer_select, $quoted_alias;
184
185       # Any aliasing accumulated here will be considered
186       # both for inner and outer adjustments of ORDER BY
187       $self->__record_alias (
188         \%col_aliases,
189         $quoted_alias,
190         $colsel_arg,
191         $table ? $orig_colname : undef,
192       );
193     }
194
195     # otherwise just leave things intact inside, and use the abbreviated one outside
196     # (as we do not have table names anymore)
197     else {
198       push @inner_select, $colsel_sql;
199
200       my $outer_quoted = $self->_quote ($orig_colname);  # it was not a duplicate so should just work
201       push @outer_select, $outer_quoted;
202       $self->__record_alias (
203         \%outer_col_aliases,
204         $outer_quoted,
205         $colsel_arg,
206         $table ? $orig_colname : undef,
207       );
208     }
209   }
210
211   my $outer_select = join (', ', @outer_select );
212   my $inner_select = join (', ', @inner_select );
213
214   %outer_col_aliases = (%outer_col_aliases, %col_aliases);
215
216   # deal with order
217   croak '$order supplied to SQLAHacks limit emulators must be a hash'
218     if (ref $order ne 'HASH');
219
220   $order = { %$order }; #copy
221
222   my $req_order = $order->{order_by};
223
224   # examine normalized version, collapses nesting
225   my $limit_order;
226   if (scalar $self->_order_by_chunks ($req_order)) {
227     $limit_order = $req_order;
228   }
229   else {
230     $limit_order = [ map
231       { join ('', $rs_alias, $name_sep, $_ ) }
232       ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
233     ];
234   }
235
236   my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
237   my $order_by_requested = $self->_order_by ($req_order);
238
239   # generate the rest
240   delete $order->{order_by};
241   my $grpby_having = $self->_order_by ($order);
242
243   # short circuit for counts - the ordering complexity is needless
244   if ($self->{_dbic_rs_attrs}{-for_count_only}) {
245     return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
246   }
247
248   # we can't really adjust the order_by columns, as introspection is lacking
249   # resort to simple substitution
250   for my $col (keys %outer_col_aliases) {
251     for ($order_by_requested, $order_by_outer) {
252       $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
253     }
254   }
255   for my $col (keys %col_aliases) {
256     $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g;
257   }
258
259
260   my $inner_lim = $rows + $offset;
261
262   $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
263
264   if ($offset) {
265     $sql = <<"SQL";
266
267     SELECT TOP $rows $outer_select FROM
268     (
269       $sql
270     ) $quoted_rs_alias
271     $order_by_outer
272 SQL
273
274   }
275
276   if ($order_by_requested) {
277     $sql = <<"SQL";
278
279     SELECT $outer_select FROM
280       ( $sql ) $quoted_rs_alias
281     $order_by_requested
282 SQL
283
284   }
285
286   $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line
287   return $sql;
288 }
289
290 # action at a distance to shorten Top code above
291 sub __record_alias {
292   my ($self, $register, $alias, $fqcol, $col) = @_;
293
294   # record qualified name
295   $register->{$fqcol} = $alias;
296   $register->{$self->_quote($fqcol)} = $alias;
297
298   return unless $col;
299
300   # record unqualified name, undef (no adjustment) if a duplicate is found
301   if (exists $register->{$col}) {
302     $register->{$col} = undef;
303   }
304   else {
305     $register->{$col} = $alias;
306   }
307
308   $register->{$self->_quote($col)} = $register->{$col};
309 }
310
311
312
313 # While we're at it, this should make LIMIT queries more efficient,
314 #  without digging into things too deeply
315 sub _find_syntax {
316   my ($self, $syntax) = @_;
317   return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
318 }
319
320 my $for_syntax = {
321   update => 'FOR UPDATE',
322   shared => 'FOR SHARE',
323 };
324 # Quotes table names, handles "limit" dialects (e.g. where rownum between x and
325 # y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
326 sub select {
327   my ($self, $table, $fields, $where, $order, @rest) = @_;
328
329   $self->{"${_}_bind"} = [] for (qw/having from order/);
330
331   if (ref $table eq 'SCALAR') {
332     $table = $$table;
333   }
334   elsif (not ref $table) {
335     $table = $self->_quote($table);
336   }
337   local $self->{rownum_hack_count} = 1
338     if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
339   @rest = (-1) unless defined $rest[0];
340   croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
341     # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
342   my ($sql, @where_bind) = $self->SUPER::select(
343     $table, $self->_recurse_fields($fields), $where, $order, @rest
344   );
345   if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
346     $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
347   }
348
349   return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
350 }
351
352 # Quotes table names, and handles default inserts
353 sub insert {
354   my $self = shift;
355   my $table = shift;
356   $table = $self->_quote($table) unless ref($table);
357
358   # SQLA will emit INSERT INTO $table ( ) VALUES ( )
359   # which is sadly understood only by MySQL. Change default behavior here,
360   # until SQLA2 comes with proper dialect support
361   if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
362     return "INSERT INTO ${table} DEFAULT VALUES"
363   }
364
365   $self->SUPER::insert($table, @_);
366 }
367
368 # Just quotes table names.
369 sub update {
370   my $self = shift;
371   my $table = shift;
372   $table = $self->_quote($table) unless ref($table);
373   $self->SUPER::update($table, @_);
374 }
375
376 # Just quotes table names.
377 sub delete {
378   my $self = shift;
379   my $table = shift;
380   $table = $self->_quote($table) unless ref($table);
381   $self->SUPER::delete($table, @_);
382 }
383
384 sub _emulate_limit {
385   my $self = shift;
386   if ($_[3] == -1) {
387     return $_[1].$self->_order_by($_[2]);
388   } else {
389     return $self->SUPER::_emulate_limit(@_);
390   }
391 }
392
393 sub _recurse_fields {
394   my ($self, $fields, $params) = @_;
395   my $ref = ref $fields;
396   return $self->_quote($fields) unless $ref;
397   return $$fields if $ref eq 'SCALAR';
398
399   if ($ref eq 'ARRAY') {
400     return join(', ', map {
401       $self->_recurse_fields($_)
402         .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
403           ? ' AS col'.$self->{rownum_hack_count}++
404           : '')
405       } @$fields);
406   }
407   elsif ($ref eq 'HASH') {
408     my %hash = %$fields;
409     my ($select, $as);
410
411     if ($hash{-select}) {
412       $select = $self->_recurse_fields (delete $hash{-select});
413       $as = $self->_quote (delete $hash{-as});
414     }
415     else {
416       my ($func, $args) = each %hash;
417       delete $hash{$func};
418
419       if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
420         croak (
421           'The select => { distinct => ... } syntax is not supported for multiple columns.'
422          .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
423          .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
424         );
425       }
426       $select = sprintf ('%s( %s )',
427         $self->_sqlcase($func),
428         $self->_recurse_fields($args)
429       );
430     }
431
432     # there should be nothing left
433     if (keys %hash) {
434       croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
435     }
436
437     $select .= " AS $as" if $as;
438     return $select;
439   }
440   # Is the second check absolutely necessary?
441   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
442     return $self->_fold_sqlbind( $fields );
443   }
444   else {
445     croak($ref . qq{ unexpected in _recurse_fields()})
446   }
447 }
448
449 sub _order_by {
450   my ($self, $arg) = @_;
451
452   if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
453
454     my $ret = '';
455
456     if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
457       $ret = $self->_sqlcase(' group by ') . $g;
458     }
459
460     if (defined $arg->{having}) {
461       my ($frag, @bind) = $self->_recurse_where($arg->{having});
462       push(@{$self->{having_bind}}, @bind);
463       $ret .= $self->_sqlcase(' having ').$frag;
464     }
465
466     if (defined $arg->{order_by}) {
467       my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
468       push(@{$self->{order_bind}}, @bind);
469       $ret .= $frag;
470     }
471
472     return $ret;
473   }
474   else {
475     my ($sql, @bind) = $self->SUPER::_order_by ($arg);
476     push(@{$self->{order_bind}}, @bind);
477     return $sql;
478   }
479 }
480
481 sub _order_directions {
482   my ($self, $order) = @_;
483
484   # strip bind values - none of the current _order_directions users support them
485   return $self->SUPER::_order_directions( [ map
486     { ref $_ ? $_->[0] : $_ }
487     $self->_order_by_chunks ($order)
488   ]);
489 }
490
491 sub _table {
492   my ($self, $from) = @_;
493   if (ref $from eq 'ARRAY') {
494     return $self->_recurse_from(@$from);
495   } elsif (ref $from eq 'HASH') {
496     return $self->_make_as($from);
497   } else {
498     return $from; # would love to quote here but _table ends up getting called
499                   # twice during an ->select without a limit clause due to
500                   # the way S::A::Limit->select works. should maybe consider
501                   # bypassing this and doing S::A::select($self, ...) in
502                   # our select method above. meantime, quoting shims have
503                   # been added to select/insert/update/delete here
504   }
505 }
506
507 sub _recurse_from {
508   my ($self, $from, @join) = @_;
509   my @sqlf;
510   push(@sqlf, $self->_make_as($from));
511   foreach my $j (@join) {
512     my ($to, $on) = @$j;
513
514     # check whether a join type exists
515     my $join_clause = '';
516     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
517     if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
518       $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
519     } else {
520       $join_clause = ' JOIN ';
521     }
522     push(@sqlf, $join_clause);
523
524     if (ref $to eq 'ARRAY') {
525       push(@sqlf, '(', $self->_recurse_from(@$to), ')');
526     } else {
527       push(@sqlf, $self->_make_as($to));
528     }
529     push(@sqlf, ' ON ', $self->_join_condition($on));
530   }
531   return join('', @sqlf);
532 }
533
534 sub _fold_sqlbind {
535   my ($self, $sqlbind) = @_;
536
537   my @sqlbind = @$$sqlbind; # copy
538   my $sql = shift @sqlbind;
539   push @{$self->{from_bind}}, @sqlbind;
540
541   return $sql;
542 }
543
544 sub _make_as {
545   my ($self, $from) = @_;
546   return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
547                         : ref $_ eq 'REF'    ? $self->_fold_sqlbind($_)
548                         : $self->_quote($_))
549                        } reverse each %{$self->_skip_options($from)});
550 }
551
552 sub _skip_options {
553   my ($self, $hash) = @_;
554   my $clean_hash = {};
555   $clean_hash->{$_} = $hash->{$_}
556     for grep {!/^-/} keys %$hash;
557   return $clean_hash;
558 }
559
560 sub _join_condition {
561   my ($self, $cond) = @_;
562   if (ref $cond eq 'HASH') {
563     my %j;
564     for (keys %$cond) {
565       my $v = $cond->{$_};
566       if (ref $v) {
567         croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
568             if ref($v) ne 'SCALAR';
569         $j{$_} = $v;
570       }
571       else {
572         my $x = '= '.$self->_quote($v); $j{$_} = \$x;
573       }
574     };
575     return scalar($self->_recurse_where(\%j));
576   } elsif (ref $cond eq 'ARRAY') {
577     return join(' OR ', map { $self->_join_condition($_) } @$cond);
578   } else {
579     die "Can't handle this yet!";
580   }
581 }
582
583 sub _quote {
584   my ($self, $label) = @_;
585   return '' unless defined $label;
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;