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