Newer Older
329 lines | 9.006kb
added common test executing ...
Yuki Kimoto authored on 2011-08-07
1
package DBIx::Custom::QueryBuilder;
2

            
3
use Object::Simple -base;
4

            
5
use Carp 'croak';
6
use DBIx::Custom::Query;
7
use DBIx::Custom::Util '_subname';
8

            
9
# Carp trust relationship
10
push @DBIx::Custom::CARP_NOT, __PACKAGE__;
11
push @DBIx::Custom::Where::CARP_NOT, __PACKAGE__;
12

            
13
has 'dbi';
14

            
15
sub build_query {
16
    my ($self, $source) = @_;
17
    
18
    my $query;
19
    
20
    # Parse tag. tag is DEPRECATED!
21
    if ($self->dbi->tag_parse && $source =~ /(\s|^)\{/) {
22
        $query = $self->_parse_tag($source);
23
        my $tag_count = delete $query->{tag_count};
24
        warn qq/Tag system such as {? name} is DEPRECATED! / .
25
             qq/use parameter system such as :name instead/
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
    }
39
    
40
    # Parse parameter
41
    else { $query = $self->_parse_parameter($source) }
42
    
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
        
52
    return $query;
53
}
54

            
55
sub _placeholder_count {
56
    my ($self, $sql) = @_;
57
    
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;
66
}
67

            
68
sub _parse_parameter {
69
    my ($self, $source) = @_;
70
    
71
    # Get and replace parameters
72
    my $sql = $source || '';
73
    my $columns = [];
74
    my $c = $self->dbi->safety_character;
75
    # Parameter regex
76
    $sql =~ s/([^:]):(\d+):([^:])/$1\\:$2\\:$3/g;
77
    my $re = qr/(^|.*?[^\\]):([$c\.]+)(?:\{(.*?)\})?(.*)/s;
78
    while ($sql =~ /$re/g) {
79
        push @$columns, $2;
80
        $sql = defined $3 ? "$1$2 $3 ?$4" : "$1?$4";
81
    }
82
    $sql =~ s/\\:/:/g;
83

            
84
    # Create query
85
    my $query = DBIx::Custom::Query->new(
86
        sql => $sql,
87
        columns => $columns
88
    );
89
    
90
    return $query;
91
}
92
    
93
# DEPRECATED!
94
has tags => sub { {} };
95

            
96
# DEPRECATED!
97
sub register_tag {
98
    my $self = shift;
99
    
100
    warn "register_tag is DEPRECATED!";
101
    
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) = @_;
112
    # Source
113
    $source ||= '';
114
    # Tree
115
    my @tree;
116
    # Value
117
    my $value = '';
118
    # State
119
    my $state = 'text';
120
    # Before charactor
121
    my $before = '';
122
    # Position
123
    my $pos = 0;
124
    # Parse
125
    my $original = $source;
126
    my $tag_count = 0;
127
    while (defined(my $c = substr($source, $pos, 1))) {
128
        # Last
129
        last unless length $c;
130
        # Parameter
131
        if ($c eq ':' && (substr($source, $pos + 1, 1) || '') =~ /\w/) {
132
            push @tree, {type => 'param'};;
133
        }
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 {
163
                    croak qq{Parsing error. unexpected "\}". }
164
                        . qq{pos $pos of "$original" } . _subname
165
                }
166
            }
167
            # Normal charactor
168
            else { $value .= $c }
169
        }
170
        # State is tags
171
        else {
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 {
181
                    croak qq{Parsing error. unexpected "\{". }
182
                        . qq{pos $pos of "$original" } . _subname
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 = '';
202
                    # Countup
203
                    $tag_count++;
204
                }
205
            }
206
            # Normal charactor
207
            else { $value .= $c }
208
        }
209
        # Save before charactor
210
        $before = $c;
211
        # increment position
212
        $pos++;
213
    }
214
    # Tag not finished
215
    croak qq{Tag not finished. "$original" } . _subname
216
      if $state eq 'tag';
217
    # Not contains tag
218
    return DBIx::Custom::Query->new(sql => $source, tag_count => $tag_count)
219
      if $tag_count == 0;
220
    # Add rest text
221
    push @tree, {type => 'text', value => $value}
222
      if $value;
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
251
            my $tag = $self->tag_processors->{$tag_name}
252
                             || $self->tags->{$tag_name};
253
            # Tag is not registered
254
            croak qq{Tag "$tag_name" is not registered } . _subname
255
              unless $tag;
256
            # Tag not sub reference
257
            croak qq{Tag "$tag_name" must be sub reference } . _subname
258
              unless ref $tag eq 'CODE';
259
            # Execute tag
260
            my $r = $tag->(@$tag_args);
261
            # Check tag return value
262
            croak qq{Tag "$tag_name" must return [STRING, ARRAY_REFERENCE] }
263
                . _subname
264
              unless ref $r eq 'ARRAY' && defined $r->[0] && ref $r->[1] eq 'ARRAY';
265
            # Part of SQL statement and colum names
266
            my ($part, $columns) = @$r;
267
            # Add columns
268
            push @$all_columns, @$columns;
269
            # Join part tag to SQL
270
            $sql .= $part;
271
        }
272
    }
273
    # Query
274
    my $query = DBIx::Custom::Query->new(
275
        sql => $sql,
276
        columns => $all_columns,
277
        tables => $tables,
278
        tag_count => $tag_count
279
    );
280
    return $query;
281
}
282

            
283
# DEPRECATED!
284
has tag_processors => sub { {} };
285

            
286
# DEPRECATED!
287
sub register_tag_processor {
288
    my $self = shift;
289
    warn "register_tag_processor is DEPRECATED!";
290
    # Merge tag
291
    my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_};
292
    $self->tag_processors({%{$self->tag_processors}, %{$tag_processors}});
293
    return $self;
294
}
295

            
296
1;
297

            
298
=head1 NAME
299

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

            
302
=head1 SYNOPSIS
303
    
304
    my $builder = DBIx::Custom::QueryBuilder->new;
305
    my $query = $builder->build_query(
306
        "select from table title = :title and author = :author"
307
    );
308

            
309
=head1 ATTRIBUTES
310

            
311
=head2 C<dbi>
312

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

            
316
L<DBIx::Custom> object.
317

            
318
=head1 METHODS
319

            
320
L<DBIx::Custom::QueryBuilder> inherits all methods from L<Object::Simple>
321
and implements the following new ones.
322

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

            
327
Create a new L<DBIx::Custom::Query> object from SQL source.
328

            
329
=cut