DBIx-Custom / lib / DBIx / Custom.pm /
Newer Older
1303 lines | 32.065kb
packaging one directory
yuki-kimoto authored on 2009-11-16
1
use 5.008001;
2

            
3
package DBIx::Custom;
4
use Object::Simple;
5

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
6
our $VERSION = '0.0601';
packaging one directory
yuki-kimoto authored on 2009-11-16
7

            
8
use Carp 'croak';
9
use DBI;
10
use DBIx::Custom::Query;
11
use DBIx::Custom::Result;
12
use DBIx::Custom::SQL::Template;
13

            
14

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
15
### Accessors
packaging one directory
yuki-kimoto authored on 2009-11-16
16
sub user        : ClassObjectAttr { initialize => {clone => 'scalar'} }
17
sub password    : ClassObjectAttr { initialize => {clone => 'scalar'} }
18
sub data_source : ClassObjectAttr { initialize => {clone => 'scalar'} }
19
sub dbi_options : ClassObjectAttr { initialize => {clone => 'hash', 
20
                                                   default => sub { {} } } }
21
sub database    : ClassObjectAttr { initialize => {clone => 'scalar'} }
add port and host method
yuki-kimoto authored on 2009-11-16
22
sub host        : ClassObjectAttr { initialize => {clone => 'scalar'} }
23
sub port        : ClassObjectAttr { initialize => {clone => 'scalar'} }
packaging one directory
yuki-kimoto authored on 2009-11-16
24

            
25
sub bind_filter  : ClassObjectAttr { initialize => {clone => 'scalar'} }
26
sub fetch_filter : ClassObjectAttr { initialize => {clone => 'scalar'} }
27

            
28
sub no_bind_filters   : ClassObjectAttr { initialize => {clone => 'array'} }
29
sub no_fetch_filters  : ClassObjectAttr { initialize => {clone => 'array'} }
30

            
31
sub filters : ClassObjectAttr {
32
    type => 'hash',
33
    deref => 1,
34
    initialize => {
35
        clone   => 'hash',
36
        default => sub { {} }
37
    }
38
}
39

            
40
sub formats : ClassObjectAttr {
41
    type => 'hash',
42
    deref => 1,
43
    initialize => {
44
        clone   => 'hash',
45
        default => sub { {} }
46
    }
47
}
48

            
49
sub result_class : ClassObjectAttr {
50
    initialize => {
51
        clone   => 'scalar',
52
        default => 'DBIx::Custom::Result'
53
    }
54
}
55

            
56
sub sql_template : ClassObjectAttr {
57
    initialize => {
58
        clone   => sub {$_[0] ? $_[0]->clone : undef},
59
        default => sub {DBIx::Custom::SQL::Template->new}
60
    }
61
}
62

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
63
sub dbh : Attr {}
packaging one directory
yuki-kimoto authored on 2009-11-16
64

            
65

            
66
### Methods
67

            
68
# Add filter
69
sub add_filter {
70
    my $invocant = shift;
71
    
72
    my %old_filters = $invocant->filters;
73
    my %new_filters = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
74
    $invocant->filters(%old_filters, %new_filters);
75
    return $invocant;
76
}
77

            
78
# Add format
79
sub add_format{
80
    my $invocant = shift;
81
    
82
    my %old_formats = $invocant->formats;
83
    my %new_formats = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
84
    $invocant->formats(%old_formats, %new_formats);
85
    return $invocant;
86
}
87

            
88
# Auto commit
89
sub _auto_commit {
90
    my $self = shift;
91
    
92
    croak("Not yet connect to database") unless $self->dbh;
93
    
94
    if (@_) {
95
        $self->dbh->{AutoCommit} = $_[0];
96
        return $self;
97
    }
98
    return $self->dbh->{AutoCommit};
99
}
100

            
101
# Connect
102
sub connect {
103
    my $self = shift;
104
    my $data_source = $self->data_source;
105
    my $user        = $self->user;
106
    my $password    = $self->password;
107
    my $dbi_options  = $self->dbi_options;
108
    
109
    my $dbh = eval{DBI->connect(
110
        $data_source,
111
        $user,
112
        $password,
113
        {
114
            RaiseError => 1,
115
            PrintError => 0,
116
            AutoCommit => 1,
117
            %{$dbi_options || {} }
118
        }
119
    )};
120
    
121
    croak $@ if $@;
122
    
123
    $self->dbh($dbh);
124
    return $self;
125
}
126

            
127
# DESTROY
128
sub DESTROY {
129
    my $self = shift;
130
    $self->disconnect if $self->connected;
131
}
132

            
133
# Is connected?
134
sub connected {
135
    my $self = shift;
136
    return ref $self->{dbh} eq 'DBI::db';
137
}
138

            
139
# Disconnect
140
sub disconnect {
141
    my $self = shift;
142
    if ($self->connected) {
143
        $self->dbh->disconnect;
144
        delete $self->{dbh};
145
    }
146
}
147

            
148
# Reconnect
149
sub reconnect {
150
    my $self = shift;
151
    $self->disconnect if $self->connected;
152
    $self->connect;
153
}
154

            
155
# Prepare statement handle
156
sub prepare {
157
    my ($self, $sql) = @_;
158
    
159
    # Connect if not
160
    $self->connect unless $self->connected;
161
    
162
    # Prepare
163
    my $sth = eval{$self->dbh->prepare($sql)};
164
    
165
    # Error
166
    croak("$@<Your SQL>\n$sql") if $@;
167
    
168
    return $sth;
169
}
170

            
171
# Execute SQL directly
172
sub do{
173
    my ($self, $sql, @bind_values) = @_;
174
    
175
    # Connect if not
176
    $self->connect unless $self->connected;
177
    
178
    # Do
179
    my $ret_val = eval{$self->dbh->do($sql, @bind_values)};
180
    
181
    # Error
182
    if ($@) {
183
        my $error = $@;
184
        require Data::Dumper;
185
        
186
        my $bind_value_dump
187
          = Data::Dumper->Dump([\@bind_values], ['*bind_valuds']);
188
        
189
        croak("$error<Your SQL>\n$sql\n<Your bind values>\n$bind_value_dump\n");
190
    }
191
}
192

            
193
# Create query
194
sub create_query {
195
    my ($self, $template) = @_;
196
    my $class = ref $self;
197
    
198
    # Create query from SQL template
199
    my $sql_template = $self->sql_template;
200
    
201
    # Try to get cached query
202
    my $query = $class->_query_caches->{$template};
203
    
204
    # Create query
205
    unless ($query) {
206
        $query = eval{$sql_template->create_query($template)};
207
        croak($@) if $@;
208
        
209
        $query = DBIx::Custom::Query->new($query);
210
        
211
        $class->_add_query_cache($template, $query);
212
    }
213
    
214
    # Connect if not
215
    $self->connect unless $self->connected;
216
    
217
    # Prepare statement handle
218
    my $sth = $self->prepare($query->{sql});
219
    
220
    # Set statement handle
221
    $query->sth($sth);
222
    
223
    # Set bind filter
224
    $query->bind_filter($self->bind_filter);
225
    
226
    # Set no filter keys when binding
227
    $query->no_bind_filters($self->no_bind_filters);
228
    
229
    # Set fetch filter
230
    $query->fetch_filter($self->fetch_filter);
231
    
232
    # Set no filter keys when fetching
233
    $query->no_fetch_filters($self->no_fetch_filters);
234
    
235
    return $query;
236
}
237

            
238
# Execute query
239
sub execute {
240
    my ($self, $query, $params)  = @_;
241
    $params ||= {};
242
    
243
    # First argument is SQL template
244
    if (!ref $query) {
245
        my $template = $query;
246
        $query = $self->create_query($template);
247
        my $query_edit_cb = $_[3];
248
        $query_edit_cb->($query) if ref $query_edit_cb eq 'CODE';
249
    }
250
    
251
    # Create bind value
252
    my $bind_values = $self->_build_bind_values($query, $params);
253
    
254
    # Execute
255
    my $sth = $query->sth;
256
    my $ret_val = eval{$sth->execute(@$bind_values)};
257
    
258
    # Execute error
259
    if (my $execute_error = $@) {
260
        require Data::Dumper;
261
        my $sql              = $query->{sql} || '';
262
        my $key_infos_dump   = Data::Dumper->Dump([$query->key_infos], ['*key_infos']);
263
        my $params_dump      = Data::Dumper->Dump([$params], ['*params']);
264
        
265
        croak("$execute_error" . 
266
              "<Your SQL>\n$sql\n" . 
267
              "<Your parameters>\n$params_dump");
268
    }
269
    
270
    # Return resultset if select statement is executed
271
    if ($sth->{NUM_OF_FIELDS}) {
272
        
273
        # Get result class
274
        my $result_class = $self->result_class;
275
        
276
        # Create result
277
        my $result = $result_class->new({
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
278
            _dbi             => $self,
packaging one directory
yuki-kimoto authored on 2009-11-16
279
            sth              => $sth,
280
            fetch_filter     => $query->fetch_filter,
281
            no_fetch_filters => $query->no_fetch_filters
282
        });
283
        return $result;
284
    }
285
    return $ret_val;
286
}
287

            
288
# Build binding values
289
sub _build_bind_values {
290
    my ($self, $query, $params) = @_;
291
    my $key_infos           = $query->key_infos;
292
    my $bind_filter         = $query->bind_filter;
293
    my $no_bind_filters_map = $query->_no_bind_filters_map || {};
294
    
295
    # binding values
296
    my @bind_values;
297
    
298
    # Create bind values
299
    KEY_INFOS :
300
    foreach my $key_info (@$key_infos) {
301
        # Set variable
302
        my $access_keys  = $key_info->{access_keys};
303
        my $original_key = $key_info->{original_key} || '';
304
        my $table        = $key_info->{table}        || '';
305
        my $column       = $key_info->{column}       || '';
306
        
307
        # Key is found?
308
        my $found;
309
        
310
        # Build bind values
311
        ACCESS_KEYS :
312
        foreach my $access_key (@$access_keys) {
313
            # Root parameter
314
            my $root_params = $params;
315
            
316
            # Search corresponding value
317
            for (my $i = 0; $i < @$access_key; $i++) {
318
                # Current key
319
                my $current_key = $access_key->[$i];
320
                
321
                # Last key
322
                if ($i == @$access_key - 1) {
323
                    # Key is array reference
324
                    if (ref $current_key eq 'ARRAY') {
325
                        # Filtering 
326
                        if ($bind_filter &&
327
                            !$no_bind_filters_map->{$original_key})
328
                        {
329
                            push @bind_values, 
330
                                 $bind_filter->($root_params->[$current_key->[0]], 
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
331
                                                $original_key, $self,
332
                                                {table => $table, column => $column});
packaging one directory
yuki-kimoto authored on 2009-11-16
333
                        }
334
                        # Not filtering
335
                        else {
336
                            push @bind_values,
337
                                 scalar $root_params->[$current_key->[0]];
338
                        }
339
                    }
340
                    # Key is string
341
                    else {
342
                        # Key is not found
343
                        next ACCESS_KEYS
344
                          unless exists $root_params->{$current_key};
345
                        
346
                        # Filtering
347
                        if ($bind_filter &&
348
                            !$no_bind_filters_map->{$original_key}) 
349
                        {
350
                            push @bind_values,
351
                                 $bind_filter->($root_params->{$current_key},
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
352
                                                $original_key, $self,
353
                                                {table => $table, column => $column});
packaging one directory
yuki-kimoto authored on 2009-11-16
354
                        }
355
                        # Not filtering
356
                        else {
357
                            push @bind_values,
358
                                 scalar $root_params->{$current_key};
359
                        }
360
                    }
361
                    
362
                    # Key is found
363
                    $found = 1;
364
                    next KEY_INFOS;
365
                }
366
                # First or middle key
367
                else {
368
                    # Key is array reference
369
                    if (ref $current_key eq 'ARRAY') {
370
                        # Go next key
371
                        $root_params = $root_params->[$current_key->[0]];
372
                    }
373
                    # Key is string
374
                    else {
375
                        # Not found
376
                        next ACCESS_KEYS
377
                          unless exists $root_params->{$current_key};
378
                        
379
                        # Go next key
380
                        $root_params = $root_params->{$current_key};
381
                    }
382
                }
383
            }
384
        }
385
        
386
        # Key is not found
387
        unless ($found) {
388
            require Data::Dumper;
389
            my $key_info_dump  = Data::Dumper->Dump([$key_info], ['*key_info']);
390
            my $params_dump    = Data::Dumper->Dump([$params], ['*params']);
391
            croak("Corresponding key is not found in your parameters\n" . 
392
                  "<Key information>\n$key_info_dump\n\n" .
393
                  "<Your parameters>\n$params_dump\n");
394
        }
395
    }
396
    return \@bind_values;
397
}
398

            
399
# Run transaction
400
sub run_transaction {
401
    my ($self, $transaction) = @_;
402
    
403
    # Check auto commit
404
    croak("AutoCommit must be true before transaction start")
405
      unless $self->_auto_commit;
406
    
407
    # Auto commit off
408
    $self->_auto_commit(0);
409
    
410
    # Run transaction
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
411
    eval {$transaction->($self)};
packaging one directory
yuki-kimoto authored on 2009-11-16
412
    
413
    # Tranzaction error
414
    my $transaction_error = $@;
415
    
416
    # Tranzaction is failed.
417
    if ($transaction_error) {
418
        # Rollback
419
        eval{$self->dbh->rollback};
420
        
421
        # Rollback error
422
        my $rollback_error = $@;
423
        
424
        # Auto commit on
425
        $self->_auto_commit(1);
426
        
427
        if ($rollback_error) {
428
            # Rollback is failed
429
            croak("${transaction_error}Rollback is failed : $rollback_error");
430
        }
431
        else {
432
            # Rollback is success
433
            croak("${transaction_error}Rollback is success");
434
        }
435
    }
436
    # Tranzaction is success
437
    else {
438
        # Commit
439
        eval{$self->dbh->commit};
440
        my $commit_error = $@;
441
        
442
        # Auto commit on
443
        $self->_auto_commit(1);
444
        
445
        # Commit is failed
446
        croak($commit_error) if $commit_error;
447
    }
448
}
449

            
450
# Get last insert id
451
sub last_insert_id {
452
    my $self = shift;
add Oracle, DB2, Pg,
yuki-kimoto authored on 2009-11-16
453
    my $class = ref $self;
454
    croak "'$class' do not suppert 'last_insert_id'";
packaging one directory
yuki-kimoto authored on 2009-11-16
455
}
456

            
457
# Insert
458
sub insert {
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
459
    my $self             = shift;
460
    my $table            = shift || '';
461
    my $insert_params    = shift || {};
462
    my $append_statement = shift unless ref $_[0];
463
    my $query_edit_cb    = shift;
packaging one directory
yuki-kimoto authored on 2009-11-16
464
    
465
    # Insert keys
466
    my @insert_keys = keys %$insert_params;
467
    
468
    # Not exists insert keys
469
    croak("Key-value pairs for insert must be specified to 'insert' second argument")
470
      unless @insert_keys;
471
    
472
    # Templte for insert
473
    my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
474
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
475
    # Create query
476
    my $query = $self->create_query($template);
477
    
478
    # Query edit callback must be code reference
479
    croak("Query edit callback must be code reference")
480
      if $query_edit_cb && ref $query_edit_cb ne 'CODE';
481
    
482
    # Query edit if need
483
    $query_edit_cb->($query) if $query_edit_cb;
484
    
485
    # Execute query
486
    my $ret_val = $self->execute($query, $insert_params);
487
    
488
    return $ret_val;
489
}
490

            
491
# Update
492
sub update {
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
493
    my $self             = shift;
494
    my $table            = shift || '';
495
    my $update_params    = shift || {};
496
    my $where_params     = shift || {};
497
    my $append_statement = shift unless ref $_[0];
498
    my $query_edit_cb    = shift;
499
    my $options          = shift;
packaging one directory
yuki-kimoto authored on 2009-11-16
500
    
501
    # Update keys
502
    my @update_keys = keys %$update_params;
503
    
504
    # Not exists update kyes
505
    croak("Key-value pairs for update must be specified to 'update' second argument")
506
      unless @update_keys;
507
    
508
    # Where keys
509
    my @where_keys = keys %$where_params;
510
    
511
    # Not exists where keys
512
    croak("Key-value pairs for where clause must be specified to 'update' third argument")
513
      if !@where_keys && !$options->{allow_update_all};
514
    
515
    # Update clause
516
    my $update_clause = '{update ' . join(' ', @update_keys) . '}';
517
    
518
    # Where clause
519
    my $where_clause = '';
520
    if (@where_keys) {
521
        $where_clause = 'where ';
522
        foreach my $where_key (@where_keys) {
523
            $where_clause .= "{= $where_key} and ";
524
        }
525
        $where_clause =~ s/ and $//;
526
    }
527
    
528
    # Template for update
529
    my $template = "update $table $update_clause $where_clause";
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
530
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
531
    
532
    # Create query
533
    my $query = $self->create_query($template);
534
    
535
    # Query edit callback must be code reference
536
    croak("Query edit callback must be code reference")
537
      if $query_edit_cb && ref $query_edit_cb ne 'CODE';
538
    
539
    # Query edit if need
540
    $query_edit_cb->($query) if $query_edit_cb;
541
    
542
    # Rearrange parammeters
543
    my $params = {'#update' => $update_params, %$where_params};
544
    
545
    # Execute query
546
    my $ret_val = $self->execute($query, $params);
547
    
548
    return $ret_val;
549
}
550

            
551
# Update all rows
552
sub update_all {
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
553
    my $self             = shift;
554
    my $table            = shift || '';
555
    my $update_params    = shift || {};
556
    my $append_statement = shift unless ref $_[0];
557
    my $query_edit_cb    = shift;
558
    my $options          = {allow_update_all => 1};
559
    
560
    return $self->update($table, $update_params, {}, $append_statement,
561
                         $query_edit_cb, $options);
packaging one directory
yuki-kimoto authored on 2009-11-16
562
}
563

            
564
# Delete
565
sub delete {
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
566
    my $self             = shift;
567
    my $table            = shift || '';
568
    my $where_params     = shift || {};
569
    my $append_statement = shift unless ref $_[0];
570
    my $query_edit_cb    = shift;
571
    my $options          = shift;
packaging one directory
yuki-kimoto authored on 2009-11-16
572
    
573
    # Where keys
574
    my @where_keys = keys %$where_params;
575
    
576
    # Not exists where keys
577
    croak("Key-value pairs for where clause must be specified to 'delete' second argument")
578
      if !@where_keys && !$options->{allow_delete_all};
579
    
580
    # Where clause
581
    my $where_clause = '';
582
    if (@where_keys) {
583
        $where_clause = 'where ';
584
        foreach my $where_key (@where_keys) {
585
            $where_clause .= "{= $where_key} and ";
586
        }
587
        $where_clause =~ s/ and $//;
588
    }
589
    
590
    # Template for delete
591
    my $template = "delete from $table $where_clause";
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
592
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
593
    
594
    # Create query
595
    my $query = $self->create_query($template);
596
    
597
    # Query edit callback must be code reference
598
    croak("Query edit callback must be code reference")
599
      if $query_edit_cb && ref $query_edit_cb ne 'CODE';
600
    
601
    # Query edit if need
602
    $query_edit_cb->($query) if $query_edit_cb;
603
    
604
    # Execute query
605
    my $ret_val = $self->execute($query, $where_params);
606
    
607
    return $ret_val;
608
}
609

            
610
# Delete all rows
611
sub delete_all {
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
612
    my $self             = shift;
613
    my $table            = shift || '';
614
    my $append_statement = shift unless ref $_[0];
615
    my $query_edit_cb    = shift;
616
    my $options          = {allow_delete_all => 1};
617
    
618
    return $self->delete($table, {}, $append_statement, $query_edit_cb,
619
                         $options);
packaging one directory
yuki-kimoto authored on 2009-11-16
620
}
621

            
622
sub _select_usage { return << 'EOS' }
623
Your select arguments is wrong.
624
select usage:
625
$dbi->select(
626
    $table,                # must be string or array ref
627
    [@$columns],           # must be array reference. this is optional
628
    {%$where_params},      # must be hash reference.  this is optional
629
    $append_statement,     # must be string.          this is optional
630
    $query_edit_callback   # must be code reference.  this is optional
631
);
632
EOS
633

            
634
sub select {
635
    my $self = shift;
636
    
637
    # Check argument
638
    croak($self->_select_usage) unless @_;
639
    
640
    # Arguments
641
    my $tables = shift || '';
642
    $tables    = [$tables] unless ref $tables;
643
    
644
    my $columns          = ref $_[0] eq 'ARRAY' ? shift : [];
645
    my $where_params     = ref $_[0] eq 'HASH'  ? shift : {};
646
    my $append_statement = $_[0] && !ref $_[0]  ? shift : '';
647
    my $query_edit_cb    = shift if ref $_[0] eq 'CODE';
648
    
649
    # Check rest argument
650
    croak($self->_select_usage) if @_;
651
    
652
    # SQL template for select statement
653
    my $template = 'select ';
654
    
655
    # Join column clause
656
    if (@$columns) {
657
        foreach my $column (@$columns) {
658
            $template .= "$column, ";
659
        }
660
        $template =~ s/, $/ /;
661
    }
662
    else {
663
        $template .= '* ';
664
    }
665
    
666
    # Join table
667
    $template .= 'from ';
668
    foreach my $table (@$tables) {
669
        $template .= "$table, ";
670
    }
671
    $template =~ s/, $/ /;
672
    
673
    # Where clause keys
674
    my @where_keys = keys %$where_params;
675
    
676
    # Join where clause
677
    if (@where_keys) {
678
        $template .= 'where ';
679
        foreach my $where_key (@where_keys) {
680
            $template .= "{= $where_key} and ";
681
        }
682
    }
683
    $template =~ s/ and $//;
684
    
685
    # Append something to last of statement
686
    if ($append_statement =~ s/^where //) {
687
        if (@where_keys) {
688
            $template .= " and $append_statement";
689
        }
690
        else {
691
            $template .= " where $append_statement";
692
        }
693
    }
694
    else {
695
        $template .= " $append_statement";
696
    }
697
    
698
    # Create query
699
    my $query = $self->create_query($template);
700
    
701
    # Query edit
702
    $query_edit_cb->($query) if $query_edit_cb;
703
    
704
    # Execute query
705
    my $result = $self->execute($query, $where_params);
706
    
707
    return $result;
708
}
709

            
710
sub _query_caches     : ClassAttr { type => 'hash',
711
                                    auto_build => sub {shift->_query_caches({}) } }
