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 = $order->{order_by};
215 scalar $self->_order_by_chunks ($req_order) # exaime normalized version, collapses nesting
217 : $order->{_virtual_order_by}
220 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
221 my $order_by_requested = $self->_order_by ($req_order);
224 delete $order->{$_} for qw/order_by _virtual_order_by/;
225 my $grpby_having = $self->_order_by ($order);
227 # short circuit for counts - the ordering complexity is needless
228 if ($self->{_dbic_rs_attrs}{-for_count_only}) {
229 return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
232 # we can't really adjust the order_by columns, as introspection is lacking
233 # resort to simple substitution
234 for my $col (keys %outer_col_aliases) {
235 for ($order_by_requested, $order_by_outer) {
236 $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
239 for my $col (keys %col_aliases) {
240 $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g;
244 my $inner_lim = $rows + $offset;
246 $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
251 SELECT TOP $rows $outer_select FROM
260 if ($order_by_requested) {
263 SELECT $outer_select FROM
273 # action at a distance to shorten Top code above
275 my ($self, $register, $alias, $fqcol, $col) = @_;
277 # record qualified name
278 $register->{$fqcol} = $alias;
279 $register->{$self->_quote($fqcol)} = $alias;
283 # record unqialified name, undef (no adjustment) if a duplicate is found
284 if (exists $register->{$col}) {
285 $register->{$col} = undef;
288 $register->{$col} = $alias;
291 $register->{$self->_quote($col)} = $register->{$col};
296 # While we're at it, this should make LIMIT queries more efficient,
297 # without digging into things too deeply
299 my ($self, $syntax) = @_;
300 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
304 update => 'FOR UPDATE',
305 shared => 'FOR SHARE',
308 my ($self, $table, $fields, $where, $order, @rest) = @_;
310 $self->{"${_}_bind"} = [] for (qw/having from order/);
312 if (ref $table eq 'SCALAR') {
315 elsif (not ref $table) {
316 $table = $self->_quote($table);
318 local $self->{rownum_hack_count} = 1
319 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
320 @rest = (-1) unless defined $rest[0];
321 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
322 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
323 my ($sql, @where_bind) = $self->SUPER::select(
324 $table, $self->_recurse_fields($fields), $where, $order, @rest
326 if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
327 $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
330 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
336 $table = $self->_quote($table) unless ref($table);
338 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
339 # which is sadly understood only by MySQL. Change default behavior here,
340 # until SQLA2 comes with proper dialect support
341 if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
342 return "INSERT INTO ${table} DEFAULT VALUES"
345 $self->SUPER::insert($table, @_);
351 $table = $self->_quote($table) unless ref($table);
352 $self->SUPER::update($table, @_);
358 $table = $self->_quote($table) unless ref($table);
359 $self->SUPER::delete($table, @_);
365 return $_[1].$self->_order_by($_[2]);
367 return $self->SUPER::_emulate_limit(@_);
371 sub _recurse_fields {
372 my ($self, $fields, $params) = @_;
373 my $ref = ref $fields;
374 return $self->_quote($fields) unless $ref;
375 return $$fields if $ref eq 'SCALAR';
377 if ($ref eq 'ARRAY') {
378 return join(', ', map {
379 $self->_recurse_fields($_)
380 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
381 ? ' AS col'.$self->{rownum_hack_count}++
384 } elsif ($ref eq 'HASH') {
385 foreach my $func (keys %$fields) {
386 if ($func eq 'distinct') {
387 my $_fields = $fields->{$func};
388 if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
390 'The select => { distinct => ... } syntax is not supported for multiple columns.'
391 .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
392 .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
396 $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
398 'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
399 ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
403 return $self->_sqlcase($func)
404 .'( '.$self->_recurse_fields($fields->{$func}).' )';
407 # Is the second check absolutely necessary?
408 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
409 return $self->_fold_sqlbind( $fields );
412 croak($ref . qq{ unexpected in _recurse_fields()})
417 my ($self, $arg) = @_;
419 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
423 if (defined $arg->{group_by}) {
424 $ret = $self->_sqlcase(' group by ')
425 .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
428 if (defined $arg->{having}) {
429 my ($frag, @bind) = $self->_recurse_where($arg->{having});
430 push(@{$self->{having_bind}}, @bind);
431 $ret .= $self->_sqlcase(' having ').$frag;
434 if (defined $arg->{order_by}) {
435 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
436 push(@{$self->{order_bind}}, @bind);
443 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
444 push(@{$self->{order_bind}}, @bind);
449 sub _order_directions {
450 my ($self, $order) = @_;
452 # strip bind values - none of the current _order_directions users support them
453 return $self->SUPER::_order_directions( [ map
454 { ref $_ ? $_->[0] : $_ }
455 $self->_order_by_chunks ($order)
460 my ($self, $from) = @_;
461 if (ref $from eq 'ARRAY') {
462 return $self->_recurse_from(@$from);
463 } elsif (ref $from eq 'HASH') {
464 return $self->_make_as($from);
466 return $from; # would love to quote here but _table ends up getting called
467 # twice during an ->select without a limit clause due to
468 # the way S::A::Limit->select works. should maybe consider
469 # bypassing this and doing S::A::select($self, ...) in
470 # our select method above. meantime, quoting shims have
471 # been added to select/insert/update/delete here
476 my ($self, $from, @join) = @_;
478 push(@sqlf, $self->_make_as($from));
479 foreach my $j (@join) {
482 # check whether a join type exists
483 my $join_clause = '';
484 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
485 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
486 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
488 $join_clause = ' JOIN ';
490 push(@sqlf, $join_clause);
492 if (ref $to eq 'ARRAY') {
493 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
495 push(@sqlf, $self->_make_as($to));
497 push(@sqlf, ' ON ', $self->_join_condition($on));
499 return join('', @sqlf);
503 my ($self, $sqlbind) = @_;
505 my @sqlbind = @$$sqlbind; # copy
506 my $sql = shift @sqlbind;
507 push @{$self->{from_bind}}, @sqlbind;
513 my ($self, $from) = @_;
514 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
515 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
517 } reverse each %{$self->_skip_options($from)});
521 my ($self, $hash) = @_;
523 $clean_hash->{$_} = $hash->{$_}
524 for grep {!/^-/} keys %$hash;
528 sub _join_condition {
529 my ($self, $cond) = @_;
530 if (ref $cond eq 'HASH') {
535 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
536 if ref($v) ne 'SCALAR';
540 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
543 return scalar($self->_recurse_where(\%j));
544 } elsif (ref $cond eq 'ARRAY') {
545 return join(' OR ', map { $self->_join_condition($_) } @$cond);
547 die "Can't handle this yet!";
552 my ($self, $label) = @_;
553 return '' unless defined $label;
554 return "*" if $label eq '*';
555 return $label unless $self->{quote_char};
556 if(ref $self->{quote_char} eq "ARRAY"){
557 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
558 if !defined $self->{name_sep};
559 my $sep = $self->{name_sep};
560 return join($self->{name_sep},
561 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
562 split(/\Q$sep\E/,$label));
564 return $self->SUPER::_quote($label);
569 $self->{limit_dialect} = shift if @_;
570 return $self->{limit_dialect};
575 $self->{quote_char} = shift if @_;
576 return $self->{quote_char};
581 $self->{name_sep} = shift if @_;
582 return $self->{name_sep};
593 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
594 and includes a number of DBIC-specific workarounds, not yet suitable for
595 inclusion into SQLA proper.
601 Tries to determine limit dialect.
605 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
606 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
608 =head2 insert update delete
610 Just quotes table names.
614 Specifies the dialect of used for implementing an SQL "limit" clause for
615 restricting the number of query results returned. Valid values are: RowNum.
617 See L<DBIx::Class::Storage::DBI/connect_info> for details.
621 Character separating quoted table names.
623 See L<DBIx::Class::Storage::DBI/connect_info> for details.
627 Set to an array-ref to specify separate left and right quotes for table names.
629 See L<DBIx::Class::Storage::DBI/connect_info> for details.