DBIx-Custom / lib / DBI / Custom.pm /
Newer Older
306 lines | 6.288kb
first commit
yuki-kimoto authored on 2009-10-13
1
package DBI::Custom;
2
use Object::Simple;
add test
yuki-kimoto authored on 2009-10-16
3

            
4
our $VERSION = '0.0101';
5

            
6
use Carp 'croak';
add some method
yuki-kimoto authored on 2009-10-14
7
use DBI;
add tests
yuki-kimoto authored on 2009-10-25
8
use DBI::Custom::SQL::Template;
add tests
yuki-kimoto authored on 2009-10-25
9
use DBI::Custom::Result;
add tests
yuki-kimoto authored on 2009-10-25
10

            
11
### Class-Object Accessors
12
sub connect_info : ClassObjectAttr { type => 'hash',  auto_build => sub {
13
    shift->Object::Simple::initialize_class_object_attr(
add tests
yuki-kimoto authored on 2009-10-25
14
        clone => sub {
add tests
yuki-kimoto authored on 2009-10-25
15
            my $value = shift;
16
            my $new_value = \%{$value || {}};
17
            $new_value->{options} = $value->{options} if $value->{options};
18
            return $new_value;
add tests
yuki-kimoto authored on 2009-10-25
19
        },
20
        default => sub { {} },
add tests
yuki-kimoto authored on 2009-10-25
21
    )
22
}}
first commit
yuki-kimoto authored on 2009-10-13
23

            
add tests
yuki-kimoto authored on 2009-10-25
24
sub bind_filter  : ClassObjectAttr { auto_build => sub {
25
    shift->Object::Simple::initialize_class_object_attr(clone => 'scalar')
26
}}
27
sub fetch_filter : ClassObjectAttr { auto_build => sub {
28
    shift->Object::Simple::initialize_class_object_attr(clone => 'scalar')
try various
yuki-kimoto authored on 2009-10-21
29
}}
first commit
yuki-kimoto authored on 2009-10-13
30

            
add tests
yuki-kimoto authored on 2009-10-25
31
sub filters : ClassObjectAttr { type => 'hash', deref => 1, auto_build => sub {
add tests
yuki-kimoto authored on 2009-10-25
32
    shift->Object::Simple::initialize_class_object_attr(
33
        clone   => 'hash',
34
        default => sub { {} }
35
    )
add tests
yuki-kimoto authored on 2009-10-25
36
}}
first commit
yuki-kimoto authored on 2009-10-13
37

            
add tests
yuki-kimoto authored on 2009-10-25
38
sub result_class : ClassObjectAttr { auto_build => sub {
add tests
yuki-kimoto authored on 2009-10-25
39
    shift->Object::Simple::initialize_class_object_attr(
40
        clone   => 'scalar',
41
        default => 'DBI::Custom::Result'
42
    )
add tests
yuki-kimoto authored on 2009-10-25
43
}}
cleanup
yuki-kimoto authored on 2009-10-14
44

            
add tests
yuki-kimoto authored on 2009-10-25
45
sub sql_template : ClassObjectAttr { auto_build => sub {
46
    shift->Object::Simple::initialize_class_object_attr(
47
        clone   => sub {my $value = shift; $value ? $value->clone : undef},
48
        default => sub { DBI::Custom::SQL::Template->new }
49
    )
50
}}
cleanup
yuki-kimoto authored on 2009-10-15
51

            
add tests
yuki-kimoto authored on 2009-10-25
52
sub valid_connect_info : ClassObjectAttr { type => 'hash', deref => 1, auto_build => sub {
53
    shift->Object::Simple::initialize_class_object_attr(
add tests
yuki-kimoto authored on 2009-10-25
54
        clone => 'hash',
add tests
yuki-kimoto authored on 2009-10-25
55
        default => sub { return {map {$_ => 1} qw/data_source user password options/} },
56
    )
57
}}
cleanup
yuki-kimoto authored on 2009-10-15
58

            
add tests
yuki-kimoto authored on 2009-10-25
59
### Object Accessor
add tests
yuki-kimoto authored on 2009-10-18
60
sub dbh          : Attr {}
add tests
yuki-kimoto authored on 2009-10-25
61

            
62

            
63
### Methods
64
# Add filter
65
sub add_filter {
66
    my $invocant = shift;
67
    
68
    my %old_filters = $invocant->filters;
69
    my %new_filters = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
70
    $invocant->filters(%old_filters, %new_filters);
71
}
add various
yuki-kimoto authored on 2009-10-18
72

            
73
# Auto commit
74
sub auto_commit {
75
    my $self = shift;
76
    
77
    croak("Cannot change AutoCommit becouse of not connected")
78
        unless $self->dbh;
79
    
80
    if (@_) {
81
        $self->dbh->{AutoCommit} = $_[0];
82
        return $self;
83
    }
84
    return $self->dbh->{AutoCommit};
85
}
add test
yuki-kimoto authored on 2009-10-16
86

            
add various things
yuki-kimoto authored on 2009-10-17
87
# Connect
add some method
yuki-kimoto authored on 2009-10-14
88
sub connect {
89
    my $self = shift;
90
    my $connect_info = $self->connect_info;
91
    
add test
yuki-kimoto authored on 2009-10-16
92
    foreach my $key (keys %{$self->connect_info}) {
add test module
yuki-kimoto authored on 2009-10-19
93
        croak("connect_info '$key' is wrong name")
try various
yuki-kimoto authored on 2009-10-21
94
          unless $self->valid_connect_info->{$key};
add test
yuki-kimoto authored on 2009-10-16
95
    }
96
    
add some method
yuki-kimoto authored on 2009-10-14
97
    my $dbh = DBI->connect(
add test
yuki-kimoto authored on 2009-10-16
98
        $connect_info->{data_source},
add some method
yuki-kimoto authored on 2009-10-14
99
        $connect_info->{user},
100
        $connect_info->{password},
101
        {
102
            RaiseError => 1,
103
            PrintError => 0,
104
            AutoCommit => 1,
105
            %{$connect_info->{options} || {} }
106
        }
107
    );
108
    
109
    $self->dbh($dbh);
add various
yuki-kimoto authored on 2009-10-18
110
    return $self;
add some method
yuki-kimoto authored on 2009-10-14
111
}
first commit
yuki-kimoto authored on 2009-10-13
112

            
add tests
yuki-kimoto authored on 2009-10-25
113
# DESTROY
add tests
yuki-kimoto authored on 2009-10-18
114
sub DESTROY {
115
    my $self = shift;
add tests
yuki-kimoto authored on 2009-10-18
116
    $self->disconnect if $self->connected;
add tests
yuki-kimoto authored on 2009-10-18
117
}
118

            
add various things
yuki-kimoto authored on 2009-10-17
119
# Is connected?
120
sub connected {
121
    my $self = shift;
add tests
yuki-kimoto authored on 2009-10-18
122
    return exists $self->{dbh} && eval {$self->{dbh}->can('prepare')};
add various things
yuki-kimoto authored on 2009-10-17
123
}
124

            
125
# Disconnect
126
sub disconnect {
127
    my $self = shift;
add tests
yuki-kimoto authored on 2009-10-18
128
    if ($self->connected) {
add various things
yuki-kimoto authored on 2009-10-17
129
        $self->dbh->disconnect;
130
        delete $self->{dbh};
131
    }
132
}
133

            
134
# Reconnect
135
sub reconnect {
136
    my $self = shift;
add tests
yuki-kimoto authored on 2009-10-18
137
    $self->disconnect if $self->connected;
add various things
yuki-kimoto authored on 2009-10-17
138
    $self->connect;
139
}
140

            
try various
yuki-kimoto authored on 2009-10-21
141
# Run tranzaction
142
sub run_tranzaction {
143
    my ($self, $tranzaction) = @_;
144
    
145
    $self->auto_commit(0);
146
    
147
    eval {
148
        $tranzaction->();
149
        $self->dbh->commit;
150
    };
151
    
152
    if ($@) {
153
        my $tranzaction_error = $@;
154
        
155
        $self->dbh->rollback or croak("$@ and rollback also failed");
156
        croak("$tranzaction_error");
157
    }
158
    $self->auto_commit(1);
add tests
yuki-kimoto authored on 2009-10-18
159
}
160

            
cleanup
yuki-kimoto authored on 2009-10-18
161
# Create SQL from SQL template
add test
yuki-kimoto authored on 2009-10-17
162
sub create_sql {
163
    my $self = shift;
164
    
165
    my ($sql, @bind) = $self->sql_template->create_sql(@_);
166
    
167
    return ($sql, @bind);
168
}
169

            
cleanup
yuki-kimoto authored on 2009-10-18
170
# Prepare and execute SQL
add some method
yuki-kimoto authored on 2009-10-14
171
sub query {
try varioud way
yuki-kimoto authored on 2009-10-17
172
    my ($self, $template, $values, $filter)  = @_;
173
    
add tests
yuki-kimoto authored on 2009-10-18
174
    my $sth_options;
175
    
176
    # Rearrange when argumets is hash referecne 
177
    if (ref $template eq 'HASH') {
178
        my $args = $template;
179
        ($template, $values, $filter, $sth_options)
180
          = @{$args}{qw/template values filter sth_options/};
181
    }
182
    
try varioud way
yuki-kimoto authored on 2009-10-17
183
    $filter ||= $self->bind_filter;
184
    
add various things
yuki-kimoto authored on 2009-10-17
185
    my ($sql, @bind) = $self->create_sql($template, $values, $filter);
add tests
yuki-kimoto authored on 2009-10-18
186
    
187
    $self->connect unless $self->connected;
188
    
add various things
yuki-kimoto authored on 2009-10-17
189
    my $sth = $self->dbh->prepare($sql);
add tests
yuki-kimoto authored on 2009-10-18
190
    
191
    if ($sth_options) {
192
        foreach my $key (keys %$sth_options) {
193
            $sth->{$key} = $sth_options->{$key};
194
        }
195
    }
196
    
cleanup
yuki-kimoto authored on 2009-10-18
197
    # Execute
add tests
yuki-kimoto authored on 2009-10-18
198
    my $ret_val = $sth->execute(@bind);
add various things
yuki-kimoto authored on 2009-10-17
199
    
cleanup
yuki-kimoto authored on 2009-10-18
200
    # Return resultset if select statement is executed
add various things
yuki-kimoto authored on 2009-10-17
201
    if ($sth->{NUM_OF_FIELDS}) {
202
        my $result_class = $self->result_class;
add various
yuki-kimoto authored on 2009-10-18
203
        my $result = $result_class->new({
204
            sth => $sth,
205
            fetch_filter => $self->fetch_filter
206
        });
add various things
yuki-kimoto authored on 2009-10-17
207
        return $result;
208
    }
add tests
yuki-kimoto authored on 2009-10-18
209
    return $ret_val;
add test
yuki-kimoto authored on 2009-10-17
210
}
211

            
cleanup
yuki-kimoto authored on 2009-10-18
212
# Prepare and execute raw SQL
add test
yuki-kimoto authored on 2009-10-17
213
sub query_raw_sql {
cleanup
yuki-kimoto authored on 2009-10-18
214
    my ($self, $sql, @bind_values) = @_;
add tests
yuki-kimoto authored on 2009-10-18
215
    
cleanup
yuki-kimoto authored on 2009-10-18
216
    # Connect
add various
yuki-kimoto authored on 2009-10-18
217
    $self->connect unless $self->connected;
cleanup
yuki-kimoto authored on 2009-10-18
218
    
219
    # Add semicolon if not exist;
add tests
yuki-kimoto authored on 2009-10-18
220
    $sql .= ';' unless $sql =~ /;$/;
cleanup
yuki-kimoto authored on 2009-10-18
221
    
222
    # Prepare
add various things
yuki-kimoto authored on 2009-10-17
223
    my $sth = $self->dbh->prepare($sql);
cleanup
yuki-kimoto authored on 2009-10-18
224
    
225
    # Execute
226
    $sth->execute(@bind_values);
227
    
add various things
yuki-kimoto authored on 2009-10-17
228
    return $sth;
add test
yuki-kimoto authored on 2009-10-17
229
}
230

            
231
Object::Simple->build_class;
232

            
first commit
yuki-kimoto authored on 2009-10-13
233
=head1 NAME
234

            
add test
yuki-kimoto authored on 2009-10-17
235
DBI::Custom - Customizable simple DBI
first commit
yuki-kimoto authored on 2009-10-13
236

            
237
=head1 VERSION
238

            
add test
yuki-kimoto authored on 2009-10-16
239
Version 0.0101
first commit
yuki-kimoto authored on 2009-10-13
240

            
241
=cut
242

            
243
=head1 SYNOPSIS
244

            
add test
yuki-kimoto authored on 2009-10-16
245
  my $dbi = DBI::Custom->new;