712
                                    
713
sub _query_cache_keys : ClassAttr { type => 'array',
714
                                    auto_build => sub {shift->_query_cache_keys([])} }
715
                                    
716
sub query_cache_max   : ClassAttr { auto_build => sub {shift->query_cache_max(50)} }
717

            
718
# Add query cahce
719
sub _add_query_cache {
720
    my ($class, $template, $query) = @_;
721
    my $query_cache_keys = $class->_query_cache_keys;
722
    my $query_caches     = $class->_query_caches;
723
    
724
    return $class if $query_caches->{$template};
725
    
726
    $query_caches->{$template} = $query;
727
    push @$query_cache_keys, $template;
728
    
729
    my $overflow = @$query_cache_keys - $class->query_cache_max;
730
    
731
    for (my $i = 0; $i < $overflow; $i++) {
732
        my $template = shift @$query_cache_keys;
733
        delete $query_caches->{$template};
734
    }
735
    
736
    return $class;
737
}
738

            
739
# Both bind_filter and fetch_filter off
740
sub filter_off {
741
    my $self = shift;
742
    
743
    # filter off
744
    $self->bind_filter(undef);
745
    $self->fetch_filter(undef);
746
    
747
    return $self;
748
}
749

            
750
Object::Simple->build_class;
751

            
752
=head1 NAME
753

            
754
DBIx::Custom - Customizable simple DBI
755

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
756
=head1 Version
packaging one directory
yuki-kimoto authored on 2009-11-16
757

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
758
Version 0.0601
packaging one directory
yuki-kimoto authored on 2009-11-16
759

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
760
=head1 Caution
packaging one directory
yuki-kimoto authored on 2009-11-16
761

            
762
This module is now experimental stage.
763

            
764
I want you to try this module
765
because I want this module stable, and not to damage your DB data by this module bug.
766

            
767
Please tell me bug if you find
768

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
769
=head1 Synopsys
packaging one directory
yuki-kimoto authored on 2009-11-16
770

            
771
  my $dbi = DBIx::Custom->new;
