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

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

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

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
67
sub _parse_parameter {
68
    my ($self, $source) = @_;
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
69
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
70
    # Get and replace parameters
71
    my $sql = $source || '';
72
    my $columns = [];
cleanup
Yuki Kimoto authored on 2011-08-02
73
    my $c = $self->{_dbi}->safety_character;
cleanup
Yuki Kimoto authored on 2011-07-29
74
    # Parameter regex
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
75
    $sql =~ s/([^:]):(\d+):([^:])/$1\\:$2\\:$3/g;
76
    my $re = qr/(^|.*?[^\\]):([$c\.]+)(?:\{(.*?)\})?(.*)/s;
cleanup
Yuki Kimoto authored on 2011-07-29
77
    while ($sql =~ /$re/g) {
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
78
        push @$columns, $2;
added EXPERIMENTAL parameter...
Yuki Kimoto authored on 2011-07-29
79
        $sql = defined $3 ? "$1$2 $3 ?$4" : "$1?$4";
cleanup
yuki-kimoto authored on 2010-10-17
80
    }
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
81
    $sql =~ s/\\:/:/g;
cleanup
yuki-kimoto authored on 2010-10-17
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
}
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
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