Commit | Line | Data |
0bcf772f |
1 | use MooseX::Declare; |
2 | |
3 | class SQL::Abstract::Compat { |
7c300b3a |
4 | |
5 | use Moose::Util::TypeConstraints; |
bad761ba |
6 | use MooseX::Types::Moose qw/Str ScalarRef ArrayRef HashRef/; |
0a18aa4f |
7 | use SQL::Abstract::Types::Compat ':all'; |
1c51edc4 |
8 | use SQL::Abstract::Types qw/AST/; |
0a18aa4f |
9 | use SQL::Abstract::AST::v1; |
10 | use Data::Dump qw/pp/; |
1c51edc4 |
11 | use Devel::PartialDump qw/dump/; |
12 | use Carp qw/croak/; |
bad761ba |
13 | |
0a18aa4f |
14 | class_type 'SQL::Abstract'; |
7c300b3a |
15 | clean; |
16 | |
17 | has logic => ( |
18 | is => 'rw', |
19 | isa => LogicEnum, |
aa0f2366 |
20 | default => 'AND', |
21 | coerce => 1 |
7c300b3a |
22 | ); |
23 | |
0a18aa4f |
24 | has visitor => ( |
25 | is => 'rw', |
26 | isa => 'SQL::Abstract', |
27 | clearer => 'clear_visitor', |
28 | lazy => 1, |
29 | builder => '_build_visitor', |
30 | ); |
bad761ba |
31 | |
32 | |
7c300b3a |
33 | method select(Str|ArrayRef|ScalarRef $from, ArrayRef|Str $fields, |
0a18aa4f |
34 | WhereType $where?, |
35 | WhereType $order?) |
36 | { |
1c51edc4 |
37 | my $ast = { |
38 | -type => 'select', |
39 | columns => [ |
40 | map { |
41 | $self->mk_name($_) |
42 | } ( is_Str($fields) ? $fields : @$fields ) |
43 | ], |
44 | tablespec => $self->tablespec($from) |
45 | }; |
0a18aa4f |
46 | |
1c51edc4 |
47 | |
48 | $ast->{where} = $self->recurse_where($where) |
49 | if defined $where; |
7c300b3a |
50 | |
0a18aa4f |
51 | return ($self->visitor->dispatch($ast), $self->visitor->binds); |
52 | } |
bad761ba |
53 | |
0a18aa4f |
54 | method where(WhereType $where, |
55 | WhereType $order?) |
56 | { |
57 | my $ret = ""; |
58 | |
59 | if ($where) { |
1c51edc4 |
60 | my $ast = $self->recurse_where($where); |
0a18aa4f |
61 | $ret .= "WHERE " . $self->visitor->_expr($ast); |
62 | } |
63 | |
64 | return $ret; |
7c300b3a |
65 | } |
bad761ba |
66 | |
0a18aa4f |
67 | method _build_visitor() { |
68 | return SQL::Abstract->create(1); |
69 | } |
70 | |
1c51edc4 |
71 | sub mk_name { |
72 | shift; |
73 | return { -type => 'name', args => [ @_ ] }; |
74 | } |
75 | |
76 | method tablespec(Str|ArrayRef|ScalarRef $from) { |
77 | return $self->mk_name($from) |
78 | if is_Str($from); |
79 | } |
80 | |
81 | method recurse_where(WhereType $ast, LogicEnum $logic?) returns (AST) { |
82 | return $self->recurse_where_hash($logic || 'AND', $ast) if is_HashRef($ast); |
83 | return $self->recurse_where_array($logic || 'OR', $ast) if is_ArrayRef($ast); |
84 | croak "Unknown where clause type " . dump($ast); |
85 | } |
86 | |
87 | method recurse_where_hash(LogicEnum $logic, HashRef $ast) returns (AST) { |
88 | my @args; |
89 | my $ret = { |
90 | -type => 'expr', |
91 | op => lc $logic, |
92 | args => \@args |
93 | }; |
94 | |
95 | while (my ($key,$value) = each %$ast) { |
96 | if ($key =~ /^-(or|and)$/) { |
97 | my $val = $self->recurse_where($value, uc $1); |
98 | if ($val->{op} eq $ret->{op}) { |
99 | push @args, @{$val->{args}}; |
100 | } |
101 | else { |
102 | push @args, $val; |
103 | } |
104 | next; |
105 | } |
106 | |
107 | push @args, $self->field($key, $value); |
108 | } |
109 | |
110 | return $args[0] if @args == 1; |
111 | |
112 | return $ret; |
113 | } |
114 | |
115 | method recurse_where_array(LogicEnum $logic, ArrayRef $ast) returns (AST) { |
116 | my @args; |
117 | my $ret = { |
118 | -type => 'expr', |
119 | op => lc $logic, |
120 | args => \@args |
121 | }; |
122 | my @nodes = @$ast; |
123 | |
124 | while (my $key = shift @nodes) { |
125 | if ($key =~ /^-(or|and)$/) { |
126 | my $value = shift @nodes |
127 | or confess "missing value after $key at " . dump($ast); |
128 | |
129 | my $val = $self->recurse_where($value, uc $1); |
130 | if ($val->{op} eq $ret->{op}) { |
131 | push @args, @{$val->{args}}; |
132 | } |
133 | else { |
134 | push @args, $val; |
135 | } |
136 | next; |
137 | } |
138 | |
139 | push @args, $self->recurse_where($key); |
140 | } |
141 | |
142 | return $args[0] if @args == 1; |
143 | |
144 | return $ret; |
145 | } |
146 | |
147 | method field(Str $key, $value) returns (AST) { |
148 | my $ret = { |
149 | -type => 'expr', |
150 | op => '==', |
151 | args => [ |
152 | { -type => 'name', args => [$key] } |
153 | ], |
154 | }; |
155 | |
156 | if (is_HashRef($value)) { |
157 | my ($op, @rest) = keys %$value; |
158 | confess "Don't know how to handle " . dump($value) . " (too many keys)" |
159 | if @rest; |
160 | |
161 | # TODO: Validate the op? |
162 | if ($op =~ /^-([a-z_]+)$/i) { |
163 | $ret->{op} = lc $1; |
164 | |
165 | if (is_ArrayRef($value->{$op})) { |
166 | push @{$ret->{args}}, $self->value($_) |
167 | for @{$value->{$op}}; |
168 | return $ret; |
169 | } |
170 | } |
171 | else { |
172 | $ret->{op} = $op; |
173 | } |
174 | |
175 | push @{$ret->{args}}, $self->value($value->{$op}); |
176 | |
177 | } |
178 | elsif (is_ArrayRef($value)) { |
179 | # Return an or clause, sort of. |
180 | return { |
181 | -type => 'expr', |
182 | op => 'or', |
183 | args => [ map { |
184 | { |
185 | -type => 'expr', |
186 | op => '==', |
187 | args => [ |
188 | { -type => 'name', args => [$key] }, |
189 | $self->value($_) |
190 | ], |
191 | } |
192 | } @$value ] |
193 | }; |
194 | } |
195 | else { |
196 | push @{$ret->{args}}, $self->value($value); |
197 | } |
198 | |
199 | return $ret; |
200 | } |
201 | |
202 | method value($value) returns (AST) { |
203 | return { -type => 'value', value => $value } |
204 | if is_Str($value); |
205 | |
206 | confess "Don't know how to handle terminal value " . dump($value); |
207 | } |
208 | |
209 | |
0bcf772f |
210 | } |
211 | |
212 | =head1 NAME |
213 | |
214 | SQL::Abstract::Compant - compatibility layer for SQL::Abstrct v 1.xx |
215 | |
216 | =head1 DESCRIPTION |
217 | |
218 | This class attempts to maintain the original behaviour of version 1 of |
219 | SQL::Abstract. It does this by internally converting to an AST and then using |
220 | the standard AST visitor. |
221 | |
222 | If so desired, you can get hold of this transformed AST somehow. This is aimed |
223 | at libraries such as L<DBIx::Class> that use SQL::Abstract-style arrays or |
224 | hashes as part of their public interface. |
225 | |
226 | =head1 AUTHOR |
227 | |
228 | Ash Berlin C<< <ash@cpan.org> >> |
229 | |
230 | =cut |
231 | |
232 | 1; |