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