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 { regex => qr/^ dt_(:?on_or_)?(:?before|after) $/xi, handler => '_where_op_CIRCA_DATETIME' },
201 map +{ regex => qr/^ dt_$_ $/xi, handler => '_where_op_GET_DATETIME_'.uc($_) },
202 qw(year month day hour minute second)
205 push @{$self->{special_ops}}, @extra_dbic_syntax;
206 push @{$self->{unary_ops}}, @extra_dbic_syntax;
211 sub _where_op_IDENT {
213 my ($op, $rhs) = splice @_, -2;
215 $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
218 # in case we are called as a top level special op (no '=')
221 $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
229 sub _where_op_VALUE {
231 my ($op, $rhs) = splice @_, -2;
233 # in case we are called as a top level special op (no '=')
237 ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
243 $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
247 $self->_convert('?'),
254 carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
255 .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
258 shift->next::method(@_);
261 # Handle limit-dialect selection
263 my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
266 $fields = $self->_recurse_fields($fields);
268 if (defined $offset) {
269 $self->throw_exception('A supplied offset must be a non-negative integer')
270 if ( $offset =~ /\D/ or $offset < 0 );
274 if (defined $limit) {
275 $self->throw_exception('A supplied limit must be a positive integer')
276 if ( $limit =~ /\D/ or $limit <= 0 );
279 $limit = $self->__max_int;
285 # this is legacy code-flow from SQLA::Limit, it is not set in stone
287 ($sql, @bind) = $self->next::method ($table, $fields, $where);
290 $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit
293 my $dialect = $self->limit_dialect
294 or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
295 $self->can ("_$dialect")
296 or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
300 $sql = $self->$limiter (
302 { %{$rs_attrs||{}}, _selector_sql => $fields },
308 ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
311 push @{$self->{where_bind}}, @bind;
313 # this *must* be called, otherwise extra binds will remain in the sql-maker
314 my @all_bind = $self->_assemble_binds;
316 $sql .= $self->_lock_select ($rs_attrs->{for})
319 return wantarray ? ($sql, @all_bind) : $sql;
322 sub _assemble_binds {
324 return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where group having order limit/);
328 update => 'FOR UPDATE',
329 shared => 'FOR SHARE',
332 my ($self, $type) = @_;
333 my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
337 # Handle default inserts
339 # optimized due to hotttnesss
340 # my ($self, $table, $data, $options) = @_;
342 # SQLA will emit INSERT INTO $table ( ) VALUES ( )
343 # which is sadly understood only by MySQL. Change default behavior here,
344 # until SQLA2 comes with proper dialect support
345 if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
348 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
351 if ( ($_[3]||{})->{returning} ) {
353 ($s, @bind) = $_[0]->_insert_returning ($_[3]);
357 return ($sql, @bind);
363 sub _recurse_fields {
364 my ($self, $fields, $depth) = @_;
366 my $ref = ref $fields;
367 return $self->_quote($fields) unless $ref;
368 return $$fields if $ref eq 'SCALAR';
370 if ($ref eq 'ARRAY') {
371 return join(', ', map { $self->_recurse_fields($_, $depth + 1) } @$fields)
374 my ($sql, @bind) = $self->_recurse_where({@$fields});
376 push @{$self->{select_bind}}, @bind;
379 elsif ($ref eq 'HASH') {
380 my %hash = %$fields; # shallow copy
382 my $as = delete $hash{-as}; # if supplied
384 my ($func, $args, @toomany) = %hash;
386 # there should be only one pair
388 $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
391 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
392 $self->throw_exception (
393 'The select => { distinct => ... } syntax is not supported for multiple columns.'
394 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
395 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
399 my $select = sprintf ('%s( %s )%s',
400 $self->_sqlcase($func),
401 $self->_recurse_fields($args, $depth + 1),
403 ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
409 # Is the second check absolutely necessary?
410 elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
411 push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
412 return $$fields->[0];
415 $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
420 # this used to be a part of _order_by but is broken out for clarity.
421 # What we have been doing forever is hijacking the $order arg of
422 # SQLA::select to pass in arbitrary pieces of data (first the group_by,
423 # then pretty much the entire resultset attr-hash, as more and more
424 # things in the SQLA space need to have mopre info about the $rs they
425 # create SQL for. The alternative would be to keep expanding the
426 # signature of _select with more and more positional parameters, which
427 # is just gross. All hail SQLA2!
428 sub _parse_rs_attrs {
429 my ($self, $arg) = @_;
433 if ($arg->{group_by}) {
434 # horible horrible, waiting for refactor
435 local $self->{select_bind};
436 if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
437 $sql .= $self->_sqlcase(' group by ') . $g;
438 push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
442 if (defined $arg->{having}) {
443 my ($frag, @bind) = $self->_recurse_where($arg->{having});
444 push(@{$self->{having_bind}}, @bind);
445 $sql .= $self->_sqlcase(' having ') . $frag;
448 if (defined $arg->{order_by}) {
449 $sql .= $self->_order_by ($arg->{order_by});
456 my ($self, $arg) = @_;
458 # check that we are not called in legacy mode (order_by as 4th argument)
459 if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
460 return $self->_parse_rs_attrs ($arg);
463 my ($sql, @bind) = $self->next::method($arg);
464 push @{$self->{order_bind}}, @bind;
470 # optimized due to hotttnesss
471 # my ($self, $from) = @_;
472 if (my $ref = ref $_[1] ) {
473 if ($ref eq 'ARRAY') {
474 return $_[0]->_recurse_from(@{$_[1]});
476 elsif ($ref eq 'HASH') {
477 return $_[0]->_recurse_from($_[1]);
479 elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
480 my ($sql, @bind) = @{ ${$_[1]} };
481 push @{$_[0]->{from_bind}}, @bind;
485 return $_[0]->next::method ($_[1]);
488 sub _generate_join_clause {
489 my ($self, $join_type) = @_;
491 $join_type = $self->{_default_jointype}
492 if ! defined $join_type;
494 return sprintf ('%s JOIN ',
495 $join_type ? $self->_sqlcase($join_type) : ''
505 # $_[1] gets set to "op"
510 # $_[2] gets set to "op"
514 my $label = $self->_convert($self->_quote($k));
515 my $placeholder = $self->_convert('?');
517 $self->throw_exception('-func must be an array') unless ref $vals eq 'ARRAY';
518 $self->throw_exception('first arg for -func must be a scalar') unless !ref $vals->[0];
520 my ($func,@rest_of_vals) = @$vals;
522 $self->_assert_pass_injection_guard($func);
524 my (@all_sql, @all_bind);
525 foreach my $val (@rest_of_vals) {
526 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
528 return ($placeholder, $self->_bindtype($k, $val) );
534 my ($sql, @bind) = @$$val;
535 $self->_assert_bindval_matches_bindtype(@bind);
536 return ($sql, @bind);
539 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
540 $self->$method('', $val);
544 push @all_bind, @bind;
547 my ($clause, @bind) = ("$func(" . (join ",", @all_sql) . ")", @all_bind);
549 my $sql = $k ? "( $label = $clause )" : "( $clause )";
559 # $_[1] gets set to "op"
564 # $_[2] gets set to "op"
568 my $label = $self->_convert($self->_quote($k));
569 my $placeholder = $self->_convert('?');
571 $self->throw_exception('argument to -op must be an arrayref') unless ref $vals eq 'ARRAY';
572 $self->throw_exception('first arg for -op must be a scalar') unless !ref $vals->[0];
574 my ($op, @rest_of_vals) = @$vals;
576 $self->_assert_pass_injection_guard($op);
578 my (@all_sql, @all_bind);
579 foreach my $val (@rest_of_vals) {
580 my ($sql, @bind) = $self->_SWITCH_refkind($val, {
582 return ($placeholder, $self->_bindtype($k, $val) );
588 my ($sql, @bind) = @$$val;
589 $self->_assert_bindval_matches_bindtype(@bind);
590 return ($sql, @bind);
593 my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $val);
594 $self->$method('', $val);
598 push @all_bind, @bind;
601 my ($clause, @bind) = ((join " $op ", @all_sql), @all_bind);
603 my $sql = $k ? "( $label = $clause )" : "( $clause )";
610 return join (' ', $self->_gen_from_blocks(@_) );
613 sub _gen_from_blocks {
614 my ($self, $from, @joins) = @_;
616 my @fchunks = $self->_from_chunk_to_sql($from);
621 # check whether a join type exists
622 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
624 if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
625 $join_type = $to_jt->{-join_type};
626 $join_type =~ s/^\s+ | \s+$//xg;
629 my @j = $self->_generate_join_clause( $join_type );
631 if (ref $to eq 'ARRAY') {
632 push(@j, '(', $self->_recurse_from(@$to), ')');
635 push(@j, $self->_from_chunk_to_sql($to));
638 my ($sql, @bind) = $self->_join_condition($on);
639 push(@j, ' ON ', $sql);
640 push @{$self->{from_bind}}, @bind;
642 push @fchunks, join '', @j;
648 sub _from_chunk_to_sql {
649 my ($self, $fromspec) = @_;
651 return join (' ', $self->_SWITCH_refkind($fromspec, {
656 push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
660 my ($as, $table, $toomuch) = ( map
661 { $_ => $fromspec->{$_} }
662 ( grep { $_ !~ /^\-/ } keys %$fromspec )
665 $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
668 ($self->_from_chunk_to_sql($table), $self->_quote($as) );
671 $self->_quote($fromspec);
676 sub _join_condition {
677 my ($self, $cond) = @_;
679 # Backcompat for the old days when a plain hashref
680 # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
681 # Once things settle we should start warning here so that
682 # folks unroll their hacks
688 (keys %$cond)[0] =~ /\./
690 ! ref ( (values %$cond)[0] )
692 $cond = { keys %$cond => { -ident => values %$cond } }
694 elsif ( ref $cond eq 'ARRAY' ) {
695 # do our own ORing so that the hashref-shim above is invoked
698 foreach my $c (@$cond) {
699 my ($sql, @bind) = $self->_join_condition($c);
703 return join(' OR ', @parts), @binds;
706 return $self->_recurse_where($cond);
715 Used to explicitly specify an SQL identifier. Takes a plain string as value
716 which is then invariably treated as a column name (and is being properly
717 quoted if quoting has been requested). Most useful for comparison of two
721 priority => { '<', 2 },
722 requestor => { -ident => 'submitter' }
727 $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
732 The -value operator signals that the argument to the right is a raw bind value.
733 It will be passed straight to DBI, without invoking any of the SQL::Abstract
734 condition-parsing logic. This allows you to, for example, pass an array as a
735 column value for databases that support array datatypes, e.g.:
738 array => { -value => [1, 2, 3] }
743 $stmt = 'WHERE array = ?';
748 See L<DBIx::Class/CONTRIBUTORS>.
752 You may distribute this code under the same terms as Perl itself.