Commit | Line | Data |
d5dedbd6 |
1 | package DBIx::Class::SQLMaker; |
6f4ddea1 |
2 | |
a697fa31 |
3 | use strict; |
4 | use warnings; |
5 | |
d5dedbd6 |
6 | =head1 NAME |
7 | |
8 | DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class |
9 | |
10 | =head1 DESCRIPTION |
11 | |
07fadea8 |
12 | This module is currently a subclass of L<SQL::Abstract> and includes a number of |
13 | DBIC-specific extensions/workarounds, not suitable for inclusion into the |
d5dedbd6 |
14 | L<SQL::Abstract> core. It also provides all (and more than) the functionality |
15 | of L<SQL::Abstract::Limit>, see L<DBIx::Class::SQLMaker::LimitDialects> for |
16 | more info. |
17 | |
07fadea8 |
18 | Currently the enhancements over L<SQL::Abstract> are: |
d5dedbd6 |
19 | |
20 | =over |
21 | |
22 | =item * Support for C<JOIN> statements (via extended C<table/from> support) |
23 | |
24 | =item * Support of functions in C<SELECT> lists |
25 | |
26 | =item * C<GROUP BY>/C<HAVING> support (via extensions to the order_by parameter) |
27 | |
07fadea8 |
28 | =item * A rudimentary multicolumn IN operator |
29 | |
d5dedbd6 |
30 | =item * Support of C<...FOR UPDATE> type of select statement modifiers |
31 | |
32 | =back |
33 | |
07fadea8 |
34 | =head1 ROADMAP |
35 | |
36 | Some maintainer musings on the current state of SQL generation within DBIC as |
37 | of Oct 2015 |
38 | |
39 | =head2 Folding of most (or all) of L<SQL::Abstract (SQLA)|SQL::Abstract> into DBIC |
40 | |
41 | The rise of complex prefetch use, and the general streamlining of result |
42 | parsing within DBIC ended up pushing the actual SQL generation to the forefront |
43 | of many casual performance profiles. While the idea behind SQLA's API is sound, |
44 | the actual implementation is terribly inefficient (once again bumping into the |
45 | ridiculously high overhead of perl function calls). |
46 | |
47 | Given that SQLA has a B<very> distinct life on its own, and is used within an |
48 | order of magnitude more projects compared to DBIC, it is prudent to B<not> |
49 | disturb the current call chains within SQLA itself. Instead in the near future |
50 | an effort will be undertaken to seek a more thorough decoupling of DBIC SQL |
51 | generation from reliance on SQLA, possibly to a point where B<DBIC will no |
52 | longer depend on SQLA> at all. |
53 | |
54 | B<The L<SQL::Abstract> library itself will continue being maintained> although |
55 | it is not likely to gain many extra features, notably dialect support, at least |
56 | not within the base C<SQL::Abstract> namespace. |
57 | |
58 | This work (if undertaken) will take into consideration the following |
59 | constraints: |
60 | |
61 | =over |
62 | |
63 | =item Main API compatibility |
64 | |
65 | The object returned by C<< $schema->storage->sqlmaker >> needs to be able to |
66 | satisfy most of the basic tests found in the current-at-the-time SQLA dist. |
67 | While things like L<case|SQL::Abstract/case> or L<logic|SQL::Abstract/logic> |
68 | or even worse L<convert|SQL::Abstract/convert> will definitely remain |
69 | unsupported, the rest of the tests should pass (within reason). |
70 | |
71 | =item Ability to plug back an SQL::Abstract (or derivative) |
72 | |
73 | During the initial work on L<Data::Query> the test suite of DBIC turned out to |
74 | be an invaluable asset to iron out hard-to-reason-about corner cases. In |
75 | addition the test suite is much more vast and intricate than the tests of SQLA |
76 | itself. This state of affairs is way too valuable to sacrifice in order to gain |
77 | faster SQL generation. Thus a compile-time-ENV-check will be introduced along |
78 | with an extra CI configuration to ensure that DBIC is used with an off-the-CPAN |
79 | SQLA and that it continues to flawlessly run its entire test suite. While this |
80 | will undoubtedly complicate the implementation of the better performing SQL |
81 | generator, it will preserve both the usability of the test suite for external |
82 | projects and will keep L<SQL::Abstract> from regressions in the future. |
83 | |
84 | =back |
85 | |
86 | Aside from these constraints it is becoming more and more practical to simply |
87 | stop using SQLA in day-to-day production deployments of DBIC. The flexibility |
88 | of the internals is simply not worth the performance cost. |
89 | |
90 | =head2 Relationship to L<Data::Query (DQ)|Data::Query> |
91 | |
92 | When initial work on DQ was taking place, the tools in L<::Storage::DBIHacks |
33d0570d |
93 | |http://github.com/dbsrgits/dbix-class/blob/master/lib/DBIx/Class/Storage/DBIHacks.pm> |
07fadea8 |
94 | were only beginning to take shape, and it wasn't clear how important they will |
95 | become further down the road. In fact the I<regexing all over the place> was |
96 | considered an ugly stop-gap, and even a couple of highly entertaining talks |
97 | were given to that effect. As the use-cases of DBIC were progressing, and |
98 | evidence for the importance of supporting arbitrary SQL was mounting, it became |
99 | clearer that DBIC itself would not really benefit in any way from an |
100 | integration with DQ, but on the contrary is likely to lose functionality while |
101 | the corners of the brand new DQ codebase are sanded off. |
102 | |
103 | The current status of DBIC/DQ integration is that the only benefit is for DQ by |
104 | having access to the very extensive "early adopter" test suite, in the same |
105 | manner as early DBIC benefitted tremendously from usurping the Class::DBI test |
106 | suite. As far as the DBIC user-base - there are no immediate practical upsides |
107 | to DQ integration, neither in terms of API nor in performance. |
108 | |
109 | So (as described higher up) the DBIC development effort will in the foreseable |
110 | future ignore the existence of DQ, and will continue optimizing the preexisting |
111 | SQLA-based solution, potentially "organically growing" its own compatible |
112 | implementation. Also (again, as described higher up) the ability to plug a |
113 | separate SQLA-compatible class providing the necessary surface API will remain |
114 | possible, and will be protected at all costs in order to continue providing DQ |
115 | access to the test cases of DBIC. |
116 | |
117 | In the short term, after one more pass over the ResultSet internals is |
118 | undertaken I<real soon now (tm)>, and before the SQLA/SQLMaker integration |
119 | takes place, the preexisting DQ-based branches will be pulled/modified/rebased |
120 | to get up-to-date with the current state of the codebase, which changed very |
121 | substantially since the last migration effort, especially in the SQL |
122 | classification meta-parsing codepath. |
123 | |
d5dedbd6 |
124 | =cut |
6a247f33 |
125 | |
126 | use base qw/ |
d5dedbd6 |
127 | DBIx::Class::SQLMaker::LimitDialects |
6a247f33 |
128 | SQL::Abstract |
70c28808 |
129 | DBIx::Class |
6a247f33 |
130 | /; |
131 | use mro 'c3'; |
a697fa31 |
132 | |
70c28808 |
133 | use DBIx::Class::Carp; |
514b84f6 |
134 | use DBIx::Class::_Util 'set_subname'; |
02562a20 |
135 | use SQL::Abstract 'is_literal_value'; |
e8fc51c7 |
136 | use namespace::clean; |
b2b22cd6 |
137 | |
6a247f33 |
138 | __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); |
139 | |
111364b3 |
140 | sub _quoting_enabled { |
141 | ( defined $_[0]->{quote_char} and length $_[0]->{quote_char} ) ? 1 : 0 |
142 | } |
143 | |
3f5b99fe |
144 | # for when I need a normalized l/r pair |
145 | sub _quote_chars { |
111364b3 |
146 | |
147 | # in case we are called in the old !!$sm->_quote_chars fashion |
148 | return () if !wantarray and ( ! defined $_[0]->{quote_char} or ! length $_[0]->{quote_char} ); |
149 | |
3f5b99fe |
150 | map |
151 | { defined $_ ? $_ : '' } |
152 | ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) ) |
153 | ; |
154 | } |
155 | |
70c28808 |
156 | # FIXME when we bring in the storage weaklink, check its schema |
157 | # weaklink and channel through $schema->throw_exception |
158 | sub throw_exception { DBIx::Class::Exception->throw($_[1]) } |
159 | |
b2b22cd6 |
160 | BEGIN { |
2ea6032a |
161 | # reinstall the belch()/puke() functions of SQL::Abstract with custom versions |
70c28808 |
162 | # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp |
b2b22cd6 |
163 | no warnings qw/redefine/; |
2ea6032a |
164 | |
514b84f6 |
165 | *SQL::Abstract::belch = set_subname 'SQL::Abstract::belch' => sub (@) { |
2ea6032a |
166 | my($func) = (caller(1))[3]; |
167 | carp "[$func] Warning: ", @_; |
168 | }; |
169 | |
514b84f6 |
170 | *SQL::Abstract::puke = set_subname 'SQL::Abstract::puke' => sub (@) { |
2ea6032a |
171 | my($func) = (caller(1))[3]; |
70c28808 |
172 | __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_)); |
2ea6032a |
173 | }; |
b2b22cd6 |
174 | } |
6f4ddea1 |
175 | |
e9657379 |
176 | # the "oh noes offset/top without limit" constant |
fcb7fcbb |
177 | # limited to 31 bits for sanity (and consistency, |
178 | # since it may be handed to the like of sprintf %u) |
179 | # |
180 | # Also *some* builds of SQLite fail the test |
181 | # some_column BETWEEN ? AND ?: 1, 4294967295 |
182 | # with the proper integer bind attrs |
183 | # |
6a247f33 |
184 | # Implemented as a method, since ::Storage::DBI also |
185 | # refers to it (i.e. for the case of software_limit or |
186 | # as the value to abuse with MSSQL ordered subqueries) |
fcb7fcbb |
187 | sub __max_int () { 0x7FFFFFFF }; |
e9657379 |
188 | |
1b5ddf23 |
189 | # we ne longer need to check this - DBIC has ways of dealing with it |
190 | # specifically ::Storage::DBI::_resolve_bindattrs() |
191 | sub _assert_bindval_matches_bindtype () { 1 }; |
192 | |
e39f188a |
193 | # poor man's de-qualifier |
194 | sub _quote { |
a3ae79ed |
195 | $_[0]->next::method( ( $_[0]{_dequalify_idents} and defined $_[1] and ! ref $_[1] ) |
e39f188a |
196 | ? $_[1] =~ / ([^\.]+) $ /x |
197 | : $_[1] |
198 | ); |
199 | } |
200 | |
b1d821de |
201 | sub _where_op_NEST { |
70c28808 |
202 | carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n" |
b1d821de |
203 | .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }| |
70c28808 |
204 | ); |
b1d821de |
205 | |
206 | shift->next::method(@_); |
207 | } |
208 | |
6a247f33 |
209 | # Handle limit-dialect selection |
6f4ddea1 |
210 | sub select { |
6a247f33 |
211 | my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; |
212 | |
02562a20 |
213 | ($fields, @{$self->{select_bind}}) = length ref $fields |
214 | ? $self->_recurse_fields( $fields ) |
215 | : $self->_quote( $fields ) |
216 | ; |
6a247f33 |
217 | |
02562a20 |
218 | # Override the default behavior of SQL::Abstract - SELECT * makes |
219 | # no sense in the context of DBIC (and has resulted in several |
220 | # tricky debugging sessions in the past) |
221 | not length $fields |
222 | and |
223 | # FIXME - some day we need to enable this, but too many things break |
224 | # ( notably S::L ) |
225 | # # Random value selected by a fair roll of dice |
226 | # # In seriousness - this has to be a number, as it is much more |
227 | # # palatable to random engines in a SELECT list |
228 | # $fields = 42 |
229 | # and |
230 | carp_unique ( |
231 | "ResultSets with an empty selection are deprecated (you almost certainly " |
232 | . "did not mean to do that): if this is indeed your intent you must " |
233 | . "explicitly supply \\'*' to your search()" |
234 | ); |
6a247f33 |
235 | |
236 | if (defined $offset) { |
70c28808 |
237 | $self->throw_exception('A supplied offset must be a non-negative integer') |
f033dcbe |
238 | if ( $offset =~ /[^0-9]/ or $offset < 0 ); |
6a247f33 |
239 | } |
240 | $offset ||= 0; |
1cbd3034 |
241 | |
6a247f33 |
242 | if (defined $limit) { |
70c28808 |
243 | $self->throw_exception('A supplied limit must be a positive integer') |
f033dcbe |
244 | if ( $limit =~ /[^0-9]/ or $limit <= 0 ); |
6a247f33 |
245 | } |
246 | elsif ($offset) { |
247 | $limit = $self->__max_int; |
6f4ddea1 |
248 | } |
c2b7c5dc |
249 | |
a6b68a60 |
250 | |
6a247f33 |
251 | my ($sql, @bind); |
252 | if ($limit) { |
253 | # this is legacy code-flow from SQLA::Limit, it is not set in stone |
254 | |
255 | ($sql, @bind) = $self->next::method ($table, $fields, $where); |
256 | |
67341081 |
257 | my $limiter; |
258 | |
259 | if( $limiter = $self->can ('emulate_limit') ) { |
260 | carp_unique( |
261 | 'Support for the legacy emulate_limit() mechanism inherited from ' |
07fadea8 |
262 | . 'SQL::Abstract::Limit has been deprecated, and will be removed at ' |
263 | . 'some future point, as it gets in the way of architectural and/or ' |
264 | . 'performance advances within DBIC. If your code uses this type of ' |
67341081 |
265 | . 'limit specification please file an RT and provide the source of ' |
266 | . 'your emulate_limit() implementation, so an acceptable upgrade-path ' |
267 | . 'can be devised' |
268 | ); |
269 | } |
270 | else { |
271 | my $dialect = $self->limit_dialect |
272 | or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self" ); |
273 | |
274 | $limiter = $self->can ("_$dialect") |
275 | or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'"); |
276 | } |
6a247f33 |
277 | |
f74d22e2 |
278 | $sql = $self->$limiter ( |
279 | $sql, |
280 | { %{$rs_attrs||{}}, _selector_sql => $fields }, |
281 | $limit, |
282 | $offset |
283 | ); |
6a247f33 |
284 | } |
285 | else { |
286 | ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs); |
287 | } |
288 | |
49afd714 |
289 | push @{$self->{where_bind}}, @bind; |
583a0c65 |
290 | |
291 | # this *must* be called, otherwise extra binds will remain in the sql-maker |
49afd714 |
292 | my @all_bind = $self->_assemble_binds; |
583a0c65 |
293 | |
e5372da4 |
294 | $sql .= $self->_lock_select ($rs_attrs->{for}) |
295 | if $rs_attrs->{for}; |
296 | |
49afd714 |
297 | return wantarray ? ($sql, @all_bind) : $sql; |
583a0c65 |
298 | } |
299 | |
300 | sub _assemble_binds { |
301 | my $self = shift; |
8b31f62e |
302 | return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where group having order limit/); |
6f4ddea1 |
303 | } |
304 | |
e5372da4 |
305 | my $for_syntax = { |
306 | update => 'FOR UPDATE', |
307 | shared => 'FOR SHARE', |
308 | }; |
309 | sub _lock_select { |
310 | my ($self, $type) = @_; |
8249c09b |
311 | |
312 | my $sql; |
313 | if (ref($type) eq 'SCALAR') { |
314 | $sql = "FOR $$type"; |
315 | } |
316 | else { |
317 | $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" ); |
318 | } |
319 | |
e5372da4 |
320 | return " $sql"; |
321 | } |
322 | |
6a247f33 |
323 | # Handle default inserts |
6f4ddea1 |
324 | sub insert { |
6a247f33 |
325 | # optimized due to hotttnesss |
326 | # my ($self, $table, $data, $options) = @_; |
7a72e5a5 |
327 | |
07fadea8 |
328 | # FIXME SQLA will emit INSERT INTO $table ( ) VALUES ( ) |
7a72e5a5 |
329 | # which is sadly understood only by MySQL. Change default behavior here, |
07fadea8 |
330 | # until we fold the extra pieces into SQLMaker properly |
6a247f33 |
331 | if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) { |
bf51641f |
332 | my @bind; |
20595c02 |
333 | my $sql = sprintf( |
334 | 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1]) |
335 | ); |
28d28903 |
336 | |
bf51641f |
337 | if ( ($_[3]||{})->{returning} ) { |
338 | my $s; |
339 | ($s, @bind) = $_[0]->_insert_returning ($_[3]); |
340 | $sql .= $s; |
28d28903 |
341 | } |
342 | |
bf51641f |
343 | return ($sql, @bind); |
7a72e5a5 |
344 | } |
345 | |
6a247f33 |
346 | next::method(@_); |
6f4ddea1 |
347 | } |
348 | |
349 | sub _recurse_fields { |
81446c4f |
350 | my ($self, $fields) = @_; |
02562a20 |
351 | |
352 | if( not length ref $fields ) { |
353 | return $self->_quote( $fields ); |
354 | } |
355 | |
356 | elsif( my $lit = is_literal_value( $fields ) ) { |
357 | return @$lit |
358 | } |
359 | |
360 | elsif( ref $fields eq 'ARRAY' ) { |
361 | my (@select, @bind, @bind_fragment); |
362 | |
363 | ( |
364 | ( $select[ $#select + 1 ], @bind_fragment ) = length ref $_ |
365 | ? $self->_recurse_fields( $_ ) |
366 | : $self->_quote( $_ ) |
367 | ), |
368 | ( push @bind, @bind_fragment ) |
369 | for @$fields; |
370 | |
ad1d374e |
371 | return (join(', ', @select), @bind); |
83e09b5b |
372 | } |
02562a20 |
373 | |
374 | # FIXME - really crappy handling of functions |
375 | elsif ( ref $fields eq 'HASH') { |
81446c4f |
376 | my %hash = %$fields; # shallow copy |
83e09b5b |
377 | |
50136dd9 |
378 | my $as = delete $hash{-as}; # if supplied |
379 | |
ad1d374e |
380 | my ($func, $rhs, @toomany) = %hash; |
81446c4f |
381 | |
382 | # there should be only one pair |
02562a20 |
383 | $self->throw_exception( |
384 | "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) |
385 | ) if @toomany; |
386 | |
387 | $self->throw_exception ( |
388 | 'The select => { distinct => ... } syntax is not supported for multiple columns.' |
389 | .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' |
390 | .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' |
391 | ) if ( |
392 | lc ($func) eq 'distinct' |
393 | and |
394 | ref $rhs eq 'ARRAY' |
395 | and |
396 | @$rhs > 1 |
50136dd9 |
397 | ); |
398 | |
02562a20 |
399 | my ($rhs_sql, @rhs_bind) = length ref $rhs |
400 | ? $self->_recurse_fields($rhs) |
401 | : $self->_quote($rhs) |
402 | ; |
403 | |
404 | return( |
405 | sprintf( '%s( %s )%s', |
406 | $self->_sqlcase($func), |
407 | $rhs_sql, |
408 | $as |
409 | ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) |
410 | : '' |
411 | ), |
412 | @rhs_bind |
413 | ); |
6f4ddea1 |
414 | } |
02562a20 |
415 | |
6f4ddea1 |
416 | else { |
02562a20 |
417 | $self->throw_exception( ref($fields) . ' unexpected in _recurse_fields()' ); |
6f4ddea1 |
418 | } |
419 | } |
420 | |
a6b68a60 |
421 | |
422 | # this used to be a part of _order_by but is broken out for clarity. |
423 | # What we have been doing forever is hijacking the $order arg of |
424 | # SQLA::select to pass in arbitrary pieces of data (first the group_by, |
425 | # then pretty much the entire resultset attr-hash, as more and more |
4a0eed52 |
426 | # things in the SQLA space need to have more info about the $rs they |
a6b68a60 |
427 | # create SQL for. The alternative would be to keep expanding the |
428 | # signature of _select with more and more positional parameters, which |
07fadea8 |
429 | # is just gross. |
430 | # |
431 | # FIXME - this will have to transition out to a subclass when the effort |
432 | # of folding the SQLA machinery into SQLMaker takes place |
a6b68a60 |
433 | sub _parse_rs_attrs { |
1cbd3034 |
434 | my ($self, $arg) = @_; |
15827712 |
435 | |
a6b68a60 |
436 | my $sql = ''; |
71b788fb |
437 | my @sqlbind; |
438 | |
439 | if ( |
440 | $arg->{group_by} |
441 | and |
442 | @sqlbind = $self->_recurse_fields($arg->{group_by}) |
443 | ) { |
444 | $sql .= $self->_sqlcase(' group by ') . shift @sqlbind; |
445 | push @{$self->{group_bind}}, @sqlbind; |
a6b68a60 |
446 | } |
1cbd3034 |
447 | |
71b788fb |
448 | if ( |
449 | $arg->{having} |
450 | and |
451 | @sqlbind = $self->_recurse_where($arg->{having}) |
452 | ) { |
453 | $sql .= $self->_sqlcase(' having ') . shift @sqlbind; |
454 | push(@{$self->{having_bind}}, @sqlbind); |
a6b68a60 |
455 | } |
15827712 |
456 | |
71b788fb |
457 | if ($arg->{order_by}) { |
458 | # unlike the 2 above, _order_by injects into @{...bind...} for us |
a6b68a60 |
459 | $sql .= $self->_order_by ($arg->{order_by}); |
460 | } |
15827712 |
461 | |
a6b68a60 |
462 | return $sql; |
463 | } |
464 | |
465 | sub _order_by { |
466 | my ($self, $arg) = @_; |
15827712 |
467 | |
a6b68a60 |
468 | # check that we are not called in legacy mode (order_by as 4th argument) |
71b788fb |
469 | ( |
470 | ref $arg eq 'HASH' |
471 | and |
472 | not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg |
473 | ) |
474 | ? $self->_parse_rs_attrs ($arg) |
475 | : do { |
476 | my ($sql, @bind) = $self->next::method($arg); |
477 | push @{$self->{order_bind}}, @bind; |
478 | $sql; # RV |
479 | } |
480 | ; |
6f4ddea1 |
481 | } |
482 | |
cb3e87f5 |
483 | sub _split_order_chunk { |
484 | my ($self, $chunk) = @_; |
485 | |
486 | # strip off sort modifiers, but always succeed, so $1 gets reset |
487 | $chunk =~ s/ (?: \s+ (ASC|DESC) )? \s* $//ix; |
488 | |
489 | return ( |
490 | $chunk, |
491 | ( $1 and uc($1) eq 'DESC' ) ? 1 : 0, |
492 | ); |
493 | } |
494 | |
6f4ddea1 |
495 | sub _table { |
6a247f33 |
496 | # optimized due to hotttnesss |
497 | # my ($self, $from) = @_; |
498 | if (my $ref = ref $_[1] ) { |
499 | if ($ref eq 'ARRAY') { |
500 | return $_[0]->_recurse_from(@{$_[1]}); |
501 | } |
502 | elsif ($ref eq 'HASH') { |
4c2b30d6 |
503 | return $_[0]->_recurse_from($_[1]); |
6a247f33 |
504 | } |
1bffc6b8 |
505 | elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') { |
506 | my ($sql, @bind) = @{ ${$_[1]} }; |
507 | push @{$_[0]->{from_bind}}, @bind; |
508 | return $sql |
509 | } |
6f4ddea1 |
510 | } |
6a247f33 |
511 | return $_[0]->next::method ($_[1]); |
6f4ddea1 |
512 | } |
513 | |
b8391c87 |
514 | sub _generate_join_clause { |
515 | my ($self, $join_type) = @_; |
516 | |
726c8f65 |
517 | $join_type = $self->{_default_jointype} |
518 | if ! defined $join_type; |
519 | |
b8391c87 |
520 | return sprintf ('%s JOIN ', |
726c8f65 |
521 | $join_type ? $self->_sqlcase($join_type) : '' |
b8391c87 |
522 | ); |
523 | } |
524 | |
6f4ddea1 |
525 | sub _recurse_from { |
726c8f65 |
526 | my $self = shift; |
726c8f65 |
527 | return join (' ', $self->_gen_from_blocks(@_) ); |
528 | } |
529 | |
530 | sub _gen_from_blocks { |
531 | my ($self, $from, @joins) = @_; |
532 | |
533 | my @fchunks = $self->_from_chunk_to_sql($from); |
6f4ddea1 |
534 | |
726c8f65 |
535 | for (@joins) { |
4c2b30d6 |
536 | my ($to, $on) = @$_; |
aa82ce29 |
537 | |
6f4ddea1 |
538 | # check whether a join type exists |
6f4ddea1 |
539 | my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to; |
aa82ce29 |
540 | my $join_type; |
541 | if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) { |
542 | $join_type = $to_jt->{-join_type}; |
543 | $join_type =~ s/^\s+ | \s+$//xg; |
6f4ddea1 |
544 | } |
aa82ce29 |
545 | |
726c8f65 |
546 | my @j = $self->_generate_join_clause( $join_type ); |
6f4ddea1 |
547 | |
548 | if (ref $to eq 'ARRAY') { |
726c8f65 |
549 | push(@j, '(', $self->_recurse_from(@$to), ')'); |
550 | } |
551 | else { |
552 | push(@j, $self->_from_chunk_to_sql($to)); |
6f4ddea1 |
553 | } |
726c8f65 |
554 | |
a697fa31 |
555 | my ($sql, @bind) = $self->_join_condition($on); |
b4e9f590 |
556 | push(@j, ' ON ', $sql); |
a697fa31 |
557 | push @{$self->{from_bind}}, @bind; |
726c8f65 |
558 | |
559 | push @fchunks, join '', @j; |
6f4ddea1 |
560 | } |
726c8f65 |
561 | |
562 | return @fchunks; |
6f4ddea1 |
563 | } |
564 | |
4c2b30d6 |
565 | sub _from_chunk_to_sql { |
566 | my ($self, $fromspec) = @_; |
567 | |
e8885a53 |
568 | return join (' ', do { |
569 | if (! ref $fromspec) { |
570 | $self->_quote($fromspec); |
571 | } |
572 | elsif (ref $fromspec eq 'SCALAR') { |
4c2b30d6 |
573 | $$fromspec; |
e8885a53 |
574 | } |
575 | elsif (ref $fromspec eq 'REF' and ref $$fromspec eq 'ARRAY') { |
4c2b30d6 |
576 | push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec]; |
577 | $$fromspec->[0]; |
e8885a53 |
578 | } |
579 | elsif (ref $fromspec eq 'HASH') { |
4c2b30d6 |
580 | my ($as, $table, $toomuch) = ( map |
581 | { $_ => $fromspec->{$_} } |
582 | ( grep { $_ !~ /^\-/ } keys %$fromspec ) |
583 | ); |
6f4ddea1 |
584 | |
70c28808 |
585 | $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" ) |
4c2b30d6 |
586 | if defined $toomuch; |
6f4ddea1 |
587 | |
4c2b30d6 |
588 | ($self->_from_chunk_to_sql($table), $self->_quote($as) ); |
e8885a53 |
589 | } |
590 | else { |
591 | $self->throw_exception('Unsupported from refkind: ' . ref $fromspec ); |
592 | } |
593 | }); |
6f4ddea1 |
594 | } |
595 | |
596 | sub _join_condition { |
597 | my ($self, $cond) = @_; |
4c2b30d6 |
598 | |
a697fa31 |
599 | # Backcompat for the old days when a plain hashref |
600 | # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2 |
a697fa31 |
601 | if ( |
602 | ref $cond eq 'HASH' |
603 | and |
604 | keys %$cond == 1 |
605 | and |
606 | (keys %$cond)[0] =~ /\./ |
607 | and |
608 | ! ref ( (values %$cond)[0] ) |
609 | ) { |
1efc866d |
610 | carp_unique( |
611 | "ResultSet {from} structures with conditions not conforming to the " |
612 | . "SQL::Abstract syntax are deprecated: you either need to stop abusing " |
613 | . "{from} altogether, or express the condition properly using the " |
614 | . "{ -ident => ... } operator" |
615 | ); |
a697fa31 |
616 | $cond = { keys %$cond => { -ident => values %$cond } } |
6f4ddea1 |
617 | } |
a697fa31 |
618 | elsif ( ref $cond eq 'ARRAY' ) { |
619 | # do our own ORing so that the hashref-shim above is invoked |
9aae3566 |
620 | my @parts; |
621 | my @binds; |
622 | foreach my $c (@$cond) { |
623 | my ($sql, @bind) = $self->_join_condition($c); |
624 | push @binds, @bind; |
625 | push @parts, $sql; |
626 | } |
627 | return join(' OR ', @parts), @binds; |
6f4ddea1 |
628 | } |
a697fa31 |
629 | |
630 | return $self->_recurse_where($cond); |
6f4ddea1 |
631 | } |
632 | |
07fadea8 |
633 | # !!! EXPERIMENTAL API !!! WILL CHANGE !!! |
634 | # |
635 | # This is rather odd, but vanilla SQLA does not have support for multicolumn IN |
636 | # expressions |
637 | # Currently has only one callsite in ResultSet, body moved into this subclass |
638 | # of SQLA to raise API questions like: |
639 | # - how do we convey a list of idents...? |
640 | # - can binds reside on lhs? |
66137dff |
641 | # |
642 | # !!! EXPERIMENTAL API !!! WILL CHANGE !!! |
643 | sub _where_op_multicolumn_in { |
644 | my ($self, $lhs, $rhs) = @_; |
645 | |
646 | if (! ref $lhs or ref $lhs eq 'ARRAY') { |
647 | my (@sql, @bind); |
648 | for (ref $lhs ? @$lhs : $lhs) { |
649 | if (! ref $_) { |
650 | push @sql, $self->_quote($_); |
651 | } |
652 | elsif (ref $_ eq 'SCALAR') { |
653 | push @sql, $$_; |
654 | } |
655 | elsif (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') { |
656 | my ($s, @b) = @$$_; |
657 | push @sql, $s; |
658 | push @bind, @b; |
659 | } |
660 | else { |
661 | $self->throw_exception("ARRAY of @{[ ref $_ ]}es unsupported for multicolumn IN lhs..."); |
662 | } |
663 | } |
664 | $lhs = \[ join(', ', @sql), @bind]; |
665 | } |
666 | elsif (ref $lhs eq 'SCALAR') { |
667 | $lhs = \[ $$lhs ]; |
668 | } |
669 | elsif (ref $lhs eq 'REF' and ref $$lhs eq 'ARRAY' ) { |
670 | # noop |
671 | } |
672 | else { |
673 | $self->throw_exception( ref($lhs) . "es unsupported for multicolumn IN lhs..."); |
674 | } |
675 | |
676 | # is this proper...? |
677 | $rhs = \[ $self->_recurse_where($rhs) ]; |
678 | |
679 | for ($lhs, $rhs) { |
680 | $$_->[0] = "( $$_->[0] )" |
1d1ccc94 |
681 | unless $$_->[0] =~ /^ \s* \( .* \) \s* $/xs; |
66137dff |
682 | } |
683 | |
684 | \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ]; |
685 | } |
686 | |
a2bd3796 |
687 | =head1 FURTHER QUESTIONS? |
d5dedbd6 |
688 | |
a2bd3796 |
689 | Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. |
d5dedbd6 |
690 | |
a2bd3796 |
691 | =head1 COPYRIGHT AND LICENSE |
d5dedbd6 |
692 | |
a2bd3796 |
693 | This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> |
694 | by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can |
695 | redistribute it and/or modify it under the same terms as the |
696 | L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. |
d5dedbd6 |
697 | |
698 | =cut |
a2bd3796 |
699 | |
700 | 1; |