DBIx-Custom / lib / DBIx / Custom.pm /
Newer Older
1138 lines | 26.166kb
cleanup
yuki-kimoto authored on 2009-12-22
1
package DBIx::Custom;
2

            
3
use strict;
4
use warnings;
5

            
remove run_transaction().
yuki-kimoto authored on 2010-01-30
6
use base 'Object::Simple';
many change
yuki-kimoto authored on 2010-02-11
7

            
packaging one directory
yuki-kimoto authored on 2009-11-16
8
use Carp 'croak';
9
use DBI;
10
use DBIx::Custom::Result;
many many changes
yuki-kimoto authored on 2010-04-30
11
use DBIx::Custom::SQLTemplate;
cleanup
yuki-kimoto authored on 2010-02-11
12
use DBIx::Custom::Query;
packaging one directory
yuki-kimoto authored on 2009-11-16
13

            
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-18
14
__PACKAGE__->attr('dbh');
version 0.0901
yuki-kimoto authored on 2009-12-17
15

            
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-18
16
__PACKAGE__->class_attr(_query_caches     => sub { {} });
17
__PACKAGE__->class_attr(_query_cache_keys => sub { [] });
packaging one directory
yuki-kimoto authored on 2009-11-16
18

            
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-22
19
__PACKAGE__->class_attr('query_cache_max', default => 50,
20
                                           inherit => 'scalar_copy');
21

            
cleanup
yuki-kimoto authored on 2010-04-28
22
__PACKAGE__->attr([qw/user password data_source/]);
23
__PACKAGE__->attr([qw/database host port/]);
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
24
__PACKAGE__->attr([qw/default_query_filter default_fetch_filter options/]);
packaging one directory
yuki-kimoto authored on 2009-11-16
25

            
cleanup
yuki-kimoto authored on 2010-04-28
26
__PACKAGE__->dual_attr([qw/ filters formats/],
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-22
27
                       default => sub { {} }, inherit => 'hash_copy');
