DBIx-Custom / lib / DBIx / Custom / QueryBuilder.pm /
Newer Older
380 lines | 9.455kb
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

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
16
# Parameter regex
17
our $PARAM_RE = qr/(^|[^\.\w]):([\.\w]+)([^\.\w]|$)/sm;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
18

            
cleanup
yuki-kimoto authored on 2010-10-17
19
sub build_query {
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
20
    my ($self, $source) = @_;
cleanup
yuki-kimoto authored on 2010-10-17
21
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
22
    my $query;
23
    
24
    # Parse tag. tag is DEPRECATED!
25
    if ($source =~ /\{/ && $source =~ /\}/) {
26
        $query = $self->_parse_tag($source);
27
        my $tag_count = delete $query->{tag_count};
fixed DEPRECATED message bug
Yuki Kimoto authored on 2011-06-10
28
        warn qq/Tag system such as {? name} is DEPRECATED! / .
29
             qq/use parameter system such as :name instead/
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
30
          if $tag_count;
31
        my $query2 = $self->_parse_parameter($query->sql);
32
        $query->sql($query2->sql);
33
        for (my $i =0; $i < @{$query->columns}; $i++) {
34
            my $column = $query->columns->[$i];
35
            if ($column eq 'RESERVED_PARAMETER') {
36
                my $column2 = shift @{$query2->columns};
37
                croak ":name syntax is wrong"
38
                  unless defined $column2;
39
                $query->columns->[$i] = $column2;
40
            }
41
        }
42
    }
cleanup
yuki-kimoto authored on 2010-10-17
43
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
44
    # Parse parameter
45
    else {
46
        $query = $self->_parse_parameter($source);
47
    }
cleanup
yuki-kimoto authored on 2010-10-17
48
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
49
    my $sql = $query->sql;
50
    $sql .= ';' unless $source =~ /;$/;
51
    $query->sql($sql);
52

            
53
    # Check placeholder count
54
    croak qq{Placeholder count in "$sql" must be same as column count}
55
        . _subname
56
      unless $self->_placeholder_count($sql) eq @{$query->columns};
57
        
cleanup
yuki-kimoto authored on 2010-10-17
58
    return $query;
59
}
60

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
61
sub _placeholder_count {
62
    my ($self, $sql) = @_;
changed argument of tag proc...
yuki-kimoto authored on 2010-08-03
63
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
64
    # Count
65
    $sql ||= '';
66
    my $count = 0;
67
    my $pos   = -1;
68
    while (($pos = index($sql, '?', $pos + 1)) != -1) {
69
        $count++;
70
    }
71
    return $count;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
72
}
73

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
74
sub _parse_parameter {
75
    my ($self, $source) = @_;
add table tag
Yuki Kimoto authored on 2011-02-09
76
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
77
    # Get and replace parameters
78
    my $sql = $source || '';
79
    my $columns = [];
80
    while ($source =~ /$PARAM_RE/g) {
81
        push @$columns, $2;
cleanup
yuki-kimoto authored on 2010-10-17
82
    }
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
83
    $sql =~ s/$PARAM_RE/$1?$3/g;
cleanup
yuki-kimoto authored on 2010-10-17
84

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
85
    # Create query
add table tag
Yuki Kimoto authored on 2011-02-09
86
    my $query = DBIx::Custom::Query->new(
87
        sql => $sql,
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
88
        columns => $columns
add table tag
Yuki Kimoto authored on 2011-02-09
89
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
90
    
91
    return $query;
92
}
93

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
94
# DEPRECATED!
95
__PACKAGE__->attr('tags' => sub { {} });
96

            
97
# DEPRECATED!
98
sub register_tag {
99
    my $self = shift;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
100
    
added warnings
Yuki Kimoto authored on 2011-06-07
101
    warn "register_tag is DEPRECATED!";
102
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
103
    # Merge tag
104
    my $tags = ref $_[0] eq 'HASH' ? $_[0] : {@_};
105
    $self->tags({%{$self->tags}, %$tags});
106
    
107
    return $self;
108
}
109

            
110
# DEPRECATED!
111
sub _parse_tag {
112
    my ($self, $source) = @_;
113

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
114
    # Source
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
115
    $source ||= '';
fixed tests
yuki-kimoto authored on 2010-08-06
116

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
117
    # Tree
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
118
    my @tree;
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
119
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
120
    # Value
121
    my $value = '';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
122
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
123
    # State
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
124
    my $state = 'text';
125
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
126
    # Before charactor
127
    my $before = '';
128

            
129
    # Position
fixed DBIx::Custom::QueryBui...
yuki-kimoto authored on 2010-08-15
130
    my $pos = 0;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
131
    
132
    # Parse
added tests
yuki-kimoto authored on 2010-08-12
133
    my $original = $source;
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
134
    my $tag_count = 0;
fixed DBIx::Custom::QueryBui...
yuki-kimoto authored on 2010-08-15
135
    while (defined(my $c = substr($source, $pos, 1))) {
136
        
137
        # Last
138
        last unless length $c;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
139
        
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
140
        # Parameter
141
        if ($c eq ':' && (substr($source, $pos + 1, 1) || '') =~ /\w/) {
142
            push @tree, {type => 'param'};;
143
        }
144
        
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
145
        # State is text
146
        if ($state eq 'text') {
147
            
148
            # Tag start charactor
149
            if ($c eq '{') {
150
                
151
                # Escaped charactor
152
                if ($before eq "\\") {
153
                    substr($value, -1, 1, '');
154
                    $value .= $c;
155
                }
156
                
157
                # Tag start
158
                else {
159
                    
160
                    # Change state
161
                    $state = 'tag';
162
                    
163
                    # Add text
164
                    push @tree, {type => 'text', value => $value}
165
                      if $value;
166
                    
167
                    # Clear
168
                    $value = '';
169
                }
170
            }
171
            
172
            # Tag end charactor
173
            elsif ($c eq '}') {
174
            
175
                # Escaped charactor
176
                if ($before eq "\\") {
177
                    substr($value, -1, 1, '');
178
                    $value .= $c;
179
                }
180
                
181
                # Unexpected
182
                else {
improved error messages
Yuki Kimoto authored on 2011-04-18
183
                    croak qq{Parsing error. unexpected "\}". }
cleanup
Yuki Kimoto authored on 2011-04-25
184
                        . qq{pos $pos of "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
185
                }
186
            }
187
            
188
            # Normal charactor
189
            else { $value .= $c }
190
        }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
191
        
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
192
        # State is tags
added tests
yuki-kimoto authored on 2010-08-12
193
        else {
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
194
            
195
            # Tag start charactor
196
            if ($c eq '{') {
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
197
            
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
198
                # Escaped charactor
199
                if ($before eq "\\") {
200
                    substr($value, -1, 1, '');
201
                    $value .= $c;
202
                }
203
                
204
                # Unexpected
205
                else {
improved error messages
Yuki Kimoto authored on 2011-04-18
206
                    croak qq{Parsing error. unexpected "\{". }
cleanup
Yuki Kimoto authored on 2011-04-25
207
                        . qq{pos $pos of "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
208
                }
209
            }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
210
            
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
211
            # Tag end charactor
212
            elsif ($c eq '}') {
213
                
214
                # Escaped charactor
215
                if ($before eq "\\") {
216
                    substr($value, -1, 1, '');
217
                    $value .= $c;
218
                }
219
                
220
                # Tag end
221
                else {
222
                
223
                    # Change state
224
                    $state = 'text';
225
                    
226
                    # Add tag
227
                    my ($tag_name, @tag_args) = split /\s+/, $value;
228
                    push @tree, {type => 'tag', tag_name => $tag_name, 
229
                                 tag_args => \@tag_args};
230
                    
231
                    # Clear
232
                    $value = '';
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
233
                    
234
                    # Countup
235
                    $tag_count++;
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
236
                }
237
            }
238
            
239
            # Normal charactor
240
            else { $value .= $c }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
241
        }
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
242
        
243
        # Save before charactor
244
        $before = $c;
245
        
246
        # increment position
247
        $pos++;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
248
    }
249
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
250
    # Tag not finished
cleanup
Yuki Kimoto authored on 2011-04-25
251
    croak qq{Tag not finished. "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
252
      if $state eq 'tag';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
253
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
254
    # Not contains tag
255
    return DBIx::Custom::Query->new(sql => $source, tag_count => $tag_count)
256
      if $tag_count == 0;
257
    
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
258
    # Add rest text
259
    push @tree, {type => 'text', value => $value}
260
      if $value;
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
261
        
262
    # SQL
263
    my $sql = '';
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
264
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
265
    # All Columns
266
    my $all_columns = [];
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
267
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
268
    # Tables
269
    my $tables = [];
270
    
271
    # Build SQL 
272
    foreach my $node (@tree) {
273
        
274
        # Text
275
        if ($node->{type} eq 'text') { $sql .= $node->{value} }
276
        
277
        # Parameter
278
        elsif ($node->{type} eq 'param') {
279
            push @$all_columns, 'RESERVED_PARAMETER';
280
        }
281
        # Tag
282
        else {
283
            
284
            # Tag name
285
            my $tag_name = $node->{tag_name};
286
            
287
            # Tag arguments
288
            my $tag_args = $node->{tag_args};
289
            
290
            # Table
291
            if ($tag_name eq 'table') {
292
                my $table = $tag_args->[0];
293
                push @$tables, $table;
294
                $sql .= $table;
295
                next;
296
            }
297

            
298
            # Get tag
299
            my $tag = $self->tag_processors->{$tag_name}
300
                             || $self->tags->{$tag_name};
301
            
302
            # Tag is not registered
303
            croak qq{Tag "$tag_name" is not registered } . _subname
304
              unless $tag;
305
            
306
            # Tag not sub reference
307
            croak qq{Tag "$tag_name" must be sub reference } . _subname
308
              unless ref $tag eq 'CODE';
309
            
310
            # Execute tag
311
            my $r = $tag->(@$tag_args);
312
            
313
            # Check tag return value
314
            croak qq{Tag "$tag_name" must return [STRING, ARRAY_REFERENCE] }
315
                . _subname
316
              unless ref $r eq 'ARRAY' && defined $r->[0] && ref $r->[1] eq 'ARRAY';
317
            
318
            # Part of SQL statement and colum names
319
            my ($part, $columns) = @$r;
320
            
321
            # Add columns
322
            push @$all_columns, @$columns;
323
            
324
            # Join part tag to SQL
325
            $sql .= $part;
326
        }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
327
    }
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
328

            
329
    # Query
330
    my $query = DBIx::Custom::Query->new(
331
        sql => $sql,
332
        columns => $all_columns,
333
        tables => $tables,
334
        tag_count => $tag_count
335
    );
336
    
337
    return $query;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
338
}
339

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

            
cleanup
Yuki Kimoto authored on 2011-01-25
343
# DEPRECATED!
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
344
sub register_tag_processor {
345
    my $self = shift;
346
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
347
    warn "register_tag_processor is DEPRECATED! use register_tag instead";
348
    
cleanup
Yuki Kimoto authored on 2011-01-25
349
    # Merge tag
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
350
    my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
351
    $self->tag_processors({%{$self->tag_processors}, %{$tag_processors}});
352
    
353
    return $self;
354
}
355

            
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
356
1;
357

            
358
=head1 NAME
359

            
360
DBIx::Custom::QueryBuilder - Query builder
361

            
362
=head1 SYNOPSIS
363
    
364
    my $builder = DBIx::Custom::QueryBuilder->new;
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
365
    my $query = $builder->build_query(
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
366
        "select from table title = :title and author = :author"
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
367
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
368

            
369
=head1 METHODS
370

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

            
374
=head2 C<build_query>
375
    
376
    my $query = $builder->build_query($source);
377

            
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
378
Create a new L<DBIx::Custom::Query> object from SQL source.
update document
yuki-kimoto authored on 2010-08-07
379

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
380
=cut