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 # examine normalized version, collapses nesting
218 if (scalar $self->_order_by_chunks ($req_order)) {
219 $limit_order = $req_order;
222 my $rs_alias = $self->{_dbic_rs_attrs}{alias};
224 { join ('', $rs_alias, $name_sep, $_ ) }
225 ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
229 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
230 my $order_by_requested = $self->_order_by ($req_order);
233 delete $order->{order_by};
234 my $grpby_having = $self->_order_by ($order);
236 # short circuit for counts - the ordering complexity is needless
237 if ($self->{_dbic_rs_attrs}{-for_count_only}) {
238 return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
241 # we can't really adjust the order_by columns, as introspection is lacking
242 # resort to simple substitution
243 for my $col (keys %outer_col_aliases) {
244 for ($order_by_requested, $order_by_outer) {
245 $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
248 for my $col (keys %col_aliases) {
249 $order_by_inner =~ s/\s+$col\s+/$col_aliases{$col}/g;
253 my $inner_lim = $rows + $offset;
255 $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
260 SELECT TOP $rows $outer_select FROM
269 if ($order_by_requested) {
272 SELECT $outer_select FROM
282 # action at a distance to shorten Top code above
284 my ($self, $register, $alias, $fqcol, $col) = @_;
286 # record qualified name
287 $register->{$fqcol} = $alias;
288 $register->{$self->_quote($fqcol)} = $alias;
292 # record unqualified name, undef (no adjustment) if a duplicate is found
293 if (exists $register->{$col}) {
294 $register->{$col} = undef;
297 $register->{$col} = $alias;
300 $register->{$self->_quote($col)} = $register->{$col};
305 # While we're at it, this should make LIMIT queries more efficient,
306 # without digging into things too deeply
308 my ($self, $syntax) = @_;
309 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
313 update => 'FOR UPDATE',
314 shared => 'FOR SHARE',
317 my ($self, $table, $fields, $where, $order, @rest) = @_;
319 $self->{"${_}_bind"} = [] for (qw/having from order/);
321 if (ref $table eq 'SCALAR') {
324 elsif (not ref $table) {
325 $table = $self->_quote($table);
327 local $self->{rownum_hack_count} = 1
328 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
329 @rest = (-1) unless defined $rest[0];
330 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
331 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
332 my ($sql, @where_bind) = $self->SUPER::select(
333 $table, $self->_recurse_fields($fields), $where, $order, @rest
335 if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
336 $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
339 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
345 $table = $self->_quote($table) unless ref($table);
347 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
348 # which is sadly understood only by MySQL. Change default behavior here,
349 # until SQLA2 comes with proper dialect support
350 if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
351 return "INSERT INTO ${table} DEFAULT VALUES"
354 $self->SUPER::insert($table, @_);
360 $table = $self->_quote($table) unless ref($table);
361 $self->SUPER::update($table, @_);
367 $table = $self->_quote($table) unless ref($table);
368 $self->SUPER::delete($table, @_);
374 return $_[1].$self->_order_by($_[2]);
376 return $self->SUPER::_emulate_limit(@_);
380 sub _recurse_fields {
381 my ($self, $fields, $params) = @_;
382 my $ref = ref $fields;
383 return $self->_quote($fields) unless $ref;
384 return $$fields if $ref eq 'SCALAR';
386 if ($ref eq 'ARRAY') {
387 return join(', ', map {
388 $self->_recurse_fields($_)
389 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
390 ? ' AS col'.$self->{rownum_hack_count}++
394 elsif ($ref eq 'HASH') {
398 if ($hash{-select}) {
399 $select = $self->_recurse_fields (delete $hash{-select});
400 $as = $self->_quote (delete $hash{-as});
403 my ($func, $args) = each %hash;
406 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
408 'The select => { distinct => ... } syntax is not supported for multiple columns.'
409 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
410 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
413 $select = sprintf ('%s( %s )',
414 $self->_sqlcase($func),
415 $self->_recurse_fields($args)
419 # there should be nothing left
421 croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
424 $select .= " AS $as" if $as;
427 # Is the second check absolutely necessary?
428 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
429 return $self->_fold_sqlbind( $fields );
432 croak($ref . qq{ unexpected in _recurse_fields()})
437 my ($self, $arg) = @_;
439 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
443 if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
444 $ret = $self->_sqlcase(' group by ') . $g;
447 if (defined $arg->{having}) {
448 my ($frag, @bind) = $self->_recurse_where($arg->{having});
449 push(@{$self->{having_bind}}, @bind);
450 $ret .= $self->_sqlcase(' having ').$frag;
453 if (defined $arg->{order_by}) {
454 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
455 push(@{$self->{order_bind}}, @bind);
462 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
463 push(@{$self->{order_bind}}, @bind);
468 sub _order_directions {
469 my ($self, $order) = @_;
471 # strip bind values - none of the current _order_directions users support them
472 return $self->SUPER::_order_directions( [ map
473 { ref $_ ? $_->[0] : $_ }
474 $self->_order_by_chunks ($order)
479 my ($self, $from) = @_;
480 if (ref $from eq 'ARRAY') {
481 return $self->_recurse_from(@$from);
482 } elsif (ref $from eq 'HASH') {
483 return $self->_make_as($from);
485 return $from; # would love to quote here but _table ends up getting called
486 # twice during an ->select without a limit clause due to
487 # the way S::A::Limit->select works. should maybe consider
488 # bypassing this and doing S::A::select($self, ...) in
489 # our select method above. meantime, quoting shims have
490 # been added to select/insert/update/delete here
495 my ($self, $from, @join) = @_;
497 push(@sqlf, $self->_make_as($from));
498 foreach my $j (@join) {
501 # check whether a join type exists
502 my $join_clause = '';
503 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
504 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
505 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
507 $join_clause = ' JOIN ';
509 push(@sqlf, $join_clause);
511 if (ref $to eq 'ARRAY') {
512 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
514 push(@sqlf, $self->_make_as($to));
516 push(@sqlf, ' ON ', $self->_join_condition($on));
518 return join('', @sqlf);
522 my ($self, $sqlbind) = @_;
524 my @sqlbind = @$$sqlbind; # copy
525 my $sql = shift @sqlbind;
526 push @{$self->{from_bind}}, @sqlbind;
532 my ($self, $from) = @_;
533 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
534 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
536 } reverse each %{$self->_skip_options($from)});
540 my ($self, $hash) = @_;
542 $clean_hash->{$_} = $hash->{$_}
543 for grep {!/^-/} keys %$hash;
547 sub _join_condition {
548 my ($self, $cond) = @_;
549 if (ref $cond eq 'HASH') {
554 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
555 if ref($v) ne 'SCALAR';
559 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
562 return scalar($self->_recurse_where(\%j));
563 } elsif (ref $cond eq 'ARRAY') {
564 return join(' OR ', map { $self->_join_condition($_) } @$cond);
566 die "Can't handle this yet!";
571 my ($self, $label) = @_;
572 return '' unless defined $label;
573 return "*" if $label eq '*';
574 return $label unless $self->{quote_char};
575 if(ref $self->{quote_char} eq "ARRAY"){
576 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
577 if !defined $self->{name_sep};
578 my $sep = $self->{name_sep};
579 return join($self->{name_sep},
580 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
581 split(/\Q$sep\E/,$label));
583 return $self->SUPER::_quote($label);
588 $self->{limit_dialect} = shift if @_;
589 return $self->{limit_dialect};
594 $self->{quote_char} = shift if @_;
595 return $self->{quote_char};
600 $self->{name_sep} = shift if @_;
601 return $self->{name_sep};
612 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
613 and includes a number of DBIC-specific workarounds, not yet suitable for
614 inclusion into SQLA proper.
620 Tries to determine limit dialect.
624 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
625 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
627 =head2 insert update delete
629 Just quotes table names.
633 Specifies the dialect of used for implementing an SQL "limit" clause for
634 restricting the number of query results returned. Valid values are: RowNum.
636 See L<DBIx::Class::Storage::DBI/connect_info> for details.
640 Character separating quoted table names.
642 See L<DBIx::Class::Storage::DBI/connect_info> for details.
646 Set to an array-ref to specify separate left and right quotes for table names.
648 See L<DBIx::Class::Storage::DBI/connect_info> for details.