DBIx-Custom / lib / DBIx / Custom / QueryBuilder.pm /
Newer Older
366 lines | 8.581kb
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
1
package DBIx::Custom::QueryBuilder;
2

            
3
use strict;
4
use warnings;
5

            
6
use base 'Object::Simple';
7

            
8
use Carp 'croak';
9
use DBIx::Custom::Query;
cleanup
Yuki Kimoto authored on 2011-04-25
10
use DBIx::Custom::Util '_subname';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
11

            
fixed Carp trast relationshi...
yuki-kimoto authored on 2010-08-12
12
# Carp trust relationship
13
push @DBIx::Custom::CARP_NOT, __PACKAGE__;
updated document
Yuki Kimoto authored on 2011-01-20
14
push @DBIx::Custom::Where::CARP_NOT, __PACKAGE__;
15

            
cleanup
yuki-kimoto authored on 2010-10-17
16
# Attributes
cleanup
Yuki Kimoto authored on 2011-01-25
17
__PACKAGE__->attr('tags' => sub { {} });
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
18

            
cleanup
yuki-kimoto authored on 2010-10-17
19
sub build_query {
20
    my ($self, $source)  = @_;
21
    
22
    # Parse
23
    my $tree = $self->_parse($source);
24
    
25
    # Build query
26
    my $query = $self->_build_query($tree);
27
    
28
    return $query;
29
}
30

            
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
31
sub register_tag {
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
32
    my $self = shift;
changed argument of tag proc...
yuki-kimoto authored on 2010-08-03
33
    
cleanup
Yuki Kimoto authored on 2011-01-25
34
    # Merge tag
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
35
    my $tags = ref $_[0] eq 'HASH' ? $_[0] : {@_};
36
    $self->tags({%{$self->tags}, %$tags});
changed argument of tag proc...
yuki-kimoto authored on 2010-08-03
37
    
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
38
    return $self;
39
}
40

            
cleanup
yuki-kimoto authored on 2010-10-17
41
sub _build_query {
42
    my ($self, $tree) = @_;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
43
    
cleanup
yuki-kimoto authored on 2010-10-17
44
    # SQL
45
    my $sql = '';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
46
    
cleanup
yuki-kimoto authored on 2010-10-17
47
    # All Columns
48
    my $all_columns = [];
49
    
add table tag
Yuki Kimoto authored on 2011-02-09
50
    # Tables
51
    my $tables = [];
52
    
cleanup
yuki-kimoto authored on 2010-10-17
53
    # Build SQL 
54
    foreach my $node (@$tree) {
55
        
56
        # Text
57
        if ($node->{type} eq 'text') { $sql .= $node->{value} }
58
        
59
        # Tag
60
        else {
61
            
62
            # Tag name
63
            my $tag_name = $node->{tag_name};
64
            
65
            # Tag arguments
66
            my $tag_args = $node->{tag_args};
67
            
add table tag
Yuki Kimoto authored on 2011-02-09
68
            # Table
69
            if ($tag_name eq 'table') {
70
                my $table = $tag_args->[0];
71
                push @$tables, $table;
72
                $sql .= $table;
73
                next;
74
            }
75

            
cleanup
Yuki Kimoto authored on 2011-01-25
76
            # Get tag
77
            my $tag = $self->tag_processors->{$tag_name}
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
78
                             || $self->tags->{$tag_name};
cleanup
yuki-kimoto authored on 2010-10-17
79
            
cleanup
Yuki Kimoto authored on 2011-01-25
80
            # Tag is not registered
select, update, and delete w...
Yuki Kimoto authored on 2011-04-25
81
            croak qq{Tag "$tag_name" is not registered } . _subname
cleanup
Yuki Kimoto authored on 2011-01-25
82
              unless $tag;
cleanup
yuki-kimoto authored on 2010-10-17
83
            
cleanup
Yuki Kimoto authored on 2011-01-25
84
            # Tag not sub reference
cleanup
Yuki Kimoto authored on 2011-04-25
85
            croak qq{Tag "$tag_name" must be sub reference } . _subname
cleanup
Yuki Kimoto authored on 2011-01-25
86
              unless ref $tag eq 'CODE';
cleanup
yuki-kimoto authored on 2010-10-17
87
            
cleanup
Yuki Kimoto authored on 2011-01-25
88
            # Execute tag
89
            my $r = $tag->(@$tag_args);
cleanup
yuki-kimoto authored on 2010-10-17
90
            
cleanup
Yuki Kimoto authored on 2011-01-25
91
            # Check tag return value
cleanup
Yuki Kimoto authored on 2011-04-25
92
            croak qq{Tag "$tag_name" must return [STRING, ARRAY_REFERENCE] }
93
                . _subname
cleanup
yuki-kimoto authored on 2010-10-17
94
              unless ref $r eq 'ARRAY' && defined $r->[0] && ref $r->[1] eq 'ARRAY';
95
            
96
            # Part of SQL statement and colum names
97
            my ($part, $columns) = @$r;
98
            
99
            # Add columns
100
            push @$all_columns, @$columns;
101
            
102
            # Join part tag to SQL
103
            $sql .= $part;
104
        }
105
    }
106

            
107
    # Check placeholder count
108
    my $placeholder_count = $self->_placeholder_count($sql);
109
    my $column_count      = @$all_columns;
110
    croak qq{Placeholder count in "$sql" must be same as column count $column_count}
cleanup
Yuki Kimoto authored on 2011-04-25
111
        . _subname
cleanup
yuki-kimoto authored on 2010-10-17
112
      unless $placeholder_count eq @$all_columns;
113
    
114
    # Add semicolon
115
    $sql .= ';' unless $sql =~ /;$/;
116
    
117
    # Query
add table tag
Yuki Kimoto authored on 2011-02-09
118
    my $query = DBIx::Custom::Query->new(
119
        sql => $sql,
120
        columns => $all_columns,
121
        tables => $tables
122
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
123
    
124
    return $query;
125
}
126

            
127
sub _parse {
128
    my ($self, $source) = @_;
129
    
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
130
    # Source
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
131
    $source ||= '';
fixed tests
yuki-kimoto authored on 2010-08-06
132

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
133
    # Tree
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
134
    my @tree;
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
135
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
136
    # Value
137
    my $value = '';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
138
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
139
    # State
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
140
    my $state = 'text';
141
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
142
    # Before charactor
143
    my $before = '';
144

            
145
    # Position
fixed DBIx::Custom::QueryBui...
yuki-kimoto authored on 2010-08-15
146
    my $pos = 0;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
147
    
148
    # Parse
added tests
yuki-kimoto authored on 2010-08-12
149
    my $original = $source;
fixed DBIx::Custom::QueryBui...
yuki-kimoto authored on 2010-08-15
150
    while (defined(my $c = substr($source, $pos, 1))) {
151
        
152
        # Last
153
        last unless length $c;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
154
        
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
155
        # State is text
156
        if ($state eq 'text') {
157
            
158
            # Tag start charactor
159
            if ($c eq '{') {
160
                
161
                # Escaped charactor
162
                if ($before eq "\\") {
163
                    substr($value, -1, 1, '');
164
                    $value .= $c;
165
                }
166
                
167
                # Tag start
168
                else {
169
                    
170
                    # Change state
171
                    $state = 'tag';
172
                    
173
                    # Add text
174
                    push @tree, {type => 'text', value => $value}
175
                      if $value;
176
                    
177
                    # Clear
178
                    $value = '';
179
                }
180
            }
181
            
182
            # Tag end charactor
183
            elsif ($c eq '}') {
184
            
185
                # Escaped charactor
186
                if ($before eq "\\") {
187
                    substr($value, -1, 1, '');
188
                    $value .= $c;
189
                }
190
                
191
                # Unexpected
192
                else {
improved error messages
Yuki Kimoto authored on 2011-04-18
193
                    croak qq{Parsing error. unexpected "\}". }
cleanup
Yuki Kimoto authored on 2011-04-25
194
                        . qq{pos $pos of "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
195
                }
196
            }
197
            
198
            # Normal charactor
199
            else { $value .= $c }
200
        }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
201
        
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
202
        # State is tags
added tests
yuki-kimoto authored on 2010-08-12
203
        else {
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
204
            
205
            # Tag start charactor
206
            if ($c eq '{') {
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
207
            
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
208
                # Escaped charactor
209
                if ($before eq "\\") {
210
                    substr($value, -1, 1, '');
211
                    $value .= $c;
212
                }
213
                
214
                # Unexpected
215
                else {
improved error messages
Yuki Kimoto authored on 2011-04-18
216
                    croak qq{Parsing error. unexpected "\{". }
cleanup
Yuki Kimoto authored on 2011-04-25
217
                        . qq{pos $pos of "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
218
                }
219
            }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
220
            
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
221
            # Tag end charactor
222
            elsif ($c eq '}') {
223
                
224
                # Escaped charactor
225
                if ($before eq "\\") {
226
                    substr($value, -1, 1, '');
227
                    $value .= $c;
228
                }
229
                
230
                # Tag end
231
                else {
232
                
233
                    # Change state
234
                    $state = 'text';
235
                    
236
                    # Add tag
237
                    my ($tag_name, @tag_args) = split /\s+/, $value;
238
                    push @tree, {type => 'tag', tag_name => $tag_name, 
239
                                 tag_args => \@tag_args};
240
                    
241
                    # Clear
242
                    $value = '';
243
                }
244
            }
245
            
246
            # Normal charactor
247
            else { $value .= $c }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
248
        }
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
249
        
250
        # Save before charactor
251
        $before = $c;
252
        
253
        # increment position
254
        $pos++;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
255
    }
256
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
257
    # Tag not finished
cleanup
Yuki Kimoto authored on 2011-04-25
258
    croak qq{Tag not finished. "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
259
      if $state eq 'tag';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
260
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
261
    # Add rest text
262
    push @tree, {type => 'text', value => $value}
263
      if $value;
264
    
265
    return \@tree;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
266
}
267

            
268
sub _placeholder_count {
269
    my ($self, $expand) = @_;
270
    
changed argument of tag proc...
yuki-kimoto authored on 2010-08-03
271
    # Count
272
    $expand ||= '';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
273
    my $count = 0;
274
    my $pos   = -1;
275
    while (($pos = index($expand, '?', $pos + 1)) != -1) {
276
        $count++;
277
    }
278
    return $count;
279
}
280

            
cleanup
Yuki Kimoto authored on 2011-01-25
281
# DEPRECATED!
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
282
__PACKAGE__->attr('tag_processors' => sub { {} });
283

            
cleanup
Yuki Kimoto authored on 2011-01-25
284
# DEPRECATED!
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
285
sub register_tag_processor {
286
    my $self = shift;
287
    
cleanup
Yuki Kimoto authored on 2011-01-25
288
    # Merge tag
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
289
    my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
290
    $self->tag_processors({%{$self->tag_processors}, %{$tag_processors}});
291
    
292
    return $self;
293
}
294

            
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
295
1;
296

            
297
=head1 NAME
298

            
299
DBIx::Custom::QueryBuilder - Query builder
300

            
301
=head1 SYNOPSIS
302
    
303
    my $builder = DBIx::Custom::QueryBuilder->new;
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
304
    my $query = $builder->build_query(
305
        "select from table {= k1} && {<> k2} || {like k3}"
306
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
307

            
308
=head1 ATTRIBUTES
309

            
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
310
=head2 C<tags>
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
311

            
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
312
    my $tags = $builder->tags;
cleanup
Yuki Kimoto authored on 2011-01-25
313
    $builder = $builder->tags(\%tags);
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
314

            
cleanup
Yuki Kimoto authored on 2011-01-25
315
Tags.
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
316

            
317
=head1 METHODS
318

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
319
L<DBIx::Custom::QueryBuilder> inherits all methods from L<Object::Simple>
320
and implements the following new ones.
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
321

            
322
=head2 C<build_query>
323
    
324
    my $query = $builder->build_query($source);
325

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
326
Create a new L<DBIx::Custom::Query> object from SQL source.
327
SQL source contains tags, such as {= title}, {like author}.
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
328

            
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
329
C<{> and C<}> is reserved. If you use these charactors,
330
you must escape them using '\'. Note that '\' is
331
already perl escaped charactor, so you must write '\\'. 
332

            
333
    'select * from books \\{ something statement \\}'
334

            
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
335
B<Example:>
336

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
337
SQL source
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
338

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
339
      "select * from table where {= title} && {like author} || {<= price}"
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
340

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
341
Query
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
342

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
343
    {
344
        sql     => "select * from table where title = ? && author like ? price <= ?;"
345
        columns => ['title', 'author', 'price']
346
    }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
347

            
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
348
=head2 C<register_tag>
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
349

            
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
350
    $builder->register_tag(\%tags);
351
    $builder->register_tag(%tags);
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
352

            
cleanup
Yuki Kimoto authored on 2011-01-25
353
Register tag.
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
354

            
renamed build_query to creat...
yuki-kimoto authored on 2010-08-06
355
B<Example:>
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
356

            
cleanup
Yuki Kimoto authored on 2011-01-25
357
    $builder->register_tag(
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
358
        '?' => sub {
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
359
            my $column = shift;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
360
            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
361
            return ['?', [$column]];
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
362
        }
363
    );
364

            
cleanup
Yuki Kimoto authored on 2011-01-25
365
See also L<DBIx::Custom::Tag> to know tag.
update document
yuki-kimoto authored on 2010-08-07
366