Commit | Line | Data |
b8e1e21f |
1 | package DBIx::Class::SQL::Abstract; |
2 | |
8b445e33 |
3 | use strict; |
4 | use warnings; |
5 | |
b8e1e21f |
6 | # Many thanks to SQL::Abstract, from which I stole most of this |
7 | |
8 | sub _debug { } |
9 | |
10 | sub _cond_resolve { |
11 | my ($self, $cond, $attrs, $join) = @_; |
b31e9bb7 |
12 | $cond = $self->_anoncopy($cond); # prevent destroying original |
b8e1e21f |
13 | my $ref = ref $cond || ''; |
14 | $join ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND'); |
15 | my $cmp = uc($attrs->{cmp}) || '='; |
16 | |
17 | # For assembling SQL fields and values |
18 | my(@sqlf) = (); |
19 | |
20 | # If an arrayref, then we join each element |
21 | if ($ref eq 'ARRAY') { |
22 | # need to use while() so can shift() for arrays |
b31e9bb7 |
23 | my $subjoin; |
b8e1e21f |
24 | while (my $el = shift @$cond) { |
b31e9bb7 |
25 | |
b8e1e21f |
26 | # skip empty elements, otherwise get invalid trailing AND stuff |
27 | if (my $ref2 = ref $el) { |
28 | if ($ref2 eq 'ARRAY') { |
29 | next unless @$el; |
30 | } elsif ($ref2 eq 'HASH') { |
31 | next unless %$el; |
b31e9bb7 |
32 | $subjoin ||= 'AND'; |
b8e1e21f |
33 | } elsif ($ref2 eq 'SCALAR') { |
34 | # literal SQL |
35 | push @sqlf, $$el; |
36 | next; |
37 | } |
38 | $self->_debug("$ref2(*top) means join with $subjoin"); |
39 | } else { |
40 | # top-level arrayref with scalars, recurse in pairs |
b31e9bb7 |
41 | $self->_debug("NOREF(*top) means join with $subjoin") if $subjoin; |
b8e1e21f |
42 | $el = {$el => shift(@$cond)}; |
43 | } |
b31e9bb7 |
44 | my @ret = $self->_cond_resolve($el, $attrs, $subjoin); |
45 | push @sqlf, shift @ret; |
b8e1e21f |
46 | } |
47 | } |
48 | elsif ($ref eq 'HASH') { |
49 | # Note: during recursion, the last element will always be a hashref, |
50 | # since it needs to point a column => value. So this be the end. |
51 | for my $k (sort keys %$cond) { |
52 | my $v = $cond->{$k}; |
b31e9bb7 |
53 | if ($k =~ /^-(.*)/) { |
54 | # special nesting, like -and, -or, -nest, so shift over |
55 | my $subjoin = $self->_modlogic($attrs, uc($1)); |
56 | $self->_debug("OP(-$1) means special logic ($subjoin), recursing..."); |
57 | my @ret = $self->_cond_resolve($v, $attrs, $subjoin); |
58 | push @sqlf, shift @ret; |
59 | } elsif (! defined($v)) { |
b8e1e21f |
60 | # undef = null |
61 | $self->_debug("UNDEF($k) means IS NULL"); |
0e5c2582 |
62 | push @sqlf, $self->_cond_key($attrs => $k) . ' IS NULL' |
b8e1e21f |
63 | } elsif (ref $v eq 'ARRAY') { |
64 | # multiple elements: multiple options |
b31e9bb7 |
65 | # warnings... $self->_debug("ARRAY($k) means multiple elements: [ @$v ]"); |
66 | |
67 | # special nesting, like -and, -or, -nest, so shift over |
68 | my $subjoin = 'OR'; |
69 | if ($v->[0] =~ /^-(.*)/) { |
70 | $subjoin = $self->_modlogic($attrs, uc($1)); # override subjoin |
71 | $self->_debug("OP(-$1) means special logic ($subjoin), shifting..."); |
72 | shift @$v; |
73 | } |
b8e1e21f |
74 | |
75 | # map into an array of hashrefs and recurse |
b31e9bb7 |
76 | my @ret = $self->_cond_resolve([map { {$k => $_} } @$v], $attrs, $subjoin); |
77 | |
78 | # push results into our structure |
79 | push @sqlf, shift @ret; |
b8e1e21f |
80 | } elsif (ref $v eq 'HASH') { |
81 | # modified operator { '!=', 'completed' } |
82 | for my $f (sort keys %$v) { |
83 | my $x = $v->{$f}; |
84 | $self->_debug("HASH($k) means modified operator: { $f }"); |
85 | |
86 | # check for the operator being "IN" or "BETWEEN" or whatever |
b31e9bb7 |
87 | if (ref $x eq 'ARRAY') { |
88 | if ($f =~ /^-?\s*(not[\s_]+)?(in|between)\s*$/i) { |
89 | my $mod = $1 ? $1 . $2 : $2; # avoid uninitialized value warnings |
90 | my $u = $self->_modlogic($attrs, uc($mod)); |
91 | $self->_debug("HASH($f => $x) uses special operator: [ $u ]"); |
92 | if ($u =~ /BETWEEN/) { |
93 | # SQL sucks |
94 | $self->throw( "BETWEEN must have exactly two arguments" ) unless @$x == 2; |
95 | push @sqlf, join ' ', |
96 | $self->_cond_key($attrs => $k), $u, |
97 | $self->_cond_value($attrs => $k => $x->[0]), |
98 | 'AND', |
99 | $self->_cond_value($attrs => $k => $x->[1]); |
100 | } else { |
101 | push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(', |
102 | join(', ', |
103 | map { $self->_cond_value($attrs, $k, $_) } @$x), |
104 | ')'; |
105 | } |
b8e1e21f |
106 | } else { |
b31e9bb7 |
107 | # multiple elements: multiple options |
108 | $self->_debug("ARRAY($x) means multiple elements: [ @$x ]"); |
109 | |
110 | # map into an array of hashrefs and recurse |
111 | my @ret = $self->_cond_resolve([map { {$k => {$f, $_}} } @$x], $attrs); |
b8e1e21f |
112 | |
b31e9bb7 |
113 | # push results into our structure |
114 | push @sqlf, shift @ret; |
115 | } |
b8e1e21f |
116 | } elsif (! defined($x)) { |
117 | # undef = NOT null |
118 | my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : ''; |
119 | push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL"; |
120 | } else { |
121 | # regular ol' value |
b31e9bb7 |
122 | $f =~ s/^-//; # strip leading -like => |
123 | $f =~ s/_/ /; # _ => " " |
124 | push @sqlf, join ' ', $self->_cond_key($attrs => $k), uc($f), |
b8e1e21f |
125 | $self->_cond_value($attrs => $k => $x); |
126 | } |
127 | } |
128 | } elsif (ref $v eq 'SCALAR') { |
129 | # literal SQL |
130 | $self->_debug("SCALAR($k) means literal SQL: $$v"); |
131 | push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v; |
132 | } else { |
133 | # standard key => val |
134 | $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v"); |
135 | push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp, |
136 | $self->_cond_value($attrs => $k => $v); |
137 | } |
138 | } |
139 | } |
140 | elsif ($ref eq 'SCALAR') { |
141 | # literal sql |
142 | $self->_debug("SCALAR(*top) means literal SQL: $$cond"); |
143 | push @sqlf, $$cond; |
144 | } |
145 | elsif (defined $cond) { |
146 | # literal sql |
147 | $self->_debug("NOREF(*top) means literal SQL: $cond"); |
148 | push @sqlf, $cond; |
149 | } |
150 | |
151 | # assemble and return sql |
604d9f38 |
152 | my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '1 = 1'; |
b8e1e21f |
153 | return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql; |
154 | } |
155 | |
156 | sub _cond_key { |
157 | my ($self, $attrs, $key) = @_; |
158 | return $key; |
159 | } |
160 | |
161 | sub _cond_value { |
162 | my ($self, $attrs, $key, $value) = @_; |
163 | push(@{$attrs->{bind}}, $value); |
164 | return '?'; |
165 | } |
b31e9bb7 |
166 | |
167 | # Anon copies of arrays/hashes |
168 | sub _anoncopy { |
169 | my ($self, $orig) = @_; |
170 | return (ref $orig eq 'HASH' ) ? { %$orig } |
171 | : (ref $orig eq 'ARRAY') ? [ @$orig ] |
172 | : $orig; # rest passthru ok |
173 | } |
174 | |
175 | sub _modlogic { |
176 | my ($self, $attrs, $sym) = @_; |
177 | $sym ||= $attrs->{logic}; |
178 | $sym =~ tr/_/ /; |
179 | $sym = $attrs->{logic} if $sym eq 'nest'; |
180 | return uc($sym); # override join |
181 | } |
b8e1e21f |
182 | |
183 | 1; |
34d52be2 |
184 | |
185 | =head1 NAME |
186 | |
187 | DBIx::Class::SQL::Abstract - SQL::Abstract customized for DBIC. |
188 | |
189 | =head1 SYNOPSIS |
190 | |
191 | =head1 DESCRIPTION |
192 | |
193 | This is a customized version of L<SQL::Abstract> for use in |
194 | generating L<DBIx::Searchbuilder> searches. |
195 | |
196 | =cut |
197 | |
198 | =head1 AUTHORS |
199 | |
200 | Matt S. Trout <perl-stuff@trout.me.uk> |
201 | |
202 | =head1 LICENSE |
203 | |
204 | You may distribute this code under the same terms as Perl itself. |
205 | |
206 | =cut |