Newer Older
262 lines | 6.986kb
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
1
package DBIx::Custom::Where;
updatedd pod
Yuki Kimoto authored on 2011-06-12
2
use Object::Simple -base;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
3

            
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
4
use Carp 'croak';
5
use DBIx::Custom::Util '_subname';
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
6
use overload 'bool' => sub {1}, fallback => 1;
7
use overload '""' => sub { shift->to_string }, fallback => 1;
8

            
updated document
Yuki Kimoto authored on 2011-01-20
9
# Carp trust relationship
10
push @DBIx::Custom::CARP_NOT, __PACKAGE__;
11

            
sub module use DBIx::Custom ...
Yuki Kimoto authored on 2011-08-02
12
has [qw/dbi param/],
added EXPERIMENTAL DBIx::Cus...
Yuki Kimoto authored on 2011-08-09
13
    clause => sub { [] },
14
    map_if => 'exists';
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
15

            
improved error messages
Yuki Kimoto authored on 2011-04-18
16
sub new {
17
    my $self = shift->SUPER::new(@_);
18
    
19
    # Check attribute names
20
    my @attrs = keys %$self;
21
    foreach my $attr (@attrs) {
cleanup
Yuki Kimoto authored on 2011-04-25
22
        croak qq{"$attr" is invalid attribute name (} . _subname . ")"
improved error messages
Yuki Kimoto authored on 2011-04-18
23
          unless $self->can($attr);
24
    }
25
    
26
    return $self;
27
}
28

            
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
29
sub to_string {
added test
Yuki Kimoto authored on 2011-01-19
30
    my $self = shift;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
31
    
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
32
    # Check if column name is safety character;
cleanup
Yuki Kimoto authored on 2011-08-02
33
    my $safety = $self->dbi->safety_character;
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
34
    if (ref $self->param eq 'HASH') {
35
        foreach my $column (keys %{$self->param}) {
36
            croak qq{"$column" is not safety column name (} . _subname . ")"
37
              unless $column =~ /^[$safety\.]+$/;
38
        }
39
    }
many changed
Yuki Kimoto authored on 2011-01-23
40
    # Clause
added test
Yuki Kimoto authored on 2011-01-19
41
    my $clause = $self->clause;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
42
    $clause = ['and', $clause] unless ref $clause eq 'ARRAY';
added test
Yuki Kimoto authored on 2011-01-19
43
    $clause->[0] = 'and' unless @$clause;
added EXPERIMENTAL DBIx::Cus...
Yuki Kimoto authored on 2011-08-09
44
    
45
    # Map condition
46
    my $map_if = $self->map_if || '';
47
    $map_if = $map_if eq 'exists' ? $map_if
48
            : $map_if eq 'defined' ? sub { defined $_[0] }
49
            : $map_if eq 'length'  ? sub { length $_[0] }
50
            : ref $map_if eq 'CODE' ? $map_if
51
            : undef;
52
    
53
    croak "You can must specify right value to C<map_if> " . _subname
54
      unless $map_if;
55
    $self->{_map_if} = $map_if;
56
    
many changed
Yuki Kimoto authored on 2011-01-23
57
    # Parse
added test
Yuki Kimoto authored on 2011-01-19
58
    my $where = [];
59
    my $count = {};
many changed
Yuki Kimoto authored on 2011-01-23
60
    $self->_parse($clause, $where, $count, 'and');
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
61
    
many changed
Yuki Kimoto authored on 2011-01-23
62
    # Stringify
63
    unshift @$where, 'where' if @$where;
added test
Yuki Kimoto authored on 2011-01-19
64
    return join(' ', @$where);
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
65
}
66

            
added test
Yuki Kimoto authored on 2011-01-19
67
our %VALID_OPERATIONS = map { $_ => 1 } qw/and or/;
many changed
Yuki Kimoto authored on 2011-01-23
68
sub _parse {
added test
Yuki Kimoto authored on 2011-01-19
69
    my ($self, $clause, $where, $count, $op) = @_;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
70
    
many changed
Yuki Kimoto authored on 2011-01-23
71
    # Array
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
72
    if (ref $clause eq 'ARRAY') {
many changed
Yuki Kimoto authored on 2011-01-23
73
        
74
        # Start
added test
Yuki Kimoto authored on 2011-01-19
75
        push @$where, '(';
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
76
        
many changed
Yuki Kimoto authored on 2011-01-23
77
        # Operation
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
78
        my $op = $clause->[0] || '';
improved error message
Yuki Kimoto authored on 2011-06-13
79
        croak qq{First argument must be "and" or "or" in where clause } .
80
              qq{"$op" is passed} . _subname . ")"
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
81
          unless $VALID_OPERATIONS{$op};
many changed
Yuki Kimoto authored on 2011-01-23
82
        
fixed DBIx::Custom::Where to...
Yuki Kimoto authored on 2011-06-27
83
        my $pushed_array;
many changed
Yuki Kimoto authored on 2011-01-23
84
        # Parse internal clause
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
85
        for (my $i = 1; $i < @$clause; $i++) {
many changed
Yuki Kimoto authored on 2011-01-23
86
            my $pushed = $self->_parse($clause->[$i], $where, $count, $op);
added test
Yuki Kimoto authored on 2011-01-19
87
            push @$where, $op if $pushed;
fixed DBIx::Custom::Where to...
Yuki Kimoto authored on 2011-06-27
88
            $pushed_array = 1 if $pushed;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
89
        }
added test
Yuki Kimoto authored on 2011-01-19
90
        pop @$where if $where->[-1] eq $op;
91
        
many changed
Yuki Kimoto authored on 2011-01-23
92
        # Undo
added test
Yuki Kimoto authored on 2011-01-19
93
        if ($where->[-1] eq '(') {
94
            pop @$where;
fixed DBIx::Custom::Where to...
Yuki Kimoto authored on 2011-06-27
95
            pop @$where if ($where->[-1] || '') eq $op;
added test
Yuki Kimoto authored on 2011-01-19
96
        }
many changed
Yuki Kimoto authored on 2011-01-23
97
        # End
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
98
        else { push @$where, ')' }
fixed DBIx::Custom::Where to...
Yuki Kimoto authored on 2011-06-27
99
        
100
        return $pushed_array;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
101
    }
many changed
Yuki Kimoto authored on 2011-01-23
102
    
103
    # String
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
104
    else {
DBIx::Custom::Where clause a...
Yuki Kimoto authored on 2011-04-18
105
        # Pushed
106
        my $pushed;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
107
        
added test
Yuki Kimoto authored on 2011-01-19
108
        # Column
cleanup
Yuki Kimoto authored on 2011-08-02
109
        my $columns = $self->dbi->query_builder->build_query($clause)->columns;
DBIx::Custom::Where clause a...
Yuki Kimoto authored on 2011-04-18
110
        if (@$columns == 0) {
111
            push @$where, $clause;
112
            $pushed = 1;
113
            return $pushed;
114
        }
115
        elsif (@$columns != 1) {
- update_param_tag is DEPREC...
Yuki Kimoto authored on 2011-06-07
116
            croak qq{Each part contains one column name: "$clause" (}
cleanup
Yuki Kimoto authored on 2011-04-25
117
                  . _subname . ")";
DBIx::Custom::Where clause a...
Yuki Kimoto authored on 2011-04-18
118
        }
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
119
        
120
        # Remove quote
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
121
        my $column = $columns->[0];
sub module use DBIx::Custom ...
Yuki Kimoto authored on 2011-08-02
122
        if (my $q = $self->dbi->_quote) {
added quote method's two cha...
Yuki Kimoto authored on 2011-07-29
123
            $q = quotemeta($q);
124
            $column =~ s/[$q]//g;
added EXPERIMENTAL reserved_...
Yuki Kimoto authored on 2011-03-30
125
        }
126
        
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
127
        # Check safety
cleanup
Yuki Kimoto authored on 2011-08-02
128
        my $safety = $self->dbi->safety_character;
cleanup
Yuki Kimoto authored on 2011-04-25
129
        croak qq{"$column" is not safety column name (} . _subname . ")"
- remaned experimental safty...
Yuki Kimoto authored on 2011-03-10
130
          unless $column =~ /^[$safety\.]+$/;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
131
        
many changed
Yuki Kimoto authored on 2011-01-23
132
        # Column count up
added test
Yuki Kimoto authored on 2011-01-19
133
        my $count = ++$count->{$column};
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
134
        
many changed
Yuki Kimoto authored on 2011-01-23
135
        # Push
136
        my $param = $self->param;
added experimental not_exist...
Yuki Kimoto authored on 2011-01-26
137
        if (ref $param eq 'HASH') {
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
138
            if (exists $param->{$column}) {
added EXPERIMENTAL DBIx::Cus...
Yuki Kimoto authored on 2011-08-09
139
                my $map_if = $self->{_map_if};
140
                
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
141
                if (ref $param->{$column} eq 'ARRAY') {
added EXPERIMENTAL DBIx::Cus...
Yuki Kimoto authored on 2011-08-09
142
                    unless (ref $param->{$column}->[$count - 1] eq 'DBIx::Custom::NotExists') {
143
                        if ($map_if eq 'exists') {
144
                            $pushed = 1 if exists $param->{$column}->[$count - 1];
145
                        }
146
                        else {
147
                            $pushed = 1 if $map_if->($param->{$column}->[$count - 1]);
148
                        }
149
                    }
added experimental not_exist...
Yuki Kimoto authored on 2011-01-26
150
                } 
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
151
                elsif ($count == 1) {
added EXPERIMENTAL DBIx::Cus...
Yuki Kimoto authored on 2011-08-09
152
                    if ($map_if eq 'exists') {
153
                        $pushed = 1 if  exists $param->{$column};
154
                    }
155
                    else {
156
                        $pushed = 1 if $map_if->($param->{$column});
157
                    }
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
158
                }
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
159
            }
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
160
            push @$where, $clause if $pushed;
161
        }
added experimental not_exist...
Yuki Kimoto authored on 2011-01-26
162
        elsif (!defined $param) {
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
163
            push @$where, $clause;
164
            $pushed = 1;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
165
        }
improved error messages
Yuki Kimoto authored on 2011-04-18
166
        else {
cleanup
Yuki Kimoto authored on 2011-04-25
167
            croak "Parameter must be hash reference or undfined value ("
168
                . _subname . ")"
improved error messages
Yuki Kimoto authored on 2011-04-18
169
        }
added test
Yuki Kimoto authored on 2011-01-19
170
        return $pushed;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
171
    }
fixed DBIx::Custom::Where to...
Yuki Kimoto authored on 2011-06-27
172
    return;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
173
}
174

            
175
1;
176

            
177
=head1 NAME
178

            
removed EXPERIMETNAL flag fr...
Yuki Kimoto authored on 2011-03-25
179
DBIx::Custom::Where - Where clause
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
180

            
181
=head1 SYNOPSYS
182

            
many changed
Yuki Kimoto authored on 2011-01-23
183
    my $where = DBIx::Custom::Where->new;
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
184
    my $string_where = "$where";
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
185

            
186
=head1 ATTRIBUTES
187

            
188
=head2 C<clause>
189

            
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
190
    my $clause = $where->clause;
191
    $where = $where->clause(
192
        ['and',
193
            'title = :title', 
194
            ['or', 'date < :date', 'date > :date']
195
        ]
added test
Yuki Kimoto authored on 2011-01-19
196
    );
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
197

            
many changed
Yuki Kimoto authored on 2011-01-23
198
Where clause. Above one is expanded to the following SQL by to_string
199
If all parameter names is exists.
200

            
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
201
    "where ( title = :title and ( date < :date or date > :date ) )"
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
202

            
added EXPERIMENTAL DBIx::Cus...
Yuki Kimoto authored on 2011-08-09
203
=head2 C<map_if EXPERIMENTAL>
204
    
205
    my $map_if = $where->map_if($condition);
206
    $where->map_if($condition);
207

            
208
If C<clause> contain named placeholder like ':title{=}'
209
and C<param> contain the corresponding key like {title => 'Perl'},
210
C<to_string> method join the cluase and convert to placeholder
211
like 'title = ?'.
212

            
213
C<map_if> method can change this mapping rule.
214
Default is C<exists>. If the key exists, mapping is done.
215
    
216
    $where->map_if('exists');
217

            
218
In case C<defined> is specified, if the value is defined,
219
mapping is done.
220

            
221
    $where->map_if('defined');
222

            
223
In case C<length> is specified, the value is defined
224
and the length is bigger than 0, mappting is done.
225

            
226
    $where->map_if('length');
227

            
228
You can also subroutine like C<sub { defined $_[0] }> for mappging.
229

            
230
    $where->map_if(sub { defined $_[0] });
231

            
update pod
Yuki Kimoto authored on 2011-01-27
232
=head2 C<param>
233

            
234
    my $param = $where->param;
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
235
    $where = $where->param({
236
        title => 'Perl',
237
        date => ['2010-11-11', '2011-03-05'],
238
    });
update pod
Yuki Kimoto authored on 2011-01-27
239

            
cleanup
Yuki Kimoto authored on 2011-08-02
240
=head2 C<dbi>
update pod
Yuki Kimoto authored on 2011-01-27
241

            
cleanup
Yuki Kimoto authored on 2011-08-02
242
    my $dbi = $where->dbi;
243
    $where = $where->dbi($dbi);
244

            
245
L<DBIx::Custom> object.
update pod
Yuki Kimoto authored on 2011-01-27
246

            
247
=head1 METHODS
248

            
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
249
L<DBIx::Custom::Where> inherits all methods from L<Object::Simple>
250
and implements the following new ones.
251

            
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
252
=head2 C<to_string>
253

            
254
    $where->to_string;
added test
Yuki Kimoto authored on 2011-01-19
255

            
DBIx::Custom::Model type att...
Yuki Kimoto authored on 2011-06-17
256
Convert where clause to string.
257

            
258
double quote is override to execute C<to_string> method.
259

            
260
    my $string_where = "$where";
added test
Yuki Kimoto authored on 2011-01-19
261

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