DBIx-Custom / lib / DBIx / Custom.pm /
Newer Older
1194 lines | 27.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 prepare {
132
    my ($self, $sql) = @_;
133
    
134
    # Connect if not
135
    $self->connect unless $self->connected;
136
    
137
    # Prepare
138
    my $sth = eval{$self->dbh->prepare($sql)};
139
    
140
    # Error
141
    croak("$@<Your SQL>\n$sql") if $@;
142
    
143
    return $sth;
144
}
145

            
146
sub do{
147
    my ($self, $sql, @bind_values) = @_;
148
    
149
    # Connect if not
150
    $self->connect unless $self->connected;
151
    
152
    # Do
version 0.0901
yuki-kimoto authored on 2009-12-17
153
    my $affected = eval{$self->dbh->do($sql, @bind_values)};
packaging one directory
yuki-kimoto authored on 2009-11-16
154
    
155
    # Error
156
    if ($@) {
157
        my $error = $@;
158
        require Data::Dumper;
159
        
160
        my $bind_value_dump
161
          = Data::Dumper->Dump([\@bind_values], ['*bind_valuds']);
162
        
163
        croak("$error<Your SQL>\n$sql\n<Your bind values>\n$bind_value_dump\n");
164
    }
version 0.0901
yuki-kimoto authored on 2009-12-17
165
    
166
    return $affected;
packaging one directory
yuki-kimoto authored on 2009-11-16
167
}
168

            
169
sub create_query {
170
    my ($self, $template) = @_;
cleanup
yuki-kimoto authored on 2010-02-11
171
    
packaging one directory
yuki-kimoto authored on 2009-11-16
172
    my $class = ref $self;
173
    
cleanup
yuki-kimoto authored on 2010-02-11
174
    if (ref $template eq 'ARRAY') {
175
        $template = $template->[1];
176
    }
177
    
packaging one directory
yuki-kimoto authored on 2009-11-16
178
    # Create query from SQL template
version 0.0901
yuki-kimoto authored on 2009-12-17
179
    my $sql_tmpl = $self->sql_tmpl;
packaging one directory
yuki-kimoto authored on 2009-11-16
180
    
181
    # Try to get cached query
many many changes
yuki-kimoto authored on 2010-04-30
182
    my $cached_query = $class->_query_caches->{"$template"};
packaging one directory
yuki-kimoto authored on 2009-11-16
183
    
184
    # Create query
fix timeformat tests
yuki-kimoto authored on 2009-11-23
185
    my $query;
cleanup
yuki-kimoto authored on 2010-02-11
186
    if ($cached_query) {
187
        $query = DBIx::Custom::Query->new(
188
            sql       => $cached_query->sql,
simplify filtering system
yuki-kimoto authored on 2010-05-01
189
            columns => $cached_query->columns
cleanup
yuki-kimoto authored on 2010-02-11
190
        );
fix timeformat tests
yuki-kimoto authored on 2009-11-23
191
    }
192
    else {
Simplify key search
yuki-kimoto authored on 2010-02-11
193
        $query = eval{$sql_tmpl->create_query($template)};
packaging one directory
yuki-kimoto authored on 2009-11-16
194
        croak($@) if $@;
195
        
many many changes
yuki-kimoto authored on 2010-04-30
196
        $class->_add_query_cache("$template", $query);
packaging one directory
yuki-kimoto authored on 2009-11-16
197
    }
198
    
199
    # Connect if not
200
    $self->connect unless $self->connected;
201
    
202
    # Prepare statement handle
203
    my $sth = $self->prepare($query->{sql});
204
    
205
    # Set statement handle
206
    $query->sth($sth);
207
    
208
    return $query;
209
}
210

            
version 0.0901
yuki-kimoto authored on 2009-12-17
211
sub query{
many many changes
yuki-kimoto authored on 2010-04-30
212
    my ($self, $query, $params, $args)  = @_;
packaging one directory
yuki-kimoto authored on 2009-11-16
213
    $params ||= {};
214
    
215
    # First argument is SQL template
Simplify key search
yuki-kimoto authored on 2010-02-11
216
    unless (ref $query eq 'DBIx::Custom::Query') {
217
        my $template;
218
        
219
        if (ref $query eq 'ARRAY') {
many many changes
yuki-kimoto authored on 2010-04-30
220
            $template = $query->[0];
Simplify key search
yuki-kimoto authored on 2010-02-11
221
        }
222
        else { $template = $query }
223
        
many many changes
yuki-kimoto authored on 2010-04-30
224
        $query = $self->create_query($template);
packaging one directory
yuki-kimoto authored on 2009-11-16
225
    }
many many changes
yuki-kimoto authored on 2010-04-30
226

            
many change
yuki-kimoto authored on 2010-04-30
227
    # Filter
228
    my $filter = $args->{filter} || $query->filter || {};
229

            
packaging one directory
yuki-kimoto authored on 2009-11-16
230
    # Create bind value
many many changes
yuki-kimoto authored on 2010-04-30
231
    my $bind_values = $self->_build_bind_values($query, $params, $filter);
packaging one directory
yuki-kimoto authored on 2009-11-16
232
    
233
    # Execute
version 0.0901
yuki-kimoto authored on 2009-12-17
234
    my $sth      = $query->sth;
235
    my $affected = eval{$sth->execute(@$bind_values)};
packaging one directory
yuki-kimoto authored on 2009-11-16
236
    
237
    # Execute error
238
    if (my $execute_error = $@) {
239
        require Data::Dumper;
240
        my $sql              = $query->{sql} || '';
241
        my $params_dump      = Data::Dumper->Dump([$params], ['*params']);
242
        
243
        croak("$execute_error" . 
244
              "<Your SQL>\n$sql\n" . 
245
              "<Your parameters>\n$params_dump");
246
    }
247
    
248
    # Return resultset if select statement is executed
249
    if ($sth->{NUM_OF_FIELDS}) {
250
        
251
        # Get result class
252
        my $result_class = $self->result_class;
253
        
254
        # Create result
255
        my $result = $result_class->new({
many many changes
yuki-kimoto authored on 2010-04-30
256
            sth             => $sth,
257
            default_filter  => $self->default_fetch_filter,
258
            filters         => $self->filters
packaging one directory
yuki-kimoto authored on 2009-11-16
259
        });
260
        return $result;
261
    }
version 0.0901
yuki-kimoto authored on 2009-12-17
262
    return $affected;
packaging one directory
yuki-kimoto authored on 2009-11-16
263
}
264

            
265
sub _build_bind_values {
many many changes
yuki-kimoto authored on 2010-04-30
266
    my ($self, $query, $params, $filter) = @_;
packaging one directory
yuki-kimoto authored on 2009-11-16
267
    
268
    # binding values
269
    my @bind_values;
270
    
Simplify key search
yuki-kimoto authored on 2010-02-11
271
    # Build bind values
simplify filtering system
yuki-kimoto authored on 2010-05-01
272
    my $count = {};
273
    foreach my $column (@{$query->columns}) {
packaging one directory
yuki-kimoto authored on 2009-11-16
274
        
Simplify key search
yuki-kimoto authored on 2010-02-11
275
        # Value
simplify filtering system
yuki-kimoto authored on 2010-05-01
276
        my $value = ref $params->{$column}
277
                  ? $params->{$column}->[$count->{$column} || 0]
278
                  : $params->{$column};
packaging one directory
yuki-kimoto authored on 2009-11-16
279
        
Simplify key search
yuki-kimoto authored on 2010-02-11
280
        # Filter
simplify filtering system
yuki-kimoto authored on 2010-05-01
281
        $filter ||= {};
many many changes
yuki-kimoto authored on 2010-04-30
282
        
simplify filtering system
yuki-kimoto authored on 2010-05-01
283
        # Filter name
284
        my $fname = $filter->{$column} || $self->default_query_filter || '';
285
        
286
        my $filters = $self->filters;
many change
yuki-kimoto authored on 2010-04-30
287
        push @bind_values, $filters->{$fname}
288
                         ? $filters->{$fname}->($value)
289
                         : $value;
simplify filtering system
yuki-kimoto authored on 2010-05-01
290
        
291
        # Count up 
292
        $count->{$column}++;
cleanup
yuki-kimoto authored on 2010-02-11
293
    }
294
    
Simplify key search
yuki-kimoto authored on 2010-02-11
295
    return \@bind_values;
cleanup
yuki-kimoto authored on 2010-02-11
296
}
297

            
remove run_transaction().
yuki-kimoto authored on 2010-01-30
298
sub transaction { DBIx::Custom::Transaction->new(dbi => shift) }
packaging one directory
yuki-kimoto authored on 2009-11-16
299

            
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
300
sub run_transaction {
301
    my ($self, $transaction) = @_;
302
    
303
    # Shorcut
many change
yuki-kimoto authored on 2010-02-11
304
    return unless $self;
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
305
    
306
    # Check auto commit
307
    croak("AutoCommit must be true before transaction start")
many change
yuki-kimoto authored on 2010-02-11
308
      unless $self->_auto_commit;
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
309
    
310
    # Auto commit off
many change
yuki-kimoto authored on 2010-02-11
311
    $self->_auto_commit(0);
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
312
    
313
    # Run transaction
314
    eval {$transaction->()};
315
    
316
    # Tranzaction error
317
    my $transaction_error = $@;
318
    
319
    # Tranzaction is failed.
320
    if ($transaction_error) {
321
        # Rollback
many change
yuki-kimoto authored on 2010-02-11
322
        eval{$self->dbh->rollback};
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
323
        
324
        # Rollback error
325
        my $rollback_error = $@;
326
        
327
        # Auto commit on
many change
yuki-kimoto authored on 2010-02-11
328
        $self->_auto_commit(1);
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
329
        
330
        if ($rollback_error) {
331
            # Rollback is failed
332
            croak("${transaction_error}Rollback is failed : $rollback_error");
333
        }
334
        else {
335
            # Rollback is success
336
            croak("${transaction_error}Rollback is success");
337
        }
338
    }
339
    # Tranzaction is success
340
    else {
341
        # Commit
many change
yuki-kimoto authored on 2010-02-11
342
        eval{$self->dbh->commit};
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
343
        my $commit_error = $@;
344
        
345
        # Auto commit on
many change
yuki-kimoto authored on 2010-02-11
346
        $self->_auto_commit(1);
remove DBIx::Custom::Transac...
yuki-kimoto authored on 2010-02-11
347
        
348
        # Commit is failed
349
        croak($commit_error) if $commit_error;
350
    }
351
}
352

            
version 0.0901
yuki-kimoto authored on 2009-12-17
353
sub create_table {
354
    my ($self, $table, @column_definitions) = @_;
355
    
356
    # Create table
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
357
    my $sql = "create table $table (";
version 0.0901
yuki-kimoto authored on 2009-12-17
358
    
359
    # Column definitions
360
    foreach my $column_definition (@column_definitions) {
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
361
        $sql .= "$column_definition,";
version 0.0901
yuki-kimoto authored on 2009-12-17
362
    }
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
363
    $sql =~ s/,$//;
version 0.0901
yuki-kimoto authored on 2009-12-17
364
    
365
    # End
rename fetch_first to fetch_...
yuki-kimoto authored on 2010-01-29
366
    $sql .= ");";
version 0.0901
yuki-kimoto authored on 2009-12-17
367
    
368
    # Do query
369
    return $self->do($sql);
370
}
371

            
372
sub drop_table {
373
    my ($self, $table) = @_;
374
    
375
    # Drop table
376
    my $sql = "drop table $table;";
377

            
378
    # Do query
379
    return $self->do($sql);
380
}
381

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
384
sub insert {
cleanup insert
yuki-kimoto authored on 2010-04-28
385
    my ($self, $table, $insert_params, $args) = @_;
386
    
387
    # Table
388
    $table ||= '';
389
    
390
    # Insert params
391
    $insert_params ||= {};
392
    
393
    # Arguments
394
    $args ||= {};
395
    
396
    # Check arguments
397
    foreach my $name (keys %$args) {
398
        croak "\"$name\" is invalid name"
399
          unless $VALID_INSERT_ARGS{$name};
400
    }
401
    
402
    my $append_statement = $args->{append} || '';
many many changes
yuki-kimoto authored on 2010-04-30
403
    my $filter           = $args->{filter};
packaging one directory
yuki-kimoto authored on 2009-11-16
404
    
405
    # Insert keys
406
    my @insert_keys = keys %$insert_params;
407
    
408
    # Not exists insert keys
409
    croak("Key-value pairs for insert must be specified to 'insert' second argument")
410
      unless @insert_keys;
411
    
412
    # Templte for insert
413
    my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
414
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
415
    
416
    # Execute query
many many changes
yuki-kimoto authored on 2010-04-30
417
    my $ret_val = $self->query($template, $insert_params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
418
    
419
    return $ret_val;
420
}
421

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
425
sub update {
simplify filtering system
yuki-kimoto authored on 2010-05-01
426
    my ($self, $table, $params, $args) = @_;
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
427
    
428
    # Check arguments
429
    foreach my $name (keys %$args) {
430
        croak "\"$name\" is invalid name"
431
          unless $VALID_UPDATE_ARGS{$name};
432
    }
433
    
434
    # Arguments
435
    my $where_params     = $args->{where} || {};
436
    my $append_statement = $args->{append} || '';
many many changes
yuki-kimoto authored on 2010-04-30
437
    my $filter           = $args->{filter};
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
438
    my $allow_update_all = $args->{allow_update_all};
packaging one directory
yuki-kimoto authored on 2009-11-16
439
    
440
    # Update keys
simplify filtering system
yuki-kimoto authored on 2010-05-01
441
    my @update_keys = keys %$params;
packaging one directory
yuki-kimoto authored on 2009-11-16
442
    
443
    # Not exists update kyes
444
    croak("Key-value pairs for update must be specified to 'update' second argument")
445
      unless @update_keys;
446
    
447
    # Where keys
448
    my @where_keys = keys %$where_params;
449
    
450
    # Not exists where keys
451
    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
452
      if !@where_keys && !$allow_update_all;
packaging one directory
yuki-kimoto authored on 2009-11-16
453
    
454
    # Update clause
455
    my $update_clause = '{update ' . join(' ', @update_keys) . '}';
456
    
457
    # Where clause
458
    my $where_clause = '';
simplify filtering system
yuki-kimoto authored on 2010-05-01
459
    my $new_where = {};
many change
yuki-kimoto authored on 2010-04-30
460
    
packaging one directory
yuki-kimoto authored on 2009-11-16
461
    if (@where_keys) {
462
        $where_clause = 'where ';
463
        foreach my $where_key (@where_keys) {
simplify filtering system
yuki-kimoto authored on 2010-05-01
464
            
465
            $where_clause .= "{= $where_key} and ";
packaging one directory
yuki-kimoto authored on 2009-11-16
466
        }
467
        $where_clause =~ s/ and $//;
468
    }
469
    
470
    # Template for update
471
    my $template = "update $table $update_clause $where_clause";
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
472
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
473
    
474
    # Rearrange parammeters
simplify filtering system
yuki-kimoto authored on 2010-05-01
475
    foreach my $where_key (@where_keys) {
476
        
477
        if (exists $params->{$where_key}) {
478
            $params->{$where_key} = [$params->{$where_key}]
479
              unless ref $params->{$where_key} eq 'ARRAY';
480
            
compile success
yuki-kimoto authored on 2010-05-01
481
            push @{$params->{$where_key}}, $where_params->{$where_key};
simplify filtering system
yuki-kimoto authored on 2010-05-01
482
        }
483
    }
packaging one directory
yuki-kimoto authored on 2009-11-16
484
    
485
    # Execute query
many many changes
yuki-kimoto authored on 2010-04-30
486
    my $ret_val = $self->query($template, $params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
487
    
488
    return $ret_val;
489
}
490

            
491
sub update_all {
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
492
    my ($self, $table, $update_params, $args) = @_;
493
    
refactoring select
yuki-kimoto authored on 2010-04-28
494
    # Allow all update
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
495
    $args ||= {};
496
    $args->{allow_update_all} = 1;
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
497
    
update document
yuki-kimoto authored on 2010-01-30
498
    # Update all rows
cleanup update and update_al...
yuki-kimoto authored on 2010-04-28
499
    return $self->update($table, $update_params, $args);
packaging one directory
yuki-kimoto authored on 2009-11-16
500
}
501

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
505
sub delete {
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
506
    my ($self, $table, $args) = @_;
507
    
508
    # Table
509
    $table            ||= '';
510

            
511
    # Check arguments
512
    foreach my $name (keys %$args) {
513
        croak "\"$name\" is invalid name"
514
          unless $VALID_DELETE_ARGS{$name};
515
    }
516
    
517
    # Arguments
518
    my $where_params     = $args->{where} || {};
519
    my $append_statement = $args->{append};
many many changes
yuki-kimoto authored on 2010-04-30
520
    my $filter    = $args->{filter};
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
521
    my $allow_delete_all = $args->{allow_delete_all};
packaging one directory
yuki-kimoto authored on 2009-11-16
522
    
523
    # Where keys
524
    my @where_keys = keys %$where_params;
525
    
526
    # Not exists where keys
527
    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
528
      if !@where_keys && !$allow_delete_all;
packaging one directory
yuki-kimoto authored on 2009-11-16
529
    
530
    # Where clause
531
    my $where_clause = '';
532
    if (@where_keys) {
533
        $where_clause = 'where ';
534
        foreach my $where_key (@where_keys) {
535
            $where_clause .= "{= $where_key} and ";
536
        }
537
        $where_clause =~ s/ and $//;
538
    }
539
    
540
    # Template for delete
541
    my $template = "delete from $table $where_clause";
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
542
    $template .= " $append_statement" if $append_statement;
packaging one directory
yuki-kimoto authored on 2009-11-16
543
    
544
    # Execute query
many many changes
yuki-kimoto authored on 2010-04-30
545
    my $ret_val = $self->query($template, $where_params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
546
    
547
    return $ret_val;
548
}
549

            
550
sub delete_all {
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
551
    my ($self, $table, $args) = @_;
552
    
refactoring select
yuki-kimoto authored on 2010-04-28
553
    # Allow all delete
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
554
    $args ||= {};
555
    $args->{allow_delete_all} = 1;
insert, update, delete appnd...
yuki-kimoto authored on 2009-11-16
556
    
update document
yuki-kimoto authored on 2010-01-30
557
    # Delete all rows
refactoring delete and delet...
yuki-kimoto authored on 2010-04-28
558
    return $self->delete($table, $args);
packaging one directory
yuki-kimoto authored on 2009-11-16
559
}
560

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
564
sub select {
refactoring select
yuki-kimoto authored on 2010-04-28
565
    my ($self, $tables, $args) = @_;
packaging one directory
yuki-kimoto authored on 2009-11-16
566
    
refactoring select
yuki-kimoto authored on 2010-04-28
567
    # Table
568
    $tables ||= '';
569
    $tables = [$tables] unless ref $tables;
packaging one directory
yuki-kimoto authored on 2009-11-16
570
    
refactoring select
yuki-kimoto authored on 2010-04-28
571
    # Check arguments
572
    foreach my $name (keys %$args) {
573
        croak "\"$name\" is invalid name"
574
          unless $VALID_SELECT_ARGS{$name};
575
    }
packaging one directory
yuki-kimoto authored on 2009-11-16
576
    
refactoring select
yuki-kimoto authored on 2010-04-28
577
    # Arguments
578
    my $columns          = $args->{columns} || [];
579
    my $where_params     = $args->{where} || {};
580
    my $append_statement = $args->{append} || '';
many many changes
yuki-kimoto authored on 2010-04-30
581
    my $filter    = $args->{filter};
packaging one directory
yuki-kimoto authored on 2009-11-16
582
    
583
    # SQL template for select statement
584
    my $template = 'select ';
585
    
586
    # Join column clause
587
    if (@$columns) {
588
        foreach my $column (@$columns) {
589
            $template .= "$column, ";
590
        }
591
        $template =~ s/, $/ /;
592
    }
593
    else {
594
        $template .= '* ';
595
    }
596
    
597
    # Join table
598
    $template .= 'from ';
599
    foreach my $table (@$tables) {
600
        $template .= "$table, ";
601
    }
602
    $template =~ s/, $/ /;
603
    
604
    # Where clause keys
605
    my @where_keys = keys %$where_params;
606
    
607
    # Join where clause
608
    if (@where_keys) {
609
        $template .= 'where ';
610
        foreach my $where_key (@where_keys) {
compile success
yuki-kimoto authored on 2010-05-01
611
            $template .= "{= $where_key} and ";
packaging one directory
yuki-kimoto authored on 2009-11-16
612
        }
613
    }
614
    $template =~ s/ and $//;
615
    
616
    # Append something to last of statement
617
    if ($append_statement =~ s/^where //) {
618
        if (@where_keys) {
619
            $template .= " and $append_statement";
620
        }
621
        else {
622
            $template .= " where $append_statement";
623
        }
624
    }
625
    else {
626
        $template .= " $append_statement";
627
    }
628
    
629
    # Execute query
simplify filtering system
yuki-kimoto authored on 2010-05-01
630
    my $result = $self->query($template, $where_params, {filter => $filter});
packaging one directory
yuki-kimoto authored on 2009-11-16
631
    
632
    return $result;
633
}
634

            
635
sub _add_query_cache {
636
    my ($class, $template, $query) = @_;
update document
yuki-kimoto authored on 2010-01-30
637
    
638
    # Query information
packaging one directory
yuki-kimoto authored on 2009-11-16
639
    my $query_cache_keys = $class->_query_cache_keys;
640
    my $query_caches     = $class->_query_caches;
641
    
update document
yuki-kimoto authored on 2010-01-30
642
    # Already cached
packaging one directory
yuki-kimoto authored on 2009-11-16
643
    return $class if $query_caches->{$template};
644
    
update document
yuki-kimoto authored on 2010-01-30
645
    # Cache
packaging one directory
yuki-kimoto authored on 2009-11-16
646
    $query_caches->{$template} = $query;
647
    push @$query_cache_keys, $template;
648
    
update document
yuki-kimoto authored on 2010-01-30
649
    # Check cache overflow
packaging one directory
yuki-kimoto authored on 2009-11-16
650
    my $overflow = @$query_cache_keys - $class->query_cache_max;
651
    for (my $i = 0; $i < $overflow; $i++) {
652
        my $template = shift @$query_cache_keys;
653
        delete $query_caches->{$template};
654
    }
655
    
656
    return $class;
657
}
658

            
659
=head1 NAME
660

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

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

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

            
667
=cut
668

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

            
cleanup
yuki-kimoto authored on 2010-02-11
671
=head1 STATE
672

            
673
This module is not stable. Method name and functionality will be change.
674

            
version 0.0901
yuki-kimoto authored on 2009-12-17
675
=head1 SYNOPSYS
676
    
677
    # New
678
    my $dbi = DBIx::Custom->new(data_source => "dbi:mysql:database=books"
679
                                user => 'ken', password => '!LFKD%$&');
680
    
681
    # Query
682
    $dbi->query("select title from books");
683
    
684
    # Query with parameters
685
    $dbi->query("select id from books where {= author} && {like title}",
686
                {author => 'ken', title => '%Perl%'});
687
    
688
    # Insert 
689
    $dbi->insert('books', {title => 'perl', author => 'Ken'});
690
    
691
    # Update 
692
    $dbi->update('books', {title => 'aaa', author => 'Ken'}, {id => 5});
693
    
694
    # Delete
695
    $dbi->delete('books', {author => 'Ken'});
696
    
697
    # Select
698
    $dbi->select('books');
699
    $dbi->select('books', {author => 'taro'}); 
700
    $dbi->select('books', [qw/author title/], {author => 'Ken'});
701
    $dbi->select('books', [qw/author title/], {author => 'Ken'},
702
                 'order by id limit 1');
packaging one directory
yuki-kimoto authored on 2009-11-16
703

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

            
706
=head2 user
707

            
update document
yuki-kimoto authored on 2010-01-30
708
Database user name
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
709
    
version 0.0901
yuki-kimoto authored on 2009-12-17
710
    $dbi  = $dbi->user('Ken');
711
    $user = $dbi->user;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
712
    
packaging one directory
yuki-kimoto authored on 2009-11-16
713
=head2 password
714

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

            
720
=head2 data_source
721

            
update document
yuki-kimoto authored on 2010-01-30
722
Database data source
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
723
    
version 0.0901
yuki-kimoto authored on 2009-12-17
724
    $dbi         = $dbi->data_source("dbi:mysql:dbname=$database");
725
    $data_source = $dbi->data_source;
packaging one directory
yuki-kimoto authored on 2009-11-16
726
    
version 0.0901
yuki-kimoto authored on 2009-12-17
727
If you know data source more, See also L<DBI>.
728

            
packaging one directory
yuki-kimoto authored on 2009-11-16
729
=head2 database
730

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

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

            
add port and host method
yuki-kimoto authored on 2009-11-16
736
=head2 host
737

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

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

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

            
745
=head2 port
746

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

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

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

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

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

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

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

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

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

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

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
772
    $dbi     = $dbi->filters({filter1 => sub { }, filter2 => sub {}});
773
    $filters = $dbi->filters;
packaging one directory
yuki-kimoto authored on 2009-11-16
774
    
version 0.0901
yuki-kimoto authored on 2009-12-17
775
This method is generally used to get a filter.
776

            
777
    $filter = $dbi->filters->{encode_utf8};
778

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

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

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

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

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

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

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

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

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

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
801
The following is bind filter sample
cleanup
yuki-kimoto authored on 2010-04-28
802
    
many many changes
yuki-kimoto authored on 2010-04-30
803
    $dbi->resist_filter(encode_utf8 => sub {
cleanup
yuki-kimoto authored on 2010-04-28
804
        my $value = shift;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
805
        
cleanup
yuki-kimoto authored on 2010-04-28
806
        require Encode 'encode_utf8';
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
807
        
cleanup
yuki-kimoto authored on 2010-04-28
808
        return encode_utf8($value);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
809
    });
cleanup
yuki-kimoto authored on 2010-04-28
810
    
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
811
    $dbi->default_query_filter('encode_utf8')
packaging one directory
yuki-kimoto authored on 2009-11-16
812

            
version 0.0901
yuki-kimoto authored on 2009-12-17
813
Bind filter arguemts is
814

            
815
    1. $value : Value
816
    2. $key   : Key
817
    3. $dbi   : DBIx::Custom object
818
    4. $infos : {table => $table, column => $column}
819

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

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

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

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

            
many many changes
yuki-kimoto authored on 2010-04-30
829
    $dbi->resist_filter(decode_utf8 => sub {
cleanup
yuki-kimoto authored on 2010-04-28
830
        my $value = shift;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
831
        
cleanup
yuki-kimoto authored on 2010-04-28
832
        require Encode 'decode_utf8';
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
833
        
cleanup
yuki-kimoto authored on 2010-04-28
834
        return decode_utf8($value);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
835
    });
packaging one directory
yuki-kimoto authored on 2009-11-16
836

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
839
Bind filter arguemts is
840

            
841
    1. $value : Value
842
    2. $key   : Key
843
    3. $dbi   : DBIx::Custom object
844
    4. $infos : {type => $table, sth => $sth, index => $index}
845

            
packaging one directory
yuki-kimoto authored on 2009-11-16
846
=head2 result_class
847

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

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

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
855
=head2 dbh
856

            
update document
yuki-kimoto authored on 2010-01-30
857
Database handle
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
858
    
version 0.0901
yuki-kimoto authored on 2009-12-17
859
    $dbi = $dbi->dbh($dbh);
860
    $dbh = $dbi->dbh;
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
861
    
862
=head2 query_cache_max
863

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
866
    $class           = DBIx::Custom->query_cache_max(50);
867
    $query_cache_max = DBIx::Custom->query_cache_max;
868

            
869
Default value is 50
870

            
update document
yuki-kimoto authored on 2010-01-30
871
=head1 METHODS
872

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

            
876
=head2 connect
877

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

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

            
882
=head2 disconnect
883

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
884
Disconnect database
885

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

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

            
890
=head2 reconnect
891

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

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

            
896
=head2 connected
897

            
version 0.0901
yuki-kimoto authored on 2009-12-17
898
Check if database is connected.
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
899
    
version 0.0901
yuki-kimoto authored on 2009-12-17
900
    $is_connected = $dbi->connected;
packaging one directory
yuki-kimoto authored on 2009-11-16
901
    
many many changes
yuki-kimoto authored on 2010-04-30
902
=head2 resist_filter
packaging one directory
yuki-kimoto authored on 2009-11-16
903

            
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
904
Resist filter
packaging one directory
yuki-kimoto authored on 2009-11-16
905
    
many many changes
yuki-kimoto authored on 2010-04-30
906
    $dbi->resist_filter($fname1 => $filter1, $fname => $filter2);
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
907
    
many many changes
yuki-kimoto authored on 2010-04-30
908
The following is resist_filter sample
version 0.0901
yuki-kimoto authored on 2009-12-17
909

            
many many changes
yuki-kimoto authored on 2010-04-30
910
    $dbi->resist_filter(
packaging one directory
yuki-kimoto authored on 2009-11-16
911
        encode_utf8 => sub {
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
912
            my ($value, $key, $dbi, $infos) = @_;
913
            utf8::upgrade($value) unless Encode::is_utf8($value);
914
            return encode('UTF-8', $value);
packaging one directory
yuki-kimoto authored on 2009-11-16
915
        },
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
916
        decode_utf8 => sub {
917
            my ($value, $key, $dbi, $infos) = @_;
918
            return decode('UTF-8', $value)
packaging one directory
yuki-kimoto authored on 2009-11-16
919
        }
920
    );
921

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

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

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

            
many many changes
yuki-kimoto authored on 2010-04-30
930
    $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
931

            
version 0.0901
yuki-kimoto authored on 2009-12-17
932
=head2 create_query
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
933
    
version 0.0901
yuki-kimoto authored on 2009-12-17
934
Create Query object parsing SQL template
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
935

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
938
$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
939

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

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

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

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

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

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
952
    $result = $dbi->query("select * from authors where {= name} and {= age}", 
953
                          {author => 'taro', age => 19});
954
    
955
    while (my @row = $result->fetch) {
956
        # do something
957
    }
958

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

            
961
Return value of query method is L<DBIx::Custom::Result> object
962

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

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

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

            
remove run_transaction().
yuki-kimoto authored on 2010-01-30
969
    $dbi->transaction->run(sub {
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
970
        my $dbi = shift;
971
        
packaging one directory
yuki-kimoto authored on 2009-11-16
972
        # do something
973
    });
974

            
975
If transaction is success, commit is execute. 
976
If tranzation is died, rollback is execute.
977

            
version 0.0901
yuki-kimoto authored on 2009-12-17
978
=head2 create_table
979

            
980
Create table
981

            
982
    $dbi->create_table(
983
        'books',
984
        'name char(255)',
985
        'age  int'
986
    );
987

            
988
First argument is table name. Rest arguments is column definition.
989

            
990
=head2 drop_table
991

            
992
Drop table
993

            
994
    $dbi->drop_table('books');
995

            
packaging one directory
yuki-kimoto authored on 2009-11-16
996
=head2 insert
997

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

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1003
Retrun value is affected rows count
packaging one directory
yuki-kimoto authored on 2009-11-16
1004
    
version 0.0901
yuki-kimoto authored on 2009-12-17
1005
The following is insert sample.
1006

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1009
You can add statement.
1010

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1013
=head2 update
1014

            
update document
yuki-kimoto authored on 2009-11-19
1015
Update rows
1016

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

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

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

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

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

            
1028
    $dbi->update('books', {title => 'Perl', author => 'Taro'},
1029
                 {id => 5}, "some statement");
1030

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1031
=head2 update_all
1032

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

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

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

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

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

            
1043
=head2 delete
1044

            
update document
yuki-kimoto authored on 2009-11-19
1045
Delete rows
1046

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1050
Retrun value is affected rows count
packaging one directory
yuki-kimoto authored on 2009-11-16
1051
    
version 0.0901
yuki-kimoto authored on 2009-12-17
1052
The following is delete sample.
1053

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

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1056
You can add statement.
1057

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

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1060
=head2 delete_all
1061

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

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

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

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

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

            
1072
=head2 select
1073
    
update document
yuki-kimoto authored on 2009-11-19
1074
Select rows
bind_filter argument is chan...
yuki-kimoto authored on 2009-11-19
1075

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1076
    $resut = $dbi->select(
packaging one directory
yuki-kimoto authored on 2009-11-16
1077
        $table,                # must be string or array;
version 0.0901
yuki-kimoto authored on 2009-12-17
1078
        \@$columns,            # must be array reference. this can be ommited
1079
        \%$where_params,       # must be hash reference.  this can be ommited
1080
        $append_statement,     # must be string.          this can be ommited
1081
        $query_edit_callback   # must be code reference.  this can be ommited
packaging one directory
yuki-kimoto authored on 2009-11-16
1082
    );
update document
yuki-kimoto authored on 2009-11-19
1083

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

            
1086
The following is some select samples
1087

            
1088
    # select * from books;
1089
    $result = $dbi->select('books');
packaging one directory
yuki-kimoto authored on 2009-11-16
1090
    
update document
yuki-kimoto authored on 2009-11-19
1091
    # select * from books where title = 'Perl';
1092
    $result = $dbi->select('books', {title => 1});
1093
    
1094
    # select title, author from books where id = 1 for update;
1095
    $result = $dbi->select(
1096
        'books',              # table
1097
        ['title', 'author'],  # columns
1098
        {id => 1},            # where clause
1099
        'for update',         # append statement
1100
    );
1101

            
1102
You can join multi tables
1103
    
1104
    $result = $dbi->select(
1105
        ['table1', 'table2'],                # tables
1106
        ['table1.id as table1_id', 'title'], # columns (alias is ok)
1107
        {table1.id => 1},                    # where clase
1108
        "where table1.id = table2.id",       # join clause (must start 'where')
1109
    );
1110

            
1111
You can also edit query
1112
        
packaging one directory
yuki-kimoto authored on 2009-11-16
1113
    $dbi->select(
update document
yuki-kimoto authored on 2009-11-19
1114
        'books',
1115
        # column, where clause, append statement,
packaging one directory
yuki-kimoto authored on 2009-11-16
1116
        sub {
1117
            my $query = shift;
rename bind_filter to query_...
yuki-kimoto authored on 2010-04-28
1118
            $query->query_filter(sub {
packaging one directory
yuki-kimoto authored on 2009-11-16
1119
                # ...
1120
            });
1121
        }
update document
yuki-kimoto authored on 2009-11-19
1122
    }
1123

            
version 0.0901
yuki-kimoto authored on 2009-12-17
1124
=head2 prepare
1125

            
1126
Prepare statement handle.
1127

            
1128
    $sth = $dbi->prepare('select * from books;');
1129

            
1130
This method is same as DBI prepare method.
1131

            
1132
See also L<DBI>.
1133

            
1134
=head2 do
1135

            
1136
Execute SQL
1137

            
1138
    $affected = $dbi->do('insert into books (title, author) values (?, ?)',
1139
                        'Perl', 'taro');
1140

            
1141
Retrun value is affected rows count.
1142

            
1143
This method is same as DBI do method.
1144

            
1145
See also L<DBI>
1146

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

            
1149

            
1150

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

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

            
1156
    1. AutoCommit is true
1157
    2. RaiseError is true
1158

            
1159
By default, Both AutoCommit and RaiseError is true.
1160
You must not change these mode not to damage your data.
1161

            
1162
If you change these mode, 
1163
you cannot get correct error message, 
1164
or run_transaction may fail.
1165

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

            
1168
DBIx::Custom is customizable DBI.
1169
You can inherit DBIx::Custom and custumize attributes.
1170

            
1171
    package DBIx::Custom::Yours;
1172
    use base DBIx::Custom;
1173
    
1174
    my $class = __PACKAGE__;
1175
    
1176
    $class->user('your_name');
1177
    $class->password('your_password');
1178

            
packaging one directory
yuki-kimoto authored on 2009-11-16
1179
=head1 AUTHOR
1180

            
1181
Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>
1182

            
1183
Github L<http://github.com/yuki-kimoto>
1184

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

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

            
1189
Copyright 2009 Yuki Kimoto, all rights reserved.
1190

            
1191
This program is free software; you can redistribute it and/or modify it
1192
under the same terms as Perl itself.
1193

            
1194
=cut