1 package DBIx::Class::SQLMaker::Converter;
3 use Data::Query::Constants;
4 use Data::Query::ExprHelpers;
8 extends 'SQL::Abstract::Converter';
10 has limit_dialect => (is => 'ro', required => 1);
11 has name_sep => (is => 'ro', required => 1);
12 has slice_stability => (is => 'ro', required => 1);
13 has slice_subquery => (is => 'ro', required => 1);
15 sub __max_int () { 0x7FFFFFFF }
17 # Handle limit-dialect selection
19 my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
21 if (defined $offset) {
22 die('A supplied offset must be a non-negative integer')
23 if ( $offset =~ /\D/ or $offset < 0 );
28 die('A supplied limit must be a positive integer')
29 if ( $limit =~ /\D/ or $limit <= 0 );
32 $limit = $self->__max_int;
35 my %final_attrs = (%{$rs_attrs||{}}, limit => $limit, offset => $offset);
37 if ($limit or $offset) {
38 my %slice_stability = %{$self->slice_stability};
40 if (my $stability = $slice_stability{$offset ? 'offset' : 'limit'}) {
41 my $source = $rs_attrs->{_rsroot_rsrc};
43 $final_attrs{order_is_stable}
44 = $final_attrs{preserve_order}
45 = $source->schema->storage
46 ->_order_by_is_stable(
47 @final_attrs{qw(from order_by where)}
50 if ($stability eq 'requires') {
51 if ($self->_order_by_to_dq($final_attrs{order_by})) {
53 $self->limit_dialect.' limit/offset implementation requires a stable order for '.($offset ? 'offset' : 'limit')
56 if (my $ident_cols = $source->_identifying_column_set) {
57 $final_attrs{order_by} = [
58 map "$final_attrs{alias}.$_", @$ident_cols
60 $final_attrs{order_is_stable} = 1;
63 'Unable to auto-construct stable order criteria for "skimming type"
65 . "dialect based on source '%s'", $source->name) );
72 my %slice_subquery = %{$self->slice_subquery};
74 if (my $subquery = $slice_subquery{$offset ? 'offset' : 'limit'}) {
76 my $f = $fields->[$_];
78 $f = { '' => $f } unless ref($f) eq 'HASH';
79 ($f->{-as} ||= $final_attrs{as}[$_]) =~ s/\Q${\$self->name_sep}/__/g;
80 } elsif ($f !~ /^\Q$final_attrs{alias}${\$self->name_sep}/) {
82 ($f->{-as} ||= $final_attrs{as}[$_]) =~ s/\Q${\$self->name_sep}/__/g;
90 return ($fields, \%final_attrs);
93 around _select_to_dq => sub {
94 my ($orig, $self) = (shift, shift);
95 my ($table, undef, $where) = @_;
96 my ($fields, $attrs) = $self->_select_attrs(@_);
97 my $orig_dq = $self->$orig($table, $fields, $where, $attrs->{order_by}, $attrs);
98 return $orig_dq unless $attrs->{limit};
99 if ($self->limit_dialect eq 'GenericSubquery') {
100 my $col_info = $attrs->{_rsroot_rsrc}->columns_info;
104 is_Identifier($_[0]->{by})
106 (@{$_[0]->{by}{elements}} == 2
107 and $_[0]->{by}{elements}[0] eq $attrs->{alias})
108 or (@{$_[0]->{by}{elements}} == 1))
110 my $this_col = $col_info->{$_[0]->{by}{elements}[-1]};
111 if ($this_col and not $this_col->{is_nullable}) {
112 $_[0]->{nulls} = 'none'
122 local $SQL::Abstract::Converter::Cur_Col_Meta
123 = { sqlt_datatype => 'integer' };
124 $self->_value_to_dq($attrs->{limit})
128 local $SQL::Abstract::Converter::Cur_Col_Meta
129 = { sqlt_datatype => 'integer' };
130 $self->_value_to_dq($attrs->{offset})
134 ($attrs->{order_is_stable}
135 ? (order_is_stable => 1)
137 ($attrs->{preserve_order}
138 ? (preserve_order => 1)
143 around _select_field_to_dq => sub {
144 my ($orig, $self) = (shift, shift);
146 my $ref = ref $field;
147 if ($ref eq 'HASH') {
148 my %hash = %$field; # shallow copy
150 my $as = delete $hash{-as}; # if supplied
152 my ($func, $args, @toomany) = %hash;
154 # there should be only one pair
156 die( "Malformed select argument - too many keys in hash: " . join (',', keys %$field ) );
159 if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
161 'The select => { distinct => ... } syntax is not supported for multiple columns.'
162 .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
163 .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
170 apply => $self->_ident_to_dq(uc($func)),
171 @{$self->_select_field_list_to_dq($args)},
174 $self->_select_field_to_dq($args);
178 return $field_dq unless $as;
186 return $self->$orig(@_);
190 around _source_to_dq => sub {
191 my ($orig, $self) = (shift, shift);
192 my $attrs = $_[4]; # table, fields, where, order, attrs
193 my $start_dq = $self->$orig(@_);
194 # if we have HAVING but no GROUP BY we render an empty DQ_GROUP
195 # node, which causes DQ to recognise the HAVING as being what it is.
196 # This ... is kinda bull. But that's how HAVING is specified.
197 return $start_dq unless $attrs->{group_by} or $attrs->{having};
198 my $grouped_dq = $self->_group_by_to_dq($attrs->{group_by}||[], $start_dq);
199 return $grouped_dq unless $attrs->{having};
203 where => $self->_where_to_dq($attrs->{having})
207 sub _group_by_to_dq {
208 my ($self, $group, $from) = @_;
211 by => $self->_select_field_list_to_dq($group),
216 around _table_to_dq => sub {
217 my ($orig, $self) = (shift, shift);
219 if (my $ref = ref $spec ) {
220 if ($ref eq 'ARRAY') {
221 return $self->_join_to_dq(@$spec);
223 elsif ($ref eq 'HASH') {
224 my ($as, $table, $toomuch) = ( map
225 { $_ => $spec->{$_} }
226 ( grep { $_ !~ /^\-/ } keys %$spec )
228 die "Only one table/as pair expected in from-spec but an exra '$toomuch' key present"
233 from => $self->_table_to_dq($table),
237 'dbix-class.source_name' => $spec->{-rsrc}->source_name,
238 'dbix-class.join_path' => $spec->{-join_path},
239 'dbix-class.is_single' => $spec->{-is_single},
246 return $self->$orig(@_);
250 my ($self, $from, @joins) = @_;
252 my $cur_dq = $self->_table_to_dq($from);
254 if (!@joins or @joins == 1 and ref($joins[0]) eq 'HASH') {
258 foreach my $join (@joins) {
259 my ($to, $on) = @$join;
261 # check whether a join type exists
262 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
264 if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
265 $join_type = lc($to_jt->{-join_type});
266 $join_type =~ s/^\s+ | \s+$//xg;
267 undef($join_type) unless $join_type =~ s/^(left|right).*/$1/;
272 ($join_type ? (outer => $join_type) : ()),
274 right => $self->_table_to_dq($to),
276 ? (on => $self->_expr_to_dq($self->_expand_join_condition($on)))
284 sub _expand_join_condition {
285 my ($self, $cond) = @_;
287 # Backcompat for the old days when a plain hashref
288 # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
289 # Once things settle we should start warning here so that
290 # folks unroll their hacks
296 (keys %$cond)[0] =~ /\./
298 ! ref ( (values %$cond)[0] )
300 return +{ keys %$cond => { -ident => values %$cond } }
302 elsif ( ref $cond eq 'ARRAY' ) {
303 return [ map $self->_expand_join_condition($_), @$cond ];
309 around _bind_to_dq => sub {
310 my ($orig, $self) = (shift, shift);
312 if ($self->bind_meta) {
313 map { ref($_) eq 'ARRAY' ? $_ : [ {} => $_ ] } @_
318 return $self->$orig(@args);
327 Used to explicitly specify an SQL identifier. Takes a plain string as value
328 which is then invariably treated as a column name (and is being properly
329 quoted if quoting has been requested). Most useful for comparison of two
333 priority => { '<', 2 },
334 requestor => { -ident => 'submitter' }
339 $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
344 The -value operator signals that the argument to the right is a raw bind value.
345 It will be passed straight to DBI, without invoking any of the SQL::Abstract
346 condition-parsing logic. This allows you to, for example, pass an array as a
347 column value for databases that support array datatypes, e.g.:
350 array => { -value => [1, 2, 3] }
355 $stmt = 'WHERE array = ?';
360 See L<DBIx::Class/CONTRIBUTORS>.
364 You may distribute this code under the same terms as Perl itself.