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
121 DBIx::Class::SQLMaker::DateOps
127 use Sub::Name 'subname';
128 use DBIx::Class::Carp;
129 use DBIx::Class::Exception;
130 use namespace::clean;
132 __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
134 # for when I need a normalized l/r pair
137 { defined $_ ? $_ : '' }
138 ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
142 # FIXME when we bring in the storage weaklink, check its schema
143 # weaklink and channel through $schema->throw_exception
144 sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
147 # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
148 # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
149 no warnings qw/redefine/;
151 *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
152 my($func) = (caller(1))[3];
153 carp "[$func] Warning: ", @_;
156 *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
157 my($func) = (caller(1))[3];
158 __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
161 # Current SQLA pollutes its namespace - clean for the time being
162 namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
165 # the "oh noes offset/top without limit" constant
166 # limited to 31 bits for sanity (and consistency,
167 # since it may be handed to the like of sprintf %u)
169 # Also *some* builds of SQLite fail the test
170 # some_column BETWEEN ? AND ?: 1, 4294967295
171 # with the proper integer bind attrs
173 # Implemented as a method, since ::Storage::DBI also
174 # refers to it (i.e. for the case of software_limit or
175 # as the value to abuse with MSSQL ordered subqueries)
176 sub __max_int () { 0x7FFFFFFF };
178 # poor man's de-qualifier
180 $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
181 ? $_[1] =~ / ([^\.]+) $ /x
187 my $self = shift->next::method(@_);
189 # use the same coderefs, they are prepared to handle both cases
190 my @extra_dbic_syntax = (
191 { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
192 { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
193 { regex => qr/^ func $/ix, handler => '_where_op_FUNC' },
194 { regex => qr/^ op $/ix, handler => '_where_op_OP' },
195 { regex => qr/^ dt $/xi, handler => '_where_op_CONVERT_DATETIME' },
196 { regex => qr/^ dt_get $/xi, handler => '_where_op_GET_DATETIME' },
197 { regex => qr/^ dt_diff $/xi, handler => '_where_op_DIFF_DATETIME' },
198 { regex => qr/^ dt_add $/xi, handler => '_where_op_ADD_DATETIME' },
199 { regex => qr/^ dt_now $/xi, handler => '_where_op_DATETIME_NOW' },
200 map +{ regex => qr/^ dt_$_ $/xi, handler => '_where_op_GET_DATETIME_'.uc($_) },
201 qw(year month day hour minute second)
204 push @{$self->{special_ops}}, @extra_dbic_syntax;
205 push @{$self->{unary_ops}}, @extra_dbic_syntax;
210 sub _where_op_IDENT {
212 my ($op, $rhs) = splice @_, -2;
214 $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
217 # in case we are called as a top level special op (no '=')
220 $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
228 sub _where_op_VALUE {
230 my ($op, $rhs) = splice @_, -2;
232 # in case we are called as a top level special op (no '=')
236 ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
242 $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
246 $self->_convert('?'),
253 carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
254 .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
257 shift->next::method(@_);
260 # Handle limit-dialect selection
262 my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
265 $fields = $self->_recurse_fields($fields);
267 if (defined $offset) {
268 $self->throw_exception('A supplied offset must be a non-negative integer')
269 if ( $offset =~ /\D/ or $offset < 0 );
273 if (defined $limit) {
274 $self->throw_exception('A supplied limit must be a positive integer')
275 if ( $limit =~ /\D/ or $limit <= 0 );
278 $limit = $self->__max_int;
284 # this is legacy code-flow from SQLA::Limit, it is not set in stone
286 ($sql, @bind) = $self->next::method ($table, $fields, $where);
289 $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit
292 my $dialect = $self->limit_dialect
293 or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
294 $self->can ("_$dialect")
295 or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
299 $sql = $self->$limiter (
301 { %{$rs_attrs||{}}, _selector_sql => $fields },
307 ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
310 push @{$self->{where_bind}}, @bind;
312 # this *must* be called, otherwise extra binds will remain in the sql-maker
313 my @all_bind = $self->_assemble_binds;
315 $sql .= $self->_lock_select ($rs_attrs->{for})
318 return wantarray ? ($sql, @all_bind) : $sql;
321 sub _assemble_binds {
323 return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where group having order limit/);
327 update => 'FOR UPDATE',
328 shared => 'FOR SHARE',
331 my ($self, $type) = @_;
332 my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
336 # Handle default inserts
338 # optimized due to hotttnesss
339 # my ($self, $table, $data, $options) = @_;
341 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
342 # which is sadly understood only by MySQL. Change default behavior here,
343 # until SQLA2 comes with proper dialect support
344 if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
347 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
350 if ( ($_[3]||{})->{returning} ) {
352 ($s, @bind) = $_[0]->_insert_returning ($_[3]);
356 return ($sql, @bind);
362 sub _recurse_fields {
363 my ($self, $fields, $depth) = @_;
365 my $ref = ref $fields;
366 return $self->_quote($fields) unless $ref;
367 return $$fields if $ref eq 'SCALAR';
369 if ($ref eq 'ARRAY') {
370 return join(', ', map { $self->_recurse_fields($_, $depth + 1) } @$fields)
373 my ($sql, @bind) = $self->_recurse_where({@$fields});
375 push @{$self->{select_bind}}, @bind;
378 elsif ($ref eq 'HASH') {
379 my %hash = %$fields; # shallow copy
381 my $as = delete $hash{-as}; # if supplied
383 my ($func, $args, @toomany) = %hash;
385 # there should be only one pair
387 $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
390 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
391 $self->throw_exception (
392 'The select => { distinct => ... } syntax is not supported for multiple columns.'
393 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
394 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
398 my $select = sprintf ('%s( %s )%s',
399 $self->_sqlcase($func),
400 $self->_recurse_fields($args, $depth + 1),
402 ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
408 # Is the second check absolutely necessary?
409 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
410 push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
411 return $$fields->[0];
414 $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
419 # this used to be a part of _order_by but is broken out for clarity.
420 # What we have been doing forever is hijacking the $order arg of
421 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
422 # then pretty much the entire resultset attr-hash, as more and more
423 # things in the SQLA space need to have mopre info about the $rs they
424 # create SQL for. The alternative would be to keep expanding the
425 # signature of _select with more and more positional parameters, which
426 # is just gross. All hail SQLA2!
427 sub _parse_rs_attrs {
428 my ($self, $arg) = @_;
432 if ($arg->{group_by}) {
433 # horible horrible, waiting for refactor
434 local $self->{select_bind};
435 if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
436 $sql .= $self->_sqlcase(' group by ') . $g;
437 push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
441 if (defined $arg->{having}) {
442 my ($frag, @bind) = $self->_recurse_where($arg->{having});
443 push(@{$self->{having_bind}}, @bind);
444 $sql .= $self->_sqlcase(' having ') . $frag;
447 if (defined $arg->{order_by}) {
448 $sql .= $self->_order_by ($arg->{order_by});
455 my ($self, $arg) = @_;
457 # check that we are not called in legacy mode (order_by as 4th argument)
458 if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
459 return $self->_parse_rs_attrs ($arg);
462 my ($sql, @bind) = $self->next::method($arg);
463 push @{$self->{order_bind}}, @bind;
469 # optimized due to hotttnesss
470 # my ($self, $from) = @_;
471 if (my $ref = ref $_[1] ) {
472 if ($ref eq 'ARRAY') {
473 return $_[0]->_recurse_from(@{$_[1]});
475 elsif ($ref eq 'HASH') {
476 return $_[0]->_recurse_from($_[1]);
478 elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
479 my ($sql, @bind) = @{ ${$_[1]} };
480 push @{$_[0]->{from_bind}}, @bind;
484 return $_[0]->next::method ($_[1]);
487 sub _generate_join_clause {
488 my ($self, $join_type) = @_;
490 $join_type = $self->{_default_jointype}
491 if ! defined $join_type;
493 return sprintf ('%s JOIN ',
494 $join_type ? $self->_sqlcase($join_type) : ''
504 # $_[1] gets set to "op"
509 # $_[2] gets set to "op"
513 my $label = $self->_convert($self->_quote($k));
514 my $placeholder = $self->_convert('?');
516 croak '-func must be an array' unless ref $vals eq 'ARRAY';
517 croak 'first arg for -func must be a scalar' unless !ref $vals->[0];
519 my ($func,@rest_of_vals) = @$vals;
521 $self->_assert_pass_injection_guard($func);
523 my (@all_sql, @all_bind);
524 foreach my $val (@rest_of_vals) {
525 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
527 return ($placeholder, $self->_bindtype($k, $val) );
533 my ($sql, @bind) = @$$val;
534 $self->_assert_bindval_matches_bindtype(@bind);
535 return ($sql, @bind);
538 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
539 $self->$method('', $val);
543 push @all_bind, @bind;
546 my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
548 my $sql = $k ? "( $label = $clause )" : "( $clause )";
558 # $_[1] gets set to "op"
563 # $_[2] gets set to "op"
567 my $label = $self->_convert($self->_quote($k));
568 my $placeholder = $self->_convert('?');
570 croak 'argument to -op must be an arrayref' unless ref $vals eq 'ARRAY';
571 croak 'first arg for -op must be a scalar' unless !ref $vals->[0];
573 my ($op, @rest_of_vals) = @$vals;
575 $self->_assert_pass_injection_guard($op);
577 my (@all_sql, @all_bind);
578 foreach my $val (@rest_of_vals) {
579 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
581 return ($placeholder, $self->_bindtype($k, $val) );
587 my ($sql, @bind) = @$$val;
588 $self->_assert_bindval_matches_bindtype(@bind);
589 return ($sql, @bind);
592 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
593 $self->$method('', $val);
597 push @all_bind, @bind;
600 my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
602 my $sql = $k ? "( $label = $clause )" : "( $clause )";
609 return join (' ', $self->_gen_from_blocks(@_) );
612 sub _gen_from_blocks {
613 my ($self, $from, @joins) = @_;
615 my @fchunks = $self->_from_chunk_to_sql($from);
620 # check whether a join type exists
621 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
623 if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
624 $join_type = $to_jt->{-join_type};
625 $join_type =~ s/^\s+ | \s+$//xg;
628 my @j = $self->_generate_join_clause( $join_type );
630 if (ref $to eq 'ARRAY') {
631 push(@j, '(', $self->_recurse_from(@$to), ')');
634 push(@j, $self->_from_chunk_to_sql($to));
637 my ($sql, @bind) = $self->_join_condition($on);
638 push(@j, ' ON ', $sql);
639 push @{$self->{from_bind}}, @bind;
641 push @fchunks, join '', @j;
647 sub _from_chunk_to_sql {
648 my ($self, $fromspec) = @_;
650 return join (' ', $self->_SWITCH_refkind($fromspec, {
655 push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
659 my ($as, $table, $toomuch) = ( map
660 { $_ => $fromspec->{$_} }
661 ( grep { $_ !~ /^\-/ } keys %$fromspec )
664 $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
667 ($self->_from_chunk_to_sql($table), $self->_quote($as) );
670 $self->_quote($fromspec);
675 sub _join_condition {
676 my ($self, $cond) = @_;
678 # Backcompat for the old days when a plain hashref
679 # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
680 # Once things settle we should start warning here so that
681 # folks unroll their hacks
687 (keys %$cond)[0] =~ /\./
689 ! ref ( (values %$cond)[0] )
691 $cond = { keys %$cond => { -ident => values %$cond } }
693 elsif ( ref $cond eq 'ARRAY' ) {
694 # do our own ORing so that the hashref-shim above is invoked
697 foreach my $c (@$cond) {
698 my ($sql, @bind) = $self->_join_condition($c);
702 return join(' OR ', @parts), @binds;
705 return $self->_recurse_where($cond);
714 Used to explicitly specify an SQL identifier. Takes a plain string as value
715 which is then invariably treated as a column name (and is being properly
716 quoted if quoting has been requested). Most useful for comparison of two
720 priority => { '<', 2 },
721 requestor => { -ident => 'submitter' }
726 $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
731 The -value operator signals that the argument to the right is a raw bind value.
732 It will be passed straight to DBI, without invoking any of the SQL::Abstract
733 condition-parsing logic. This allows you to, for example, pass an array as a
734 column value for databases that support array datatypes, e.g.:
737 array => { -value => [1, 2, 3] }
742 $stmt = 'WHERE array = ?';
747 See L<DBIx::Class/CONTRIBUTORS>.
751 You may distribute this code under the same terms as Perl itself.