Moved DBIC::SQL::Abstract inner classes to DBIx::Class::SQLAHacks namespace to decoup...
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / SQLAHacks.pm
CommitLineData
6f4ddea1 1
2package # Hide from PAUSE
3DBIx::Class::SQLAHacks; # Would merge upstream, but nate doesn't reply :(
4
5
6use base qw/SQL::Abstract::Limit/;
7
8sub new {
9 my $self = shift->SUPER::new(@_);
10
11 # This prevents the caching of $dbh in S::A::L, I believe
12 # If limit_dialect is a ref (like a $dbh), go ahead and replace
13 # it with what it resolves to:
14 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
15 if ref $self->{limit_dialect};
16
17 $self;
18}
19
20
21
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.
25#
26# Since we currently do not have access to the SQLA AST, resort
27# to barbaric mutilation of any SQL supplied in literal form
28
29sub _strip_outer_paren {
30 my ($self, $arg) = @_;
31
32 return $self->_SWITCH_refkind ($arg, {
33 ARRAYREFREF => sub {
34 $$arg->[0] = __strip_outer_paren ($$arg->[0]);
35 return $arg;
36 },
37 SCALARREF => sub {
38 return \__strip_outer_paren( $$arg );
39 },
40 FALLBACK => sub {
41 return $arg
42 },
43 });
44}
45
46sub __strip_outer_paren {
47 my $sql = shift;
48
49 if ($sql and not ref $sql) {
50 while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
51 $sql = $1;
52 }
53 }
54
55 return $sql;
56}
57
58sub _where_field_IN {
59 my ($self, $lhs, $op, $rhs) = @_;
60 $rhs = $self->_strip_outer_paren ($rhs);
61 return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
62}
63
64sub _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);
68}
69
70
71
72# DB2 is the only remaining DB using this. Even though we are not sure if
73# RowNumberOver is still needed here (should be part of SQLA) leave the
74# code in place
75sub _RowNumberOver {
76 my ($self, $sql, $order, $rows, $offset ) = @_;
77
78 $offset += 1;
79 my $last = $rows + $offset;
80 my ( $order_by ) = $self->_order_by( $order );
81
82 $sql = <<"SQL";
83SELECT * FROM
84(
85 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
86 $sql
87 $order_by
88 ) Q1
89) Q2
90WHERE ROW_NUM BETWEEN $offset AND $last
91
92SQL
93
94 return $sql;
95}
96
97
98# While we're at it, this should make LIMIT queries more efficient,
99# without digging into things too deeply
100use Scalar::Util 'blessed';
101sub _find_syntax {
102 my ($self, $syntax) = @_;
103
104 # DB2 is the only remaining DB using this. Even though we are not sure if
105 # RowNumberOver is still needed here (should be part of SQLA) leave the
106 # code in place
107 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
108 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
109 return 'RowNumberOver';
110 }
111
112 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
113}
114
115sub select {
116 my ($self, $table, $fields, $where, $order, @rest) = @_;
117 if (ref $table eq 'SCALAR') {
118 $table = $$table;
119 }
120 elsif (not ref $table) {
121 $table = $self->_quote($table);
122 }
123 local $self->{rownum_hack_count} = 1
124 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
125 @rest = (-1) unless defined $rest[0];
126 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
127 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
128 local $self->{having_bind} = [];
129 my ($sql, @ret) = $self->SUPER::select(
130 $table, $self->_recurse_fields($fields), $where, $order, @rest
131 );
132 $sql .=
133 $self->{for} ?
134 (
135 $self->{for} eq 'update' ? ' FOR UPDATE' :
136 $self->{for} eq 'shared' ? ' FOR SHARE' :
137 ''
138 ) :
139 ''
140 ;
141 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
142}
143
144sub insert {
145 my $self = shift;
146 my $table = shift;
147 $table = $self->_quote($table) unless ref($table);
148 $self->SUPER::insert($table, @_);
149}
150
151sub update {
152 my $self = shift;
153 my $table = shift;
154 $table = $self->_quote($table) unless ref($table);
155 $self->SUPER::update($table, @_);
156}
157
158sub delete {
159 my $self = shift;
160 my $table = shift;
161 $table = $self->_quote($table) unless ref($table);
162 $self->SUPER::delete($table, @_);
163}
164
165sub _emulate_limit {
166 my $self = shift;
167 if ($_[3] == -1) {
168 return $_[1].$self->_order_by($_[2]);
169 } else {
170 return $self->SUPER::_emulate_limit(@_);
171 }
172}
173
174sub _recurse_fields {
175 my ($self, $fields, $params) = @_;
176 my $ref = ref $fields;
177 return $self->_quote($fields) unless $ref;
178 return $$fields if $ref eq 'SCALAR';
179
180 if ($ref eq 'ARRAY') {
181 return join(', ', map {
182 $self->_recurse_fields($_)
183 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
184 ? ' AS col'.$self->{rownum_hack_count}++
185 : '')
186 } @$fields);
187 } elsif ($ref eq 'HASH') {
188 foreach my $func (keys %$fields) {
189 return $self->_sqlcase($func)
190 .'( '.$self->_recurse_fields($fields->{$func}).' )';
191 }
192 }
193 # Is the second check absolutely necessary?
194 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
195 return $self->_bind_to_sql( $fields );
196 }
197 else {
198 Carp::croak($ref . qq{ unexpected in _recurse_fields()})
199 }
200}
201
202sub _order_by {
203 my $self = shift;
204 my $ret = '';
205 my @extra;
206 if (ref $_[0] eq 'HASH') {
207 if (defined $_[0]->{group_by}) {
208 $ret = $self->_sqlcase(' group by ')
209 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
210 }
211 if (defined $_[0]->{having}) {
212 my $frag;
213 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
214 push(@{$self->{having_bind}}, @extra);
215 $ret .= $self->_sqlcase(' having ').$frag;
216 }
217 if (defined $_[0]->{order_by}) {
218 $ret .= $self->_order_by($_[0]->{order_by});
219 }
220 if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
221 return $self->SUPER::_order_by($_[0]);
222 }
223 } elsif (ref $_[0] eq 'SCALAR') {
224 $ret = $self->_sqlcase(' order by ').${ $_[0] };
225 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
226 my @order = @{+shift};
227 $ret = $self->_sqlcase(' order by ')
228 .join(', ', map {
229 my $r = $self->_order_by($_, @_);
230 $r =~ s/^ ?ORDER BY //i;
231 $r;
232 } @order);
233 } else {
234 $ret = $self->SUPER::_order_by(@_);
235 }
236 return $ret;
237}
238
239sub _order_directions {
240 my ($self, $order) = @_;
241 $order = $order->{order_by} if ref $order eq 'HASH';
242 return $self->SUPER::_order_directions($order);
243}
244
245sub _table {
246 my ($self, $from) = @_;
247 if (ref $from eq 'ARRAY') {
248 return $self->_recurse_from(@$from);
249 } elsif (ref $from eq 'HASH') {
250 return $self->_make_as($from);
251 } else {
252 return $from; # would love to quote here but _table ends up getting called
253 # twice during an ->select without a limit clause due to
254 # the way S::A::Limit->select works. should maybe consider
255 # bypassing this and doing S::A::select($self, ...) in
256 # our select method above. meantime, quoting shims have
257 # been added to select/insert/update/delete here
258 }
259}
260
261sub _recurse_from {
262 my ($self, $from, @join) = @_;
263 my @sqlf;
264 push(@sqlf, $self->_make_as($from));
265 foreach my $j (@join) {
266 my ($to, $on) = @$j;
267
268 # check whether a join type exists
269 my $join_clause = '';
270 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
271 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
272 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
273 } else {
274 $join_clause = ' JOIN ';
275 }
276 push(@sqlf, $join_clause);
277
278 if (ref $to eq 'ARRAY') {
279 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
280 } else {
281 push(@sqlf, $self->_make_as($to));
282 }
283 push(@sqlf, ' ON ', $self->_join_condition($on));
284 }
285 return join('', @sqlf);
286}
287
288sub _bind_to_sql {
289 my $self = shift;
290 my $arr = shift;
291 my $sql = shift @$$arr;
292 $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
293 return $sql
294}
295
296sub _make_as {
297 my ($self, $from) = @_;
298 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
299 : ref $_ eq 'REF' ? $self->_bind_to_sql($_)
300 : $self->_quote($_))
301 } reverse each %{$self->_skip_options($from)});
302}
303
304sub _skip_options {
305 my ($self, $hash) = @_;
306 my $clean_hash = {};
307 $clean_hash->{$_} = $hash->{$_}
308 for grep {!/^-/} keys %$hash;
309 return $clean_hash;
310}
311
312sub _join_condition {
313 my ($self, $cond) = @_;
314 if (ref $cond eq 'HASH') {
315 my %j;
316 for (keys %$cond) {
317 my $v = $cond->{$_};
318 if (ref $v) {
319 # XXX no throw_exception() in this package and croak() fails with strange results
320 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
321 if ref($v) ne 'SCALAR';
322 $j{$_} = $v;
323 }
324 else {
325 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
326 }
327 };
328 return scalar($self->_recurse_where(\%j));
329 } elsif (ref $cond eq 'ARRAY') {
330 return join(' OR ', map { $self->_join_condition($_) } @$cond);
331 } else {
332 die "Can't handle this yet!";
333 }
334}
335
336sub _quote {
337 my ($self, $label) = @_;
338 return '' unless defined $label;
339 return "*" if $label eq '*';
340 return $label unless $self->{quote_char};
341 if(ref $self->{quote_char} eq "ARRAY"){
342 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
343 if !defined $self->{name_sep};
344 my $sep = $self->{name_sep};
345 return join($self->{name_sep},
346 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
347 split(/\Q$sep\E/,$label));
348 }
349 return $self->SUPER::_quote($label);
350}
351
352sub limit_dialect {
353 my $self = shift;
354 $self->{limit_dialect} = shift if @_;
355 return $self->{limit_dialect};
356}
357
358sub quote_char {
359 my $self = shift;
360 $self->{quote_char} = shift if @_;
361 return $self->{quote_char};
362}
363
364sub name_sep {
365 my $self = shift;
366 $self->{name_sep} = shift if @_;
367 return $self->{name_sep};
368}
369
3701;
371
372__END__
373
374=pod
375
376=head1 NAME
377
378DBIx::Class::SQLAHacks - Things desired to be merged into SQL::Abstract
379
380=head1 METHODS
381
382=head2 new
383
384Tries to determine limit dialect.
385
386=head2 select
387
388Quotes table names, handles "limit" dialects (e.g. where rownum between x and
389y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
390
391=head2 insert update delete
392
393Just quotes table names.
394
395=head2 limit_dialect
396
397Specifies the dialect of used for implementing an SQL "limit" clause for
398restricting the number of query results returned. Valid values are: RowNum.
399
400See L<DBIx::Class::Storage::DBI/connect_info> for details.
401
402=head2 name_sep
403
404Character separating quoted table names.
405
406See L<DBIx::Class::Storage::DBI/connect_info> for details.
407
408=head2 quote_char
409
410Set to an array-ref to specify separate left and right quotes for table names.
411
412See L<DBIx::Class::Storage::DBI/connect_info> for details.
413
414=cut
415