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

            
updatedd pod
Yuki Kimoto authored on 2011-06-12
3
use Object::Simple -base;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
4

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

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

            
cleanup
Yuki Kimoto authored on 2011-07-29
13
has 'safety_character';
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
14

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

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

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

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
69
sub _parse_parameter {
70
    my ($self, $source) = @_;
cleanup
Yuki Kimoto authored on 2011-07-29
71

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
72
    # Get and replace parameters
73
    my $sql = $source || '';
74
    my $columns = [];
cleanup
Yuki Kimoto authored on 2011-07-29
75
    my $c = $self->safety_character;
76
    # Parameter regex
added EXPERIMENTAL parameter...
Yuki Kimoto authored on 2011-07-29
77
    my $re = qr/^(.*?):([$c\.]+)(?:\{(.*?)\})?(.*)/s;
cleanup
Yuki Kimoto authored on 2011-07-29
78
    while ($sql =~ /$re/g) {
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
79
        push @$columns, $2;
added EXPERIMENTAL parameter...
Yuki Kimoto authored on 2011-07-29
80
        $sql = defined $3 ? "$1$2 $3 ?$4" : "$1?$4";
cleanup
yuki-kimoto authored on 2010-10-17
81
    }
82

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

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
92
# DEPRECATED!
cleanup
Yuki Kimoto authored on 2011-06-13
93
has tags => sub { {} };
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
94

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

            
108
# DEPRECATED!
109
sub _parse_tag {
110
    my ($self, $source) = @_;
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
111
    # Source
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
112
    $source ||= '';
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
113
    # Tree
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
114
    my @tree;
115
    # Value
116
    my $value = '';
117
    # State
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
118
    my $state = 'text';
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
119
    # Before charactor
120
    my $before = '';
121
    # Position
fixed DBIx::Custom::QueryBui...
yuki-kimoto authored on 2010-08-15
122
    my $pos = 0;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
123
    # Parse
added tests
yuki-kimoto authored on 2010-08-12
124
    my $original = $source;
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
125
    my $tag_count = 0;
fixed DBIx::Custom::QueryBui...
yuki-kimoto authored on 2010-08-15
126
    while (defined(my $c = substr($source, $pos, 1))) {
127
        # Last
128
        last unless length $c;
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
129
        # Parameter
130
        if ($c eq ':' && (substr($source, $pos + 1, 1) || '') =~ /\w/) {
131
            push @tree, {type => 'param'};;
132
        }
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
133
        # State is text
134
        if ($state eq 'text') {
135
            # Tag start charactor
136
            if ($c eq '{') {
137
                # Escaped charactor
138
                if ($before eq "\\") {
139
                    substr($value, -1, 1, '');
140
                    $value .= $c;
141
                }
142
                # Tag start
143
                else {
144
                    # Change state
145
                    $state = 'tag';
146
                    # Add text
147
                    push @tree, {type => 'text', value => $value}
148
                      if $value;
149
                    # Clear
150
                    $value = '';
151
                }
152
            }
153
            # Tag end charactor
154
            elsif ($c eq '}') {
155
                # Escaped charactor
156
                if ($before eq "\\") {
157
                    substr($value, -1, 1, '');
158
                    $value .= $c;
159
                }
160
                # Unexpected
161
                else {
improved error messages
Yuki Kimoto authored on 2011-04-18
162
                    croak qq{Parsing error. unexpected "\}". }
cleanup
Yuki Kimoto authored on 2011-04-25
163
                        . qq{pos $pos of "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
164
                }
165
            }
166
            # Normal charactor
167
            else { $value .= $c }
168
        }
169
        # State is tags
added tests
yuki-kimoto authored on 2010-08-12
170
        else {
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
171
            # Tag start charactor
172
            if ($c eq '{') {
173
                # Escaped charactor
174
                if ($before eq "\\") {
175
                    substr($value, -1, 1, '');
176
                    $value .= $c;
177
                }
178
                # Unexpected
179
                else {
improved error messages
Yuki Kimoto authored on 2011-04-18
180
                    croak qq{Parsing error. unexpected "\{". }
cleanup
Yuki Kimoto authored on 2011-04-25
181
                        . qq{pos $pos of "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
182
                }
183
            }
184
            # Tag end charactor
185
            elsif ($c eq '}') {
186
                # Escaped charactor
187
                if ($before eq "\\") {
188
                    substr($value, -1, 1, '');
189
                    $value .= $c;
190
                }
191
                # Tag end
192
                else {
193
                    # Change state
194
                    $state = 'text';
195
                    # Add tag
196
                    my ($tag_name, @tag_args) = split /\s+/, $value;
197
                    push @tree, {type => 'tag', tag_name => $tag_name, 
198
                                 tag_args => \@tag_args};
199
                    # Clear
200
                    $value = '';
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
201
                    # Countup
202
                    $tag_count++;
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
203
                }
204
            }
205
            # Normal charactor
206
            else { $value .= $c }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
207
        }
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
208
        # Save before charactor
209
        $before = $c;
210
        # increment position
211
        $pos++;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
212
    }
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
213
    # Tag not finished
cleanup
Yuki Kimoto authored on 2011-04-25
214
    croak qq{Tag not finished. "$original" } . _subname
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
215
      if $state eq 'tag';
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
216
    # Not contains tag
217
    return DBIx::Custom::Query->new(sql => $source, tag_count => $tag_count)
218
      if $tag_count == 0;
removed DBIx::Custom::Query ...
yuki-kimoto authored on 2010-08-12
219
    # Add rest text
220
    push @tree, {type => 'text', value => $value}
221
      if $value;
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
222
    # SQL
223
    my $sql = '';
224
    # All Columns
225
    my $all_columns = [];
226
    # Tables
227
    my $tables = [];
228
    # Build SQL 
229
    foreach my $node (@tree) {
230
        # Text
231
        if ($node->{type} eq 'text') { $sql .= $node->{value} }
232
        # Parameter
233
        elsif ($node->{type} eq 'param') {
234
            push @$all_columns, 'RESERVED_PARAMETER';
235
        }
236
        # Tag
237
        else {
238
            # Tag name
239
            my $tag_name = $node->{tag_name};
240
            # Tag arguments
241
            my $tag_args = $node->{tag_args};
242
            # Table
243
            if ($tag_name eq 'table') {
244
                my $table = $tag_args->[0];
245
                push @$tables, $table;
246
                $sql .= $table;
247
                next;
248
            }
249
            # Get tag
250
            my $tag = $self->tag_processors->{$tag_name}
251
                             || $self->tags->{$tag_name};
252
            # Tag is not registered
253
            croak qq{Tag "$tag_name" is not registered } . _subname
254
              unless $tag;
255
            # Tag not sub reference
256
            croak qq{Tag "$tag_name" must be sub reference } . _subname
257
              unless ref $tag eq 'CODE';
258
            # Execute tag
259
            my $r = $tag->(@$tag_args);
260
            # Check tag return value
261
            croak qq{Tag "$tag_name" must return [STRING, ARRAY_REFERENCE] }
262
                . _subname
263
              unless ref $r eq 'ARRAY' && defined $r->[0] && ref $r->[1] eq 'ARRAY';
264
            # Part of SQL statement and colum names
265
            my ($part, $columns) = @$r;
266
            # Add columns
267
            push @$all_columns, @$columns;
268
            # Join part tag to SQL
269
            $sql .= $part;
270
        }
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
271
    }
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
272
    # Query
273
    my $query = DBIx::Custom::Query->new(
274
        sql => $sql,
275
        columns => $all_columns,
276
        tables => $tables,
277
        tag_count => $tag_count
278
    );
279
    return $query;
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
280
}
281

            
cleanup
Yuki Kimoto authored on 2011-01-25
282
# DEPRECATED!
cleanup
Yuki Kimoto authored on 2011-06-13
283
has tag_processors => sub { {} };
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
284

            
cleanup
Yuki Kimoto authored on 2011-01-25
285
# DEPRECATED!
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
286
sub register_tag_processor {
287
    my $self = shift;
- added EXPERIMENTAL order m...
Yuki Kimoto authored on 2011-06-28
288
    warn "register_tag_processor is DEPRECATED!";
cleanup
Yuki Kimoto authored on 2011-01-25
289
    # Merge tag
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
290
    my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
291
    $self->tag_processors({%{$self->tag_processors}, %{$tag_processors}});
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(
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
305
        "select from table title = :title and author = :author"
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
306
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
307

            
308
=head1 METHODS
309

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

            
313
=head2 C<build_query>
314
    
315
    my $query = $builder->build_query($source);
316

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

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