772
  
773
  my $query = $dbi->create_query($template);
774
  $dbi->execute($query);
775

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
776
=head1 Accessors
packaging one directory
yuki-kimoto authored on 2009-11-16
777

            
778
=head2 user
779

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
780
Set and get database user name
781
    
782
    # For object
783
    $self  = $self->user($user);
784
    $user  = $self->user;
785
    
786
    # For class
787
    $class = $class->user($user);
788
    $user  = $class->user;
packaging one directory
yuki-kimoto authored on 2009-11-16
789
    
790
    # Sample
791
    $dbi->user('taro');
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
792
    
packaging one directory
yuki-kimoto authored on 2009-11-16
793
=head2 password
794

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
795
Set and get database password
796
    
797
    # For object
798
    $self     = $self->password($password);
799
    $password = $self->password;
800

            
801
    # For class
802
    $class    = $class->password($password);
803
    $password = $class->password;
packaging one directory
yuki-kimoto authored on 2009-11-16
804
    
805
    # Sample
806
    $dbi->password('lkj&le`@s');
807

            
808
=head2 data_source
809

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
810
Set and get database data source
811
    
812
    # For object
813
    $self        = $self->data_source($data_soruce);
814
    $data_source = $self->data_source;
815
    
816
    # For class
817
    $class       = $class->data_source($data_soruce);
