Commit | Line | Data |
a0185af2 |
1 | use MooseX::Declare; |
2 | use MooseX::Method::Signatures; |
3 | |
4 | |
5 | class SQL::Abstract { |
6 | |
7 | use Carp qw/croak/; |
8 | use Data::Dump qw/pp/; |
9 | |
10 | use Moose::Util::TypeConstraints; |
3e63a4d5 |
11 | use MooseX::Types -declare => [qw/NameSeparator/]; |
a0185af2 |
12 | use MooseX::Types::Moose qw/ArrayRef Str/; |
4769c837 |
13 | use MooseX::AttributeHelpers; |
14 | |
15 | use namespace::clean -except => ['meta']; |
a0185af2 |
16 | |
17 | subtype NameSeparator, |
18 | as ArrayRef[Str]; |
19 | #where { @$_ == 1 ||| @$_ == 2 }, |
20 | #message { "Name separator must be one or two elements" }; |
21 | |
22 | coerce NameSeparator, from Str, via { [ $_ ] }; |
23 | |
24 | our $VERSION = '2.000000'; |
25 | |
26 | our $AST_VERSION = '1'; |
27 | |
3e63a4d5 |
28 | # Operator precedence for bracketing |
29 | our %PRIO = ( |
30 | and => 10, |
31 | or => 50 |
32 | ); |
33 | |
34 | our %OP_MAP = ( |
35 | '>' => '>', |
36 | '<' => '<', |
37 | '==' => '=', |
38 | '!=' => '!=', |
39 | ); |
40 | |
a0185af2 |
41 | has name_separator => ( |
42 | is => 'rw', |
43 | isa => NameSeparator, |
44 | default => sub { ['.'] }, |
45 | coerece => 1, |
46 | required => 1, |
47 | ); |
48 | |
49 | has list_separator => ( |
50 | is => 'rw', |
51 | isa => Str, |
52 | default => ', ', |
53 | required => 1, |
54 | ); |
55 | |
4769c837 |
56 | has binds => ( |
57 | isa => ArrayRef, |
5bf8c024 |
58 | is => 'ro', |
4769c837 |
59 | default => sub { [ ] }, |
60 | metaclass => 'Collection::Array', |
61 | provides => { |
62 | push => 'add_bind', |
5bf8c024 |
63 | clear => '_clear_binds', |
4769c837 |
64 | } |
65 | ); |
66 | |
3e63a4d5 |
67 | method generate (Object|ClassName $self: ArrayRef $ast) { |
5bf8c024 |
68 | my $class_meth = !blessed($self); |
69 | $self = $self->new if $class_meth; |
a0185af2 |
70 | |
71 | local $_ = $ast->[0]; |
73382d73 |
72 | s/^-/_/g or croak "Unknown type tag '$_'"; |
4769c837 |
73 | my $meth = $self->can($_) || \&_generic_func; |
5bf8c024 |
74 | return $class_meth |
75 | ? ($meth->($self, $ast), $self->binds) |
76 | : $meth->($self, $ast); |
4769c837 |
77 | } |
78 | |
79 | method _select(ArrayRef $ast) { |
80 | |
a0185af2 |
81 | } |
82 | |
73382d73 |
83 | method _where(ArrayRef $ast) { |
84 | my (undef, @clauses) = @$ast; |
85 | |
86 | return 'WHERE ' . $self->_recurse_where(\@clauses); |
87 | } |
88 | |
89 | method _order_by(ArrayRef $ast) { |
90 | my (undef, @clauses) = @$ast; |
91 | |
92 | my @output; |
93 | |
94 | for (@clauses) { |
95 | if ($_->[0] =~ /^-(asc|desc)$/) { |
96 | my $o = $1; |
97 | push @output, $self->generate($_->[1]) . " " . uc($o); |
98 | next; |
99 | } |
100 | push @output, $self->generate($_); |
101 | } |
102 | |
103 | return "ORDER BY " . join(", ", @output); |
104 | } |
105 | |
4769c837 |
106 | method _name(ArrayRef $ast) { |
a0185af2 |
107 | my (undef, @names) = @$ast; |
108 | |
109 | my $sep = $self->name_separator; |
110 | |
111 | return $sep->[0] . |
112 | join( $sep->[1] . $sep->[0], @names ) . |
113 | $sep->[1] |
114 | if (@$sep > 1); |
115 | |
116 | return join($sep->[0], @names); |
117 | } |
118 | |
119 | method _list(ArrayRef $ast) { |
120 | my (undef, @items) = @$ast; |
121 | |
122 | return join( |
123 | $self->list_separator, |
124 | map { $self->generate($_) } @items); |
a0185af2 |
125 | } |
126 | |
4769c837 |
127 | method _alias(ArrayRef $ast) { |
128 | my (undef, $alias, $as) = @$ast; |
129 | |
130 | return $self->generate($alias) . " AS $as"; |
131 | |
132 | } |
133 | |
134 | method _value(ArrayRef $ast) { |
135 | my ($undef, $value) = @$ast; |
136 | |
137 | $self->add_bind($value); |
138 | return "?"; |
139 | } |
140 | |
3e63a4d5 |
141 | method _recurse_where($clauses) { |
3e63a4d5 |
142 | |
143 | my $OP = 'AND'; |
144 | my $prio = $PRIO{and}; |
145 | my $first = $clauses->[0]; |
4769c837 |
146 | |
3e63a4d5 |
147 | if (!ref $first && $first =~ /^-(and|or)$/) { |
148 | $OP = uc($1); |
149 | $prio = $PRIO{$1}; |
150 | shift @$clauses; |
151 | } |
152 | |
153 | my @output; |
154 | foreach (@$clauses) { |
7d3908d3 |
155 | croak "invalid component in where clause" unless ArrayRef->check($_); |
4769c837 |
156 | my $op = $_->[0]; |
157 | |
158 | unless (substr($op, 0, 1) eq '-') { |
159 | # A simple comparison op (==, >, etc.) |
3e63a4d5 |
160 | |
161 | push @output, $self->_binop(@$_); |
162 | |
163 | } elsif ($op =~ /^-(and|or)$/) { |
164 | my $sub_prio = $PRIO{$1}; |
165 | |
865ef15a |
166 | if ($sub_prio <= $prio) { |
3e63a4d5 |
167 | push @output, $self->_recurse_where($_); |
168 | } else { |
169 | push @output, '(' . $self->_recurse_where($_) . ')'; |
170 | } |
171 | } else { |
172 | push @output, $self->generate($_); |
4769c837 |
173 | } |
174 | } |
175 | |
865ef15a |
176 | return join(" $OP ", @output); |
3e63a4d5 |
177 | } |
178 | |
179 | method _binop($op, $lhs, $rhs) { |
180 | join (' ', $self->generate($lhs), |
181 | $OP_MAP{$op} || croak("Unknown binary operator $op"), |
182 | $self->generate($rhs) |
183 | ); |
4769c837 |
184 | } |
185 | |
d2582f0f |
186 | method _in($ast) { |
187 | my (undef, $field, @values) = @$ast; |
188 | |
189 | return $self->generate($field) . |
190 | " IN (" . |
191 | join(", ", map { $self->generate($_) } @values ) . |
192 | ")"; |
193 | } |
194 | |
4769c837 |
195 | method _generic_func(ArrayRef $ast) { |
196 | } |
197 | |
198 | |
a0185af2 |
199 | }; |