1 package # Hide from PAUSE
2 DBIx::Class::SQLAHacks;
4 use base qw/SQL::Abstract::Limit/;
7 use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
10 # reinstall the carp()/croak() functions imported into SQL::Abstract
11 # as Carp and Carp::Clan do not like each other much
12 no warnings qw/redefine/;
14 for my $f (qw/carp croak/) {
16 my $orig = \&{"SQL::Abstract::$f"};
17 *{"SQL::Abstract::$f"} = sub {
19 local $Carp::CarpLevel = 1; # even though Carp::Clan ignores this, $orig will not
21 if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
22 __PACKAGE__->can($f)->(@_);
32 my $self = shift->SUPER::new(@_);
34 # This prevents the caching of $dbh in S::A::L, I believe
35 # If limit_dialect is a ref (like a $dbh), go ahead and replace
36 # it with what it resolves to:
37 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
38 if ref $self->{limit_dialect};
44 # Some databases (sqlite) do not handle multiple parenthesis
45 # around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
46 # is interpreted as x IN 1 or something similar.
48 # Since we currently do not have access to the SQLA AST, resort
49 # to barbaric mutilation of any SQL supplied in literal form
51 sub _strip_outer_paren {
52 my ($self, $arg) = @_;
54 return $self->_SWITCH_refkind ($arg, {
56 $$arg->[0] = __strip_outer_paren ($$arg->[0]);
60 return \__strip_outer_paren( $$arg );
68 sub __strip_outer_paren {
71 if ($sql and not ref $sql) {
72 while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
81 my ($self, $lhs, $op, $rhs) = @_;
82 $rhs = $self->_strip_outer_paren ($rhs);
83 return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
86 sub _where_field_BETWEEN {
87 my ($self, $lhs, $op, $rhs) = @_;
88 $rhs = $self->_strip_outer_paren ($rhs);
89 return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
92 # Slow but ANSI standard Limit/Offset support. DB2 uses this
94 my ($self, $sql, $order, $rows, $offset ) = @_;
97 my $last = $rows + $offset - 1;
98 my ( $order_by ) = $self->_order_by( $order );
103 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
108 WHERE ROW_NUM BETWEEN $offset AND $last
115 # Crappy Top based Limit/Offset support. MSSQL uses this currently,
116 # but may have to switch to RowNumberOver one day
118 my ( $self, $sql, $order, $rows, $offset ) = @_;
120 # mangle the input sql so it can be properly aliased in the outer queries
121 $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix
122 or croak "Unrecognizable SELECT: $sql";
124 my @sql_select = split (/\s*,\s*/, $sql_select);
126 # we can't support subqueries (in fact MSSQL can't) - croak
127 if (@sql_select != @{$self->{_dbic_rs_attrs}{select}}) {
129 'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while '
130 . 'the resultset select attribure contains %d elements: %s',
132 scalar @{$self->{_dbic_rs_attrs}{select}},
137 my $name_sep = $self->name_sep || '.';
138 $name_sep = "\Q$name_sep\E";
139 my $col_re = qr/ ^ (?: (.+) $name_sep )? ([^$name_sep]+) $ /x;
141 # construct the new select lists, rename(alias) some columns if necessary
142 my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
144 for (@{$self->{_dbic_rs_attrs}{select}}) {
146 my ($table, $orig_colname) = ( $_ =~ $col_re );
148 $seen_names{$orig_colname}++;
151 for my $i (0 .. $#sql_select) {
153 my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i];
154 my $colsel_sql = $sql_select[$i];
156 # this may or may not work (in case of a scalarref or something)
157 my ($table, $orig_colname) = ( $colsel_arg =~ $col_re );
160 # do not attempt to understand non-scalar selects - alias numerically
161 if (ref $colsel_arg) {
162 $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) );
164 # column name seen more than once - alias it
165 elsif ($orig_colname && ($seen_names{$orig_colname} > 1) ) {
166 $quoted_alias = $self->_quote ("${table}__${orig_colname}");
169 # we did rename - make a record and adjust
172 push @inner_select, "$colsel_sql AS $quoted_alias";
174 # push alias to outer
175 push @outer_select, $quoted_alias;
177 # Any aliasing accumulated here will be considered
178 # both for inner and outer adjustments of ORDER BY
179 $self->__record_alias (
183 $table ? $orig_colname : undef,
187 # otherwise just leave things intact inside, and use the abbreviated one outside
188 # (as we do not have table names anymore)
190 push @inner_select, $colsel_sql;
192 my $outer_quoted = $self->_quote ($orig_colname); # it was not a duplicate so should just work
193 push @outer_select, $outer_quoted;
194 $self->__record_alias (
198 $table ? $orig_colname : undef,
203 my $outer_select = join (', ', @outer_select );
204 my $inner_select = join (', ', @inner_select );
206 %outer_col_aliases = (%outer_col_aliases, %col_aliases);
209 croak '$order supplied to SQLAHacks limit emulators must be a hash'
210 if (ref $order ne 'HASH');
212 $order = { %$order }; #copy
214 my $req_order = $order->{order_by};
216 scalar $self->_order_by_chunks ($req_order) # examine normalized version, collapses nesting
218 : $order->{_virtual_order_by}
221 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
222 my $order_by_requested = $self->_order_by ($req_order);
225 delete $order->{$_} for qw/order_by _virtual_order_by/;
226 my $grpby_having = $self->_order_by ($order);
228 # short circuit for counts - the ordering complexity is needless
229 if ($self->{_dbic_rs_attrs}{-for_count_only}) {
230 return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
233 # we can't really adjust the order_by columns, as introspection is lacking
234 # resort to simple substitution
235 for my $col (keys %outer_col_aliases) {
236 for ($order_by_requested, $order_by_outer) {
237 $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
240 for my $col (keys %col_aliases) {
241 $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g;
245 my $inner_lim = $rows + $offset;
247 $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
252 SELECT TOP $rows $outer_select FROM
261 if ($order_by_requested) {
264 SELECT $outer_select FROM
274 # action at a distance to shorten Top code above
276 my ($self, $register, $alias, $fqcol, $col) = @_;
278 # record qualified name
279 $register->{$fqcol} = $alias;
280 $register->{$self->_quote($fqcol)} = $alias;
284 # record unqualified name, undef (no adjustment) if a duplicate is found
285 if (exists $register->{$col}) {
286 $register->{$col} = undef;
289 $register->{$col} = $alias;
292 $register->{$self->_quote($col)} = $register->{$col};
297 # While we're at it, this should make LIMIT queries more efficient,
298 # without digging into things too deeply
300 my ($self, $syntax) = @_;
301 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
305 update => 'FOR UPDATE',
306 shared => 'FOR SHARE',
309 my ($self, $table, $fields, $where, $order, @rest) = @_;
311 $self->{"${_}_bind"} = [] for (qw/having from order/);
313 if (ref $table eq 'SCALAR') {
316 elsif (not ref $table) {
317 $table = $self->_quote($table);
319 local $self->{rownum_hack_count} = 1
320 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
321 @rest = (-1) unless defined $rest[0];
322 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
323 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
324 my ($sql, @where_bind) = $self->SUPER::select(
325 $table, $self->_recurse_fields($fields), $where, $order, @rest
327 if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
328 $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
331 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
337 $table = $self->_quote($table) unless ref($table);
339 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
340 # which is sadly understood only by MySQL. Change default behavior here,
341 # until SQLA2 comes with proper dialect support
342 if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
343 return "INSERT INTO ${table} DEFAULT VALUES"
346 $self->SUPER::insert($table, @_);
352 $table = $self->_quote($table) unless ref($table);
353 $self->SUPER::update($table, @_);
359 $table = $self->_quote($table) unless ref($table);
360 $self->SUPER::delete($table, @_);
366 return $_[1].$self->_order_by($_[2]);
368 return $self->SUPER::_emulate_limit(@_);
372 sub _recurse_fields {
373 my ($self, $fields, $params) = @_;
374 my $ref = ref $fields;
375 return $self->_quote($fields) unless $ref;
376 return $$fields if $ref eq 'SCALAR';
378 if ($ref eq 'ARRAY') {
379 return join(', ', map {
380 $self->_recurse_fields($_)
381 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
382 ? ' AS col'.$self->{rownum_hack_count}++
386 elsif ($ref eq 'HASH') {
390 if ($hash{-select}) {
391 $select = $self->_recurse_fields (delete $hash{-select});
392 $as = $self->_quote (delete $hash{-as});
395 my ($func, $args) = each %hash;
398 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
400 'The select => { distinct => ... } syntax is not supported for multiple columns.'
401 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
402 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
405 $select = sprintf ('%s( %s )',
406 $self->_sqlcase($func),
407 $self->_recurse_fields($args)
411 # there should be nothing left
413 croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
416 $select .= " AS $as" if $as;
419 # Is the second check absolutely necessary?
420 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
421 return $self->_fold_sqlbind( $fields );
424 croak($ref . qq{ unexpected in _recurse_fields()})
429 my ($self, $arg) = @_;
431 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
435 if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
436 $ret = $self->_sqlcase(' group by ') . $g;
439 if (defined $arg->{having}) {
440 my ($frag, @bind) = $self->_recurse_where($arg->{having});
441 push(@{$self->{having_bind}}, @bind);
442 $ret .= $self->_sqlcase(' having ').$frag;
445 if (defined $arg->{order_by}) {
446 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
447 push(@{$self->{order_bind}}, @bind);
454 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
455 push(@{$self->{order_bind}}, @bind);
460 sub _order_directions {
461 my ($self, $order) = @_;
463 # strip bind values - none of the current _order_directions users support them
464 return $self->SUPER::_order_directions( [ map
465 { ref $_ ? $_->[0] : $_ }
466 $self->_order_by_chunks ($order)
471 my ($self, $from) = @_;
472 if (ref $from eq 'ARRAY') {
473 return $self->_recurse_from(@$from);
474 } elsif (ref $from eq 'HASH') {
475 return $self->_make_as($from);
477 return $from; # would love to quote here but _table ends up getting called
478 # twice during an ->select without a limit clause due to
479 # the way S::A::Limit->select works. should maybe consider
480 # bypassing this and doing S::A::select($self, ...) in
481 # our select method above. meantime, quoting shims have
482 # been added to select/insert/update/delete here
487 my ($self, $from, @join) = @_;
489 push(@sqlf, $self->_make_as($from));
490 foreach my $j (@join) {
493 # check whether a join type exists
494 my $join_clause = '';
495 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
496 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
497 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
499 $join_clause = ' JOIN ';
501 push(@sqlf, $join_clause);
503 if (ref $to eq 'ARRAY') {
504 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
506 push(@sqlf, $self->_make_as($to));
508 push(@sqlf, ' ON ', $self->_join_condition($on));
510 return join('', @sqlf);
514 my ($self, $sqlbind) = @_;
516 my @sqlbind = @$$sqlbind; # copy
517 my $sql = shift @sqlbind;
518 push @{$self->{from_bind}}, @sqlbind;
524 my ($self, $from) = @_;
525 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
526 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
528 } reverse each %{$self->_skip_options($from)});
532 my ($self, $hash) = @_;
534 $clean_hash->{$_} = $hash->{$_}
535 for grep {!/^-/} keys %$hash;
539 sub _join_condition {
540 my ($self, $cond) = @_;
541 if (ref $cond eq 'HASH') {
546 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
547 if ref($v) ne 'SCALAR';
551 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
554 return scalar($self->_recurse_where(\%j));
555 } elsif (ref $cond eq 'ARRAY') {
556 return join(' OR ', map { $self->_join_condition($_) } @$cond);
558 die "Can't handle this yet!";
563 my ($self, $label) = @_;
564 return '' unless defined $label;
565 return "*" if $label eq '*';
566 return $label unless $self->{quote_char};
567 if(ref $self->{quote_char} eq "ARRAY"){
568 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
569 if !defined $self->{name_sep};
570 my $sep = $self->{name_sep};
571 return join($self->{name_sep},
572 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
573 split(/\Q$sep\E/,$label));
575 return $self->SUPER::_quote($label);
580 $self->{limit_dialect} = shift if @_;
581 return $self->{limit_dialect};
586 $self->{quote_char} = shift if @_;
587 return $self->{quote_char};
592 $self->{name_sep} = shift if @_;
593 return $self->{name_sep};
604 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
605 and includes a number of DBIC-specific workarounds, not yet suitable for
606 inclusion into SQLA proper.
612 Tries to determine limit dialect.
616 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
617 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
619 =head2 insert update delete
621 Just quotes table names.
625 Specifies the dialect of used for implementing an SQL "limit" clause for
626 restricting the number of query results returned. Valid values are: RowNum.
628 See L<DBIx::Class::Storage::DBI/connect_info> for details.
632 Character separating quoted table names.
634 See L<DBIx::Class::Storage::DBI/connect_info> for details.
638 Set to an array-ref to specify separate left and right quotes for table names.
640 See L<DBIx::Class::Storage::DBI/connect_info> for details.