Newer Older
183 lines | 4.543kb
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
1
package DBIx::Custom::Where;
2

            
3
use strict;
4
use warnings;
5

            
6
use base 'Object::Simple';
7

            
8
use overload 'bool' => sub {1}, fallback => 1;
9
use overload '""' => sub { shift->to_string }, fallback => 1;
10

            
11
use Carp 'croak';
12

            
updated document
Yuki Kimoto authored on 2011-01-20
13
# Carp trust relationship
14
push @DBIx::Custom::CARP_NOT, __PACKAGE__;
15

            
added test
Yuki Kimoto authored on 2011-01-19
16
__PACKAGE__->attr(
- remaned experimental safty...
Yuki Kimoto authored on 2011-03-10
17
    [qw/param query_builder safety_character/],
cleanup
Yuki Kimoto authored on 2011-01-25
18
    clause => sub { [] },
added EXPERIMENTAL reserved_...
Yuki Kimoto authored on 2011-03-30
19
    reserved_word_quote => ''
added test
Yuki Kimoto authored on 2011-01-19
20
);
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
21

            
improved error messages
Yuki Kimoto authored on 2011-04-18
22
sub new {
23
    my $self = shift->SUPER::new(@_);
24
    
25
    # Check attribute names
26
    my @attrs = keys %$self;
27
    foreach my $attr (@attrs) {
28
        croak qq{"$attr" is invalid attribute name}
29
            . qq{ (DBIx::Custom::Where::new) }
30
          unless $self->can($attr);
31
    }
32
    
33
    return $self;
34
}
35

            
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
36
sub to_string {
added test
Yuki Kimoto authored on 2011-01-19
37
    my $self = shift;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
38
    
many changed
Yuki Kimoto authored on 2011-01-23
39
    # Clause
added test
Yuki Kimoto authored on 2011-01-19
40
    my $clause = $self->clause;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
41
    $clause = ['and', $clause] unless ref $clause eq 'ARRAY';
added test
Yuki Kimoto authored on 2011-01-19
42
    $clause->[0] = 'and' unless @$clause;
43

            
many changed
Yuki Kimoto authored on 2011-01-23
44
    # Parse
added test
Yuki Kimoto authored on 2011-01-19
45
    my $where = [];
46
    my $count = {};
many changed
Yuki Kimoto authored on 2011-01-23
47
    $self->_parse($clause, $where, $count, 'and');
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
48
    
many changed
Yuki Kimoto authored on 2011-01-23
49
    # Stringify
50
    unshift @$where, 'where' if @$where;
added test
Yuki Kimoto authored on 2011-01-19
51
    return join(' ', @$where);
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
52
}
53

            
added test
Yuki Kimoto authored on 2011-01-19
54
our %VALID_OPERATIONS = map { $_ => 1 } qw/and or/;
many changed
Yuki Kimoto authored on 2011-01-23
55
sub _parse {
added test
Yuki Kimoto authored on 2011-01-19
56
    my ($self, $clause, $where, $count, $op) = @_;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
57
    
many changed
Yuki Kimoto authored on 2011-01-23
58
    # Array
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
59
    if (ref $clause eq 'ARRAY') {
many changed
Yuki Kimoto authored on 2011-01-23
60
        
61
        # Start
added test
Yuki Kimoto authored on 2011-01-19
62
        push @$where, '(';
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
63
        
many changed
Yuki Kimoto authored on 2011-01-23
64
        # Operation
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
65
        my $op = $clause->[0] || '';
improved error messages
Yuki Kimoto authored on 2011-04-18
66
        croak qq{"$op" is invalid operation (DBIx::Custom::Where::to_string)}
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
67
          unless $VALID_OPERATIONS{$op};
many changed
Yuki Kimoto authored on 2011-01-23
68
        
69
        # Parse internal clause
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
70
        for (my $i = 1; $i < @$clause; $i++) {
many changed
Yuki Kimoto authored on 2011-01-23
71
            my $pushed = $self->_parse($clause->[$i], $where, $count, $op);
added test
Yuki Kimoto authored on 2011-01-19
72
            push @$where, $op if $pushed;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
73
        }
added test
Yuki Kimoto authored on 2011-01-19
74
        pop @$where if $where->[-1] eq $op;
75
        
many changed
Yuki Kimoto authored on 2011-01-23
76
        # Undo
added test
Yuki Kimoto authored on 2011-01-19
77
        if ($where->[-1] eq '(') {
78
            pop @$where;
79
            pop @$where;
80
        }
many changed
Yuki Kimoto authored on 2011-01-23
81
        # End
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
82
        else { push @$where, ')' }
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
83
    }
many changed
Yuki Kimoto authored on 2011-01-23
84
    
85
    # String
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
86
    else {
DBIx::Custom::Where clause a...
Yuki Kimoto authored on 2011-04-18
87
        # Pushed
88
        my $pushed;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
89
        
added test
Yuki Kimoto authored on 2011-01-19
90
        # Column
91
        my $columns = $self->query_builder->build_query($clause)->columns;
DBIx::Custom::Where clause a...
Yuki Kimoto authored on 2011-04-18
92
        if (@$columns == 0) {
93
            push @$where, $clause;
94
            $pushed = 1;
95
            return $pushed;
96
        }
97
        elsif (@$columns != 1) {
improved error messages
Yuki Kimoto authored on 2011-04-18
98
            croak qq{Each tag contains one column name: tag "$clause" }
99
                  . "(DBIx::Custom::Where::to_string)"
DBIx::Custom::Where clause a...
Yuki Kimoto authored on 2011-04-18
100
        }
101

            
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
102
        my $column = $columns->[0];
added EXPERIMENTAL reserved_...
Yuki Kimoto authored on 2011-03-30
103
        if (my $q = $self->reserved_word_quote) {
104
            $column =~ s/$q//g;
105
        }
106
        
- remaned experimental safty...
Yuki Kimoto authored on 2011-03-10
107
        my $safety = $self->safety_character;
improved error messages
Yuki Kimoto authored on 2011-04-18
108
        croak qq{"$column" is not safety column name (DBIx::Custom::Where::to_string)}
- remaned experimental safty...
Yuki Kimoto authored on 2011-03-10
109
          unless $column =~ /^[$safety\.]+$/;
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
110
        
many changed
Yuki Kimoto authored on 2011-01-23
111
        # Column count up
added test
Yuki Kimoto authored on 2011-01-19
112
        my $count = ++$count->{$column};
changed DBIx::Custom::Where ...
Yuki Kimoto authored on 2011-01-19
113
        
many changed
Yuki Kimoto authored on 2011-01-23
114
        # Push
115
        my $param = $self->param;
added experimental not_exist...
Yuki Kimoto authored on 2011-01-26
116
        if (ref $param eq 'HASH') {
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
117
            if (exists $param->{$column}) {
118
                if (ref $param->{$column} eq 'ARRAY') {
added experimental not_exist...
Yuki Kimoto authored on 2011-01-26
119
                    $pushed = 1
120
                      if  exists $param->{$column}->[$count - 1]
121
                       && ref $param->{$column}->[$count - 1] ne 'DBIx::Custom::NotExists';
122
                } 
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
123
                elsif ($count == 1) {
124
                    $pushed = 1;
125
                }
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
126
            }
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
127
            push @$where, $clause if $pushed;
128
        }
added experimental not_exist...
Yuki Kimoto authored on 2011-01-26
129
        elsif (!defined $param) {
renamed DBIx::Custom::TagPro...
Yuki Kimoto authored on 2011-01-24
130
            push @$where, $clause;
131
            $pushed = 1;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
132
        }
improved error messages
Yuki Kimoto authored on 2011-04-18
133
        else {
134
            croak "Parameter must be hash reference or undfined value "
135
                . "(DBIx::Custom::Where::to_string)"
136
        }
added test
Yuki Kimoto authored on 2011-01-19
137
        return $pushed;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
138
    }
139
}
140

            
141
1;
142

            
143
=head1 NAME
144

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

            
147
=head1 SYNOPSYS
148

            
many changed
Yuki Kimoto authored on 2011-01-23
149
    my $where = DBIx::Custom::Where->new;
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
150

            
151
=head1 ATTRIBUTES
152

            
153
=head2 C<clause>
154

            
added test
Yuki Kimoto authored on 2011-01-19
155
    $where->clause(
156
        ['and', '{= title}', ['or', '{< date}', '{> date}']]
157
    );
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
158

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

            
162
    "where ( {= title} and ( {< date} or {> date} ) )"
added experimental DBIx::Cus...
Yuki Kimoto authored on 2011-01-18
163

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

            
166
    my $param = $where->param;
167
    $where    = $where->param({title => 'Perl',
168
                               date => ['2010-11-11', '2011-03-05']},
169
                               name => ['Ken', 'Taro']);
170

            
- remaned experimental safty...
Yuki Kimoto authored on 2011-03-10
171
=head2 C<safety_character>
update pod
Yuki Kimoto authored on 2011-01-27
172

            
- remaned experimental safty...
Yuki Kimoto authored on 2011-03-10
173
    my $safety_character = $self->safety_character;
174
    $dbi                 = $self->safety_character($name);
update pod
Yuki Kimoto authored on 2011-01-27
175

            
176
=head1 METHODS
177

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

            
180
    $where->to_string;
added test
Yuki Kimoto authored on 2011-01-19
181

            
182
Convert where clause to string correspoinding to param name.
183