1 package # Hide from PAUSE
2 DBIx::Class::SQLAHacks;
4 use base qw/SQL::Abstract::Limit/;
7 use Carp::Clan qw/^DBIx::Class/;
10 my $self = shift->SUPER::new(@_);
12 # This prevents the caching of $dbh in S::A::L, I believe
13 # If limit_dialect is a ref (like a $dbh), go ahead and replace
14 # it with what it resolves to:
15 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
16 if ref $self->{limit_dialect};
22 # Some databases (sqlite) do not handle multiple parenthesis
23 # around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
24 # is interpreted as x IN 1 or something similar.
26 # Since we currently do not have access to the SQLA AST, resort
27 # to barbaric mutilation of any SQL supplied in literal form
29 sub _strip_outer_paren {
30 my ($self, $arg) = @_;
32 return $self->_SWITCH_refkind ($arg, {
34 $$arg->[0] = __strip_outer_paren ($$arg->[0]);
38 return \__strip_outer_paren( $$arg );
46 sub __strip_outer_paren {
49 if ($sql and not ref $sql) {
50 while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
59 my ($self, $lhs, $op, $rhs) = @_;
60 $rhs = $self->_strip_outer_paren ($rhs);
61 return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
64 sub _where_field_BETWEEN {
65 my ($self, $lhs, $op, $rhs) = @_;
66 $rhs = $self->_strip_outer_paren ($rhs);
67 return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
70 # Slow but ANSI standard Limit/Offset support. DB2 uses this
72 my ($self, $sql, $order, $rows, $offset ) = @_;
75 my $last = $rows + $offset - 1;
76 my ( $order_by ) = $self->_order_by( $order );
81 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
86 WHERE ROW_NUM BETWEEN $offset AND $last
93 # Crappy Top based Limit/Offset support. MSSQL uses this currently,
94 # but may have to switch to RowNumberOver one day
96 my ( $self, $sql, $order, $rows, $offset ) = @_;
98 croak '$order supplied to SQLAHacks limit emulators must be a hash'
99 if (ref $order ne 'HASH');
101 $order = { %$order }; #copy
103 my $last = $rows + $offset;
105 my $req_order = $self->_order_by ($order->{order_by});
107 my $limit_order = $req_order ? $order->{order_by} : $order->{_virtual_order_by};
109 delete $order->{$_} for qw/order_by _virtual_order_by/;
110 my $grpby_having = $self->_order_by ($order);
112 my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
114 $sql =~ s/^\s*(SELECT|select)//;
119 SELECT TOP $rows * FROM
121 SELECT TOP $last $sql $grpby_having $order_by_inner
133 # While we're at it, this should make LIMIT queries more efficient,
134 # without digging into things too deeply
136 my ($self, $syntax) = @_;
137 return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
141 my ($self, $table, $fields, $where, $order, @rest) = @_;
143 $self->{"${_}_bind"} = [] for (qw/having from order/);
145 if (ref $table eq 'SCALAR') {
148 elsif (not ref $table) {
149 $table = $self->_quote($table);
151 local $self->{rownum_hack_count} = 1
152 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
153 @rest = (-1) unless defined $rest[0];
154 croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
155 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
156 my ($sql, @where_bind) = $self->SUPER::select(
157 $table, $self->_recurse_fields($fields), $where, $order, @rest
162 $self->{for} eq 'update' ? ' FOR UPDATE' :
163 $self->{for} eq 'shared' ? ' FOR SHARE' :
168 return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
174 $table = $self->_quote($table) unless ref($table);
175 $self->SUPER::insert($table, @_);
181 $table = $self->_quote($table) unless ref($table);
182 $self->SUPER::update($table, @_);
188 $table = $self->_quote($table) unless ref($table);
189 $self->SUPER::delete($table, @_);
195 return $_[1].$self->_order_by($_[2]);
197 return $self->SUPER::_emulate_limit(@_);
201 sub _recurse_fields {
202 my ($self, $fields, $params) = @_;
203 my $ref = ref $fields;
204 return $self->_quote($fields) unless $ref;
205 return $$fields if $ref eq 'SCALAR';
207 if ($ref eq 'ARRAY') {
208 return join(', ', map {
209 $self->_recurse_fields($_)
210 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
211 ? ' AS col'.$self->{rownum_hack_count}++
214 } elsif ($ref eq 'HASH') {
215 foreach my $func (keys %$fields) {
216 if ($func eq 'distinct') {
217 my $_fields = $fields->{$func};
218 if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
220 'The select => { distinct => ... } syntax is not supported for multiple columns.'
221 .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
222 .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
226 $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
228 'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
229 ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
233 return $self->_sqlcase($func)
234 .'( '.$self->_recurse_fields($fields->{$func}).' )';
237 # Is the second check absolutely necessary?
238 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
239 return $self->_fold_sqlbind( $fields );
242 croak($ref . qq{ unexpected in _recurse_fields()})
247 my ($self, $arg) = @_;
249 if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
253 if (defined $arg->{group_by}) {
254 $ret = $self->_sqlcase(' group by ')
255 .$self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 });
258 if (defined $arg->{having}) {
259 my ($frag, @bind) = $self->_recurse_where($arg->{having});
260 push(@{$self->{having_bind}}, @bind);
261 $ret .= $self->_sqlcase(' having ').$frag;
264 if (defined $arg->{order_by}) {
265 my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
266 push(@{$self->{order_bind}}, @bind);
273 my ($sql, @bind) = $self->SUPER::_order_by ($arg);
274 push(@{$self->{order_bind}}, @bind);
279 sub _order_directions {
280 my ($self, $order) = @_;
282 # strip bind values - none of the current _order_directions users support them
283 return $self->SUPER::_order_directions( [ map
284 { ref $_ ? $_->[0] : $_ }
285 $self->_order_by_chunks ($order)
290 my ($self, $from) = @_;
291 if (ref $from eq 'ARRAY') {
292 return $self->_recurse_from(@$from);
293 } elsif (ref $from eq 'HASH') {
294 return $self->_make_as($from);
296 return $from; # would love to quote here but _table ends up getting called
297 # twice during an ->select without a limit clause due to
298 # the way S::A::Limit->select works. should maybe consider
299 # bypassing this and doing S::A::select($self, ...) in
300 # our select method above. meantime, quoting shims have
301 # been added to select/insert/update/delete here
306 my ($self, $from, @join) = @_;
308 push(@sqlf, $self->_make_as($from));
309 foreach my $j (@join) {
312 # check whether a join type exists
313 my $join_clause = '';
314 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
315 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
316 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
318 $join_clause = ' JOIN ';
320 push(@sqlf, $join_clause);
322 if (ref $to eq 'ARRAY') {
323 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
325 push(@sqlf, $self->_make_as($to));
327 push(@sqlf, ' ON ', $self->_join_condition($on));
329 return join('', @sqlf);
333 my ($self, $sqlbind) = @_;
335 my @sqlbind = @$$sqlbind; # copy
336 my $sql = shift @sqlbind;
337 push @{$self->{from_bind}}, @sqlbind;
343 my ($self, $from) = @_;
344 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
345 : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
347 } reverse each %{$self->_skip_options($from)});
351 my ($self, $hash) = @_;
353 $clean_hash->{$_} = $hash->{$_}
354 for grep {!/^-/} keys %$hash;
358 sub _join_condition {
359 my ($self, $cond) = @_;
360 if (ref $cond eq 'HASH') {
365 croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
366 if ref($v) ne 'SCALAR';
370 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
373 return scalar($self->_recurse_where(\%j));
374 } elsif (ref $cond eq 'ARRAY') {
375 return join(' OR ', map { $self->_join_condition($_) } @$cond);
377 die "Can't handle this yet!";
382 my ($self, $label) = @_;
383 return '' unless defined $label;
384 return "*" if $label eq '*';
385 return $label unless $self->{quote_char};
386 if(ref $self->{quote_char} eq "ARRAY"){
387 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
388 if !defined $self->{name_sep};
389 my $sep = $self->{name_sep};
390 return join($self->{name_sep},
391 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
392 split(/\Q$sep\E/,$label));
394 return $self->SUPER::_quote($label);
399 $self->{limit_dialect} = shift if @_;
400 return $self->{limit_dialect};
405 $self->{quote_char} = shift if @_;
406 return $self->{quote_char};
411 $self->{name_sep} = shift if @_;
412 return $self->{name_sep};
423 DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
424 and includes a number of DBIC-specific workarounds, not yet suitable for
425 inclusion into SQLA proper.
431 Tries to determine limit dialect.
435 Quotes table names, handles "limit" dialects (e.g. where rownum between x and
436 y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
438 =head2 insert update delete
440 Just quotes table names.
444 Specifies the dialect of used for implementing an SQL "limit" clause for
445 restricting the number of query results returned. Valid values are: RowNum.
447 See L<DBIx::Class::Storage::DBI/connect_info> for details.
451 Character separating quoted table names.
453 See L<DBIx::Class::Storage::DBI/connect_info> for details.
457 Set to an array-ref to specify separate left and right quotes for table names.
459 See L<DBIx::Class::Storage::DBI/connect_info> for details.