basic pod stubs for everything but the CDBI compat layer.
[dbsrgits/DBIx-Class-Historic.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) = @_;
9 my $ref = ref $cond || '';
10 $join ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND');
11 my $cmp = uc($attrs->{cmp}) || '=';
12
13 # For assembling SQL fields and values
14 my(@sqlf) = ();
15
16 # If an arrayref, then we join each element
17 if ($ref eq 'ARRAY') {
18 # need to use while() so can shift() for arrays
19 while (my $el = shift @$cond) {
20 my $subjoin = 'OR';
21
22 # skip empty elements, otherwise get invalid trailing AND stuff
23 if (my $ref2 = ref $el) {
24 if ($ref2 eq 'ARRAY') {
25 next unless @$el;
26 } elsif ($ref2 eq 'HASH') {
27 next unless %$el;
28 $subjoin = 'AND';
29 } elsif ($ref2 eq 'SCALAR') {
30 # literal SQL
31 push @sqlf, $$el;
32 next;
33 }
34 $self->_debug("$ref2(*top) means join with $subjoin");
35 } else {
36 # top-level arrayref with scalars, recurse in pairs
37 $self->_debug("NOREF(*top) means join with $subjoin");
38 $el = {$el => shift(@$cond)};
39 }
40 push @sqlf, scalar $self->_cond_resolve($el, $attrs, $subjoin);
41 }
42 }
43 elsif ($ref eq 'HASH') {
44 # Note: during recursion, the last element will always be a hashref,
45 # since it needs to point a column => value. So this be the end.
46 for my $k (sort keys %$cond) {
47 my $v = $cond->{$k};
48 if (! defined($v)) {
49 # undef = null
50 $self->_debug("UNDEF($k) means IS NULL");
51 push @sqlf, $k . ' IS NULL'
52 } elsif (ref $v eq 'ARRAY') {
53 # multiple elements: multiple options
54 $self->_debug("ARRAY($k) means multiple elements: [ @$v ]");
55
56 # map into an array of hashrefs and recurse
57 my @w = ();
58 push @w, { $k => $_ } for @$v;
59 push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR');
60
61 } elsif (ref $v eq 'HASH') {
62 # modified operator { '!=', 'completed' }
63 for my $f (sort keys %$v) {
64 my $x = $v->{$f};
65 $self->_debug("HASH($k) means modified operator: { $f }");
66
67 # check for the operator being "IN" or "BETWEEN" or whatever
68 if ($f =~ /^([\s\w]+)$/i && ref $x eq 'ARRAY') {
69 my $u = uc($1);
70 if ($u =~ /BETWEEN/) {
71 # SQL sucks
72 die "BETWEEN must have exactly two arguments" unless @$x == 2;
73 push @sqlf, join ' ',
74 $self->_cond_key($attrs => $k), $u,
75 $self->_cond_value($attrs => $k => $x->[0]),
76 'AND',
77 $self->_cond_value($attrs => $k => $x->[1]);
78 } else {
79 push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(',
80 join(', ',
81 map { $self->_cond_value($attrs, $k, $_) } @$x),
82 ')';
83 }
84 } elsif (ref $x eq 'ARRAY') {
85 # multiple elements: multiple options
86 $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
87
88 # map into an array of hashrefs and recurse
89 my @w = ();
90 push @w, { $k => { $f => $_ } } for @$x;
91 push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR');
92
93 } elsif (! defined($x)) {
94 # undef = NOT null
95 my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : '';
96 push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL";
97 } else {
98 # regular ol' value
99 push @sqlf, join ' ', $self->_cond_key($attrs => $k), $f,
100 $self->_cond_value($attrs => $k => $x);
101 }
102 }
103 } elsif (ref $v eq 'SCALAR') {
104 # literal SQL
105 $self->_debug("SCALAR($k) means literal SQL: $$v");
106 push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v;
107 } else {
108 # standard key => val
109 $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v");
110 push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp,
111 $self->_cond_value($attrs => $k => $v);
112 }
113 }
114 }
115 elsif ($ref eq 'SCALAR') {
116 # literal sql
117 $self->_debug("SCALAR(*top) means literal SQL: $$cond");
118 push @sqlf, $$cond;
119 }
120 elsif (defined $cond) {
121 # literal sql
122 $self->_debug("NOREF(*top) means literal SQL: $cond");
123 push @sqlf, $cond;
124 }
125
126 # assemble and return sql
604d9f38 127 my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '1 = 1';
b8e1e21f 128 return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql;
129}
130
131sub _cond_key {
132 my ($self, $attrs, $key) = @_;
133 return $key;
134}
135
136sub _cond_value {
137 my ($self, $attrs, $key, $value) = @_;
138 push(@{$attrs->{bind}}, $value);
139 return '?';
140}
141
1421;
34d52be2 143
144=head1 NAME
145
146DBIx::Class::SQL::Abstract - SQL::Abstract customized for DBIC.
147
148=head1 SYNOPSIS
149
150=head1 DESCRIPTION
151
152This is a customized version of L<SQL::Abstract> for use in
153generating L<DBIx::Searchbuilder> searches.
154
155=cut
156
157=head1 AUTHORS
158
159Matt S. Trout <perl-stuff@trout.me.uk>
160
161=head1 LICENSE
162
163You may distribute this code under the same terms as Perl itself.
164
165=cut