squash, fixes subquery with insert_bulk
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / SQLMaker.pm
CommitLineData
d5dedbd6 1package DBIx::Class::SQLMaker;
6f4ddea1 2
a697fa31 3use strict;
4use warnings;
5
d5dedbd6 6=head1 NAME
7
8DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
9
10=head1 DESCRIPTION
11
12This module is a subclass of L<SQL::Abstract> and includes a number of
13DBIC-specific workarounds, not yet suitable for inclusion into the
14L<SQL::Abstract> core. It also provides all (and more than) the functionality
15of L<SQL::Abstract::Limit>, see L<DBIx::Class::SQLMaker::LimitDialects> for
16more info.
17
18Currently the enhancements to L<SQL::Abstract> are:
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
28=item * Support of C<...FOR UPDATE> type of select statement modifiers
29
30=back
31
32=cut
6a247f33 33
34use base qw/
d5dedbd6 35 DBIx::Class::SQLMaker::LimitDialects
6a247f33 36 SQL::Abstract
70c28808 37 DBIx::Class
6a247f33 38/;
39use mro 'c3';
a697fa31 40
6298a324 41use Sub::Name 'subname';
70c28808 42use DBIx::Class::Carp;
e8fc51c7 43use namespace::clean;
b2b22cd6 44
6a247f33 45__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
46
3f5b99fe 47# for when I need a normalized l/r pair
48sub _quote_chars {
49 map
50 { defined $_ ? $_ : '' }
51 ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
52 ;
53}
54
70c28808 55# FIXME when we bring in the storage weaklink, check its schema
56# weaklink and channel through $schema->throw_exception
57sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
58
b2b22cd6 59BEGIN {
2ea6032a 60 # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
70c28808 61 # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
b2b22cd6 62 no warnings qw/redefine/;
2ea6032a 63
64 *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
65 my($func) = (caller(1))[3];
66 carp "[$func] Warning: ", @_;
67 };
68
69 *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
70 my($func) = (caller(1))[3];
70c28808 71 __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
2ea6032a 72 };
b2b22cd6 73}
6f4ddea1 74
e9657379 75# the "oh noes offset/top without limit" constant
fcb7fcbb 76# limited to 31 bits for sanity (and consistency,
77# since it may be handed to the like of sprintf %u)
78#
79# Also *some* builds of SQLite fail the test
80# some_column BETWEEN ? AND ?: 1, 4294967295
81# with the proper integer bind attrs
82#
6a247f33 83# Implemented as a method, since ::Storage::DBI also
84# refers to it (i.e. for the case of software_limit or
85# as the value to abuse with MSSQL ordered subqueries)
fcb7fcbb 86sub __max_int () { 0x7FFFFFFF };
e9657379 87
1b5ddf23 88# we ne longer need to check this - DBIC has ways of dealing with it
89# specifically ::Storage::DBI::_resolve_bindattrs()
90sub _assert_bindval_matches_bindtype () { 1 };
91
e39f188a 92# poor man's de-qualifier
93sub _quote {
94 $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
95 ? $_[1] =~ / ([^\.]+) $ /x
96 : $_[1]
97 );
98}
99
b1d821de 100sub _where_op_NEST {
70c28808 101 carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
b1d821de 102 .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
70c28808 103 );
b1d821de 104
105 shift->next::method(@_);
106}
107
6a247f33 108# Handle limit-dialect selection
6f4ddea1 109sub select {
6a247f33 110 my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
111
112
113 $fields = $self->_recurse_fields($fields);
114
115 if (defined $offset) {
70c28808 116 $self->throw_exception('A supplied offset must be a non-negative integer')
6a247f33 117 if ( $offset =~ /\D/ or $offset < 0 );
118 }
119 $offset ||= 0;
1cbd3034 120
6a247f33 121 if (defined $limit) {
70c28808 122 $self->throw_exception('A supplied limit must be a positive integer')
6a247f33 123 if ( $limit =~ /\D/ or $limit <= 0 );
124 }
125 elsif ($offset) {
126 $limit = $self->__max_int;
6f4ddea1 127 }
c2b7c5dc 128
a6b68a60 129
6a247f33 130 my ($sql, @bind);
131 if ($limit) {
132 # this is legacy code-flow from SQLA::Limit, it is not set in stone
133
134 ($sql, @bind) = $self->next::method ($table, $fields, $where);
135
67341081 136 my $limiter;
137
138 if( $limiter = $self->can ('emulate_limit') ) {
139 carp_unique(
140 'Support for the legacy emulate_limit() mechanism inherited from '
141 . 'SQL::Abstract::Limit has been deprecated, and will be removed when '
142 . 'DBIC transitions to Data::Query. If your code uses this type of '
143 . 'limit specification please file an RT and provide the source of '
144 . 'your emulate_limit() implementation, so an acceptable upgrade-path '
145 . 'can be devised'
146 );
147 }
148 else {
149 my $dialect = $self->limit_dialect
150 or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self" );
151
152 $limiter = $self->can ("_$dialect")
153 or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
154 }
6a247f33 155
f74d22e2 156 $sql = $self->$limiter (
157 $sql,
158 { %{$rs_attrs||{}}, _selector_sql => $fields },
159 $limit,
160 $offset
161 );
6a247f33 162 }
163 else {
164 ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
165 }
166
49afd714 167 push @{$self->{where_bind}}, @bind;
583a0c65 168
169# this *must* be called, otherwise extra binds will remain in the sql-maker
49afd714 170 my @all_bind = $self->_assemble_binds;
583a0c65 171
e5372da4 172 $sql .= $self->_lock_select ($rs_attrs->{for})
173 if $rs_attrs->{for};
174
49afd714 175 return wantarray ? ($sql, @all_bind) : $sql;
583a0c65 176}
177
178sub _assemble_binds {
179 my $self = shift;
8b31f62e 180 return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where group having order limit/);
6f4ddea1 181}
182
e5372da4 183my $for_syntax = {
184 update => 'FOR UPDATE',
185 shared => 'FOR SHARE',
186};
187sub _lock_select {
188 my ($self, $type) = @_;
8249c09b 189
190 my $sql;
191 if (ref($type) eq 'SCALAR') {
192 $sql = "FOR $$type";
193 }
194 else {
195 $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
196 }
197
e5372da4 198 return " $sql";
199}
200
6a247f33 201# Handle default inserts
6f4ddea1 202sub insert {
6a247f33 203# optimized due to hotttnesss
204# my ($self, $table, $data, $options) = @_;
7a72e5a5 205
206 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
207 # which is sadly understood only by MySQL. Change default behavior here,
208 # until SQLA2 comes with proper dialect support
6a247f33 209 if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
bf51641f 210 my @bind;
20595c02 211 my $sql = sprintf(
212 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
213 );
28d28903 214
bf51641f 215 if ( ($_[3]||{})->{returning} ) {
216 my $s;
217 ($s, @bind) = $_[0]->_insert_returning ($_[3]);
218 $sql .= $s;
28d28903 219 }
220
bf51641f 221 return ($sql, @bind);
7a72e5a5 222 }
223
6a247f33 224 next::method(@_);
6f4ddea1 225}
226
d2404c3b 227sub _insert_ARRAYREFREF {
228 my ($self, $data) = @_;
229
750ff9db 230 my ($cols, $subquery) = @$$data;
231 if (not $subquery) {
d2404c3b 232 return next::method($self, $cols);
233 }
234
d2404c3b 235 my @fields = sort @$cols;
236
750ff9db 237 my ($sql, @bind) = next::method($self, $subquery);
d2404c3b 238
750ff9db 239 # as_query wraps in brackets. drop them
240 $_ = $self->_quote($_) for @fields;
241 $sql = "( ".join(", ", @fields).") " . substr($sql, 1, -1);
d2404c3b 242
243 return ($sql, @bind);
d2404c3b 244}
245
6f4ddea1 246sub _recurse_fields {
81446c4f 247 my ($self, $fields) = @_;
6f4ddea1 248 my $ref = ref $fields;
249 return $self->_quote($fields) unless $ref;
250 return $$fields if $ref eq 'SCALAR';
251
252 if ($ref eq 'ARRAY') {
81446c4f 253 return join(', ', map { $self->_recurse_fields($_) } @$fields);
83e09b5b 254 }
255 elsif ($ref eq 'HASH') {
81446c4f 256 my %hash = %$fields; # shallow copy
83e09b5b 257
50136dd9 258 my $as = delete $hash{-as}; # if supplied
259
81446c4f 260 my ($func, $args, @toomany) = %hash;
261
262 # there should be only one pair
263 if (@toomany) {
70c28808 264 $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
81446c4f 265 }
50136dd9 266
267 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
70c28808 268 $self->throw_exception (
50136dd9 269 'The select => { distinct => ... } syntax is not supported for multiple columns.'
270 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
271 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
83e09b5b 272 );
6f4ddea1 273 }
83e09b5b 274
50136dd9 275 my $select = sprintf ('%s( %s )%s',
276 $self->_sqlcase($func),
277 $self->_recurse_fields($args),
278 $as
0491b597 279 ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
50136dd9 280 : ''
281 );
282
83e09b5b 283 return $select;
6f4ddea1 284 }
285 # Is the second check absolutely necessary?
286 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
4c2b30d6 287 push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
288 return $$fields->[0];
6f4ddea1 289 }
290 else {
70c28808 291 $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
6f4ddea1 292 }
293}
294
a6b68a60 295
296# this used to be a part of _order_by but is broken out for clarity.
297# What we have been doing forever is hijacking the $order arg of
298# SQLA::select to pass in arbitrary pieces of data (first the group_by,
299# then pretty much the entire resultset attr-hash, as more and more
4a0eed52 300# things in the SQLA space need to have more info about the $rs they
a6b68a60 301# create SQL for. The alternative would be to keep expanding the
302# signature of _select with more and more positional parameters, which
303# is just gross. All hail SQLA2!
304sub _parse_rs_attrs {
1cbd3034 305 my ($self, $arg) = @_;
15827712 306
a6b68a60 307 my $sql = '';
1cbd3034 308
0542ec57 309 if ($arg->{group_by}) {
a4f0b0ab 310 # horrible horrible, waiting for refactor
0542ec57 311 local $self->{select_bind};
312 if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
313 $sql .= $self->_sqlcase(' group by ') . $g;
314 push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
315 }
a6b68a60 316 }
1cbd3034 317
a6b68a60 318 if (defined $arg->{having}) {
319 my ($frag, @bind) = $self->_recurse_where($arg->{having});
320 push(@{$self->{having_bind}}, @bind);
321 $sql .= $self->_sqlcase(' having ') . $frag;
322 }
15827712 323
a6b68a60 324 if (defined $arg->{order_by}) {
325 $sql .= $self->_order_by ($arg->{order_by});
326 }
15827712 327
a6b68a60 328 return $sql;
329}
330
331sub _order_by {
332 my ($self, $arg) = @_;
15827712 333
a6b68a60 334 # check that we are not called in legacy mode (order_by as 4th argument)
335 if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
336 return $self->_parse_rs_attrs ($arg);
fde3719a 337 }
1cbd3034 338 else {
6a247f33 339 my ($sql, @bind) = $self->next::method($arg);
a6b68a60 340 push @{$self->{order_bind}}, @bind;
1cbd3034 341 return $sql;
fd4cb60a 342 }
6f4ddea1 343}
344
cb3e87f5 345sub _split_order_chunk {
346 my ($self, $chunk) = @_;
347
348 # strip off sort modifiers, but always succeed, so $1 gets reset
349 $chunk =~ s/ (?: \s+ (ASC|DESC) )? \s* $//ix;
350
351 return (
352 $chunk,
353 ( $1 and uc($1) eq 'DESC' ) ? 1 : 0,
354 );
355}
356
6f4ddea1 357sub _table {
6a247f33 358# optimized due to hotttnesss
359# my ($self, $from) = @_;
360 if (my $ref = ref $_[1] ) {
361 if ($ref eq 'ARRAY') {
362 return $_[0]->_recurse_from(@{$_[1]});
363 }
364 elsif ($ref eq 'HASH') {
4c2b30d6 365 return $_[0]->_recurse_from($_[1]);
6a247f33 366 }
1bffc6b8 367 elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
368 my ($sql, @bind) = @{ ${$_[1]} };
369 push @{$_[0]->{from_bind}}, @bind;
370 return $sql
371 }
6f4ddea1 372 }
6a247f33 373 return $_[0]->next::method ($_[1]);
6f4ddea1 374}
375
b8391c87 376sub _generate_join_clause {
377 my ($self, $join_type) = @_;
378
726c8f65 379 $join_type = $self->{_default_jointype}
380 if ! defined $join_type;
381
b8391c87 382 return sprintf ('%s JOIN ',
726c8f65 383 $join_type ? $self->_sqlcase($join_type) : ''
b8391c87 384 );
385}
386
6f4ddea1 387sub _recurse_from {
726c8f65 388 my $self = shift;
726c8f65 389 return join (' ', $self->_gen_from_blocks(@_) );
390}
391
392sub _gen_from_blocks {
393 my ($self, $from, @joins) = @_;
394
395 my @fchunks = $self->_from_chunk_to_sql($from);
6f4ddea1 396
726c8f65 397 for (@joins) {
4c2b30d6 398 my ($to, $on) = @$_;
aa82ce29 399
6f4ddea1 400 # check whether a join type exists
6f4ddea1 401 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
aa82ce29 402 my $join_type;
403 if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
404 $join_type = $to_jt->{-join_type};
405 $join_type =~ s/^\s+ | \s+$//xg;
6f4ddea1 406 }
aa82ce29 407
726c8f65 408 my @j = $self->_generate_join_clause( $join_type );
6f4ddea1 409
410 if (ref $to eq 'ARRAY') {
726c8f65 411 push(@j, '(', $self->_recurse_from(@$to), ')');
412 }
413 else {
414 push(@j, $self->_from_chunk_to_sql($to));
6f4ddea1 415 }
726c8f65 416
a697fa31 417 my ($sql, @bind) = $self->_join_condition($on);
b4e9f590 418 push(@j, ' ON ', $sql);
a697fa31 419 push @{$self->{from_bind}}, @bind;
726c8f65 420
421 push @fchunks, join '', @j;
6f4ddea1 422 }
726c8f65 423
424 return @fchunks;
6f4ddea1 425}
426
4c2b30d6 427sub _from_chunk_to_sql {
428 my ($self, $fromspec) = @_;
429
e8885a53 430 return join (' ', do {
431 if (! ref $fromspec) {
432 $self->_quote($fromspec);
433 }
434 elsif (ref $fromspec eq 'SCALAR') {
4c2b30d6 435 $$fromspec;
e8885a53 436 }
437 elsif (ref $fromspec eq 'REF' and ref $$fromspec eq 'ARRAY') {
4c2b30d6 438 push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
439 $$fromspec->[0];
e8885a53 440 }
441 elsif (ref $fromspec eq 'HASH') {
4c2b30d6 442 my ($as, $table, $toomuch) = ( map
443 { $_ => $fromspec->{$_} }
444 ( grep { $_ !~ /^\-/ } keys %$fromspec )
445 );
6f4ddea1 446
70c28808 447 $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
4c2b30d6 448 if defined $toomuch;
6f4ddea1 449
4c2b30d6 450 ($self->_from_chunk_to_sql($table), $self->_quote($as) );
e8885a53 451 }
452 else {
453 $self->throw_exception('Unsupported from refkind: ' . ref $fromspec );
454 }
455 });
6f4ddea1 456}
457
458sub _join_condition {
459 my ($self, $cond) = @_;
4c2b30d6 460
a697fa31 461 # Backcompat for the old days when a plain hashref
462 # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
463 # Once things settle we should start warning here so that
464 # folks unroll their hacks
465 if (
466 ref $cond eq 'HASH'
467 and
468 keys %$cond == 1
469 and
470 (keys %$cond)[0] =~ /\./
471 and
472 ! ref ( (values %$cond)[0] )
473 ) {
474 $cond = { keys %$cond => { -ident => values %$cond } }
6f4ddea1 475 }
a697fa31 476 elsif ( ref $cond eq 'ARRAY' ) {
477 # do our own ORing so that the hashref-shim above is invoked
9aae3566 478 my @parts;
479 my @binds;
480 foreach my $c (@$cond) {
481 my ($sql, @bind) = $self->_join_condition($c);
482 push @binds, @bind;
483 push @parts, $sql;
484 }
485 return join(' OR ', @parts), @binds;
6f4ddea1 486 }
a697fa31 487
488 return $self->_recurse_where($cond);
6f4ddea1 489}
490
66137dff 491# This is hideously ugly, but SQLA does not understand multicol IN expressions
492# FIXME TEMPORARY - DQ should have native syntax for this
493# moved here to raise API questions
494#
495# !!! EXPERIMENTAL API !!! WILL CHANGE !!!
496sub _where_op_multicolumn_in {
497 my ($self, $lhs, $rhs) = @_;
498
499 if (! ref $lhs or ref $lhs eq 'ARRAY') {
500 my (@sql, @bind);
501 for (ref $lhs ? @$lhs : $lhs) {
502 if (! ref $_) {
503 push @sql, $self->_quote($_);
504 }
505 elsif (ref $_ eq 'SCALAR') {
506 push @sql, $$_;
507 }
508 elsif (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') {
509 my ($s, @b) = @$$_;
510 push @sql, $s;
511 push @bind, @b;
512 }
513 else {
514 $self->throw_exception("ARRAY of @{[ ref $_ ]}es unsupported for multicolumn IN lhs...");
515 }
516 }
517 $lhs = \[ join(', ', @sql), @bind];
518 }
519 elsif (ref $lhs eq 'SCALAR') {
520 $lhs = \[ $$lhs ];
521 }
522 elsif (ref $lhs eq 'REF' and ref $$lhs eq 'ARRAY' ) {
523 # noop
524 }
525 else {
526 $self->throw_exception( ref($lhs) . "es unsupported for multicolumn IN lhs...");
527 }
528
529 # is this proper...?
530 $rhs = \[ $self->_recurse_where($rhs) ];
531
532 for ($lhs, $rhs) {
533 $$_->[0] = "( $$_->[0] )"
534 unless $$_->[0] =~ /^ \s* \( .* \) \s* ^/xs;
535 }
536
537 \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ];
538}
539
6f4ddea1 5401;
d5dedbd6 541
542=head1 AUTHORS
543
544See L<DBIx::Class/CONTRIBUTORS>.
545
546=head1 LICENSE
547
548You may distribute this code under the same terms as Perl itself.
549
550=cut