818
    $data_source = $class->data_source;
packaging one directory
yuki-kimoto authored on 2009-11-16
819
    
820
    # Sample(SQLite)
821
    $dbi->data_source(dbi:SQLite:dbname=$database);
822
    
823
    # Sample(MySQL);
824
    $dbi->data_source("dbi:mysql:dbname=$database");
825
    
826
    # Sample(PostgreSQL)
827
    $dbi->data_source("dbi:Pg:dbname=$database");
828
    
829
=head2 database
830

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
831
Set and get database name
832

            
833
    # For object
834
    $self     = $self->database($database);
835
    $database = $self->database;
836

            
837
    # For class
838
    $class    = $class->database($database);
839
    $database = $class->database;
840
    
841
    # Sample
842
    $dbi->database('books');
packaging one directory
yuki-kimoto authored on 2009-11-16
843

            
add port and host method
yuki-kimoto authored on 2009-11-16
844
=head2 host
845

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
846
Set and get host name
847

            
848
    # For object
849
    $self = $self->host($host);
850
    $host = $self->host;
851

            
852
    # For class
853
    $class = $class->host($host);
854
    $host  = $class->host;
855
    
856
    # Sample
857
    $dbi->host('somehost.com');
858
    $dbi->host('127.1.2.3');
add port and host method
yuki-kimoto authored on 2009-11-16
859

            
860
=head2 port
861

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
862
Set and get port
863

            
864
    # For object
