Switch several caller() invocations to explicit CORE::caller()
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / SQLMaker.pm
1 package DBIx::Class::SQLMaker;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
9
10 =head1 DESCRIPTION
11
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
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
18 Currently the enhancements over 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 * A rudimentary multicolumn IN operator
29
30 =item * Support of C<...FOR UPDATE> type of select statement modifiers
31
32 =back
33
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
93 |http://github.com/dbsrgits/dbix-class/blob/current/blead/lib/DBIx/Class/Storage/DBIHacks.pm>
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
124 =cut
125
126 use base qw/
127   DBIx::Class::SQLMaker::LimitDialects
128   SQL::Abstract
129   DBIx::Class
130 /;
131 use mro 'c3';
132
133 use Sub::Name 'subname';
134 use DBIx::Class::Carp;
135 use namespace::clean;
136
137 __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
138
139 sub _quoting_enabled {
140   ( defined $_[0]->{quote_char} and length $_[0]->{quote_char} ) ? 1 : 0
141 }
142
143 # for when I need a normalized l/r pair
144 sub _quote_chars {
145
146   # in case we are called in the old !!$sm->_quote_chars fashion
147   return () if !wantarray and ( ! defined $_[0]->{quote_char} or ! length $_[0]->{quote_char} );
148
149   map
150     { defined $_ ? $_ : '' }
151     ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
152   ;
153 }
154
155 # FIXME when we bring in the storage weaklink, check its schema
156 # weaklink and channel through $schema->throw_exception
157 sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
158
159 BEGIN {
160   # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
161   # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
162   no warnings qw/redefine/;
163
164   *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
165     my($func) = (caller(1))[3];
166     carp "[$func] Warning: ", @_;
167   };
168
169   *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
170     my($func) = (caller(1))[3];
171     __PACKAGE__->throw_exception("[$func] Fatal: " . join ('',  @_));
172   };
173 }
174
175 # the "oh noes offset/top without limit" constant
176 # limited to 31 bits for sanity (and consistency,
177 # since it may be handed to the like of sprintf %u)
178 #
179 # Also *some* builds of SQLite fail the test
180 #   some_column BETWEEN ? AND ?: 1, 4294967295
181 # with the proper integer bind attrs
182 #
183 # Implemented as a method, since ::Storage::DBI also
184 # refers to it (i.e. for the case of software_limit or
185 # as the value to abuse with MSSQL ordered subqueries)
186 sub __max_int () { 0x7FFFFFFF };
187
188 # we ne longer need to check this - DBIC has ways of dealing with it
189 # specifically ::Storage::DBI::_resolve_bindattrs()
190 sub _assert_bindval_matches_bindtype () { 1 };
191
192 # poor man's de-qualifier
193 sub _quote {
194   $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
195     ? $_[1] =~ / ([^\.]+) $ /x
196     : $_[1]
197   );
198 }
199
200 sub _where_op_NEST {
201   carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
202       .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
203   );
204
205   shift->next::method(@_);
206 }
207
208 # Handle limit-dialect selection
209 sub select {
210   my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
211
212
213   ($fields, @{$self->{select_bind}}) = $self->_recurse_fields($fields);
214
215   if (defined $offset) {
216     $self->throw_exception('A supplied offset must be a non-negative integer')
217       if ( $offset =~ /\D/ or $offset < 0 );
218   }
219   $offset ||= 0;
220
221   if (defined $limit) {
222     $self->throw_exception('A supplied limit must be a positive integer')
223       if ( $limit =~ /\D/ or $limit <= 0 );
224   }
225   elsif ($offset) {
226     $limit = $self->__max_int;
227   }
228
229
230   my ($sql, @bind);
231   if ($limit) {
232     # this is legacy code-flow from SQLA::Limit, it is not set in stone
233
234     ($sql, @bind) = $self->next::method ($table, $fields, $where);
235
236     my $limiter;
237
238     if( $limiter = $self->can ('emulate_limit') ) {
239       carp_unique(
240         'Support for the legacy emulate_limit() mechanism inherited from '
241       . 'SQL::Abstract::Limit has been deprecated, and will be removed at '
242       . 'some future point, as it gets in the way of architectural and/or '
243       . 'performance advances within DBIC. If your code uses this type of '
244       . 'limit specification please file an RT and provide the source of '
245       . 'your emulate_limit() implementation, so an acceptable upgrade-path '
246       . 'can be devised'
247       );
248     }
249     else {
250       my $dialect = $self->limit_dialect
251         or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self" );
252
253       $limiter = $self->can ("_$dialect")
254         or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
255     }
256
257     $sql = $self->$limiter (
258       $sql,
259       { %{$rs_attrs||{}}, _selector_sql => $fields },
260       $limit,
261       $offset
262     );
263   }
264   else {
265     ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
266   }
267
268   push @{$self->{where_bind}}, @bind;
269
270 # this *must* be called, otherwise extra binds will remain in the sql-maker
271   my @all_bind = $self->_assemble_binds;
272
273   $sql .= $self->_lock_select ($rs_attrs->{for})
274     if $rs_attrs->{for};
275
276   return wantarray ? ($sql, @all_bind) : $sql;
277 }
278
279 sub _assemble_binds {
280   my $self = shift;
281   return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where group having order limit/);
282 }
283
284 my $for_syntax = {
285   update => 'FOR UPDATE',
286   shared => 'FOR SHARE',
287 };
288 sub _lock_select {
289   my ($self, $type) = @_;
290
291   my $sql;
292   if (ref($type) eq 'SCALAR') {
293     $sql = "FOR $$type";
294   }
295   else {
296     $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
297   }
298
299   return " $sql";
300 }
301
302 # Handle default inserts
303 sub insert {
304 # optimized due to hotttnesss
305 #  my ($self, $table, $data, $options) = @_;
306
307   # FIXME SQLA will emit INSERT INTO $table ( ) VALUES ( )
308   # which is sadly understood only by MySQL. Change default behavior here,
309   # until we fold the extra pieces into SQLMaker properly
310   if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
311     my @bind;
312     my $sql = sprintf(
313       'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
314     );
315
316     if ( ($_[3]||{})->{returning} ) {
317       my $s;
318       ($s, @bind) = $_[0]->_insert_returning ($_[3]);
319       $sql .= $s;
320     }
321
322     return ($sql, @bind);
323   }
324
325   next::method(@_);
326 }
327
328 sub _recurse_fields {
329   my ($self, $fields) = @_;
330   my $ref = ref $fields;
331   return $self->_quote($fields) unless $ref;
332   return $$fields if $ref eq 'SCALAR';
333
334   if ($ref eq 'ARRAY') {
335     my (@select, @bind);
336     for my $field (@$fields) {
337       my ($select, @new_bind) = $self->_recurse_fields($field);
338       push @select, $select;
339       push @bind, @new_bind;
340     }
341     return (join(', ', @select), @bind);
342   }
343   elsif ($ref eq 'HASH') {
344     my %hash = %$fields;  # shallow copy
345
346     my $as = delete $hash{-as};   # if supplied
347
348     my ($func, $rhs, @toomany) = %hash;
349
350     # there should be only one pair
351     if (@toomany) {
352       $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
353     }
354
355     if (lc ($func) eq 'distinct' && ref $rhs eq 'ARRAY' && @$rhs > 1) {
356       $self->throw_exception (
357         'The select => { distinct => ... } syntax is not supported for multiple columns.'
358        .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }'
359        .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }'
360       );
361     }
362
363     my ($rhs_sql, @rhs_bind) = $self->_recurse_fields($rhs);
364     my $select = sprintf ('%s( %s )%s',
365       $self->_sqlcase($func),
366       $rhs_sql,
367       $as
368         ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
369         : ''
370     );
371
372     return ($select, @rhs_bind);
373   }
374   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
375     return @{$$fields};
376   }
377   else {
378     $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
379   }
380 }
381
382
383 # this used to be a part of _order_by but is broken out for clarity.
384 # What we have been doing forever is hijacking the $order arg of
385 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
386 # then pretty much the entire resultset attr-hash, as more and more
387 # things in the SQLA space need to have more info about the $rs they
388 # create SQL for. The alternative would be to keep expanding the
389 # signature of _select with more and more positional parameters, which
390 # is just gross.
391 #
392 # FIXME - this will have to transition out to a subclass when the effort
393 # of folding the SQLA machinery into SQLMaker takes place
394 sub _parse_rs_attrs {
395   my ($self, $arg) = @_;
396
397   my $sql = '';
398   my @sqlbind;
399
400   if (
401     $arg->{group_by}
402       and
403     @sqlbind = $self->_recurse_fields($arg->{group_by})
404   ) {
405     $sql .= $self->_sqlcase(' group by ') . shift @sqlbind;
406     push @{$self->{group_bind}}, @sqlbind;
407   }
408
409   if (
410     $arg->{having}
411       and
412     @sqlbind = $self->_recurse_where($arg->{having})
413   ) {
414     $sql .= $self->_sqlcase(' having ') . shift @sqlbind;
415     push(@{$self->{having_bind}}, @sqlbind);
416   }
417
418   if ($arg->{order_by}) {
419     # unlike the 2 above, _order_by injects into @{...bind...} for us
420     $sql .= $self->_order_by ($arg->{order_by});
421   }
422
423   return $sql;
424 }
425
426 sub _order_by {
427   my ($self, $arg) = @_;
428
429   # check that we are not called in legacy mode (order_by as 4th argument)
430   (
431     ref $arg eq 'HASH'
432       and
433     not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg
434   )
435     ? $self->_parse_rs_attrs ($arg)
436     : do {
437       my ($sql, @bind) = $self->next::method($arg);
438       push @{$self->{order_bind}}, @bind;
439       $sql; # RV
440     }
441   ;
442 }
443
444 sub _split_order_chunk {
445   my ($self, $chunk) = @_;
446
447   # strip off sort modifiers, but always succeed, so $1 gets reset
448   $chunk =~ s/ (?: \s+ (ASC|DESC) )? \s* $//ix;
449
450   return (
451     $chunk,
452     ( $1 and uc($1) eq 'DESC' ) ? 1 : 0,
453   );
454 }
455
456 sub _table {
457 # optimized due to hotttnesss
458 #  my ($self, $from) = @_;
459   if (my $ref = ref $_[1] ) {
460     if ($ref eq 'ARRAY') {
461       return $_[0]->_recurse_from(@{$_[1]});
462     }
463     elsif ($ref eq 'HASH') {
464       return $_[0]->_recurse_from($_[1]);
465     }
466     elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
467       my ($sql, @bind) = @{ ${$_[1]} };
468       push @{$_[0]->{from_bind}}, @bind;
469       return $sql
470     }
471   }
472   return $_[0]->next::method ($_[1]);
473 }
474
475 sub _generate_join_clause {
476     my ($self, $join_type) = @_;
477
478     $join_type = $self->{_default_jointype}
479       if ! defined $join_type;
480
481     return sprintf ('%s JOIN ',
482       $join_type ?  $self->_sqlcase($join_type) : ''
483     );
484 }
485
486 sub _recurse_from {
487   my $self = shift;
488   return join (' ', $self->_gen_from_blocks(@_) );
489 }
490
491 sub _gen_from_blocks {
492   my ($self, $from, @joins) = @_;
493
494   my @fchunks = $self->_from_chunk_to_sql($from);
495
496   for (@joins) {
497     my ($to, $on) = @$_;
498
499     # check whether a join type exists
500     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
501     my $join_type;
502     if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
503       $join_type = $to_jt->{-join_type};
504       $join_type =~ s/^\s+ | \s+$//xg;
505     }
506
507     my @j = $self->_generate_join_clause( $join_type );
508
509     if (ref $to eq 'ARRAY') {
510       push(@j, '(', $self->_recurse_from(@$to), ')');
511     }
512     else {
513       push(@j, $self->_from_chunk_to_sql($to));
514     }
515
516     my ($sql, @bind) = $self->_join_condition($on);
517     push(@j, ' ON ', $sql);
518     push @{$self->{from_bind}}, @bind;
519
520     push @fchunks, join '', @j;
521   }
522
523   return @fchunks;
524 }
525
526 sub _from_chunk_to_sql {
527   my ($self, $fromspec) = @_;
528
529   return join (' ', do {
530     if (! ref $fromspec) {
531       $self->_quote($fromspec);
532     }
533     elsif (ref $fromspec eq 'SCALAR') {
534       $$fromspec;
535     }
536     elsif (ref $fromspec eq 'REF' and ref $$fromspec eq 'ARRAY') {
537       push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
538       $$fromspec->[0];
539     }
540     elsif (ref $fromspec eq 'HASH') {
541       my ($as, $table, $toomuch) = ( map
542         { $_ => $fromspec->{$_} }
543         ( grep { $_ !~ /^\-/ } keys %$fromspec )
544       );
545
546       $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
547         if defined $toomuch;
548
549       ($self->_from_chunk_to_sql($table), $self->_quote($as) );
550     }
551     else {
552       $self->throw_exception('Unsupported from refkind: ' . ref $fromspec );
553     }
554   });
555 }
556
557 sub _join_condition {
558   my ($self, $cond) = @_;
559
560   # Backcompat for the old days when a plain hashref
561   # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
562   if (
563     ref $cond eq 'HASH'
564       and
565     keys %$cond == 1
566       and
567     (keys %$cond)[0] =~ /\./
568       and
569     ! ref ( (values %$cond)[0] )
570   ) {
571     carp_unique(
572       "ResultSet {from} structures with conditions not conforming to the "
573     . "SQL::Abstract syntax are deprecated: you either need to stop abusing "
574     . "{from} altogether, or express the condition properly using the "
575     . "{ -ident => ... } operator"
576     );
577     $cond = { keys %$cond => { -ident => values %$cond } }
578   }
579   elsif ( ref $cond eq 'ARRAY' ) {
580     # do our own ORing so that the hashref-shim above is invoked
581     my @parts;
582     my @binds;
583     foreach my $c (@$cond) {
584       my ($sql, @bind) = $self->_join_condition($c);
585       push @binds, @bind;
586       push @parts, $sql;
587     }
588     return join(' OR ', @parts), @binds;
589   }
590
591   return $self->_recurse_where($cond);
592 }
593
594 # !!! EXPERIMENTAL API !!! WILL CHANGE !!!
595 #
596 # This is rather odd, but vanilla SQLA does not have support for multicolumn IN
597 # expressions
598 # Currently has only one callsite in ResultSet, body moved into this subclass
599 # of SQLA to raise API questions like:
600 # - how do we convey a list of idents...?
601 # - can binds reside on lhs?
602 #
603 # !!! EXPERIMENTAL API !!! WILL CHANGE !!!
604 sub _where_op_multicolumn_in {
605   my ($self, $lhs, $rhs) = @_;
606
607   if (! ref $lhs or ref $lhs eq 'ARRAY') {
608     my (@sql, @bind);
609     for (ref $lhs ? @$lhs : $lhs) {
610       if (! ref $_) {
611         push @sql, $self->_quote($_);
612       }
613       elsif (ref $_ eq 'SCALAR') {
614         push @sql, $$_;
615       }
616       elsif (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') {
617         my ($s, @b) = @$$_;
618         push @sql, $s;
619         push @bind, @b;
620       }
621       else {
622         $self->throw_exception("ARRAY of @{[ ref $_ ]}es unsupported for multicolumn IN lhs...");
623       }
624     }
625     $lhs = \[ join(', ', @sql), @bind];
626   }
627   elsif (ref $lhs eq 'SCALAR') {
628     $lhs = \[ $$lhs ];
629   }
630   elsif (ref $lhs eq 'REF' and ref $$lhs eq 'ARRAY' ) {
631     # noop
632   }
633   else {
634     $self->throw_exception( ref($lhs) . "es unsupported for multicolumn IN lhs...");
635   }
636
637   # is this proper...?
638   $rhs = \[ $self->_recurse_where($rhs) ];
639
640   for ($lhs, $rhs) {
641     $$_->[0] = "( $$_->[0] )"
642       unless $$_->[0] =~ /^ \s* \( .* \) \s* $/xs;
643   }
644
645   \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ];
646 }
647
648 =head1 FURTHER QUESTIONS?
649
650 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
651
652 =head1 COPYRIGHT AND LICENSE
653
654 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
655 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
656 redistribute it and/or modify it under the same terms as the
657 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
658
659 =cut
660
661 1;