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/) {
15 my $orig = \&{"SQL::Abstract::$f"};
16 *{"SQL::Abstract::$f"} = sub {
18 local $Carp::CarpLevel = 1; # even though Carp::Clan ignores this, $orig will not
20 if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+\(\) called/) {
21 __PACKAGE__->can($f)->(@_);
31 my $self = shift->SUPER::new(@_);
33 # This prevents the caching of $dbh in S::A::L, I believe
34 # If limit_dialect is a ref (like a $dbh), go ahead and replace
35 # it with what it resolves to:
36 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
37 if ref $self->{limit_dialect};
43 # Some databases (sqlite) do not handle multiple parenthesis
44 # around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
45 # is interpreted as x IN 1 or something similar.
47 # Since we currently do not have access to the SQLA AST, resort
48 # to barbaric mutilation of any SQL supplied in literal form
50 sub _strip_outer_paren {
51 my ($self, $arg) = @_;
53 return $self->_SWITCH_refkind ($arg, {
55 $$arg->[0] = __strip_outer_paren ($$arg->[0]);
59 return \__strip_outer_paren( $$arg );
67 sub __strip_outer_paren {
70 if ($sql and not ref $sql) {
71 while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
80 my ($self, $lhs, $op, $rhs) = @_;
81 $rhs = $self->_strip_outer_paren ($rhs);
82 return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
85 sub _where_field_BETWEEN {
86 my ($self, $lhs, $op, $rhs) = @_;
87 $rhs = $self->_strip_outer_paren ($rhs);
88 return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
91 # Slow but ANSI standard Limit/Offset support. DB2 uses this
93 my ($self, $sql, $order, $rows, $offset ) = @_;
96 my $last = $rows + $offset - 1;
97 my ( $order_by ) = $self->_order_by( $order );
102 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
107 WHERE ROW_NUM BETWEEN $offset AND $last
114 # Crappy Top based Limit/Offset support. MSSQL uses this currently,
115 # but may have to switch to RowNumberOver one day
117 my ( $self, $sql, $order, $rows, $offset ) = @_;
119 # mangle the input sql so it can be properly aliased in the outer queries
120 $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix
121 or croak "Unrecognizable SELECT: $sql";
123 my @sql_select = split (/\s*,\s*/, $sql_select);
125 # we can't support subqueries (in fact MSSQL can't) - croak
126 if (@sql_select != @{$self->{_dbic_rs_attrs}{select}}) {
128 'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while '
129 . 'the resultset select attribure contains %d elements: %s',
131 scalar @{$self->{_dbic_rs_attrs}{select}},
136 my $name_sep = $self->name_sep || '.';
137 $name_sep = "\Q$name_sep\E";
138 my $col_re = qr/ ^ (?: (.+) $name_sep )? ([^$name_sep]+) $ /x;
140 # construct the new select lists, rename(alias) some columns if necessary
141 my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
143 for (@{$self->{_dbic_rs_attrs}{select}}) {
145 my ($table, $orig_colname) = ( $_ =~ $col_re );
147 $seen_names{$orig_colname}++;
150 for my $i (0 .. $#sql_select) {
152 my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i];
153 my $colsel_sql = $sql_select[$i];
155 # this may or may not work (in case of a scalarref or something)
156 my ($table, $orig_colname) = ( $colsel_arg =~ $col_re );
159 # do not attempt to understand non-scalar selects - alias numerically
160 if (ref $colsel_arg) {
161 $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) );
163 # column name seen more than once - alias it
164 elsif ($orig_colname && ($seen_names{$orig_colname} > 1) ) {
165 $quoted_alias = $self->_quote ("${table}__${orig_colname}");
168 # we did rename - make a record and adjust
171 push @inner_select, "$colsel_sql AS $quoted_alias";
173 # push alias to outer
174 push @outer_select, $quoted_alias;
176 # Any aliasing accumulated here will be considered
177 # both for inner and outer adjustments of ORDER BY
178 $self->__record_alias (
182 $table ? $orig_colname : undef,
186 # otherwise just leave things intact inside, and use the abbreviated one outside
187 # (as we do not have table names anymore)
189 push @inner_select, $colsel_sql;
191 my $outer_quoted = $self->_quote ($orig_colname); # it was not a duplicate so should just work
192 push @outer_select, $outer_quoted;
193 $self->__record_alias (
197 $table ? $orig_colname : undef,
202 my $outer_select = join (', ', @outer_select );
203 my $inner_select = join (', ', @inner_select );
205 %outer_col_aliases = (%outer_col_aliases, %col_aliases);
208 croak '$order supplied to SQLAHacks limit emulators must be a hash'
209 if (ref $order ne 'HASH');
211 $order = { %$order }; #copy
213 my $req_order = [ $self->_order_by_chunks ($order->{order_by}) ];
214 my $limit_order = [ @$req_order ? @$req_order : $self->_order_by_chunks ($order->{_virtual_order_by}) ];
216 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
217 my $order_by_requested = $self->_order_by ($req_order);
219 # we can't really adjust the order_by columns, as introspection is lacking
220 # resort to simple substitution
221 for my $col (keys %outer_col_aliases) {
222 for ($order_by_requested, $order_by_outer) {
223 $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
226 for my $col (keys %col_aliases) {
227 $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g;
232 delete $order->{$_} for qw/order_by _virtual_order_by/;
233 my $grpby_having = $self->_order_by ($order);
236 my $inner_lim = $rows + $offset;
238 $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
243 SELECT TOP $rows $outer_select FROM
252 if ($order_by_requested) {
255 SELECT $outer_select FROM
256 ( $sql ) AS outer_sel
265 # action at a distance to shorten Top code above
267 my ($self, $register, $alias, $fqcol, $col) = @_;
269 # record qualified name
270 $register->{$fqcol} = $alias;
271 $register->{$self->_quote($fqcol)} = $alias;
275 # record unqialified name, undef (no adjustment) if a duplicate is found
276 if (exists $register->{$col}) {
277 $register->{$col} = undef;
280 $register->{$col} = $alias;
283 $register->{$self->_quote($col)} = $register->{$col};
288 # While we're at it, this should make LIMIT queries more efficient,
289 # without digging into things too deeply
291 my ($self, $syntax) = @_;
292 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
296 update => 'FOR UPDATE',
297 shared => 'FOR SHARE',
300 my ($self, $table, $fields, $where, $order, @rest) = @_;
302 $self->{"${_}_bind"} = [] for (qw/having from order/);
304 if (ref $table eq 'SCALAR') {
307 elsif (not ref $table) {
308 $table = $self->_quote($table);
310 local $self->{rownum_hack_count} = 1
311 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
312 @rest = (-1) unless defined $rest[0];
313 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
314 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
315 my ($sql, @where_bind) = $self->SUPER::select(
316 $table, $self->_recurse_fields($fields), $where, $order, @rest
318 if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
319 $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
322 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
328 $table = $self->_quote($table) unless ref($table);
330 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
331 # which is sadly understood only by MySQL. Change default behavior here,
332 # until SQLA2 comes with proper dialect support
333 if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
334 return "INSERT INTO ${table} DEFAULT VALUES"
337 $self->SUPER::insert($table, @_);
343 $table = $self->_quote($table) unless ref($table);
344 $self->SUPER::update($table, @_);
350 $table = $self->_quote($table) unless ref($table);
351 $self->SUPER::delete($table, @_);
357 return $_[1].$self->_order_by($_[2]);
359 return $self->SUPER::_emulate_limit(@_);
363 sub _recurse_fields {
364 my ($self, $fields, $params) = @_;
365 my $ref = ref $fields;
366 return $self->_quote($fields) unless $ref;
367 return $$fields if $ref eq 'SCALAR';
369 if ($ref eq 'ARRAY') {
370 return join(', ', map {
371 $self->_recurse_fields($_)
372 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
373 ? ' AS col'.$self->{rownum_hack_count}++
376 } elsif ($ref eq 'HASH') {
377 foreach my $func (keys %$fields) {
378 if ($func eq 'distinct') {
379 my $_fields = $fields->{$func};
380 if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
382 'The select => { distinct => ... } syntax is not supported for multiple columns.'
383 .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
384 .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
388 $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
390 'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
391 ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
395 return $self->_sqlcase($func)
396 .'( '.$self->_recurse_fields($fields->{$func}).' )';
399 # Is the second check absolutely necessary?
400 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
401 return $self->_fold_sqlbind( $fields );
404 croak($ref . qq{ unexpected in _recurse_fields()})
409 my ($self, $arg) = @_;
411 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
415 if (defined $arg->{group_by}) {
416 $ret = $self->_sqlcase(' group by ')
417 .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
420 if (defined $arg->{having}) {
421 my ($frag, @bind) = $self->_recurse_where($arg->{having});
422 push(@{$self->{having_bind}}, @bind);
423 $ret .= $self->_sqlcase(' having ').$frag;
426 if (defined $arg->{order_by}) {
427 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
428 push(@{$self->{order_bind}}, @bind);
435 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
436 push(@{$self->{order_bind}}, @bind);
441 sub _order_directions {
442 my ($self, $order) = @_;
444 # strip bind values - none of the current _order_directions users support them
445 return $self->SUPER::_order_directions( [ map
446 { ref $_ ? $_->[0] : $_ }
447 $self->_order_by_chunks ($order)
452 my ($self, $from) = @_;
453 if (ref $from eq 'ARRAY') {
454 return $self->_recurse_from(@$from);
455 } elsif (ref $from eq 'HASH') {
456 return $self->_make_as($from);
458 return $from; # would love to quote here but _table ends up getting called
459 # twice during an ->select without a limit clause due to
460 # the way S::A::Limit->select works. should maybe consider
461 # bypassing this and doing S::A::select($self, ...) in
462 # our select method above. meantime, quoting shims have
463 # been added to select/insert/update/delete here
468 my ($self, $from, @join) = @_;
470 push(@sqlf, $self->_make_as($from));
471 foreach my $j (@join) {
474 # check whether a join type exists
475 my $join_clause = '';
476 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
477 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
478 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
480 $join_clause = ' JOIN ';
482 push(@sqlf, $join_clause);
484 if (ref $to eq 'ARRAY') {
485 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
487 push(@sqlf, $self->_make_as($to));
489 push(@sqlf, ' ON ', $self->_join_condition($on));
491 return join('', @sqlf);
495 my ($self, $sqlbind) = @_;
497 my @sqlbind = @$$sqlbind; # copy
498 my $sql = shift @sqlbind;
499 push @{$self->{from_bind}}, @sqlbind;
505 my ($self, $from) = @_;
506 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
507 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
509 } reverse each %{$self->_skip_options($from)});
513 my ($self, $hash) = @_;
515 $clean_hash->{$_} = $hash->{$_}
516 for grep {!/^-/} keys %$hash;
520 sub _join_condition {
521 my ($self, $cond) = @_;
522 if (ref $cond eq 'HASH') {
527 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
528 if ref($v) ne 'SCALAR';
532 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
535 return scalar($self->_recurse_where(\%j));
536 } elsif (ref $cond eq 'ARRAY') {
537 return join(' OR ', map { $self->_join_condition($_) } @$cond);
539 die "Can't handle this yet!";
544 my ($self, $label) = @_;
545 return '' unless defined $label;
546 return "*" if $label eq '*';
547 return $label unless $self->{quote_char};
548 if(ref $self->{quote_char} eq "ARRAY"){
549 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
550 if !defined $self->{name_sep};
551 my $sep = $self->{name_sep};
552 return join($self->{name_sep},
553 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
554 split(/\Q$sep\E/,$label));
556 return $self->SUPER::_quote($label);
561 $self->{limit_dialect} = shift if @_;
562 return $self->{limit_dialect};
567 $self->{quote_char} = shift if @_;
568 return $self->{quote_char};
573 $self->{name_sep} = shift if @_;
574 return $self->{name_sep};
585 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
586 and includes a number of DBIC-specific workarounds, not yet suitable for
587 inclusion into SQLA proper.
593 Tries to determine limit dialect.
597 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
598 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
600 =head2 insert update delete
602 Just quotes table names.
606 Specifies the dialect of used for implementing an SQL "limit" clause for
607 restricting the number of query results returned. Valid values are: RowNum.
609 See L<DBIx::Class::Storage::DBI/connect_info> for details.
613 Character separating quoted table names.
615 See L<DBIx::Class::Storage::DBI/connect_info> for details.
619 Set to an array-ref to specify separate left and right quotes for table names.
621 See L<DBIx::Class::Storage::DBI/connect_info> for details.