865
    $self = $self->port($port);
866
    $port = $self->port;
add port and host method
yuki-kimoto authored on 2009-11-16
867

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
868
    # For class
869
    $class = $class->port($port);
870
    $port = $class->port;
871
    
872
    # Sample
873
    $dbi->port(1198);
packaging one directory
yuki-kimoto authored on 2009-11-16
874

            
875
=head2 dbi_options
876

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
877
Set and get DBI option
packaging one directory
yuki-kimoto authored on 2009-11-16
878

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
879
    # For object
880
    $self        = $self->dbi_options({$options => $value, ...});
881
    $dbi_options = $self->dbi_options;
882
    
883
    # For class
884
    $class       = $class->dbi_options({$options => $value, ...});
885
    $dbi_options = $class->dbi_options;
886
    
packaging one directory
yuki-kimoto authored on 2009-11-16
887
    # Sample
888
    $dbi->dbi_options({PrintError => 0, RaiseError => 1});
889

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
890
=head2 sql_template
packaging one directory
yuki-kimoto authored on 2009-11-16
891

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
892
Set and get SQL::Template object
packaging one directory
yuki-kimoto authored on 2009-11-16
893

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
894
    # For object
895
    $self         = $self->sql_template($sql_template);
896
    $sql_template = $self->sql_template;
