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 croak '$order supplied to SQLAHacks limit emulators must be a hash'
120 if (ref $order ne 'HASH');
122 $order = { %$order }; #copy
124 my $last = $rows + $offset;
126 my $req_order = $self->_order_by ($order->{order_by});
128 my $limit_order = $req_order ? $order->{order_by} : $order->{_virtual_order_by};
130 delete $order->{$_} for qw/order_by _virtual_order_by/;
131 my $grpby_having = $self->_order_by ($order);
133 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
135 $sql =~ s/^\s*(SELECT|select)//;
140 SELECT TOP $rows * FROM
142 SELECT TOP $last $sql $grpby_having $order_by_inner
154 # While we're at it, this should make LIMIT queries more efficient,
155 # without digging into things too deeply
157 my ($self, $syntax) = @_;
158 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
162 my ($self, $table, $fields, $where, $order, @rest) = @_;
164 $self->{"${_}_bind"} = [] for (qw/having from order/);
166 if (ref $table eq 'SCALAR') {
169 elsif (not ref $table) {
170 $table = $self->_quote($table);
172 local $self->{rownum_hack_count} = 1
173 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
174 @rest = (-1) unless defined $rest[0];
175 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
176 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
177 my ($sql, @where_bind) = $self->SUPER::select(
178 $table, $self->_recurse_fields($fields), $where, $order, @rest
183 $self->{for} eq 'update' ? ' FOR UPDATE' :
184 $self->{for} eq 'shared' ? ' FOR SHARE' :
189 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
195 $table = $self->_quote($table) unless ref($table);
196 $self->SUPER::insert($table, @_);
202 $table = $self->_quote($table) unless ref($table);
203 $self->SUPER::update($table, @_);
209 $table = $self->_quote($table) unless ref($table);
210 $self->SUPER::delete($table, @_);
216 return $_[1].$self->_order_by($_[2]);
218 return $self->SUPER::_emulate_limit(@_);
222 sub _recurse_fields {
223 my ($self, $fields, $params) = @_;
224 my $ref = ref $fields;
225 return $self->_quote($fields) unless $ref;
226 return $$fields if $ref eq 'SCALAR';
228 if ($ref eq 'ARRAY') {
229 return join(', ', map {
230 $self->_recurse_fields($_)
231 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
232 ? ' AS col'.$self->{rownum_hack_count}++
235 } elsif ($ref eq 'HASH') {
236 foreach my $func (keys %$fields) {
237 if ($func eq 'distinct') {
238 my $_fields = $fields->{$func};
239 if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
241 'The select => { distinct => ... } syntax is not supported for multiple columns.'
242 .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
243 .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
247 $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
249 'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
250 ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
254 return $self->_sqlcase($func)
255 .'( '.$self->_recurse_fields($fields->{$func}).' )';
258 # Is the second check absolutely necessary?
259 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
260 return $self->_fold_sqlbind( $fields );
263 croak($ref . qq{ unexpected in _recurse_fields()})
268 my ($self, $arg) = @_;
270 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
274 if (defined $arg->{group_by}) {
275 $ret = $self->_sqlcase(' group by ')
276 .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
279 if (defined $arg->{having}) {
280 my ($frag, @bind) = $self->_recurse_where($arg->{having});
281 push(@{$self->{having_bind}}, @bind);
282 $ret .= $self->_sqlcase(' having ').$frag;
285 if (defined $arg->{order_by}) {
286 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
287 push(@{$self->{order_bind}}, @bind);
294 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
295 push(@{$self->{order_bind}}, @bind);
300 sub _order_directions {
301 my ($self, $order) = @_;
303 # strip bind values - none of the current _order_directions users support them
304 return $self->SUPER::_order_directions( [ map
305 { ref $_ ? $_->[0] : $_ }
306 $self->_order_by_chunks ($order)
311 my ($self, $from) = @_;
312 if (ref $from eq 'ARRAY') {
313 return $self->_recurse_from(@$from);
314 } elsif (ref $from eq 'HASH') {
315 return $self->_make_as($from);
317 return $from; # would love to quote here but _table ends up getting called
318 # twice during an ->select without a limit clause due to
319 # the way S::A::Limit->select works. should maybe consider
320 # bypassing this and doing S::A::select($self, ...) in
321 # our select method above. meantime, quoting shims have
322 # been added to select/insert/update/delete here
327 my ($self, $from, @join) = @_;
329 push(@sqlf, $self->_make_as($from));
330 foreach my $j (@join) {
333 # check whether a join type exists
334 my $join_clause = '';
335 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
336 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
337 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
339 $join_clause = ' JOIN ';
341 push(@sqlf, $join_clause);
343 if (ref $to eq 'ARRAY') {
344 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
346 push(@sqlf, $self->_make_as($to));
348 push(@sqlf, ' ON ', $self->_join_condition($on));
350 return join('', @sqlf);
354 my ($self, $sqlbind) = @_;
356 my @sqlbind = @$$sqlbind; # copy
357 my $sql = shift @sqlbind;
358 push @{$self->{from_bind}}, @sqlbind;
364 my ($self, $from) = @_;
365 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
366 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
368 } reverse each %{$self->_skip_options($from)});
372 my ($self, $hash) = @_;
374 $clean_hash->{$_} = $hash->{$_}
375 for grep {!/^-/} keys %$hash;
379 sub _join_condition {
380 my ($self, $cond) = @_;
381 if (ref $cond eq 'HASH') {
386 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
387 if ref($v) ne 'SCALAR';
391 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
394 return scalar($self->_recurse_where(\%j));
395 } elsif (ref $cond eq 'ARRAY') {
396 return join(' OR ', map { $self->_join_condition($_) } @$cond);
398 die "Can't handle this yet!";
403 my ($self, $label) = @_;
404 return '' unless defined $label;
405 return "*" if $label eq '*';
406 return $label unless $self->{quote_char};
407 if(ref $self->{quote_char} eq "ARRAY"){
408 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
409 if !defined $self->{name_sep};
410 my $sep = $self->{name_sep};
411 return join($self->{name_sep},
412 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
413 split(/\Q$sep\E/,$label));
415 return $self->SUPER::_quote($label);
420 $self->{limit_dialect} = shift if @_;
421 return $self->{limit_dialect};
426 $self->{quote_char} = shift if @_;
427 return $self->{quote_char};
432 $self->{name_sep} = shift if @_;
433 return $self->{name_sep};
444 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
445 and includes a number of DBIC-specific workarounds, not yet suitable for
446 inclusion into SQLA proper.
452 Tries to determine limit dialect.
456 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
457 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
459 =head2 insert update delete
461 Just quotes table names.
465 Specifies the dialect of used for implementing an SQL "limit" clause for
466 restricting the number of query results returned. Valid values are: RowNum.
468 See L<DBIx::Class::Storage::DBI/connect_info> for details.
472 Character separating quoted table names.
474 See L<DBIx::Class::Storage::DBI/connect_info> for details.
478 Set to an array-ref to specify separate left and right quotes for table names.
480 See L<DBIx::Class::Storage::DBI/connect_info> for details.