1 package DBIx::Class::SQLMaker;
8 DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
12 This module is a subclass of L<SQL::Abstract> and includes a number of
13 DBIC-specific workarounds, not yet 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
18 Currently the enhancements to L<SQL::Abstract> are:
22 =item * Support for C<JOIN> statements (via extended C<table/from> support)
24 =item * Support of functions in C<SELECT> lists
26 =item * C<GROUP BY>/C<HAVING> support (via extensions to the order_by parameter)
28 =item * Support of C<...FOR UPDATE> type of select statement modifiers
30 =item * The L</-ident> operator
32 =item * The L</-value> operator
34 =item * Date Functions:
36 Note that for the following functions use different functions for different
37 RDBMS'. See the SQLMaker docs for your database to see what functions are
42 =item * -dt => $date_time_obj
44 This function will convert the passed datetime to whatever format the current
47 =item * -dt_diff => [$unit, \'foo.date_from', \'foo.date_to']
49 This function will diff two dates and return the units requested. Note that
50 it correctly recurses if you pass it something like a function or a date value.
51 Also note that not all RDBMS' are equal; some units supported on some databases
52 and some are supported on others. See the documentation for the SQLMaker class
55 =item * -dt_get => [$part, \'foo.date_col']
57 This function will extract the passed part from the passed column. Note that
58 it correctly recurses if you pass it something like a function or a date value.
59 Also note that not all RDBMS' are equal; some parts supported on some databases
60 and some are supported on others. See the documentation for the SQLMaker class
63 =item * -dt_year => \'foo.date_col'
65 A shortcut for -dt_get => [year => ...]
67 =item * -dt_month => \'foo.date_col'
69 A shortcut for -dt_get => [month => ...]
71 =item * -dt_day => \'foo.date_col'
73 A shortcut for -dt_get => [day_of_month => ...]
75 =item * -dt_hour => \'foo.date_col'
77 A shortcut for -dt_get => [hour => ...]
79 =item * -dt_minute => \'foo.date_col'
81 A shortcut for -dt_get => [minute => ...]
83 =item * -dt_second => \'foo.date_col'
85 A shortcut for -dt_get => [second => ...]
91 Another operator is C<-func> that allows you to call SQL functions with
92 arguments. It receives an array reference containing the function name
93 as the 0th argument and the other arguments being its parameters. For example:
96 -func => ['substr', 'Hello', 50, 5],
101 $stmt = "WHERE (substr(?,?,?))";
102 @bind = ("Hello", 50, 5);
104 Yet another operator is C<-op> that allows you to use SQL operators. It
105 receives an array reference containing the operator 0th argument and the other
106 arguments being its operands. For example:
109 foo => { -op => ['+', \'bar', 50, 5] },
114 $stmt = "WHERE (foo = bar + ? + ?)";
120 DBIx::Class::SQLMaker::LimitDialects
126 use Sub::Name 'subname';
127 use DBIx::Class::Carp;
128 use DBIx::Class::Exception;
129 use namespace::clean;
131 __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect datetime_parser/);
133 # for when I need a normalized l/r pair
136 { defined $_ ? $_ : '' }
137 ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
141 # FIXME when we bring in the storage weaklink, check its schema
142 # weaklink and channel through $schema->throw_exception
143 sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
146 # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
147 # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
148 no warnings qw/redefine/;
150 *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
151 my($func) = (caller(1))[3];
152 carp "[$func] Warning: ", @_;
155 *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
156 my($func) = (caller(1))[3];
157 __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
160 # Current SQLA pollutes its namespace - clean for the time being
161 namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
164 # the "oh noes offset/top without limit" constant
165 # limited to 31 bits for sanity (and consistency,
166 # since it may be handed to the like of sprintf %u)
168 # Also *some* builds of SQLite fail the test
169 # some_column BETWEEN ? AND ?: 1, 4294967295
170 # with the proper integer bind attrs
172 # Implemented as a method, since ::Storage::DBI also
173 # refers to it (i.e. for the case of software_limit or
174 # as the value to abuse with MSSQL ordered subqueries)
175 sub __max_int () { 0x7FFFFFFF };
177 # poor man's de-qualifier
179 $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
180 ? $_[1] =~ / ([^\.]+) $ /x
186 my $self = shift->next::method(@_);
188 # use the same coderefs, they are prepared to handle both cases
189 my @extra_dbic_syntax = (
190 { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
191 { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
192 { regex => qr/^ func $/ix, handler => '_where_op_FUNC' },
193 { regex => qr/^ op $/ix, handler => '_where_op_OP' },
194 { regex => qr/^ dt $/xi, handler => '_where_op_CONVERT_DATETIME' },
195 { regex => qr/^ dt_get $/xi, handler => '_where_op_GET_DATETIME' },
196 { regex => qr/^ dt_diff $/xi, handler => '_where_op_DIFF_DATETIME' },
197 map +{ regex => qr/^ dt_$_ $/xi, handler => '_where_op_GET_DATETIME_'.uc($_) },
201 push @{$self->{special_ops}}, @extra_dbic_syntax;
202 push @{$self->{unary_ops}}, @extra_dbic_syntax;
207 sub _where_op_IDENT {
209 my ($op, $rhs) = splice @_, -2;
211 $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
214 # in case we are called as a top level special op (no '=')
217 $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
225 sub _where_op_CONVERT_DATETIME {
227 my ($op, $rhs) = splice @_, -2;
228 croak "-$op takes a DateTime only" unless ref $rhs && $rhs->isa('DateTime');
230 # in case we are called as a top level special op (no '=')
233 $rhs = $self->datetime_parser->format_datetime($rhs);
236 ($lhs || $self->{_nested_func_lhs} || undef),
242 $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
246 $self->_convert('?'),
252 sub _unsupported_date_extraction {
253 "date part extraction not supported for part \"$_[1]\" with database \"$_[2]\""
256 sub _unsupported_date_diff {
257 "date diff not supported for part \"$_[1]\" with database \"$_[2]\""
260 sub _datetime_sql { die 'date part extraction not implemented for this database' }
262 sub _datetime_diff_sql { die 'date diffing not implemented for this database' }
264 sub _where_op_GET_DATETIME {
279 croak 'args to -dt_get must be an arrayref' unless ref $vals eq 'ARRAY';
280 croak 'first arg to -dt_get must be a scalar' unless !ref $vals->[0];
282 my $part = $vals->[0];
283 my $val = $vals->[1];
285 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
287 return ($self->_convert('?'), $self->_bindtype($k, $val) );
293 my ($sql, @bind) = @$$val;
294 $self->_assert_bindval_matches_bindtype(@bind);
295 return ($sql, @bind);
298 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
299 $self->$method('', $val);
303 return $self->_datetime_sql($part, $sql), @bind;
306 for my $part (qw(month day year)) {
308 my $name = '_where_op_GET_DATETIME_' . uc($part);
309 *{$name} = subname "DBIx::Class::SQLMaker::$name", sub {
311 my ($op, $rhs) = splice @_, -2;
315 return $self->_where_op_GET_DATETIME($op, $lhs, [$part, $rhs])
319 sub _where_op_DIFF_DATETIME {
334 croak 'args to -dt_diff must be an arrayref' unless ref $vals eq 'ARRAY';
335 croak 'first arg to -dt_diff must be a scalar' unless !ref $vals->[0];
336 croak '-dt_diff must have two more arguments' unless scalar @$vals == 3;
338 my ($part, @val) = @$vals;
339 my $placeholder = $self->_convert('?');
341 my (@all_sql, @all_bind);
342 foreach my $val (@val) {
343 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
345 return ($placeholder, $self->_bindtype($k, $val) );
351 my ($sql, @bind) = @$$val;
352 $self->_assert_bindval_matches_bindtype(@bind);
353 return ($sql, @bind);
356 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
357 $self->$method('', $val);
361 push @all_bind, @bind;
364 return $self->_datetime_diff_sql($part, $all_sql[0], $all_sql[1]), @all_bind
367 sub _where_op_VALUE {
369 my ($op, $rhs) = splice @_, -2;
371 # in case we are called as a top level special op (no '=')
375 ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
381 $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
385 $self->_convert('?'),
392 carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
393 .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
396 shift->next::method(@_);
399 # Handle limit-dialect selection
401 my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
404 $fields = $self->_recurse_fields($fields);
406 if (defined $offset) {
407 $self->throw_exception('A supplied offset must be a non-negative integer')
408 if ( $offset =~ /\D/ or $offset < 0 );
412 if (defined $limit) {
413 $self->throw_exception('A supplied limit must be a positive integer')
414 if ( $limit =~ /\D/ or $limit <= 0 );
417 $limit = $self->__max_int;
423 # this is legacy code-flow from SQLA::Limit, it is not set in stone
425 ($sql, @bind) = $self->next::method ($table, $fields, $where);
428 $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit
431 my $dialect = $self->limit_dialect
432 or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
433 $self->can ("_$dialect")
434 or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
438 $sql = $self->$limiter (
440 { %{$rs_attrs||{}}, _selector_sql => $fields },
446 ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
449 push @{$self->{where_bind}}, @bind;
451 # this *must* be called, otherwise extra binds will remain in the sql-maker
452 my @all_bind = $self->_assemble_binds;
454 $sql .= $self->_lock_select ($rs_attrs->{for})
457 return wantarray ? ($sql, @all_bind) : $sql;
460 sub _assemble_binds {
462 return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where group having order limit/);
466 update => 'FOR UPDATE',
467 shared => 'FOR SHARE',
470 my ($self, $type) = @_;
471 my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
475 # Handle default inserts
477 # optimized due to hotttnesss
478 # my ($self, $table, $data, $options) = @_;
480 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
481 # which is sadly understood only by MySQL. Change default behavior here,
482 # until SQLA2 comes with proper dialect support
483 if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
486 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
489 if ( ($_[3]||{})->{returning} ) {
491 ($s, @bind) = $_[0]->_insert_returning ($_[3]);
495 return ($sql, @bind);
501 sub _recurse_fields {
502 my ($self, $fields, $depth) = @_;
504 my $ref = ref $fields;
505 return $self->_quote($fields) unless $ref;
506 return $$fields if $ref eq 'SCALAR';
508 if ($ref eq 'ARRAY') {
509 return join(', ', map { $self->_recurse_fields($_, $depth + 1) } @$fields)
512 my ($sql, @bind) = $self->_recurse_where({@$fields});
514 push @{$self->{select_bind}}, @bind;
517 elsif ($ref eq 'HASH') {
518 my %hash = %$fields; # shallow copy
520 my $as = delete $hash{-as}; # if supplied
522 my ($func, $args, @toomany) = %hash;
524 # there should be only one pair
526 $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
529 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
530 $self->throw_exception (
531 'The select => { distinct => ... } syntax is not supported for multiple columns.'
532 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
533 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
537 my $select = sprintf ('%s( %s )%s',
538 $self->_sqlcase($func),
539 $self->_recurse_fields($args, $depth + 1),
541 ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
547 # Is the second check absolutely necessary?
548 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
549 push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
550 return $$fields->[0];
553 $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
558 # this used to be a part of _order_by but is broken out for clarity.
559 # What we have been doing forever is hijacking the $order arg of
560 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
561 # then pretty much the entire resultset attr-hash, as more and more
562 # things in the SQLA space need to have mopre info about the $rs they
563 # create SQL for. The alternative would be to keep expanding the
564 # signature of _select with more and more positional parameters, which
565 # is just gross. All hail SQLA2!
566 sub _parse_rs_attrs {
567 my ($self, $arg) = @_;
571 if ($arg->{group_by}) {
572 # horible horrible, waiting for refactor
573 local $self->{select_bind};
574 if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
575 $sql .= $self->_sqlcase(' group by ') . $g;
576 push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
580 if (defined $arg->{having}) {
581 my ($frag, @bind) = $self->_recurse_where($arg->{having});
582 push(@{$self->{having_bind}}, @bind);
583 $sql .= $self->_sqlcase(' having ') . $frag;
586 if (defined $arg->{order_by}) {
587 $sql .= $self->_order_by ($arg->{order_by});
594 my ($self, $arg) = @_;
596 # check that we are not called in legacy mode (order_by as 4th argument)
597 if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
598 return $self->_parse_rs_attrs ($arg);
601 my ($sql, @bind) = $self->next::method($arg);
602 push @{$self->{order_bind}}, @bind;
608 # optimized due to hotttnesss
609 # my ($self, $from) = @_;
610 if (my $ref = ref $_[1] ) {
611 if ($ref eq 'ARRAY') {
612 return $_[0]->_recurse_from(@{$_[1]});
614 elsif ($ref eq 'HASH') {
615 return $_[0]->_recurse_from($_[1]);
617 elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
618 my ($sql, @bind) = @{ ${$_[1]} };
619 push @{$_[0]->{from_bind}}, @bind;
623 return $_[0]->next::method ($_[1]);
626 sub _generate_join_clause {
627 my ($self, $join_type) = @_;
629 $join_type = $self->{_default_jointype}
630 if ! defined $join_type;
632 return sprintf ('%s JOIN ',
633 $join_type ? $self->_sqlcase($join_type) : ''
643 # $_[1] gets set to "op"
648 # $_[2] gets set to "op"
652 my $label = $self->_convert($self->_quote($k));
653 my $placeholder = $self->_convert('?');
655 croak '-func must be an array' unless ref $vals eq 'ARRAY';
656 croak 'first arg for -func must be a scalar' unless !ref $vals->[0];
658 my ($func,@rest_of_vals) = @$vals;
660 $self->_assert_pass_injection_guard($func);
662 my (@all_sql, @all_bind);
663 foreach my $val (@rest_of_vals) {
664 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
666 return ($placeholder, $self->_bindtype($k, $val) );
672 my ($sql, @bind) = @$$val;
673 $self->_assert_bindval_matches_bindtype(@bind);
674 return ($sql, @bind);
677 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
678 $self->$method('', $val);
682 push @all_bind, @bind;
685 my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
687 my $sql = $k ? "( $label = $clause )" : "( $clause )";
697 # $_[1] gets set to "op"
702 # $_[2] gets set to "op"
706 my $label = $self->_convert($self->_quote($k));
707 my $placeholder = $self->_convert('?');
709 croak 'argument to -op must be an arrayref' unless ref $vals eq 'ARRAY';
710 croak 'first arg for -op must be a scalar' unless !ref $vals->[0];
712 my ($op, @rest_of_vals) = @$vals;
714 $self->_assert_pass_injection_guard($op);
716 my (@all_sql, @all_bind);
717 foreach my $val (@rest_of_vals) {
718 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
720 return ($placeholder, $self->_bindtype($k, $val) );
726 my ($sql, @bind) = @$$val;
727 $self->_assert_bindval_matches_bindtype(@bind);
728 return ($sql, @bind);
731 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
732 $self->$method('', $val);
736 push @all_bind, @bind;
739 my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
741 my $sql = $k ? "( $label = $clause )" : "( $clause )";
748 return join (' ', $self->_gen_from_blocks(@_) );
751 sub _gen_from_blocks {
752 my ($self, $from, @joins) = @_;
754 my @fchunks = $self->_from_chunk_to_sql($from);
759 # check whether a join type exists
760 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
762 if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
763 $join_type = $to_jt->{-join_type};
764 $join_type =~ s/^\s+ | \s+$//xg;
767 my @j = $self->_generate_join_clause( $join_type );
769 if (ref $to eq 'ARRAY') {
770 push(@j, '(', $self->_recurse_from(@$to), ')');
773 push(@j, $self->_from_chunk_to_sql($to));
776 my ($sql, @bind) = $self->_join_condition($on);
777 push(@j, ' ON ', $sql);
778 push @{$self->{from_bind}}, @bind;
780 push @fchunks, join '', @j;
786 sub _from_chunk_to_sql {
787 my ($self, $fromspec) = @_;
789 return join (' ', $self->_SWITCH_refkind($fromspec, {
794 push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
798 my ($as, $table, $toomuch) = ( map
799 { $_ => $fromspec->{$_} }
800 ( grep { $_ !~ /^\-/ } keys %$fromspec )
803 $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
806 ($self->_from_chunk_to_sql($table), $self->_quote($as) );
809 $self->_quote($fromspec);
814 sub _join_condition {
815 my ($self, $cond) = @_;
817 # Backcompat for the old days when a plain hashref
818 # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
819 # Once things settle we should start warning here so that
820 # folks unroll their hacks
826 (keys %$cond)[0] =~ /\./
828 ! ref ( (values %$cond)[0] )
830 $cond = { keys %$cond => { -ident => values %$cond } }
832 elsif ( ref $cond eq 'ARRAY' ) {
833 # do our own ORing so that the hashref-shim above is invoked
836 foreach my $c (@$cond) {
837 my ($sql, @bind) = $self->_join_condition($c);
841 return join(' OR ', @parts), @binds;
844 return $self->_recurse_where($cond);
853 Used to explicitly specify an SQL identifier. Takes a plain string as value
854 which is then invariably treated as a column name (and is being properly
855 quoted if quoting has been requested). Most useful for comparison of two
859 priority => { '<', 2 },
860 requestor => { -ident => 'submitter' }
865 $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
870 The -value operator signals that the argument to the right is a raw bind value.
871 It will be passed straight to DBI, without invoking any of the SQL::Abstract
872 condition-parsing logic. This allows you to, for example, pass an array as a
873 column value for databases that support array datatypes, e.g.:
876 array => { -value => [1, 2, 3] }
881 $stmt = 'WHERE array = ?';
886 See L<DBIx::Class/CONTRIBUTORS>.
890 You may distribute this code under the same terms as Perl itself.