packaging one directory
yuki-kimoto authored on 2009-11-16
897

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
898
    # For class
899
    $class        = $class->sql_template($sql_template);
900
    $sql_template = $class->sql_template;
packaging one directory
yuki-kimoto authored on 2009-11-16
901

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
902
    # Sample
903
    $dbi->sql_template(DBI::Cutom::SQL::Template->new);
packaging one directory
yuki-kimoto authored on 2009-11-16
904

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

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
907
Set and get filters
packaging one directory
yuki-kimoto authored on 2009-11-16
908

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
909
    # For object
910
    $self    = $self->filters($filters);
911
    $filters = $self->filters;
packaging one directory
yuki-kimoto authored on 2009-11-16
912

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
913
    # For class
914
    $class   = $class->filters($filters);
915
    $filters = $class->filters;
packaging one directory
yuki-kimoto authored on 2009-11-16
916
    
917
    # Sample
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
918
    $ret = $dbi->filters->{encode_utf8}->($value);
packaging one directory
yuki-kimoto authored on 2009-11-16
919

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

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
922
Set and get formats
packaging one directory
yuki-kimoto authored on 2009-11-16
923

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
924
    # For object
925
    $self    = $self->formats($formats);
926
    $formats = $self->formats;
927

            
928
    # For class
929
    $self    = $self->formats($formats);
930
    $formats = $self->formats;
931

            
932
    # Sample
933
    $datetime_format = $dbi->formats->{datetime};
packaging one directory
yuki-kimoto authored on 2009-11-16
934

            
935
=head2 bind_filter
936

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
937
Set and get binding filter
packaging one directory
yuki-kimoto authored on 2009-11-16
938

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
939
    # For object
940
    $self        = $self->bind_filter($bind_filter);
941
    $bind_filter = $self->bind_filter
packaging one directory
yuki-kimoto authored on 2009-11-16
942

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
943
    # For object
944
    $class       = $class->bind_filter($bind_filter);
945
    $bind_filter = $class->bind_filter
946

            
947
    # Sample
948
    $dbi->bind_filter(sub {
949
        my ($value, $key, $dbi, $infos) = @_;
950
        
951
        # edit $value
952
        
953
        return $value;
954
    });
packaging one directory
yuki-kimoto authored on 2009-11-16
955

            
956
=head2 fetch_filter
957

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
958
Set and get Fetch filter
959

            
960
    # For object
961
    $self         = $self->fetch_filter($fetch_filter);
962
    $fetch_filter = $self->fetch_filter;
963

            
964
    # For class
965
    $class        = $class->fetch_filter($fetch_filter);
966
    $fetch_filter = $class->fetch_filter;
packaging one directory
yuki-kimoto authored on 2009-11-16
967

            
968
    # Sample
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
969
    $dbi->fetch_filter(sub {
970
        my ($value, $key, $dbi, $infos) = @_;
971
        
972
        # edit $value
973
        
974
        return $value;
975
    });