packaging one directory
yuki-kimoto authored on 2009-11-16
28

            
cleanup
yuki-kimoto authored on 2010-04-28
29
__PACKAGE__->attr(result_class => 'DBIx::Custom::Result');
many many changes
yuki-kimoto authored on 2010-04-30
30
__PACKAGE__->attr(sql_tmpl => sub { DBIx::Custom::SQLTemplate->new });
packaging one directory
yuki-kimoto authored on 2009-11-16
31

            
many many changes
yuki-kimoto authored on 2010-04-30
32
sub resist_filter {
packaging one directory
yuki-kimoto authored on 2009-11-16
33
    my $invocant = shift;
34
    
update document
yuki-kimoto authored on 2010-01-30
35
    # Add filter
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-18
36
    my $filters = ref $_[0] eq 'HASH' ? $_[0] : {@_};
37
    $invocant->filters({%{$invocant->filters}, %$filters});
38
    
packaging one directory
yuki-kimoto authored on 2009-11-16
39
    return $invocant;
40
}
41

            
many many changes
yuki-kimoto authored on 2010-04-30
42
sub resist_format{
packaging one directory
yuki-kimoto authored on 2009-11-16
43
    my $invocant = shift;
44
    
update document
yuki-kimoto authored on 2010-01-30
45
    # Add format
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-18
46
    my $formats = ref $_[0] eq 'HASH' ? $_[0] : {@_};
47
    $invocant->formats({%{$invocant->formats}, %$formats});
48

            
packaging one directory
yuki-kimoto authored on 2009-11-16
49
    return $invocant;
50
}
51

            
52
sub _auto_commit {
53
    my $self = shift;
54
    
update document
yuki-kimoto authored on 2010-01-30
55
    # Not connected
packaging one directory
yuki-kimoto authored on 2009-11-16
56
    croak("Not yet connect to database") unless $self->dbh;
57
    
58
    if (@_) {
update document
yuki-kimoto authored on 2010-01-30
59
        
60
        # Set AutoCommit
packaging one directory
yuki-kimoto authored on 2009-11-16
61
        $self->dbh->{AutoCommit} = $_[0];
update document
yuki-kimoto authored on 2010-01-30
62
        
packaging one directory
yuki-kimoto authored on 2009-11-16
63
        return $self;
64
    }
65
    return $self->dbh->{AutoCommit};
66
}
67

            
68
sub connect {
69
    my $self = shift;
update document
yuki-kimoto authored on 2010-01-30
70
    
71
    # Information
packaging one directory
yuki-kimoto authored on 2009-11-16
72
    my $data_source = $self->data_source;
73
    my $user        = $self->user;
74
    my $password    = $self->password;
version 0.0901
yuki-kimoto authored on 2009-12-17
75
    my $options     = $self->options;
packaging one directory
yuki-kimoto authored on 2009-11-16
76
    
update document
yuki-kimoto authored on 2010-01-30
77
    # Connect
packaging one directory
yuki-kimoto authored on 2009-11-16
78
    my $dbh = eval{DBI->connect(
79
        $data_source,
80
        $user,
81
        $password,
82
        {
83
            RaiseError => 1,
84
            PrintError => 0,
85
            AutoCommit => 1,
version 0.0901
yuki-kimoto authored on 2009-12-17
86
            %{$options || {} }
packaging one directory
yuki-kimoto authored on 2009-11-16
87
        }
88
    )};
89
    
update document
yuki-kimoto authored on 2010-01-30
90
    # Connect error
packaging one directory
yuki-kimoto authored on 2009-11-16
91
    croak $@ if $@;
92
    
update document
yuki-kimoto authored on 2010-01-30
93
    # Database handle
packaging one directory
yuki-kimoto authored on 2009-11-16
94
    $self->dbh($dbh);
update document
yuki-kimoto authored on 2010-01-30
95
    
packaging one directory
yuki-kimoto authored on 2009-11-16
96
    return $self;
97
}
98

            
99
sub DESTROY {
100
    my $self = shift;
update document
yuki-kimoto authored on 2010-01-30
101
    
102
    # Disconnect
packaging one directory
yuki-kimoto authored on 2009-11-16
103
    $self->disconnect if $self->connected;
104
}
105

            
update document
yuki-kimoto authored on 2010-01-30
106
sub connected { ref shift->{dbh} eq 'DBI::db' }
packaging one directory
yuki-kimoto authored on 2009-11-16
107

            
108
sub disconnect {
109
    my $self = shift;
update document
yuki-kimoto authored on 2010-01-30
110
    
packaging one directory
yuki-kimoto authored on 2009-11-16
111
    if ($self->connected) {
update document
yuki-kimoto authored on 2010-01-30
112
        
113
        # Disconnect
packaging one directory
yuki-kimoto authored on 2009-11-16
114
        $self->dbh->disconnect;
115
        delete $self->{dbh};
116
    }
update document
yuki-kimoto authored on 2010-01-30
117
    
118
    return $self;
packaging one directory
yuki-kimoto authored on 2009-11-16
119
}
120

            
121
sub reconnect {
122
    my $self = shift;
update document
yuki-kimoto authored on 2010-01-30
123
    
124
    # Reconnect
packaging one directory
yuki-kimoto authored on 2009-11-16
125
    $self->disconnect if $self->connected;
126
    $self->connect;
update document
yuki-kimoto authored on 2010-01-30
127
    
128
    return $self;
packaging one directory
yuki-kimoto authored on 2009-11-16
129
}
130

            
131
sub create_query {
132
    my ($self, $template) = @_;
cleanup
yuki-kimoto authored on 2010-02-11
133
    
packaging one directory
yuki-kimoto authored on 2009-11-16
134
    my $class = ref $self;
135
    
cleanup
yuki-kimoto authored on 2010-02-11
136
    if (ref $template eq 'ARRAY') {
137
        $template = $template->[1];
138
    }
139
    
packaging one directory
yuki-kimoto authored on 2009-11-16
140
    # Create query from SQL template
version 0.0901
yuki-kimoto authored on 2009-12-17
141
    my $sql_tmpl = $self->sql_tmpl;
packaging one directory
yuki-kimoto authored on 2009-11-16
142
    
143
    # Try to get cached query
many many changes
yuki-kimoto authored on 2010-04-30
144
    my $cached_query = $class->_query_caches->{"$template"};
packaging one directory
yuki-kimoto authored on 2009-11-16
145
    
146
    # Create query
fix timeformat tests
yuki-kimoto authored on 2009-11-23
147
    my $query;
cleanup
yuki-kimoto authored on 2010-02-11
148
    if ($cached_query) {
149
        $query = DBIx::Custom::Query->new(
150
            sql       => $cached_query->sql,
simplify filtering system
yuki-kimoto authored on 2010-05-01
151
            columns => $cached_query->columns
cleanup
yuki-kimoto authored on 2010-02-11
152
        );
fix timeformat tests
yuki-kimoto authored on 2009-11-23
153
    }
154
    else {
Simplify key search
yuki-kimoto authored on 2010-02-11
155
        $query = eval{$sql_tmpl->create_query($template)};
packaging one directory
yuki-kimoto authored on 2009-11-16
156
        croak($@) if $@;
157
        
many many changes
yuki-kimoto authored on 2010-04-30
158
        $class->_add_query_cache("$template", $query);
packaging one directory
yuki-kimoto authored on 2009-11-16
159
    }
160
    
161
    # Connect if not
162
    $self->connect unless $self->connected;
163
    
164
    # Prepare statement handle
add all tests
yuki-kimoto authored on 2010-05-01
165
    my $sth = $self->dbh->prepare($query->{sql});
packaging one directory
yuki-kimoto authored on 2009-11-16
166
    
167
    # Set statement handle
168
    $query->sth($sth);
169
    
170
    return $query;
171
}
172

            
version 0.0901
yuki-kimoto authored on 2009-12-17
173
sub query{
many many changes
yuki-kimoto authored on 2010-04-30
174
    my ($self, $query, $params, $args)  = @_;
packaging one directory
yuki-kimoto authored on 2009-11-16
175
    $params ||= {};
176
    
177
    # First argument is SQL template
Simplify key search
yuki-kimoto authored on 2010-02-11
178
    unless (ref $query eq 'DBIx::Custom::Query') {
179
        my $template;
180
        
181
        if (ref $query eq 'ARRAY') {
many many changes
yuki-kimoto authored on 2010-04-30
182
            $template = $query->[0];
Simplify key search
yuki-kimoto authored on 2010-02-11
183
        }
184
        else { $template = $query }
185
        
many many changes
yuki-kimoto authored on 2010-04-30
186
        $query = $self->create_query($template);
packaging one directory
yuki-kimoto authored on 2009-11-16
187
    }
many many changes
yuki-kimoto authored on 2010-04-30
188

            
many change
yuki-kimoto authored on 2010-04-30
189
    # Filter
190
    my $filter = $args->{filter} || $query->filter || {};
191

            
packaging one directory
yuki-kimoto authored on 2009-11-16
192
    # Create bind value
many many changes
yuki-kimoto authored on 2010-04-30
193
    my $bind_values = $self->_build_bind_values($query, $params, $filter);
packaging one directory
yuki-kimoto authored on 2009-11-16
194
    
195
    # Execute
version 0.0901
yuki-kimoto authored on 2009-12-17
196
    my $sth      = $query->sth;
197
    my $affected = eval{$sth->execute(@$bind_values)};
packaging one directory
yuki-kimoto authored on 2009-11-16
198
    
199
    # Execute error
200
    if (my $execute_error = $@) {
201
        require Data::Dumper;
202
        my $sql              = $query->{sql} || '';
203
        my $params_dump      = Data::Dumper->Dump([$params], ['*params']);
204
        
205
        croak("$execute_error" . 
206
              "<Your SQL>\n$sql\n" . 
207
              "<Your parameters>\n$params_dump");
208
    }
209
    
210
    # Return resultset if select statement is executed
211
    if ($sth->{NUM_OF_FIELDS}) {
212
        
213
        # Get result class
214
        my $result_class = $self->result_class;
215
        
216
        # Create result
217
        my $result = $result_class->new({
many many changes
yuki-kimoto authored on 2010-04-30
218
            sth             => $sth,
219
            default_filter  => $self->default_fetch_filter,
220
            filters         => $self->filters
packaging one directory
yuki-kimoto authored on 2009-11-16
221
        });
222
        return $result;
223
    }
version 0.0901
yuki-kimoto authored on 2009-12-17
224
    return $affected;
packaging one directory
yuki-kimoto authored on 2009-11-16
225
}
226

            
227
sub _build_bind_values {
many many changes
yuki-kimoto authored on 2010-04-30
228
    my ($self, $query, $params, $filter) = @_;
packaging one directory
yuki-kimoto authored on 2009-11-16
229
    
230
    # binding values
231
    my @bind_values;
232
    
Simplify key search
yuki-kimoto authored on 2010-02-11
233
    # Build bind values
simplify filtering system
yuki-kimoto authored on 2010-05-01
234
    my $count = {};
235
    foreach my $column (@{$query->columns}) {
packaging one directory
yuki-kimoto authored on 2009-11-16
236
        
Simplify key search
yuki-kimoto authored on 2010-02-11
237
        # Value
simplify filtering system
yuki-kimoto authored on 2010-05-01
238
        my $value = ref $params->{$column}
239
                  ? $params->{$column}->[$count->{$column} || 0]
240
                  : $params->{$column};
packaging one directory
yuki-kimoto authored on 2009-11-16
241
        
Simplify key search
yuki-kimoto authored on 2010-02-11
242
        # Filter
simplify filtering system
yuki-kimoto authored on 2010-05-01
243
        $filter ||= {};
many many changes
yuki-kimoto authored on 2010-04-30
244
        
simplify filtering system
yuki-kimoto authored on 2010-05-01
245
        # Filter name
246
        my $fname = $filter->{$column} || $self->default_query_filter || '';
247
        
248
        my $filters = $self->filters;
many change
yuki-kimoto authored on 2010-04-30
249
        push @bind_values, $filters->{$fname}
250
                         ? $filters->{$fname}->($value)
251
                         : $value;
simplify filtering system
yuki-kimoto authored on 2010-05-01
252
        
253
        # Count up 
254
        $count->{$column}++;
cleanup
yuki-kimoto authored on 2010-02-11
255
    }
256
    
Simplify key search
yuki-kimoto authored on 2010-02-11
257
    return \@bind_values;
cleanup
yuki-kimoto authored on 2010-02-11
258
}
259

            
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
260
sub run_transaction {
261
    my ($self, $transaction) = @_;
262
    
263
    # Shorcut
many change
yuki-kimoto authored on 2010-02-11
264
    return unless $self;
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
265
    
266
    # Check auto commit
267
    croak("AutoCommit must be true before transaction start")
many change
yuki-kimoto authored on 2010-02-11
268
      unless $self->_auto_commit;
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
269
    
270
    # Auto commit off
many change
yuki-kimoto authored on 2010-02-11
271
    $self->_auto_commit(0);
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
272
    
273
    # Run transaction
274
    eval {$transaction->()};
275
    
276
    # Tranzaction error
277
    my $transaction_error = $@;
278
    
279
    # Tranzaction is failed.
280
    if ($transaction_error) {
281
        # Rollback
many change
yuki-kimoto authored on 2010-02-11
282
        eval{$self->dbh->rollback};
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
283
        
284
        # Rollback error
285
        my $rollback_error = $@;
286
        
287
        # Auto commit on
many change
yuki-kimoto authored on 2010-02-11
288
        $self->_auto_commit(1);
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
289
        
290
        if ($rollback_error) {
291
            # Rollback is failed
292
            croak("${transaction_error}Rollback is failed : $rollback_error");
293
        }
294
        else {
295
            # Rollback is success
296
            croak("${transaction_error}Rollback is success");
297
        }
298
    }
299
    # Tranzaction is success
300
    else {
301
        # Commit
many change
yuki-kimoto authored on 2010-02-11
302
        eval{$self->dbh->commit};
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
303
        my $commit_error = $@;
304
        
305
        # Auto commit on
many change
yuki-kimoto authored on 2010-02-11
306
        $self->_auto_commit(1);
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
307
        
308
        # Commit is failed
309
        croak($commit_error) if $commit_error;
310
    }
311
}
312

            
version 0.0901
yuki-kimoto authored on 2009-12-17
313
sub create_table {
314
    my ($self, $table, @column_definitions) = @_;
315
    
316
    # Create table
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
317
    my $sql = "create table $table (";
version 0.0901
yuki-kimoto authored on 2009-12-17
318
    
319
    # Column definitions
320
    foreach my $column_definition (@column_definitions) {
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
321
        $sql .= "$column_definition,";
version 0.0901
yuki-kimoto authored on 2009-12-17
322
    }
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
323
    $sql =~ s/,$//;
version 0.0901
yuki-kimoto authored on 2009-12-17
324
    
325
    # End
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
326
    $sql .= ");";
version 0.0901
yuki-kimoto authored on 2009-12-17
327
    
add all tests
yuki-kimoto authored on 2010-05-01
328
    # Connect
329
    $self->connect unless $self->connected;
330
    
version 0.0901
yuki-kimoto authored on 2009-12-17
331
    # Do query
add all tests
yuki-kimoto authored on 2010-05-01
332
    return $self->dbh->do($sql);
version 0.0901
yuki-kimoto authored on 2009-12-17
333
}
334

            
335
sub drop_table {
336
    my ($self, $table) = @_;
337
    
338
    # Drop table
339
    my $sql = "drop table $table;";
340

            
add all tests
yuki-kimoto authored on 2010-05-01
341
    # Connect
342
    $self->connect unless $self->connected;
343

            
version 0.0901
yuki-kimoto authored on 2009-12-17
344
    # Do query
add all tests
yuki-kimoto authored on 2010-05-01
345
    return $self->dbh->do($sql);
version 0.0901
yuki-kimoto authored on 2009-12-17
346
}
347

            
many many changes
yuki-kimoto authored on 2010-04-30
348
our %VALID_INSERT_ARGS = map { $_ => 1 } qw/append filter/;
cleanup insert
yuki-kimoto authored on 2010-04-28
349

            
packaging one directory
yuki-kimoto authored on 2009-11-16
350
sub insert {
cleanup insert
yuki-kimoto authored on 2010-04-28
351
    my ($self, $table, $insert_params, $args) = @_;
352
    
353
    # Table
354
    $table ||= '';
355
    
356
    # Insert params
357
    $insert_params ||= {};
358
    
359
    # Arguments
360
    $args ||= {};
361
    
362
    # Check arguments
363
    foreach my $name (keys %$args) {
364
        croak "\"$name\" is invalid name"
365
          unless $VALID_INSERT_ARGS{$name};
366
    }
367
    
368
    my $append_statement = $args->{append} || '';
many many changes
yuki-kimoto authored on 2010-04-30
369
    my $filter           = $args->{filter};
packaging one directory
yuki-kimoto authored on 2009-11-16
370
    
371
    # Insert keys
372
    my @insert_keys = keys %$insert_params;
373
    
374
    # Not exists insert keys
375
    croak("Key-value pairs for insert must be specified to 'insert' second argument")
376
      unless @insert_keys;
377
    
378
    # Templte for insert
379
    my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
380
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
381
    
382
    # Execute query
many many changes
yuki-kimoto authored on 2010-04-30
383
    my $ret_val = $self->query($template, $insert_params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
384
    
385
    return $ret_val;
386
}
387

            
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
388
our %VALID_UPDATE_ARGS
many many changes
yuki-kimoto authored on 2010-04-30
389
  = map { $_ => 1 } qw/where append filter allow_update_all/;
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
390

            
packaging one directory
yuki-kimoto authored on 2009-11-16
391
sub update {
simplify filtering system
yuki-kimoto authored on 2010-05-01
392
    my ($self, $table, $params, $args) = @_;
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
393
    
394
    # Check arguments
395
    foreach my $name (keys %$args) {
396
        croak "\"$name\" is invalid name"
397
          unless $VALID_UPDATE_ARGS{$name};
398
    }
399
    
400
    # Arguments
401
    my $where_params     = $args->{where} || {};
402
    my $append_statement = $args->{append} || '';
many many changes
yuki-kimoto authored on 2010-04-30
403
    my $filter           = $args->{filter};
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
404
    my $allow_update_all = $args->{allow_update_all};
packaging one directory
yuki-kimoto authored on 2009-11-16
405
    
406
    # Update keys
simplify filtering system
yuki-kimoto authored on 2010-05-01
407
    my @update_keys = keys %$params;
packaging one directory
yuki-kimoto authored on 2009-11-16
408
    
409
    # Not exists update kyes
410
    croak("Key-value pairs for update must be specified to 'update' second argument")
411
      unless @update_keys;
412
    
413
    # Where keys
414
    my @where_keys = keys %$where_params;
415
    
416
    # Not exists where keys
417
    croak("Key-value pairs for where clause must be specified to 'update' third argument")
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
418
      if !@where_keys && !$allow_update_all;
packaging one directory
yuki-kimoto authored on 2009-11-16
419
    
420
    # Update clause
421
    my $update_clause = '{update ' . join(' ', @update_keys) . '}';
422
    
423
    # Where clause
424
    my $where_clause = '';
simplify filtering system
yuki-kimoto authored on 2010-05-01
425
    my $new_where = {};
many change
yuki-kimoto authored on 2010-04-30
426
    
packaging one directory
yuki-kimoto authored on 2009-11-16
427
    if (@where_keys) {
428
        $where_clause = 'where ';
429
        foreach my $where_key (@where_keys) {
simplify filtering system
yuki-kimoto authored on 2010-05-01
430
            
431
            $where_clause .= "{= $where_key} and ";
packaging one directory
yuki-kimoto authored on 2009-11-16
432
        }
433
        $where_clause =~ s/ and $//;
434
    }
435
    
436
    # Template for update
437
    my $template = "update $table $update_clause $where_clause";
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
438
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
439
    
440
    # Rearrange parammeters
simplify filtering system
yuki-kimoto authored on 2010-05-01
441
    foreach my $where_key (@where_keys) {
442
        
443
        if (exists $params->{$where_key}) {
444
            $params->{$where_key} = [$params->{$where_key}]
445
              unless ref $params->{$where_key} eq 'ARRAY';
446
            
compile success
yuki-kimoto authored on 2010-05-01
447
            push @{$params->{$where_key}}, $where_params->{$where_key};
simplify filtering system
yuki-kimoto authored on 2010-05-01
448
        }
add tests
yuki-kimoto authored on 2010-05-01
449
        else {
450
            $params->{$where_key} = $where_params->{$where_key};
451
        }
simplify filtering system
yuki-kimoto authored on 2010-05-01
452
    }
packaging one directory
yuki-kimoto authored on 2009-11-16
453
    
454
    # Execute query
many many changes
yuki-kimoto authored on 2010-04-30
455
    my $ret_val = $self->query($template, $params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
456
    
457
    return $ret_val;
458
}
459

            
460
sub update_all {
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
461
    my ($self, $table, $update_params, $args) = @_;
462
    
refactoring select
yuki-kimoto authored on 2010-04-28
463
    # Allow all update
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
464
    $args ||= {};
465
    $args->{allow_update_all} = 1;
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
466
    
update document
yuki-kimoto authored on 2010-01-30
467
    # Update all rows
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
468
    return $self->update($table, $update_params, $args);
packaging one directory
yuki-kimoto authored on 2009-11-16
469
}
470

            
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
471
our %VALID_DELETE_ARGS
many many changes
yuki-kimoto authored on 2010-04-30
472
  = map { $_ => 1 } qw/where append filter allow_delete_all/;
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
473

            
packaging one directory
yuki-kimoto authored on 2009-11-16
474
sub delete {
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
475
    my ($self, $table, $args) = @_;
476
    
477
    # Table
478
    $table            ||= '';
479

            
480
    # Check arguments
481
    foreach my $name (keys %$args) {
482
        croak "\"$name\" is invalid name"
483
          unless $VALID_DELETE_ARGS{$name};
484
    }
485
    
486
    # Arguments
487
    my $where_params     = $args->{where} || {};
488
    my $append_statement = $args->{append};
many many changes
yuki-kimoto authored on 2010-04-30
489
    my $filter    = $args->{filter};
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
490
    my $allow_delete_all = $args->{allow_delete_all};
packaging one directory
yuki-kimoto authored on 2009-11-16
491
    
492
    # Where keys
493
    my @where_keys = keys %$where_params;
494
    
495
    # Not exists where keys
496
    croak("Key-value pairs for where clause must be specified to 'delete' second argument")
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
497
      if !@where_keys && !$allow_delete_all;
packaging one directory
yuki-kimoto authored on 2009-11-16
498
    
499
    # Where clause
500
    my $where_clause = '';
501
    if (@where_keys) {
502
        $where_clause = 'where ';
503
        foreach my $where_key (@where_keys) {
504
            $where_clause .= "{= $where_key} and ";
505
        }
506
        $where_clause =~ s/ and $//;
507
    }
508
    
509
    # Template for delete
510
    my $template = "delete from $table $where_clause";
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
511
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
512
    
513
    # Execute query
many many changes
yuki-kimoto authored on 2010-04-30
514
    my $ret_val = $self->query($template, $where_params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
515
    
516
    return $ret_val;
517
}
518

            
519
sub delete_all {
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
520
    my ($self, $table, $args) = @_;
521
    
refactoring select
yuki-kimoto authored on 2010-04-28
522
    # Allow all delete
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
523
    $args ||= {};
524
    $args->{allow_delete_all} = 1;
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
525
    
update document
yuki-kimoto authored on 2010-01-30
526
    # Delete all rows
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
527
    return $self->delete($table, $args);
packaging one directory
yuki-kimoto authored on 2009-11-16
528
}
529

            
refactoring select
yuki-kimoto authored on 2010-04-28
530
our %VALID_SELECT_ARGS
many many changes
yuki-kimoto authored on 2010-04-30
531
  = map { $_ => 1 } qw/columns where append filter/;
refactoring select
yuki-kimoto authored on 2010-04-28
532

            
packaging one directory
yuki-kimoto authored on 2009-11-16
533
sub select {
refactoring select
yuki-kimoto authored on 2010-04-28
534
    my ($self, $tables, $args) = @_;
packaging one directory
yuki-kimoto authored on 2009-11-16
535
    
refactoring select
yuki-kimoto authored on 2010-04-28
536
    # Table
537
    $tables ||= '';
538
    $tables = [$tables] unless ref $tables;
packaging one directory
yuki-kimoto authored on 2009-11-16
539
    
refactoring select
yuki-kimoto authored on 2010-04-28
540
    # Check arguments
541
    foreach my $name (keys %$args) {
542
        croak "\"$name\" is invalid name"
543
          unless $VALID_SELECT_ARGS{$name};
544
    }
packaging one directory
yuki-kimoto authored on 2009-11-16
545
    
refactoring select
yuki-kimoto authored on 2010-04-28
546
    # Arguments
547
    my $columns          = $args->{columns} || [];
548
    my $where_params     = $args->{where} || {};
549
    my $append_statement = $args->{append} || '';
many many changes
yuki-kimoto authored on 2010-04-30
550
    my $filter    = $args->{filter};
packaging one directory
yuki-kimoto authored on 2009-11-16
551
    
552
    # SQL template for select statement
553
    my $template = 'select ';
554
    
555
    # Join column clause
556
    if (@$columns) {
557
        foreach my $column (@$columns) {
558
            $template .= "$column, ";
559
        }
560
        $template =~ s/, $/ /;
561
    }
562
    else {
563
        $template .= '* ';
564
    }
565
    
566
    # Join table
567
    $template .= 'from ';
568
    foreach my $table (@$tables) {
569
        $template .= "$table, ";
570
    }
571
    $template =~ s/, $/ /;
572
    
573
    # Where clause keys
574
    my @where_keys = keys %$where_params;
575
    
576
    # Join where clause
577
    if (@where_keys) {
578
        $template .= 'where ';
579
        foreach my $where_key (@where_keys) {
compile success
yuki-kimoto authored on 2010-05-01
580
            $template .= "{= $where_key} and ";
packaging one directory
yuki-kimoto authored on 2009-11-16
581
        }
582
    }
583
    $template =~ s/ and $//;
584
    
585
    # Append something to last of statement
586
    if ($append_statement =~ s/^where //) {
587
        if (@where_keys) {
588
            $template .= " and $append_statement";
589
        }
590
        else {
591
            $template .= " where $append_statement";
592
        }
593
    }
594
    else {
595
        $template .= " $append_statement";
596
    }
597
    
598
    # Execute query
simplify filtering system
yuki-kimoto authored on 2010-05-01
599
    my $result = $self->query($template, $where_params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
600
    
601
    return $result;
602
}
603

            
604
sub _add_query_cache {
605
    my ($class, $template, $query) = @_;
update document
yuki-kimoto authored on 2010-01-30
606
    
607
    # Query information
packaging one directory
yuki-kimoto authored on 2009-11-16
608
    my $query_cache_keys = $class->_query_cache_keys;
609
    my $query_caches     = $class->_query_caches;
610
    
update document
yuki-kimoto authored on 2010-01-30
611
    # Already cached
packaging one directory
yuki-kimoto authored on 2009-11-16
612
    return $class if $query_caches->{$template};
613
    
update document
yuki-kimoto authored on 2010-01-30
614
    # Cache
packaging one directory
yuki-kimoto authored on 2009-11-16
615
    $query_caches->{$template} = $query;
616
    push @$query_cache_keys, $template;
617
    
update document
yuki-kimoto authored on 2010-01-30
618
    # Check cache overflow
packaging one directory
yuki-kimoto authored on 2009-11-16
619
    my $overflow = @$query_cache_keys - $class->query_cache_max;
620
    for (my $i = 0; $i < $overflow; $i++) {
621
        my $template = shift @$query_cache_keys;
622
        delete $query_caches->{$template};
623
    }
624
    
625
    return $class;
626
}
627

            
628
=head1 NAME
629

            
version 0.0901
yuki-kimoto authored on 2009-12-17
630
DBIx::Custom - Customizable DBI
packaging one directory
yuki-kimoto authored on 2009-11-16
631

            
version 0.0901
yuki-kimoto authored on 2009-12-17
632
=head1 VERSION
packaging one directory
yuki-kimoto authored on 2009-11-16
633

            
many change
yuki-kimoto authored on 2010-02-11
634
Version 0.1201
catch up with Object::Simple...
yuki-kimoto authored on 2010-01-18
635

            
636
=cut
637

            
many change
yuki-kimoto authored on 2010-02-11
638
our $VERSION = '0.1201';
packaging one directory
yuki-kimoto authored on 2009-11-16
639

            
cleanup
yuki-kimoto authored on 2010-02-11
640
=head1 STATE
641

            
642
This module is not stable. Method name and functionality will be change.
643

            
version 0.0901
yuki-kimoto authored on 2009-12-17
644
=head1 SYNOPSYS
645
    
646
    # New
647
    my $dbi = DBIx::Custom->new(data_source => "dbi:mysql:database=books"
648
                                user => 'ken', password => '!LFKD%$&');
649
    
650
    # Query
651
    $dbi->query("select title from books");
652
    
653
    # Query with parameters
654
    $dbi->query("select id from books where {= author} && {like title}",
655
                {author => 'ken', title => '%Perl%'});
656
    
657
    # Insert 
658
    $dbi->insert('books', {title => 'perl', author => 'Ken'});
659
    
660
    # Update 
661
    $dbi->update('books', {title => 'aaa', author => 'Ken'}, {id => 5});
662
    
663
    # Delete
664
    $dbi->delete('books', {author => 'Ken'});
665
    
666
    # Select
667
    $dbi->select('books');
668
    $dbi->select('books', {author => 'taro'}); 
669
    $dbi->select('books', [qw/author title/], {author => 'Ken'});
670
    $dbi->select('books', [qw/author title/], {author => 'Ken'},
671
                 'order by id limit 1');
packaging one directory
yuki-kimoto authored on 2009-11-16
672

            
update document
yuki-kimoto authored on 2010-01-30
673
=head1 ATTRIBUTES
packaging one directory
yuki-kimoto authored on 2009-11-16
674

            
675
=head2 user
676

            
update document
yuki-kimoto authored on 2010-01-30
677
Database user name
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
678
    
version 0.0901
yuki-kimoto authored on 2009-12-17
679
    $dbi  = $dbi->user('Ken');
680
    $user = $dbi->user;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
681
    
packaging one directory
yuki-kimoto authored on 2009-11-16
682
=head2 password
683

            
update document
yuki-kimoto authored on 2010-01-30
684
Database password
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
685
    
version 0.0901
yuki-kimoto authored on 2009-12-17
686
    $dbi      = $dbi->password('lkj&le`@s');
687
    $password = $dbi->password;
packaging one directory
yuki-kimoto authored on 2009-11-16
688

            
689
=head2 data_source
690

            
update document
yuki-kimoto authored on 2010-01-30
691
Database data source
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
692
    
version 0.0901
yuki-kimoto authored on 2009-12-17
693
    $dbi         = $dbi->data_source("dbi:mysql:dbname=$database");
694
    $data_source = $dbi->data_source;
packaging one directory
yuki-kimoto authored on 2009-11-16
695
    
version 0.0901
yuki-kimoto authored on 2009-12-17
696
If you know data source more, See also L<DBI>.
697

            
packaging one directory
yuki-kimoto authored on 2009-11-16
698
=head2 database
699

            
update document
yuki-kimoto authored on 2010-01-30
700
Database name
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
701

            
version 0.0901
yuki-kimoto authored on 2009-12-17
702
    $dbi      = $dbi->database('books');
703
    $database = $dbi->database;
packaging one directory
yuki-kimoto authored on 2009-11-16
704

            
add port and host method
yuki-kimoto authored on 2009-11-16
705
=head2 host
706

            
update document
yuki-kimoto authored on 2010-01-30
707
Host name
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
708

            
version 0.0901
yuki-kimoto authored on 2009-12-17
709
    $dbi  = $dbi->host('somehost.com');
710
    $host = $dbi->host;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
711

            
version 0.0901
yuki-kimoto authored on 2009-12-17
712
You can also set IP address like '127.03.45.12'.
add port and host method
yuki-kimoto authored on 2009-11-16
713

            
714
=head2 port
715

            
update document
yuki-kimoto authored on 2010-01-30
716
Port number
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
717

            
version 0.0901
yuki-kimoto authored on 2009-12-17
718
    $dbi  = $dbi->port(1198);
719
    $port = $dbi->port;
add port and host method
yuki-kimoto authored on 2009-11-16
720

            
version 0.0901
yuki-kimoto authored on 2009-12-17
721
=head2 options
packaging one directory
yuki-kimoto authored on 2009-11-16
722

            
update document
yuki-kimoto authored on 2010-01-30
723
DBI options
packaging one directory
yuki-kimoto authored on 2009-11-16
724

            
version 0.0901
yuki-kimoto authored on 2009-12-17
725
    $dbi     = $dbi->options({PrintError => 0, RaiseError => 1});
726
    $options = $dbi->options;
packaging one directory
yuki-kimoto authored on 2009-11-16
727

            
version 0.0901
yuki-kimoto authored on 2009-12-17
728
=head2 sql_tmpl
packaging one directory
yuki-kimoto authored on 2009-11-16
729

            
many many changes
yuki-kimoto authored on 2010-04-30
730
SQLTemplate object
packaging one directory
yuki-kimoto authored on 2009-11-16
731

            
many many changes
yuki-kimoto authored on 2010-04-30
732
    $dbi      = $dbi->sql_tmpl(DBIx::Cutom::SQLTemplate->new);
version 0.0901
yuki-kimoto authored on 2009-12-17
733
    $sql_tmpl = $dbi->sql_tmpl;
packaging one directory
yuki-kimoto authored on 2009-11-16
734

            
many many changes
yuki-kimoto authored on 2010-04-30
735
See also L<DBIx::Custom::SQLTemplate>.
packaging one directory
yuki-kimoto authored on 2009-11-16
736

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
737
=head2 filters
packaging one directory
yuki-kimoto authored on 2009-11-16
738

            
update document
yuki-kimoto authored on 2010-01-30
739
Filters
packaging one directory
yuki-kimoto authored on 2009-11-16
740

            
version 0.0901
yuki-kimoto authored on 2009-12-17
741
    $dbi     = $dbi->filters({filter1 => sub { }, filter2 => sub {}});
742
    $filters = $dbi->filters;
packaging one directory
yuki-kimoto authored on 2009-11-16
743
    
version 0.0901
yuki-kimoto authored on 2009-12-17
744
This method is generally used to get a filter.
745

            
746
    $filter = $dbi->filters->{encode_utf8};
747

            
many many changes
yuki-kimoto authored on 2010-04-30
748
If you add filter, use resist_filter method.
packaging one directory
yuki-kimoto authored on 2009-11-16
749

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
750
=head2 formats
packaging one directory
yuki-kimoto authored on 2009-11-16
751

            
update document
yuki-kimoto authored on 2010-01-30
752
Formats
packaging one directory
yuki-kimoto authored on 2009-11-16
753

            
version 0.0901
yuki-kimoto authored on 2009-12-17
754
    $dbi     = $dbi->formats({format1 => sub { }, format2 => sub {}});
755
    $formats = $dbi->formats;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
756

            
version 0.0901
yuki-kimoto authored on 2009-12-17
757
This method is generally used to get a format.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
758

            
version 0.0901
yuki-kimoto authored on 2009-12-17
759
    $filter = $dbi->formats->{datetime};
760

            
many many changes
yuki-kimoto authored on 2010-04-30
761
If you add format, use resist_format method.
packaging one directory
yuki-kimoto authored on 2009-11-16
762

            
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
763
=head2 default_query_filter
packaging one directory
yuki-kimoto authored on 2009-11-16
764

            
update document
yuki-kimoto authored on 2010-01-30
765
Binding filter
packaging one directory
yuki-kimoto authored on 2009-11-16
766

            
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
767
    $dbi                 = $dbi->default_query_filter($default_query_filter);
768
    $default_query_filter = $dbi->default_query_filter
packaging one directory
yuki-kimoto authored on 2009-11-16
769

            
version 0.0901
yuki-kimoto authored on 2009-12-17
770
The following is bind filter sample
cleanup
yuki-kimoto authored on 2010-04-28
771
    
many many changes
yuki-kimoto authored on 2010-04-30
772
    $dbi->resist_filter(encode_utf8 => sub {
cleanup
yuki-kimoto authored on 2010-04-28
773
        my $value = shift;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
774
        
cleanup
yuki-kimoto authored on 2010-04-28
775
        require Encode 'encode_utf8';
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
776
        
cleanup
yuki-kimoto authored on 2010-04-28
777
        return encode_utf8($value);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
778
    });
cleanup
yuki-kimoto authored on 2010-04-28
779
    
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
780
    $dbi->default_query_filter('encode_utf8')
packaging one directory
yuki-kimoto authored on 2009-11-16
781

            
version 0.0901
yuki-kimoto authored on 2009-12-17
782
Bind filter arguemts is
783

            
784
    1. $value : Value
785
    2. $key   : Key
786
    3. $dbi   : DBIx::Custom object
787
    4. $infos : {table => $table, column => $column}
788

            
cleanup
yuki-kimoto authored on 2010-04-28
789
=head2 default_fetch_filter
packaging one directory
yuki-kimoto authored on 2009-11-16
790

            
update document
yuki-kimoto authored on 2010-01-30
791
Fetching filter
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
792

            
cleanup
yuki-kimoto authored on 2010-04-28
793
    $dbi                  = $dbi->default_fetch_filter($default_fetch_filter);
794
    $default_fetch_filter = $dbi->default_fetch_filter;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
795

            
version 0.0901
yuki-kimoto authored on 2009-12-17
796
The following is fetch filter sample
packaging one directory
yuki-kimoto authored on 2009-11-16
797

            
many many changes
yuki-kimoto authored on 2010-04-30
798
    $dbi->resist_filter(decode_utf8 => sub {
cleanup
yuki-kimoto authored on 2010-04-28
799
        my $value = shift;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
800
        
cleanup
yuki-kimoto authored on 2010-04-28
801
        require Encode 'decode_utf8';
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
802
        
cleanup
yuki-kimoto authored on 2010-04-28
803
        return decode_utf8($value);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
804
    });
packaging one directory
yuki-kimoto authored on 2009-11-16
805

            
cleanup
yuki-kimoto authored on 2010-04-28
806
    $dbi->default_fetch_filter('decode_utf8');
807

            
version 0.0901
yuki-kimoto authored on 2009-12-17
808
Bind filter arguemts is
809

            
810
    1. $value : Value
811
    2. $key   : Key
812
    3. $dbi   : DBIx::Custom object
813
    4. $infos : {type => $table, sth => $sth, index => $index}
814

            
packaging one directory
yuki-kimoto authored on 2009-11-16
815
=head2 result_class
816

            
update document
yuki-kimoto authored on 2010-01-30
817
Resultset class
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
818

            
version 0.0901
yuki-kimoto authored on 2009-12-17
819
    $dbi          = $dbi->result_class('DBIx::Custom::Result');
packaging one directory
yuki-kimoto authored on 2009-11-16
820
    $result_class = $dbi->result_class;
821

            
update document
yuki-kimoto authored on 2010-01-30
822
Default is L<DBIx::Custom::Result>
823

            
packaging one directory
yuki-kimoto authored on 2009-11-16
824
=head2 dbh
825

            
update document
yuki-kimoto authored on 2010-01-30
826
Database handle
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
827
    
version 0.0901
yuki-kimoto authored on 2009-12-17
828
    $dbi = $dbi->dbh($dbh);
829
    $dbh = $dbi->dbh;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
830
    
831
=head2 query_cache_max
832

            
update document
yuki-kimoto authored on 2010-01-30
833
Query cache max
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
834

            
version 0.0901
yuki-kimoto authored on 2009-12-17
835
    $class           = DBIx::Custom->query_cache_max(50);
836
    $query_cache_max = DBIx::Custom->query_cache_max;
837

            
838
Default value is 50
839

            
update document
yuki-kimoto authored on 2010-01-30
840
=head1 METHODS
841

            
842
This class is L<Object::Simple> subclass.
843
You can use all methods of L<Object::Simple>
packaging one directory
yuki-kimoto authored on 2009-11-16
844

            
845
=head2 connect
846

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
847
Connect to database
848

            
packaging one directory
yuki-kimoto authored on 2009-11-16
849
    $dbi->connect;
850

            
851
=head2 disconnect
852

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
853
Disconnect database
854

            
packaging one directory
yuki-kimoto authored on 2009-11-16
855
    $dbi->disconnect;
856

            
version 0.0901
yuki-kimoto authored on 2009-12-17
857
If database is already disconnected, this method do nothing.
packaging one directory
yuki-kimoto authored on 2009-11-16
858

            
859
=head2 reconnect
860

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
861
Reconnect to database
862

            
packaging one directory
yuki-kimoto authored on 2009-11-16
863
    $dbi->reconnect;
864

            
865
=head2 connected
866

            
version 0.0901
yuki-kimoto authored on 2009-12-17
867
Check if database is connected.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
868
    
version 0.0901
yuki-kimoto authored on 2009-12-17
869
    $is_connected = $dbi->connected;
packaging one directory
yuki-kimoto authored on 2009-11-16
870
    
many many changes
yuki-kimoto authored on 2010-04-30
871
=head2 resist_filter
packaging one directory
yuki-kimoto authored on 2009-11-16
872

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
873
Resist filter
packaging one directory
yuki-kimoto authored on 2009-11-16
874
    
many many changes
yuki-kimoto authored on 2010-04-30
875
    $dbi->resist_filter($fname1 => $filter1, $fname => $filter2);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
876
    
many many changes
yuki-kimoto authored on 2010-04-30
877
The following is resist_filter sample
version 0.0901
yuki-kimoto authored on 2009-12-17
878

            
many many changes
yuki-kimoto authored on 2010-04-30
879
    $dbi->resist_filter(
packaging one directory
yuki-kimoto authored on 2009-11-16
880
        encode_utf8 => sub {
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
881
            my ($value, $key, $dbi, $infos) = @_;
882
            utf8::upgrade($value) unless Encode::is_utf8($value);
883
            return encode('UTF-8', $value);
packaging one directory
yuki-kimoto authored on 2009-11-16
884
        },
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
885
        decode_utf8 => sub {
886
            my ($value, $key, $dbi, $infos) = @_;
887
            return decode('UTF-8', $value)
packaging one directory
yuki-kimoto authored on 2009-11-16
888
        }
889
    );
890

            
many many changes
yuki-kimoto authored on 2010-04-30
891
=head2 resist_format
packaging one directory
yuki-kimoto authored on 2009-11-16
892

            
version 0.0901
yuki-kimoto authored on 2009-12-17
893
Add format
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
894

            
many many changes
yuki-kimoto authored on 2010-04-30
895
    $dbi->resist_format($fname1 => $format, $fname2 => $format2);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
896
    
many many changes
yuki-kimoto authored on 2010-04-30
897
The following is resist_format sample.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
898

            
many many changes
yuki-kimoto authored on 2010-04-30
899
    $dbi->resist_format(date => '%Y:%m:%d', datetime => '%Y-%m-%d %H:%M:%S');
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
900

            
version 0.0901
yuki-kimoto authored on 2009-12-17
901
=head2 create_query
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
902
    
version 0.0901
yuki-kimoto authored on 2009-12-17
903
Create Query object parsing SQL template
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
904

            
version 0.0901
yuki-kimoto authored on 2009-12-17
905
    my $query = $dbi->create_query("select * from authors where {= name} and {= age}");
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
906

            
version 0.0901
yuki-kimoto authored on 2009-12-17
907
$query is <DBIx::Query> object. This is executed by query method as the following
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
908

            
version 0.0901
yuki-kimoto authored on 2009-12-17
909
    $dbi->query($query, $params);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
910

            
many many changes
yuki-kimoto authored on 2010-04-30
911
If you know SQL template, see also L<DBIx::Custom::SQLTemplate>.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
912

            
version 0.0901
yuki-kimoto authored on 2009-12-17
913
=head2 query
packaging one directory
yuki-kimoto authored on 2009-11-16
914

            
version 0.0901
yuki-kimoto authored on 2009-12-17
915
Query
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
916

            
version 0.0901
yuki-kimoto authored on 2009-12-17
917
    $result = $dbi->query($template, $params);
packaging one directory
yuki-kimoto authored on 2009-11-16
918

            
version 0.0901
yuki-kimoto authored on 2009-12-17
919
The following is query sample
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
920

            
packaging one directory
yuki-kimoto authored on 2009-11-16
921
    $result = $dbi->query("select * from authors where {= name} and {= age}", 
922
                          {author => 'taro', age => 19});
923
    
924
    while (my @row = $result->fetch) {
925
        # do something
926
    }
927

            
many many changes
yuki-kimoto authored on 2010-04-30
928
If you now syntax of template, See also L<DBIx::Custom::SQLTemplate>
version 0.0901
yuki-kimoto authored on 2009-12-17
929

            
930
Return value of query method is L<DBIx::Custom::Result> object
931

            
932
See also L<DBIx::Custom::Result>.
packaging one directory
yuki-kimoto authored on 2009-11-16
933

            
remove run_transaction().
yuki-kimoto authored on 2010-01-30
934
=head2 transaction
packaging one directory
yuki-kimoto authored on 2009-11-16
935

            
remove run_transaction().
yuki-kimoto authored on 2010-01-30
936
Get L<DBIx::Custom::Transaction> object, and you run a transaction.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
937

            
remove run_transaction().
yuki-kimoto authored on 2010-01-30
938
    $dbi->transaction->run(sub {
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
939
        my $dbi = shift;
940
        
packaging one directory
yuki-kimoto authored on 2009-11-16
941
        # do something
942
    });
943

            
944
If transaction is success, commit is execute. 
945
If tranzation is died, rollback is execute.
946

            
version 0.0901
yuki-kimoto authored on 2009-12-17
947
=head2 create_table
948

            
949
Create table
950

            
951
    $dbi->create_table(
952
        'books',
953
        'name char(255)',
954
        'age  int'
955
    );
956

            
957
First argument is table name. Rest arguments is column definition.
958

            
959
=head2 drop_table
960

            
961
Drop table
962

            
963
    $dbi->drop_table('books');
964

            
packaging one directory
yuki-kimoto authored on 2009-11-16
965
=head2 insert
966

            
update document
yuki-kimoto authored on 2009-11-19
967
Insert row
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
968

            
version 0.0901
yuki-kimoto authored on 2009-12-17
969
    $affected = $dbi->insert($table, \%$insert_params);
970
    $affected = $dbi->insert($table, \%$insert_params, $append);
update document
yuki-kimoto authored on 2009-11-19
971

            
version 0.0901
yuki-kimoto authored on 2009-12-17
972
Retrun value is affected rows count
packaging one directory
yuki-kimoto authored on 2009-11-16
973
    
version 0.0901
yuki-kimoto authored on 2009-12-17
974
The following is insert sample.
975

            
packaging one directory
yuki-kimoto authored on 2009-11-16
976
    $dbi->insert('books', {title => 'Perl', author => 'Taro'});
977

            
version 0.0901
yuki-kimoto authored on 2009-12-17
978
You can add statement.
979

            
980
    $dbi->insert('books', {title => 'Perl', author => 'Taro'}, "some statement");
981

            
packaging one directory
yuki-kimoto authored on 2009-11-16
982
=head2 update
983

            
update document
yuki-kimoto authored on 2009-11-19
984
Update rows
985

            
version 0.0901
yuki-kimoto authored on 2009-12-17
986
    $affected = $dbi->update($table, \%update_params, \%where);
987
    $affected = $dbi->update($table, \%update_params, \%where, $append);
988

            
989
Retrun value is affected rows count
update document
yuki-kimoto authored on 2009-11-19
990

            
version 0.0901
yuki-kimoto authored on 2009-12-17
991
The following is update sample.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
992

            
packaging one directory
yuki-kimoto authored on 2009-11-16
993
    $dbi->update('books', {title => 'Perl', author => 'Taro'}, {id => 5});
994

            
version 0.0901
yuki-kimoto authored on 2009-12-17
995
You can add statement.
996

            
997
    $dbi->update('books', {title => 'Perl', author => 'Taro'},
998
                 {id => 5}, "some statement");
999

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1000
=head2 update_all
1001

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1002
Update all rows
1003

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1004
    $affected = $dbi->update_all($table, \%updat_params);
update document
yuki-kimoto authored on 2009-11-19
1005

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1006
Retrun value is affected rows count
1007

            
1008
The following is update_all sample.
update document
yuki-kimoto authored on 2009-11-19
1009

            
1010
    $dbi->update_all('books', {author => 'taro'});
packaging one directory
yuki-kimoto authored on 2009-11-16
1011

            
1012
=head2 delete
1013

            
update document
yuki-kimoto authored on 2009-11-19
1014
Delete rows
1015

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1016
    $affected = $dbi->delete($table, \%where);
1017
    $affected = $dbi->delete($table, \%where, $append);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1018

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1019
Retrun value is affected rows count
packaging one directory
yuki-kimoto authored on 2009-11-16
1020
    
version 0.0901
yuki-kimoto authored on 2009-12-17
1021
The following is delete sample.
1022

            
update document
yuki-kimoto authored on 2009-11-19
1023
    $dbi->delete('books', {id => 5});
packaging one directory
yuki-kimoto authored on 2009-11-16
1024

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1025
You can add statement.
1026

            
1027
    $dbi->delete('books', {id => 5}, "some statement");
1028

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1029
=head2 delete_all
1030

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1031
Delete all rows
1032

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1033
    $affected = $dbi->delete_all($table);
packaging one directory
yuki-kimoto authored on 2009-11-16
1034

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1035
Retrun value is affected rows count
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1036

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1037
The following is delete_all sample.
1038

            
1039
    $dbi->delete_all('books');
packaging one directory
yuki-kimoto authored on 2009-11-16
1040

            
1041
=head2 select
1042
    
update document
yuki-kimoto authored on 2009-11-19
1043
Select rows
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1044

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1045
    $resut = $dbi->select(
packaging one directory
yuki-kimoto authored on 2009-11-16
1046
        $table,                # must be string or array;
version 0.0901
yuki-kimoto authored on 2009-12-17
1047
        \@$columns,            # must be array reference. this can be ommited
1048
        \%$where_params,       # must be hash reference.  this can be ommited
1049
        $append_statement,     # must be string.          this can be ommited
1050
        $query_edit_callback   # must be code reference.  this can be ommited
packaging one directory
yuki-kimoto authored on 2009-11-16
1051
    );
update document
yuki-kimoto authored on 2009-11-19
1052

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1053
$reslt is L<DBIx::Custom::Result> object
update document
yuki-kimoto authored on 2009-11-19
1054

            
1055
The following is some select samples
1056

            
1057
    # select * from books;
1058
    $result = $dbi->select('books');
packaging one directory
yuki-kimoto authored on 2009-11-16
1059
    
update document
yuki-kimoto authored on 2009-11-19
1060
    # select * from books where title = 'Perl';
1061
    $result = $dbi->select('books', {title => 1});
1062
    
1063
    # select title, author from books where id = 1 for update;
1064
    $result = $dbi->select(
1065
        'books',              # table
1066
        ['title', 'author'],  # columns
1067
        {id => 1},            # where clause
1068
        'for update',         # append statement
1069
    );
1070

            
1071
You can join multi tables
1072
    
1073
    $result = $dbi->select(
1074
        ['table1', 'table2'],                # tables
1075
        ['table1.id as table1_id', 'title'], # columns (alias is ok)
1076
        {table1.id => 1},                    # where clase
1077
        "where table1.id = table2.id",       # join clause (must start 'where')
1078
    );
1079

            
1080
You can also edit query
1081
        
packaging one directory
yuki-kimoto authored on 2009-11-16
1082
    $dbi->select(
update document
yuki-kimoto authored on 2009-11-19
1083
        'books',
1084
        # column, where clause, append statement,
packaging one directory
yuki-kimoto authored on 2009-11-16
1085
        sub {
1086
            my $query = shift;
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
1087
            $query->query_filter(sub {
packaging one directory
yuki-kimoto authored on 2009-11-16
1088
                # ...
1089
            });
1090
        }
update document
yuki-kimoto authored on 2009-11-19
1091
    }
1092

            
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
1093
=head2 run_transaction
1094

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1095
=head1 DBIx::Custom default configuration
packaging one directory
yuki-kimoto authored on 2009-11-16
1096

            
update document
yuki-kimoto authored on 2009-11-19
1097
DBIx::Custom have DBI object.
packaging one directory
yuki-kimoto authored on 2009-11-16
1098
This module is work well in the following DBI condition.
1099

            
1100
    1. AutoCommit is true
1101
    2. RaiseError is true
1102

            
1103
By default, Both AutoCommit and RaiseError is true.
1104
You must not change these mode not to damage your data.
1105

            
1106
If you change these mode, 
1107
you cannot get correct error message, 
1108
or run_transaction may fail.
1109

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1110
=head1 Inheritance of DBIx::Custom
1111

            
1112
DBIx::Custom is customizable DBI.
1113
You can inherit DBIx::Custom and custumize attributes.
1114

            
1115
    package DBIx::Custom::Yours;
1116
    use base DBIx::Custom;
1117
    
1118
    my $class = __PACKAGE__;
1119
    
1120
    $class->user('your_name');
1121
    $class->password('your_password');
1122

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1123
=head1 AUTHOR
1124

            
1125
Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
1126

            
1127
Github L<http://github.com/yuki-kimoto>
1128

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1129
I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom>
1130

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1131
=head1 COPYRIGHT & LICENSE
1132

            
1133
Copyright 2009 Yuki Kimoto, all rights reserved.
1134

            
1135
This program is free software; you can redistribute it and/or modify it
1136
under the same terms as Perl itself.
1137

            
1138
=cut