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}++
385 } elsif ($ref eq 'HASH') {
386 foreach my $func (keys %$fields) {
387 if ($func eq 'distinct') {
388 my $_fields = $fields->{$func};
389 if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
391 'The select => { distinct => ... } syntax is not supported for multiple columns.'
392 .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
393 .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
397 $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
399 'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
400 ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
404 return $self->_sqlcase($func)
405 .'( '.$self->_recurse_fields($fields->{$func}).' )';
408 # Is the second check absolutely necessary?
409 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
410 return $self->_fold_sqlbind( $fields );
413 croak($ref . qq{ unexpected in _recurse_fields()})
418 my ($self, $arg) = @_;
420 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
424 if (defined $arg->{group_by}) {
425 $ret = $self->_sqlcase(' group by ')
426 .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
429 if (defined $arg->{having}) {
430 my ($frag, @bind) = $self->_recurse_where($arg->{having});
431 push(@{$self->{having_bind}}, @bind);
432 $ret .= $self->_sqlcase(' having ').$frag;
435 if (defined $arg->{order_by}) {
436 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
437 push(@{$self->{order_bind}}, @bind);
444 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
445 push(@{$self->{order_bind}}, @bind);
450 sub _order_directions {
451 my ($self, $order) = @_;
453 # strip bind values - none of the current _order_directions users support them
454 return $self->SUPER::_order_directions( [ map
455 { ref $_ ? $_->[0] : $_ }
456 $self->_order_by_chunks ($order)
461 my ($self, $from) = @_;
462 if (ref $from eq 'ARRAY') {
463 return $self->_recurse_from(@$from);
464 } elsif (ref $from eq 'HASH') {
465 return $self->_make_as($from);
467 return $from; # would love to quote here but _table ends up getting called
468 # twice during an ->select without a limit clause due to
469 # the way S::A::Limit->select works. should maybe consider
470 # bypassing this and doing S::A::select($self, ...) in
471 # our select method above. meantime, quoting shims have
472 # been added to select/insert/update/delete here
477 my ($self, $from, @join) = @_;
479 push(@sqlf, $self->_make_as($from));
480 foreach my $j (@join) {
483 # check whether a join type exists
484 my $join_clause = '';
485 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
486 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
487 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
489 $join_clause = ' JOIN ';
491 push(@sqlf, $join_clause);
493 if (ref $to eq 'ARRAY') {
494 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
496 push(@sqlf, $self->_make_as($to));
498 push(@sqlf, ' ON ', $self->_join_condition($on));
500 return join('', @sqlf);
504 my ($self, $sqlbind) = @_;
506 my @sqlbind = @$$sqlbind; # copy
507 my $sql = shift @sqlbind;
508 push @{$self->{from_bind}}, @sqlbind;
514 my ($self, $from) = @_;
515 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
516 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
518 } reverse each %{$self->_skip_options($from)});
522 my ($self, $hash) = @_;
524 $clean_hash->{$_} = $hash->{$_}
525 for grep {!/^-/} keys %$hash;
529 sub _join_condition {
530 my ($self, $cond) = @_;
531 if (ref $cond eq 'HASH') {
536 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
537 if ref($v) ne 'SCALAR';
541 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
544 return scalar($self->_recurse_where(\%j));
545 } elsif (ref $cond eq 'ARRAY') {
546 return join(' OR ', map { $self->_join_condition($_) } @$cond);
548 die "Can't handle this yet!";
553 my ($self, $label) = @_;
554 return '' unless defined $label;
555 return "*" if $label eq '*';
556 return $label unless $self->{quote_char};
557 if(ref $self->{quote_char} eq "ARRAY"){
558 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
559 if !defined $self->{name_sep};
560 my $sep = $self->{name_sep};
561 return join($self->{name_sep},
562 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
563 split(/\Q$sep\E/,$label));
565 return $self->SUPER::_quote($label);
570 $self->{limit_dialect} = shift if @_;
571 return $self->{limit_dialect};
576 $self->{quote_char} = shift if @_;
577 return $self->{quote_char};
582 $self->{name_sep} = shift if @_;
583 return $self->{name_sep};
594 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
595 and includes a number of DBIC-specific workarounds, not yet suitable for
596 inclusion into SQLA proper.
602 Tries to determine limit dialect.
606 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
607 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
609 =head2 insert update delete
611 Just quotes table names.
615 Specifies the dialect of used for implementing an SQL "limit" clause for
616 restricting the number of query results returned. Valid values are: RowNum.
618 See L<DBIx::Class::Storage::DBI/connect_info> for details.
622 Character separating quoted table names.
624 See L<DBIx::Class::Storage::DBI/connect_info> for details.
628 Set to an array-ref to specify separate left and right quotes for table names.
630 See L<DBIx::Class::Storage::DBI/connect_info> for details.