packaging one directory
yuki-kimoto authored on 2009-11-16
976

            
977
=head2 no_bind_filters
978

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
979
Set and get no filter keys when binding
980
    
981
    # For object
982
    $self            = $self->no_bind_filters($no_bind_filters);
983
    $no_bind_filters = $self->no_bind_filters;
984

            
985
    # For class
986
    $class           = $class->no_bind_filters($no_bind_filters);
987
    $no_bind_filters = $class->no_bind_filters;
988

            
989
    # Sample
990
    $dbi->no_bind_filters(qw/title author/);
packaging one directory
yuki-kimoto authored on 2009-11-16
991

            
992
=head2 no_fetch_filters
993

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
994
Set and get no filter keys when fetching
995

            
996
    # For object
997
    $self             = $self->no_fetch_filters($no_fetch_filters);
998
    $no_fetch_filters = $self->no_fetch_filters;
999

            
1000
    # For class
1001
    $class            = $class->no_fetch_filters($no_fetch_filters);
1002
    $no_fetch_filters = $class->no_fetch_filters;
1003

            
1004
    # Sample
1005
    $dbi->no_fetch_filters(qw/title author/);
packaging one directory
yuki-kimoto authored on 2009-11-16
1006

            
1007
=head2 result_class
1008

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1009
Set and get resultset class
1010

            
1011
    # For object
packaging one directory
yuki-kimoto authored on 2009-11-16
1012
    $self         = $dbi->result_class($result_class);
1013
    $result_class = $dbi->result_class;
1014
    
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1015
    # For class
1016
    $class        = $class->result_class($result_class);
1017
    $result_class = $class->result_class;
1018
    
packaging one directory
yuki-kimoto authored on 2009-11-16
1019
    # Sample
1020
    $dbi->result_class('DBIx::Custom::Result');
1021

            
1022
=head2 dbh
1023

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1024
Get database handle
1025
    
1026
    $self = $self->dbh($dbh);
1027
    $dbh  = $self->dbh;
1028
    
1029
    # Sample
1030
    $table_info = $dbi->dbh->table_info
1031
    
1032
=head2 query_cache_max
1033

            
1034
Set and get query cache max
1035

            
1036
    $class           = $class->query_cache_max($query_cache_max);
1037
    $query_cache_max = $class->query_cache_max;
1038
    
1039
    # Sample
1040
    DBIx::Custom->query_cache_max(50);
packaging one directory
yuki-kimoto authored on 2009-11-16
1041

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1042
DBIx::Custom cache queries for performance.
1043

            
1044
Default is 50
1045

            
1046
=head1 Methods
packaging one directory
yuki-kimoto authored on 2009-11-16
1047

            
1048
=head2 connect
1049

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1052
    $self = $dbi->connect;
1053
    
1054
    # Sample
1055
    $dbi = DBIx::Custom->new(user => 'taro', password => 'lji8(', 
1056
                            data_soruce => "dbi:mysql:dbname=$database");
1057
    $dbi->connect;
1058

            
1059
=head2 disconnect
1060

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1061
Disconnect database
1062

            
1063
    $self = $dbi->disconnect;
1064
    
1065
    # Sample
packaging one directory
yuki-kimoto authored on 2009-11-16
1066
    $dbi->disconnect;
1067

            
1068
If database is already disconnected, this method do noting.
1069

            
1070
=head2 reconnect
1071

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

            
1074
    $self = $dbi->reconnect;
1075
    
1076
    # Sample
packaging one directory
yuki-kimoto authored on 2009-11-16
1077
    $dbi->reconnect;
1078

            
1079
=head2 connected
1080

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1081
Check connected
1082
    
1083
    $is_connected = $self->connected;
1084
    
1085
    # Sample