first commit
yuki-kimoto authored on 2009-10-13
246

            
add test
yuki-kimoto authored on 2009-10-16
247
=head1 METHODS
first commit
yuki-kimoto authored on 2009-10-13
248

            
add test
yuki-kimoto authored on 2009-10-16
249
=head2 add_filter
first commit
yuki-kimoto authored on 2009-10-13
250

            
add test
yuki-kimoto authored on 2009-10-16
251
=head2 bind_filter
first commit
yuki-kimoto authored on 2009-10-13
252

            
add test
yuki-kimoto authored on 2009-10-16
253
=head2 clone
first commit
yuki-kimoto authored on 2009-10-13
254

            
add test
yuki-kimoto authored on 2009-10-16
255
=head2 connect
first commit
yuki-kimoto authored on 2009-10-13
256

            
add test
yuki-kimoto authored on 2009-10-16
257
=head2 connect_info
first commit
yuki-kimoto authored on 2009-10-13
258

            
add test
yuki-kimoto authored on 2009-10-16
259
=head2 dbh
first commit
yuki-kimoto authored on 2009-10-13
260

            
add test
yuki-kimoto authored on 2009-10-16
261
=head2 fetch_filter
first commit
yuki-kimoto authored on 2009-10-13
262

            
add test
yuki-kimoto authored on 2009-10-16
263
=head2 filters
first commit
yuki-kimoto authored on 2009-10-13
264

            
cleanup
yuki-kimoto authored on 2009-10-21
265
=head2 prototype
first commit
yuki-kimoto authored on 2009-10-13
266

            
add test
yuki-kimoto authored on 2009-10-16
267
=head2 new
268

            
269
=head2 query
first commit
yuki-kimoto authored on 2009-10-13
270

            
add test
yuki-kimoto authored on 2009-10-17
271
=head2 create_sql
272

            
273
=head2 query_raw_sql
274

            
275
=head2 sql_template
276

            
add tests
yuki-kimoto authored on 2009-10-18
277
=head2 auto_commit
278

            
279
=head2 connected
280

            
281
=head2 disconnect
282

            
283
=head2 reconnect
284

            
285
=head2 result_class
286

            
cleanup
yuki-kimoto authored on 2009-10-22
287
=head2 run_tranzaction
first commit
yuki-kimoto authored on 2009-10-13
288

            
cleanup
yuki-kimoto authored on 2009-10-22
289
=head2 valid_connect_info
first commit
yuki-kimoto authored on 2009-10-13
290

            
291

            
add various
yuki-kimoto authored on 2009-10-18
292
=head1 AUTHOR
first commit
yuki-kimoto authored on 2009-10-13
293

            
add various
yuki-kimoto authored on 2009-10-18
294
Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
first commit
yuki-kimoto authored on 2009-10-13
295

            
296
=head1 COPYRIGHT & LICENSE
297

            
298
Copyright 2009 Yuki Kimoto, all rights reserved.
299

            
300
This program is free software; you can redistribute it and/or modify it
301
under the same terms as Perl itself.
302

            
303

            
304
=cut
305

            
306
1; # End of DBI::Custom