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 my $esc_name_sep = "\Q$name_sep\E";
139 my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x;
141 my $rs_alias = $self->{_dbic_rs_attrs}{alias};
142 my $quoted_rs_alias = $self->_quote ($rs_alias);
144 # construct the new select lists, rename(alias) some columns if necessary
145 my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
147 for (@{$self->{_dbic_rs_attrs}{select}}) {
149 my ($table, $orig_colname) = ( $_ =~ $col_re );
151 $seen_names{$orig_colname}++;
154 for my $i (0 .. $#sql_select) {
156 my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i];
157 my $colsel_sql = $sql_select[$i];
159 # this may or may not work (in case of a scalarref or something)
160 my ($table, $orig_colname) = ( $colsel_arg =~ $col_re );
163 # do not attempt to understand non-scalar selects - alias numerically
164 if (ref $colsel_arg) {
165 $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) );
167 # column name seen more than once - alias it
168 elsif ($orig_colname && ($seen_names{$orig_colname} > 1) ) {
169 $quoted_alias = $self->_quote ("${table}__${orig_colname}");
172 # we did rename - make a record and adjust
175 push @inner_select, "$colsel_sql AS $quoted_alias";
177 # push alias to outer
178 push @outer_select, $quoted_alias;
180 # Any aliasing accumulated here will be considered
181 # both for inner and outer adjustments of ORDER BY
182 $self->__record_alias (
186 $table ? $orig_colname : undef,
190 # otherwise just leave things intact inside, and use the abbreviated one outside
191 # (as we do not have table names anymore)
193 push @inner_select, $colsel_sql;
195 my $outer_quoted = $self->_quote ($orig_colname); # it was not a duplicate so should just work
196 push @outer_select, $outer_quoted;
197 $self->__record_alias (
201 $table ? $orig_colname : undef,
206 my $outer_select = join (', ', @outer_select );
207 my $inner_select = join (', ', @inner_select );
209 %outer_col_aliases = (%outer_col_aliases, %col_aliases);
212 croak '$order supplied to SQLAHacks limit emulators must be a hash'
213 if (ref $order ne 'HASH');
215 $order = { %$order }; #copy
217 my $req_order = $order->{order_by};
219 # examine normalized version, collapses nesting
221 if (scalar $self->_order_by_chunks ($req_order)) {
222 $limit_order = $req_order;
226 { join ('', $rs_alias, $name_sep, $_ ) }
227 ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
231 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
232 my $order_by_requested = $self->_order_by ($req_order);
235 delete $order->{order_by};
236 my $grpby_having = $self->_order_by ($order);
238 # short circuit for counts - the ordering complexity is needless
239 if ($self->{_dbic_rs_attrs}{-for_count_only}) {
240 return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
243 # we can't really adjust the order_by columns, as introspection is lacking
244 # resort to simple substitution
245 for my $col (keys %outer_col_aliases) {
246 for ($order_by_requested, $order_by_outer) {
247 $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
250 for my $col (keys %col_aliases) {
251 $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g;
255 my $inner_lim = $rows + $offset;
257 $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
262 SELECT TOP $rows $outer_select FROM
271 if ($order_by_requested) {
274 SELECT $outer_select FROM
275 ( $sql ) $quoted_rs_alias
281 $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line
285 # action at a distance to shorten Top code above
287 my ($self, $register, $alias, $fqcol, $col) = @_;
289 # record qualified name
290 $register->{$fqcol} = $alias;
291 $register->{$self->_quote($fqcol)} = $alias;
295 # record unqualified name, undef (no adjustment) if a duplicate is found
296 if (exists $register->{$col}) {
297 $register->{$col} = undef;
300 $register->{$col} = $alias;
303 $register->{$self->_quote($col)} = $register->{$col};
308 # While we're at it, this should make LIMIT queries more efficient,
309 # without digging into things too deeply
311 my ($self, $syntax) = @_;
312 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
316 update => 'FOR UPDATE',
317 shared => 'FOR SHARE',
320 my ($self, $table, $fields, $where, $order, @rest) = @_;
322 $self->{"${_}_bind"} = [] for (qw/having from order/);
324 if (ref $table eq 'SCALAR') {
327 elsif (not ref $table) {
328 $table = $self->_quote($table);
330 local $self->{rownum_hack_count} = 1
331 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
332 @rest = (-1) unless defined $rest[0];
333 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
334 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
335 my ($sql, @where_bind) = $self->SUPER::select(
336 $table, $self->_recurse_fields($fields), $where, $order, @rest
338 if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
339 $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
342 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
348 $table = $self->_quote($table) unless ref($table);
350 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
351 # which is sadly understood only by MySQL. Change default behavior here,
352 # until SQLA2 comes with proper dialect support
353 if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
354 return "INSERT INTO ${table} DEFAULT VALUES"
357 $self->SUPER::insert($table, @_);
363 $table = $self->_quote($table) unless ref($table);
364 $self->SUPER::update($table, @_);
370 $table = $self->_quote($table) unless ref($table);
371 $self->SUPER::delete($table, @_);
377 return $_[1].$self->_order_by($_[2]);
379 return $self->SUPER::_emulate_limit(@_);
383 sub _recurse_fields {
384 my ($self, $fields, $params) = @_;
385 my $ref = ref $fields;
386 return $self->_quote($fields) unless $ref;
387 return $$fields if $ref eq 'SCALAR';
389 if ($ref eq 'ARRAY') {
390 return join(', ', map {
391 $self->_recurse_fields($_)
392 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
393 ? ' AS col'.$self->{rownum_hack_count}++
397 elsif ($ref eq 'HASH') {
401 if ($hash{-select}) {
402 $select = $self->_recurse_fields (delete $hash{-select});
403 $as = $self->_quote (delete $hash{-as});
406 my ($func, $args) = each %hash;
409 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
411 'The select => { distinct => ... } syntax is not supported for multiple columns.'
412 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
413 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
416 $select = sprintf ('%s( %s )',
417 $self->_sqlcase($func),
418 $self->_recurse_fields($args)
422 # there should be nothing left
424 croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
427 $select .= " AS $as" if $as;
430 # Is the second check absolutely necessary?
431 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
432 return $self->_fold_sqlbind( $fields );
435 croak($ref . qq{ unexpected in _recurse_fields()})
440 my ($self, $arg) = @_;
442 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
446 if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
447 $ret = $self->_sqlcase(' group by ') . $g;
450 if (defined $arg->{having}) {
451 my ($frag, @bind) = $self->_recurse_where($arg->{having});
452 push(@{$self->{having_bind}}, @bind);
453 $ret .= $self->_sqlcase(' having ').$frag;
456 if (defined $arg->{order_by}) {
457 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
458 push(@{$self->{order_bind}}, @bind);
465 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
466 push(@{$self->{order_bind}}, @bind);
471 sub _order_directions {
472 my ($self, $order) = @_;
474 # strip bind values - none of the current _order_directions users support them
475 return $self->SUPER::_order_directions( [ map
476 { ref $_ ? $_->[0] : $_ }
477 $self->_order_by_chunks ($order)
482 my ($self, $from) = @_;
483 if (ref $from eq 'ARRAY') {
484 return $self->_recurse_from(@$from);
485 } elsif (ref $from eq 'HASH') {
486 return $self->_make_as($from);
488 return $from; # would love to quote here but _table ends up getting called
489 # twice during an ->select without a limit clause due to
490 # the way S::A::Limit->select works. should maybe consider
491 # bypassing this and doing S::A::select($self, ...) in
492 # our select method above. meantime, quoting shims have
493 # been added to select/insert/update/delete here
498 my ($self, $from, @join) = @_;
500 push(@sqlf, $self->_make_as($from));
501 foreach my $j (@join) {
504 # check whether a join type exists
505 my $join_clause = '';
506 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
507 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
508 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
510 $join_clause = ' JOIN ';
512 push(@sqlf, $join_clause);
514 if (ref $to eq 'ARRAY') {
515 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
517 push(@sqlf, $self->_make_as($to));
519 push(@sqlf, ' ON ', $self->_join_condition($on));
521 return join('', @sqlf);
525 my ($self, $sqlbind) = @_;
527 my @sqlbind = @$$sqlbind; # copy
528 my $sql = shift @sqlbind;
529 push @{$self->{from_bind}}, @sqlbind;
535 my ($self, $from) = @_;
536 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
537 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
539 } reverse each %{$self->_skip_options($from)});
543 my ($self, $hash) = @_;
545 $clean_hash->{$_} = $hash->{$_}
546 for grep {!/^-/} keys %$hash;
550 sub _join_condition {
551 my ($self, $cond) = @_;
552 if (ref $cond eq 'HASH') {
557 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
558 if ref($v) ne 'SCALAR';
562 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
565 return scalar($self->_recurse_where(\%j));
566 } elsif (ref $cond eq 'ARRAY') {
567 return join(' OR ', map { $self->_join_condition($_) } @$cond);
569 die "Can't handle this yet!";
574 my ($self, $label) = @_;
575 return '' unless defined $label;
576 return "*" if $label eq '*';
577 return $label unless $self->{quote_char};
578 if(ref $self->{quote_char} eq "ARRAY"){
579 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
580 if !defined $self->{name_sep};
581 my $sep = $self->{name_sep};
582 return join($self->{name_sep},
583 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
584 split(/\Q$sep\E/,$label));
586 return $self->SUPER::_quote($label);
591 $self->{limit_dialect} = shift if @_;
592 return $self->{limit_dialect};
597 $self->{quote_char} = shift if @_;
598 return $self->{quote_char};
603 $self->{name_sep} = shift if @_;
604 return $self->{name_sep};
615 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
616 and includes a number of DBIC-specific workarounds, not yet suitable for
617 inclusion into SQLA proper.
623 Tries to determine limit dialect.
627 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
628 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
630 =head2 insert update delete
632 Just quotes table names.
636 Specifies the dialect of used for implementing an SQL "limit" clause for
637 restricting the number of query results returned. Valid values are: RowNum.
639 See L<DBIx::Class::Storage::DBI/connect_info> for details.
643 Character separating quoted table names.
645 See L<DBIx::Class::Storage::DBI/connect_info> for details.
649 Set to an array-ref to specify separate left and right quotes for table names.
651 See L<DBIx::Class::Storage::DBI/connect_info> for details.