1086
    if ($dbi->connected) { # do something }
packaging one directory
yuki-kimoto authored on 2009-11-16
1087
    
1088
=head2 filter_off
1089

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1090
bind_filter and fitch_filter off
1091
    
1092
    $self = $self->filter_off
1093
    
1094
    # Sample
1095
    $dbi->filter_off;
packaging one directory
yuki-kimoto authored on 2009-11-16
1096
    
1097
This is equeal to
1098
    
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1099
    $dbi->bind_filter(undef);
1100
    $dbi->fetch_filter(undef);
packaging one directory
yuki-kimoto authored on 2009-11-16
1101

            
1102
=head2 add_filter
1103

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1104
Resist filter
packaging one directory
yuki-kimoto authored on 2009-11-16
1105
    
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1106
    $self = $self->add_filter({$name => $filter, ...});
1107
    # or
1108
    $self = $self->add_filter($name => $filter, ...);
1109
    
1110
    # Sample (For example DBIx::Custom::Basic)
packaging one directory
yuki-kimoto authored on 2009-11-16
1111
    $dbi->add_filter(
1112
        encode_utf8 => sub {
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1113
            my ($value, $key, $dbi, $infos) = @_;
1114
            utf8::upgrade($value) unless Encode::is_utf8($value);
1115
            return encode('UTF-8', $value);
packaging one directory
yuki-kimoto authored on 2009-11-16
1116
        },
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1117
        decode_utf8 => sub {
1118
            my ($value, $key, $dbi, $infos) = @_;
1119
            return decode('UTF-8', $value)
packaging one directory
yuki-kimoto authored on 2009-11-16
1120
        }
1121
    );
1122

            
1123
=head2 add_format
1124

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1125
Resist format
1126

            
1127
    $self = $self->add_format({$name => $format, ...});
1128
    # or
1129
    $self = $self->add_format($name => $format, ...);
1130
    
1131
    # Sample
1132
    $dbi->add_format(date => '%Y:%m:%d', datetime => '%Y-%m-%d %H:%M:%S');
1133

            
1134
=head2 prepare
1135

            
1136
Prepare statement handle
1137

            
1138
    $sth = $self->prepare($sql);
1139
    
1140
    # Sample
1141
    $sth = $dbi->prepare('select * from books;');
1142

            
1143
This method is same as DBI prepare method.
1144

            
1145
=head2 do
1146

            
1147
Execute SQL
1148

            
1149
    $ret_val = $self->do($sql, @bind_values);
1150
    
1151
    # Sample
1152
    $ret_val = $dbi->do('insert into books (title, author) values (?, ?)',
1153
                        'Perl', 'taro');
1154

            
1155
This method is same as DBI do method.
packaging one directory
yuki-kimoto authored on 2009-11-16
1156

            
1157
=head2 create_query
1158
    
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1159
Create Query object from SQL template
1160

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1161
    my $query = $dbi->create_query($template);
1162
    
1163
=head2 execute
1164

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1165
Parse SQL template and execute SQL
1166

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1167
    $result = $dbi->query($query, $params);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1168
    $result = $dbi->query($template, $params); # Shortcut
packaging one directory
yuki-kimoto authored on 2009-11-16
1169
    
1170
    # Sample
1171
    $result = $dbi->query("select * from authors where {= name} and {= age}", 
1172
                          {author => 'taro', age => 19});
1173
    
1174
    while (my @row = $result->fetch) {
1175
        # do something
1176
    }
1177

            
1178
See also L<DBIx::Custom::SQL::Template>
1179

            
1180
=head2 run_transaction
1181

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1182
Run transaction
1183

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1184
    $dbi->run_transaction(sub {
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1185
        my $dbi = shift;
1186
        
packaging one directory
yuki-kimoto authored on 2009-11-16
1187
        # do something
1188
    });
1189

            
1190
If transaction is success, commit is execute. 
1191
If tranzation is died, rollback is execute.
1192

            
1193
=head2 insert
1194

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1195
Insert
1196

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1197
    $dbi->insert($table, $insert_values);
1198
    
1199
    # Sample
1200
    $dbi->insert('books', {title => 'Perl', author => 'Taro'});
1201

            
1202
=head2 update
1203

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1204
Update
1205

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1206
    $dbi->update($table, $update_values, $where);
1207
    
1208
    # Sample
1209
    $dbi->update('books', {title => 'Perl', author => 'Taro'}, {id => 5});
1210

            
1211
=head2 update_all
1212

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1215
    $dbi->update($table, $updat_values);
1216

            
1217
=head2 delete
1218

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1219
Delete
1220

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1221
    $dbi->delete($table, $where);
1222
    
1223
    # Sample
1224
    $dbi->delete('Books', {id => 5});
1225

            
1226
=head2 delete_all
1227

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1230
    $dbi->delete_all($table);
1231

            
1232
=head2 last_insert_id
1233

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1234
Get last insert id
1235

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1236
    $last_insert_id = $dbi->last_insert_id;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1237

            
1238
This method is implemented by subclass.
packaging one directory
yuki-kimoto authored on 2009-11-16
1239

            
1240
=head2 select
1241
    
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1242
Select
1243

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1244
    $dbi->select(
1245
        $table,                # must be string or array;
1246
        [@$columns],           # must be array reference. this is optional
1247
        {%$where_params},      # must be hash reference.  this is optional
1248
        $append_statement,     # must be string.          this is optional
1249
        $query_edit_callback   # must be code reference.  this is optional
1250
    );
1251
    
1252
    # Sample
1253
    $dbi->select(
1254
        'Books',
1255
        ['title', 'author'],
1256
        {id => 1},
1257
        "for update",
1258
        sub {
1259
            my $query = shift;
1260
            $query->bind_filter(sub {
1261
                # ...
1262
            });
1263
        }
1264
    );
1265
    
1266
    # The way to join multi tables
1267
    $dbi->select(
1268
        ['table1', 'table2'],
1269
        ['table1.id as table1_id', 'title'],
1270
        {table1.id => 1},
1271
        "where table1.id = table2.id",
1272
    );
1273

            
1274

            
1275
=head1 CAUTION
1276

            
1277
DBIx::Custom have DIB object internal.
1278
This module is work well in the following DBI condition.
1279

            
1280
    1. AutoCommit is true
1281
    2. RaiseError is true
1282

            
1283
By default, Both AutoCommit and RaiseError is true.
1284
You must not change these mode not to damage your data.
1285

            
1286
If you change these mode, 
1287
you cannot get correct error message, 
1288
or run_transaction may fail.
1289

            
1290
=head1 AUTHOR
1291

            
1292
Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
1293

            
1294
Github L<http://github.com/yuki-kimoto>
1295

            
1296
=head1 COPYRIGHT & LICENSE
1297

            
1298
Copyright 2009 Yuki Kimoto, all rights reserved.
1299

            
1300
This program is free software; you can redistribute it and/or modify it
1301
under the same terms as Perl itself.
1302

            
1303
=cut