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

            
removed undocumented DBIx::C...
Yuki Kimoto authored on 2011-08-02
13
has 'dbi';
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!
removed undocumented DBIx::C...
Yuki Kimoto authored on 2011-08-02
21
    if ($self->dbi->tag_parse && $source =~ /(\s|^)\{/) {
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
22
        $query = $self->_parse_tag($source);
23
        my $tag_count = delete $query->{tag_count};
fixed DEPRECATED message bug
Yuki Kimoto authored on 2011-06-10
24
        warn qq/Tag system such as {? name} is DEPRECATED! / .
25
             qq/use parameter system such as :name instead/
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
26
          if $tag_count;
27
        my $query2 = $self->_parse_parameter($query->sql);
28
        $query->sql($query2->sql);
29
        for (my $i =0; $i < @{$query->columns}; $i++) {
30
            my $column = $query->columns->[$i];
31
            if ($column eq 'RESERVED_PARAMETER') {
32
                my $column2 = shift @{$query2->columns};
33
                croak ":name syntax is wrong"
34
                  unless defined $column2;
35
                $query->columns->[$i] = $column2;
36
            }
37
        }
38
    }
cleanup
yuki-kimoto authored on 2010-10-17
39
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
40
    # Parse parameter
added tag_parse attribute
Yuki Kimoto authored on 2011-06-28
41
    else { $query = $self->_parse_parameter($source) }
cleanup
yuki-kimoto authored on 2010-10-17
42
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
43
    my $sql = $query->sql;
44
    $sql .= ';' unless $source =~ /;$/;
45
    $query->sql($sql);
46

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

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

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
68
sub _parse_parameter {
69
    my ($self, $source) = @_;
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
70
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
71
    # Get and replace parameters
72
    my $sql = $source || '';
73
    my $columns = [];
removed undocumented DBIx::C...
Yuki Kimoto authored on 2011-08-02
74
    my $c = $self->dbi->safety_character;
cleanup
Yuki Kimoto authored on 2011-07-29
75
    # Parameter regex
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
76
    $sql =~ s/([^:]):(\d+):([^:])/$1\\:$2\\:$3/g;
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
    }
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
82
    $sql =~ s/\\:/:/g;
cleanup
yuki-kimoto authored on 2010-10-17
83

            
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
84
    # Create query
add table tag
Yuki Kimoto authored on 2011-02-09
85
    my $query = DBIx::Custom::Query->new(
86
        sql => $sql,
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
87
        columns => $columns
add table tag
Yuki Kimoto authored on 2011-02-09
88
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
89
    
90
    return $query;
91
}
fixed named placeholder bug ...
Yuki Kimoto authored on 2011-08-01
92
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
93
# DEPRECATED!
cleanup
Yuki Kimoto authored on 2011-06-13
94
has tags => sub { {} };
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
95

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

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

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

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

            
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
297
1;
298

            
299
=head1 NAME
300

            
301
DBIx::Custom::QueryBuilder - Query builder
302

            
303
=head1 SYNOPSIS
304
    
305
    my $builder = DBIx::Custom::QueryBuilder->new;
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
306
    my $query = $builder->build_query(
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
307
        "select from table title = :title and author = :author"
remove DBIx::Custom::QueryBu...
yuki-kimoto authored on 2010-08-05
308
    );
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
309

            
cleanup
Yuki Kimoto authored on 2011-08-02
310
=head1 ATTRIBUTES
311

            
312
=head2 C<dbi>
313

            
314
    my $dbi = $builder->dbi;
315
    $builder = $builder->dbi($dbi);
316

            
317
L<DBIx::Custom> object.
318

            
renamed default_query_filter...
yuki-kimoto authored on 2010-08-03
319
=head1 METHODS
320

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

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

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

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