File Coverage

blib/lib/Teng.pm
Criterion Covered Total %
statement 337 379 88.9
branch 125 174 71.8
condition 49 74 66.2
subroutine 56 59 94.9
pod 32 34 94.1
total 599 720 83.1


line stmt bran cond sub pod time code
1             package Teng;
2 69     69   7703505 use strict;
  69         881  
  69         2119  
3 69     69   400 use warnings;
  69         137  
  69         1672  
4 69     69   347 use Carp ();
  69         126  
  69         1803  
5 69     69   34389 use Class::Load 0.06 ();
  69         1552350  
  69         2144  
6 69     69   114650 use DBI 1.33;
  69         1257057  
  69         4099  
7 69     69   571 use Scalar::Util;
  69         157  
  69         2772  
8 69     69   35120 use SQL::Maker::SQLType qw(sql_type);
  69         29786  
  69         4007  
9 69     69   32305 use Teng::Row;
  69         196  
  69         2239  
10 69     69   30043 use Teng::Iterator;
  69         208  
  69         2214  
11 69     69   29119 use Teng::Schema;
  69         179  
  69         2462  
12 69     69   31256 use DBIx::TransactionManager 1.06;
  69         72975  
  69         2031  
13 69     69   28461 use Teng::QueryBuilder;
  69         209  
  69         3538  
14             use Class::Accessor::Lite 0.05
15 69         535 rw => [ qw(
16             connect_info
17             on_connect_do
18             schema
19             schema_class
20             suppress_row_objects
21             sql_builder
22             sql_comment
23             owner_pid
24             no_ping
25             fields_case
26             apply_sql_types
27             guess_sql_types
28             trace_ignore_if
29             )]
30 69     69   491 ;
  69         1304  
31              
32             our $VERSION = '0.34';
33              
34       3     sub _noop {}
35              
36             sub load_plugin {
37 66     66 1 46946 my ($class, $pkg, $opt) = @_;
38 66 100       508 $pkg = $pkg =~ s/^\+// ? $pkg : "Teng::Plugin::$pkg";
39 66         361 Class::Load::load_class($pkg);
40              
41 66 50       3628 $class = ref($class) if ref($class);
42              
43 66   100     530 my $alias = delete $opt->{alias} || +{};
44             {
45 69     69   22049 no strict 'refs';
  69         228  
  69         352777  
  66         158  
46 66         137 for my $method ( @{"${pkg}::EXPORT"} ){
  66         432  
47 68   66     747 *{$class . '::' . ($alias->{$method} || $method)} = $pkg->can($method);
  68         698  
48             }
49             }
50              
51 66 100       635 $pkg->init($class, $opt) if $pkg->can('init');
52             }
53              
54             sub new {
55 91     91 1 834205 my $class = shift;
56 91 100       569 my %args = @_ == 1 ? %{$_[0]} : @_;
  77         430  
57 91         437 my $loader = delete $args{loader};
58              
59 91 100       442 if ( my $mode = delete $args{mode} ) {
60 2         117 warn "IMPORTANT: 'mode' option is DEPRECATED AND *WILL* BE REMOVED. PLEASE USE 'no_ping' option.\n";
61 2 50       15 if ( !exists $args{no_ping} ) {
62 2 100       12 $args{no_ping} = $mode eq 'ping' ? 0 : 1;
63             }
64             }
65              
66             my $self = bless {
67             schema_class => "$class\::Schema",
68             owner_pid => $$,
69             no_ping => 0,
70             fields_case => 'NAME_lc',
71             boolean_value => {true => 1, false => 0},
72 91   50     1870 trace_ignore_if => $args{trace_ignore_if} || \&_noop,
73             %args,
74             }, $class;
75              
76 91 100 100     1085 if (!$loader && ! $self->schema) {
77 86         1172 my $schema_class = $self->{schema_class};
78 86         575 Class::Load::load_class( $schema_class );
79 86         10599 my $schema = $schema_class->instance;
80 86 50       649 if (! $schema) {
81 0         0 Carp::croak("schema object was not passed, and could not get schema instance from $schema_class");
82             }
83 86         678 $schema->namespace($class);
84 86         883 $self->schema( $schema );
85             }
86              
87 91 50 66     1329 unless ($self->connect_info || $self->{dbh}) {
88 0         0 Carp::croak("'dbh' or 'connect_info' is required.");
89             }
90              
91 91 100       1473 if ( ! $self->{dbh} ) {
92 20         80 $self->connect;
93             } else {
94 71         499 $self->_prepare_from_dbh;
95             }
96              
97 89         2326 return $self;
98             }
99              
100             sub set_boolean_value {
101 1     1 1 3132 my $self = shift;
102 1 50       5 if (@_) {
103 1         4 my ($true, $false) = @_;
104 1         7 $self->{boolean_value} = {true => $true, false => $false};
105             }
106 1         2 return $self->{boolean_value};
107             }
108              
109             sub mode {
110 0     0 1 0 my $self = shift;
111 0         0 warn "IMPORTANT: 'mode' option is DEPRECATED AND *WILL* BE REMOVED. PLEASE USE 'no_ping' option.\n";
112              
113 0 0       0 if ( @_ ) {
114 0         0 my $mode = shift;
115 0 0       0 if ( $mode eq 'ping' ) {
116 0         0 $self->no_ping(0);
117             }
118             else {
119 0         0 $self->no_ping(1);
120             }
121             }
122              
123 0 0       0 return $self->no_ping ? 'no_ping' : 'ping';
124             }
125              
126             # forcefully connect
127             sub connect {
128 28     28 1 6726 my ($self, @args) = @_;
129              
130 28         147 $self->in_transaction_check;
131              
132 26 50       86 if (@args) {
133 0         0 $self->connect_info( \@args );
134             }
135 26         72 my $connect_info = $self->connect_info;
136             $connect_info->[3] = {
137             # basic defaults
138             AutoCommit => 1,
139             PrintError => 0,
140             RaiseError => 1,
141 26 100       115 %{ $connect_info->[3] || {} },
  26         203  
142             };
143              
144 26 100 33     69 $self->{dbh} = eval { DBI->connect(@$connect_info) }
  26         168  
145             or Carp::croak("Connection error: " . ($@ || $DBI::errstr));
146 25         122553 delete $self->{txn_manager};
147              
148 25         208 $self->owner_pid($$);
149              
150 25         275 $self->_on_connect_do;
151 24         222 $self->_prepare_from_dbh;
152             }
153              
154             sub _on_connect_do {
155 74     74   183 my $self = shift;
156              
157 74 100       462 if ( my $on_connect_do = $self->on_connect_do ) {
158 17 100       132 if (not ref($on_connect_do)) {
    100          
    100          
159 4         47 $self->do($on_connect_do);
160             } elsif (ref($on_connect_do) eq 'CODE') {
161 8         22 $on_connect_do->($self);
162             } elsif (ref($on_connect_do) eq 'ARRAY') {
163 4         18 $self->do($_) for @$on_connect_do;
164             } else {
165 1         113 Carp::croak('Invalid on_connect_do: '.ref($on_connect_do));
166             }
167             }
168             }
169              
170             sub reconnect {
171 58     58 1 583637 my $self = shift;
172              
173 58         723 $self->in_transaction_check;
174              
175 50         306 my $dbh = $self->{dbh};
176              
177 50         544 $self->disconnect();
178              
179 50 50       577 if ( @_ ) {
180 0         0 $self->connect(@_);
181             }
182             else {
183             # Why don't use $dbh->clone({InactiveDestroy => 0}) ?
184             # because, DBI v1.616 clone with \%attr has bug.
185             # my $dbh2 = $dbh->clone({});
186             # my $dbh3 = $dbh2->clone({});
187             # $dbh2 is ok, but $dbh3 is undef.
188             # ---
189             # Don't assign $self-{dbh} directry.
190             # Because if $self->{dbh} is undef then reconnect fail always.
191             # https://github.com/nekokak/p5-Teng/pull/98
192 50 100 33     169 my $new_dbh = eval { $dbh->clone }
  50         1090  
193             or Carp::croak("ReConnection error: " . ($@ || $DBI::errstr));
194 49         34980 $self->{dbh} = $new_dbh;
195 49         344 $self->{dbh}->{InactiveDestroy} = 0;
196              
197 49         293 $self->owner_pid($$);
198 49         756 $self->_on_connect_do;
199 49         524 $self->_prepare_from_dbh;
200             }
201             }
202              
203             sub disconnect {
204 52     52 1 6783 my $self = shift;
205              
206 52         221 delete $self->{txn_manager};
207 52 50       414 if ( my $dbh = $self->{dbh} ) {
208 52 100 100     423 if ( $self->owner_pid && ($self->owner_pid != $$) ) {
209 3         1648 $dbh->{InactiveDestroy} = 1;
210             }
211             else {
212 49         4212 $dbh->disconnect;
213             }
214             }
215 52         798 $self->owner_pid(undef);
216             }
217              
218             sub _prepare_from_dbh {
219 144     144   424 my $self = shift;
220              
221 144         2581 $self->{driver_name} = $self->{dbh}->{Driver}->{Name};
222 144         652 my $builder = $self->{sql_builder};
223 144 100       896 if (! $builder ) {
224 89   100     1856 my $sql_builder_class = $self->{sql_builder_class} || 'Teng::QueryBuilder';
225             $builder = $sql_builder_class->new(
226             driver => $self->{driver_name},
227 89 100       1265 %{ $self->{sql_builder_args} || {} }
  89         1887  
228             );
229 89         3506 $self->sql_builder( $builder );
230             }
231 144         2445 $self->{dbh}->{FetchHashKeyName} = $self->{fields_case};
232              
233 144 100       2427 $self->{schema}->prepare_from_dbh($self->{dbh}) if $self->{schema};
234             }
235              
236             sub _verify_pid {
237 730     730   1177 my $self = shift;
238              
239 730 100 66     3652 if ( !$self->owner_pid || $self->owner_pid != $$ ) {
    50          
240 1         625 $self->reconnect;
241             }
242             elsif ( my $dbh = $self->{dbh} ) {
243 729 50 100     14685 if ( !$dbh->FETCH('Active') ) {
    100          
244 0         0 $self->reconnect;
245             }
246             elsif ( !$self->no_ping && !$dbh->ping) {
247 12         1092 $self->reconnect;
248             }
249             }
250             }
251              
252             sub dbh {
253 663     663 1 36050 my $self = shift;
254              
255 663         1921 $self->_verify_pid;
256 659         23477 $self->{dbh};
257             }
258              
259             sub connected {
260 0     0 1 0 my $self = shift;
261 0         0 my $dbh = $self->{dbh};
262 0   0     0 return $self->owner_pid && $dbh->ping;
263             }
264              
265             sub _execute {
266 1     1   7797 my $self = shift;
267 1         9 warn "IMPORTANT: '_execute' method is DEPRECATED AND *WILL* BE REMOVED. PLEASE USE 'execute' method.\n";
268 1         4 return $self->execute(@_);
269             }
270              
271             our $SQL_COMMENT_LEVEL = 1;
272             sub trace_query_set_comment {
273 4     4 0 18 my ($self, $sql) = @_;
274              
275 4         7 my $i = $SQL_COMMENT_LEVEL; # optimize, as we would *NEVER* be called
276 4         52 while ( my (@caller) = caller($i++) ) {
277 5 50       52 next if ( $caller[0]->isa( __PACKAGE__ ) );
278 5 50       19 next if $caller[0] =~ /^Teng::/; # skip Teng::Row, Teng::Plugin::* etc.
279 5 100       19 next if $self->trace_ignore_if->(@caller);
280 4         21 my $comment = "$caller[1] at line $caller[2]";
281 4         10 $comment =~ s/\*\// /g;
282 4         27 $sql = "/* $comment */\n$sql";
283 4         15 last;
284             }
285              
286 4         19 return $sql;
287             }
288              
289             sub execute {
290 423     423 1 16652 my ($self, $sql, $binds) = @_;
291              
292 423 100 66     2540 if ($ENV{TENG_SQL_COMMENT} || $self->sql_comment) {
293 4         19 $sql = $self->trace_query_set_comment($sql);
294             }
295              
296 423         2832 my $sth;
297 423         759 eval {
298 423         1160 $sth = $self->dbh->prepare($sql);
299 417         41815 my $i = 1;
300 417 100       811 for my $v ( @{ $binds || [] } ) {
  417         1842  
301 605 100 100     5652 if (Scalar::Util::blessed($v) && ref($v) eq 'SQL::Maker::SQLType') {
302 331         711 $sth->bind_param($i++, ${$v->value_ref}, $v->type);
  331         1026  
303             } else {
304             # allow array ref for using pg_types. e.g. [ $value => { pg_type => PG_BYTEA } ]
305             # ref. https://metacpan.org/pod/DBD::Pg#quote
306 274 50       2167 $sth->bind_param( $i++, ref($v) eq 'ARRAY' ? @$v : $v );
307             }
308             }
309 417         666650 $sth->execute();
310             };
311              
312 423 100       5493 if ($@) {
313 12         85 $self->handle_error($sql, $binds, $@);
314             }
315              
316             # When the return value is never used, should finish statement handler
317 411 100       1258 unless (defined wantarray) {
318 2         17 $sth->finish();
319 2         23 return;
320             }
321              
322 409         1652 return $sth;
323             }
324              
325             sub _last_insert_id {
326 27     27   86 my ($self, $table_name, $column) = @_;
327              
328 27         68 my $driver = $self->{driver_name};
329 27 50       206 if ( $driver eq 'mysql' ) {
    50          
    50          
    0          
330 0         0 return $self->{dbh}->{mysql_insertid};
331             } elsif ( $driver eq 'Pg' ) {
332 0 0       0 if (defined $column) {
333 0         0 return $self->dbh->last_insert_id( undef, undef, undef, undef,{ sequence => join( '_', $table_name, $column, 'seq' ) } );
334             } else {
335 0         0 return $self->dbh->last_insert_id( undef, undef, $table_name, undef);
336             }
337             } elsif ( $driver eq 'SQLite' ) {
338 27         78 return $self->dbh->func('last_insert_rowid');
339             } elsif ( $driver eq 'Oracle' ) {
340 0         0 return;
341             } else {
342 0         0 Carp::croak "Don't know how to get last insert id for $driver";
343             }
344             }
345              
346             sub _bind_sql_type_to_args {
347 196     196   548 my ( $self, $table, $args ) = @_;
348 196         421 my $bind_args = {};
349              
350 196         320 for my $col (keys %{$args}) {
  196         555  
351             # if $args->{$col} is a ref, it is scalar ref or already
352             # sql type bined parameter. so ignored.
353 341 100       5495 $bind_args->{$col} = ref $args->{$col} ? $args->{$col} : sql_type(\$args->{$col}, $table->get_sql_type($col));
354             }
355              
356 196         3708 return $bind_args;
357             }
358              
359             sub do_insert {
360 167     167 1 502 my ($self, $table_name, $args, $prefix) = @_;
361              
362 167   50     1132 $prefix ||= 'INSERT INTO';
363 167         670 my $table = $self->schema->get_table($table_name);
364 167 100       551 if (! $table) {
365 1         6 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
366 1         187 Carp::croak( "Table definition for $table_name does not exist (Did you declare it in our schema?)" );
367             }
368              
369 166         291 for my $col (keys %{$args}) {
  166         776  
370 306         1275 $args->{$col} = $table->call_deflate($col, $args->{$col});
371             }
372 166         1088 my $bind_args = $self->_bind_sql_type_to_args( $table, $args );
373 166         1681 my ($sql, @binds) = $self->{sql_builder}->insert( $table_name, $bind_args, { prefix => $prefix } );
374 166         33582 $self->execute($sql, \@binds);
375             }
376              
377             sub fast_insert {
378 7     7 1 19486 my ($self, $table_name, $args, $prefix) = @_;
379              
380 7         23 my $sth = $self->do_insert($table_name, $args, $prefix);
381              
382             # XXX in MySQL 5.7.8 or later, $self->dbh->{mysql_insertid} will always return 0,
383             # so that get mysql_insertid from $sth. (https://bugs.mysql.com/bug.php?id=78778)
384 7 100       110 return $sth->{mysql_insertid} if defined $sth->{mysql_insertid};
385              
386             # XXX in Pg, _last_insert_id has potential failure when inserting to non Serial table or explicitly inserting Serrial id
387 6         41 $self->_last_insert_id($table_name);
388             }
389              
390             sub insert {
391 162     162 1 1163847 my ($self, $table_name, $args, $prefix) = @_;
392              
393 162         936 my $sth = $self->do_insert($table_name, $args, $prefix);
394 150 100       2650 return unless defined wantarray;
395              
396 53         446 my $table = $self->schema->get_table($table_name);
397 53         303 my $pk = $table->primary_keys();
398              
399 53         433 my @missing_primary_keys = grep { not defined $args->{$_} } @$pk;
  62         449  
400 53 100       325 if (@missing_primary_keys == 1) {
401             # XXX in MySQL 5.7.8 or later, $self->dbh->{mysql_insertid} will always return 0,
402             # so that get mysql_insertid from $sth. (https://bugs.mysql.com/bug.php?id=78778)
403             $args->{$missing_primary_keys[0]} = defined $sth->{mysql_insertid} ? $sth->{mysql_insertid}
404 22 100       477 : $self->_last_insert_id($table_name, $missing_primary_keys[0]);
405             }
406              
407 53 100       566 return $args if $self->suppress_row_objects;
408              
409 51         367 my %where;
410 51         146 my $refetch = 1;
411 51         213 for my $key (@$pk) {
412 60 50       253 if (ref $args->{$key}) {
413             # care references. eg. \'NOW()'
414 0         0 $refetch = undef;
415 0         0 last;
416             }
417 60         294 $where{$key} = $args->{$key};
418             }
419 51 50 33     423 if (%where && $refetch) {
420             # refetch the row for cleanup scalar refs and fill default values
421 51         551 return $self->single($table_name, \%where);
422             }
423              
424             $table->row_class->new(
425             {
426 0         0 row_data => $args,
427             teng => $self,
428             table_name => $table_name,
429             }
430             );
431             }
432              
433             sub bulk_insert {
434 2     2 1 4574 my ($self, $table_name, $args, $opt) = @_;
435              
436 2 50       5 return unless scalar(@{$args||[]});
  2 50       12  
437              
438 2         7 my $dbh = $self->dbh;
439             my $can_multi_insert = $dbh->{Driver}->{Name} eq 'mysql' ? 1
440             : $dbh->{Driver}->{Name} eq 'Pg'
441 2 50 33     64 && $dbh->{ pg_server_version } >= 82000 ? 1
    50          
442             : 0;
443              
444 2 50       16 if ($can_multi_insert) {
445 0         0 my $table = $self->schema->get_table($table_name);
446 0 0       0 if (! $table) {
447 0         0 Carp::croak( "Table definition for $table_name does not exist (Did you declare it in our schema?)" );
448             }
449              
450 0 0       0 if ( $table->has_deflators ) {
451 0         0 for my $row (@$args) {
452 0         0 for my $col (keys %{$row}) {
  0         0  
453 0         0 $row->{$col} = $table->call_deflate($col, $row->{$col});
454             }
455             }
456             }
457              
458 0         0 my ($sql, @binds) = $self->sql_builder->insert_multi( $table_name, $args, $opt );
459 0         0 $self->execute($sql, \@binds);
460             } else {
461             # use transaction for better performance and atomicity.
462 2         15 my $txn = $self->txn_scope();
463 2         183 for my $arg (@$args) {
464             # do not run trigger for consistency with mysql.
465 6         32 $self->insert($table_name, $arg, $opt->{prefix});
466             }
467 2         41 $txn->commit;
468             }
469             }
470              
471             sub do_update {
472 30     30 1 90 my ($self, $table_name, $args, $where) = @_;
473              
474 30         187 my ($sql, @binds) = $self->{sql_builder}->update( $table_name, $args, $where );
475 30         7491 my $sth = $self->execute($sql, \@binds);
476 30         214 my $rows = $sth->rows;
477 30         118 $sth->finish;
478              
479 30         444 $rows;
480             }
481              
482             sub update {
483 8     8 1 6124 my ($self, $table_name, $args, $where) = @_;
484              
485 8         27 my $table = $self->schema->get_table($table_name);
486 8 100       25 if (! $table) {
487 1         95 Carp::croak( "Table definition for $table_name does not exist (Did you declare it in our schema?)" );
488             }
489              
490 7         15 for my $col (keys %{$args}) {
  7         22  
491 9         48 $args->{$col} = $table->call_deflate($col, $args->{$col});
492             }
493            
494 7         36 $self->do_update($table_name, $self->_bind_sql_type_to_args( $table, $args ), $where);
495             }
496              
497             sub delete {
498 17     17 1 6854 my ($self, $table_name, $where) = @_;
499              
500 17         86 my ($sql, @binds) = $self->{sql_builder}->delete( $table_name, $where );
501 17         3180 my $sth = $self->execute($sql, \@binds);
502 17         148 my $rows = $sth->rows;
503 17         81 $sth->finish;
504              
505 17         328 $rows;
506             }
507              
508             #--------------------------------------------------------------------------------
509             # for transaction
510             sub txn_manager {
511 67     67 1 118 my $self = shift;
512 67         167 $self->_verify_pid;
513             $self->{txn_manager} ||= ($self->{txn_manager_class})
514 65 50 66     1835 ? $self->{txn_manager_class}->new($self->dbh)
515             : DBIx::TransactionManager->new($self->dbh);
516             }
517              
518             sub in_transaction_check {
519 86     86 0 222 my $self = shift;
520              
521 86 100       436 return unless $self->{txn_manager};
522              
523 31 100       143 if ( my $info = $self->{txn_manager}->in_transaction ) {
524 10         114 my $caller = $info->{caller};
525 10         23 my $pid = $info->{pid};
526 10         2014 Carp::confess("Detected transaction during a connect operation (last known transaction at $caller->[1] line $caller->[2], pid $pid). Refusing to proceed at");
527             }
528             }
529              
530             sub txn_scope {
531 19     19 1 13611 my $self = shift;
532 19         101 my @caller = caller();
533              
534 19         85 $self->txn_manager->txn_scope(caller => \@caller);
535             }
536              
537             sub txn_begin {
538 24     24 1 21393 my $self = shift;
539              
540 24         101 $self->txn_manager->txn_begin;
541             }
542 12     12 1 8144 sub txn_rollback { $_[0]->txn_manager->txn_rollback }
543 12     12 1 1053 sub txn_commit { $_[0]->txn_manager->txn_commit }
544 0     0 1 0 sub txn_end { $_[0]->txn_manager->txn_end }
545              
546             #--------------------------------------------------------------------------------
547              
548             sub do {
549 21     21 1 12364 my ($self, $sql, $attr, @bind_vars) = @_;
550 21         41 my $ret;
551 21         41 eval { $ret = $self->dbh->do($sql, $attr, @bind_vars) };
  21         113  
552 21 100       128518 if ($@) {
553 1 50       9 $self->handle_error($sql, @bind_vars ? \@bind_vars : '', $@);
554             }
555 20         105 $ret;
556             }
557              
558             sub _get_select_columns {
559 179     179   610 my ($self, $table, $opt) = @_;
560              
561             return $opt->{'+columns'}
562 4         92 ? [@{$table->{escaped_columns}{$self->{driver_name}}}, @{$opt->{'+columns'}}]
  4         28  
563             : ($opt->{columns} || $table->{escaped_columns}{$self->{driver_name}})
564 179 100 66     2514 ;
565             }
566              
567             sub search {
568 35     35 1 61376 my ($self, $table_name, $where, $opt) = @_;
569              
570 35         150 my $table = $self->{schema}->get_table( $table_name );
571 35 100       106 if (! $table) {
572 1         186 Carp::croak("No such table $table_name");
573             }
574              
575             my ($sql, @binds) = $self->{sql_builder}->select(
576 34         113 $table_name,
577             $self->_get_select_columns($table, $opt),
578             $where,
579             $opt
580             );
581              
582 34         12670 $self->search_by_sql($sql, \@binds, $table_name);
583             }
584              
585             sub _bind_named {
586 5     5   13 my ($self, $sql, $args ) = @_;
587              
588 5         9 my @bind;
589 5         39 $sql =~ s{:([A-Za-z_][A-Za-z0-9_]*)}{
590 7 100       205 Carp::croak("'$1' does not exist in bind hash") if !exists $args->{$1};
591 6 100 66     37 if ( ref $args->{$1} && ref $args->{$1} eq "ARRAY" ) {
592 1         8 push @bind, @{ $args->{$1} };
  1         3  
593 1         3 my $tmp = join ',', map { '?' } @{ $args->{$1} };
  3         8  
  1         3  
594 1         6 "( $tmp )";
595             } else {
596 5         16 push @bind, $args->{$1};
597 5         29 '?'
598             }
599             }ge;
600              
601 4         35 return ($sql, \@bind);
602             }
603              
604             sub search_named {
605 4     4 1 10654 my ($self, $sql, $args, $table_name) = @_;
606              
607 4         16 $self->search_by_sql($self->_bind_named($sql, $args), $table_name);
608             }
609              
610             sub single {
611 139     139 1 2843229 my ($self, $table_name, $where, $opt) = @_;
612              
613 139         547 $opt->{limit} = 1;
614              
615 139         1259 my $table = $self->{schema}->get_table( $table_name );
616 139 50       573 Carp::croak("No such table $table_name") unless $table;
617              
618             my ($sql, @binds) = $self->{sql_builder}->select(
619 139         844 $table_name,
620             $self->_get_select_columns($table, $opt),
621             $where,
622             $opt
623             );
624 139         77548 my $sth = $self->execute($sql, \@binds);
625              
626             # When the return value is never used, should not create row object
627             # case example: use `FOR UPDATE` query for global locking
628 139 50       529 unless (defined wantarray) {
629 0         0 $sth->finish();
630 0         0 return;
631             }
632              
633 139         7158 my $row = $sth->fetchrow_hashref($self->{fields_case});
634              
635 139 100       1236 return undef unless $row; ## no critic
636 123 50       507 return $row if $self->{suppress_row_objects};
637              
638             $table->{row_class}->new(
639             {
640 123         1900 sql => $sql,
641             row_data => $row,
642             teng => $self,
643             table => $table,
644             table_name => $table_name,
645             }
646             );
647             }
648              
649             sub search_by_sql {
650 56     56 1 40054 my ($self, $sql, $bind, $table_name) = @_;
651              
652 56   100     315 $table_name ||= $self->_guess_table_name( $sql );
653 56         220 my $sth = $self->execute($sql, $bind);
654              
655             # When the return value is never used, should not create iterator object
656             # case example: use `FOR UPDATE` query for global locking
657 55 50       220 unless (defined wantarray) {
658 0         0 $sth->finish();
659 0         0 return;
660             }
661              
662             my $itr = Teng::Iterator->new(
663             teng => $self,
664             sth => $sth,
665             sql => $sql,
666             row_class => $self->{schema}->get_row_class($table_name),
667             table => $self->{schema}->get_table( $table_name ),
668             table_name => $table_name,
669             apply_sql_types => $self->{apply_sql_types} || $self->{guess_sql_types},
670             guess_sql_types => $self->{guess_sql_types},
671             suppress_object_creation => $self->{suppress_row_objects},
672 55   66     454 );
673 55 100       393 return wantarray ? $itr->all : $itr;
674             }
675              
676             sub single_by_sql {
677 2     2 1 1612 my ($self, $sql, $bind, $table_name) = @_;
678              
679 2   33     7 $table_name ||= $self->_guess_table_name( $sql );
680 2         10 my $table = $self->{schema}->get_table( $table_name );
681 2 50       8 Carp::croak("No such table $table_name") unless $table;
682              
683 2         21 my $sth = $self->execute($sql, $bind);
684              
685             # When the return value is never used, should not create row object
686             # case example: use `FOR UPDATE` query for global locking
687 2 50       7 unless (defined wantarray) {
688 0         0 $sth->finish();
689 0         0 return;
690             }
691              
692 2         139 my $row = $sth->fetchrow_hashref($self->{fields_case});
693              
694 2 50       15 return unless $row;
695 2 50       9 return $row if $self->{suppress_row_objects};
696              
697             $table->{row_class}->new(
698             {
699 2         35 sql => $sql,
700             row_data => $row,
701             teng => $self,
702             table => $table,
703             table_name => $table_name,
704             }
705             );
706             }
707              
708             sub new_row_from_hash {
709 4     4 1 3486 my ($self, $table_name, $data, $sql) = @_;
710              
711 4         17 my $table = $self->{schema}->get_table( $table_name );
712 4 50       10 Carp::croak("No such table $table_name") unless $table;
713              
714 4 50       8 return $data if $self->{suppress_row_objects};
715              
716             $table->{row_class}->new(
717             {
718 4   66     15 sql => $sql || do {
719             my @caller = caller(0);
720             my $level = 0;
721             while ($caller[0] eq __PACKAGE__ || $caller[0] eq ref $self) {
722             @caller = caller(++$level);
723             }
724             sprintf '/* DUMMY QUERY %s->new_row_from_hash created from %s line %d */', ref $self, $caller[1], $caller[2];
725             },
726             row_data => $data,
727             teng => $self,
728             table => $table,
729             table_name => $table_name,
730             }
731             );
732             }
733              
734             sub single_named {
735 1     1 1 1652 my ($self, $sql, $args, $table_name) = @_;
736              
737 1         9 $self->single_by_sql($self->_bind_named($sql, $args), $table_name);
738             }
739              
740             sub _guess_table_name {
741 27     27   2279 my ($class, $sql) = @_;
742              
743 27 100       243 if ($sql =~ /\sfrom\s+["`]?([\w]+)["`]?\s*/si) {
744 26         160 return $1;
745             }
746 1         4 return;
747             }
748              
749             sub handle_error {
750 13     13 1 52 my ($self, $stmt, $bind, $reason) = @_;
751 13         5919 require Data::Dumper;
752              
753 13         55362 local $Data::Dumper::Maxdepth = 2;
754 13         84 $stmt =~ s/\n/\n /gm;
755 13         63 Carp::croak sprintf <<"TRACE", $reason, $stmt, Data::Dumper::Dumper($bind);
756             @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
757             @@@@@ Teng 's Exception @@@@@
758             Reason : %s
759             SQL : %s
760             BIND : %s
761             @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
762             TRACE
763             }
764              
765             sub DESTROY {
766 87     87   167305 my $self = shift;
767              
768 87 100 100     481 if ( $self->owner_pid and $self->owner_pid != $$ and my $dbh = $self->{dbh} ) {
      66        
769 1         142 $dbh->{InactiveDestroy} = 1;
770             }
771             }
772              
773             1;
774              
775             __END__
776             =head1 NAME
777              
778             Teng - very simple DBI wrapper/ORMapper
779              
780             =head1 SYNOPSIS
781              
782             my $db = MyDB->new({ connect_info => [ 'dbi:SQLite:' ] });
783             my $row = $db->insert( 'table' => {
784             col1 => $value
785             } );
786              
787             =head1 DESCRIPTION
788              
789             Teng is very simple DBI wrapper and simple O/R Mapper.
790             It aims to be lightweight, with minimal dependencies so it's easier to install.
791              
792             =head1 BASIC USAGE
793              
794             create your db model base class.
795              
796             package Your::Model;
797             use parent 'Teng';
798             1;
799            
800             create your db schema class.
801             See Teng::Schema for docs on defining schema class.
802              
803             package Your::Model::Schema;
804             use Teng::Schema::Declare;
805             table {
806             name 'user';
807             pk 'id';
808             columns qw( foo bar baz );
809             };
810             1;
811            
812             in your script.
813              
814             use Your::Model;
815            
816             my $teng = Your::Model->new(\%args);
817             # insert new record.
818             my $row = $teng->insert('user',
819             {
820             id => 1,
821             }
822             );
823             $row->update({name => 'nekokak'}); # same do { $row->name('nekokak'); $row->update; }
824              
825             $row = $teng->single_by_sql(q{SELECT id, name FROM user WHERE id = ?}, [ 1 ]);
826             $row->delete();
827              
828             =head1 ARCHITECTURE
829              
830             Teng classes are comprised of three distinct components:
831              
832             =head2 MODEL
833              
834             The C<model> is where you say
835              
836             package MyApp::Model;
837             use parent 'Teng';
838              
839             This is the entry point to using Teng. You connect, insert, update, delete, select stuff using this object.
840              
841             =head2 SCHEMA
842              
843             The C<schema> is a simple class that describes your table definitions. Note that this is different from DBIx::Class terms.
844             DBIC's schema is equivalent to Teng's model + schema, where the actual schema information is scattered across the result classes.
845              
846             In Teng, you simply use Teng::Schema's domain specific language to define a set of tables
847              
848             package MyApp::Model::Schema;
849             use Teng::Schema::Declare;
850              
851             table {
852             name $table_name;
853             pk $primary_key_column;
854             columns qw(
855             column1
856             column2
857             column3
858             );
859             }
860              
861             ... and other tables ...
862              
863             =head2 ROW
864              
865             Unlike DBIx::Class, you don't need to have a set of classes that represent a row type (i.e. "result" classes in DBIC terms).
866             In Teng, the row objects are blessed into anonymous classes that inherit from Teng::Row,
867             so you don't have to create these classes if you just want to use some simple queries.
868              
869             If you want to define methods to be performed by your row objects, simply create a row class like so:
870              
871             package MyApp::Model::Row::Camelizedtable_name;
872             use parent qw(Teng::Row);
873              
874             Note that your table name will be camelized.
875              
876             =head1 METHODS
877              
878             Teng provides a number of methods to all your classes,
879              
880             =over
881              
882             =item $teng = Teng->new(\%args)
883              
884             Creates a new Teng instance.
885              
886             # connect new database connection.
887             my $db = Your::Model->new(
888             connect_info => [ $dsn, $username, $password, \%connect_options ]
889             );
890              
891             Arguments can be:
892              
893             =over
894              
895             =item * C<connect_info>
896              
897             Specifies the information required to connect to the database.
898             The argument should be a reference to a array in the form:
899              
900             [ $dsn, $user, $password, \%options ]
901              
902             You must pass C<connect_info> or C<dbh> to the constructor.
903              
904             =item * C<dbh>
905              
906             Specifies the database handle to use.
907              
908             =item * C<no_ping>
909              
910             By default, ping before each executing query.
911             If it affect performance then you can set to true for ping stopping.
912              
913             =item * C<fields_case>
914              
915             specific DBI.pm's FetchHashKeyName.
916              
917             =item * C<schema>
918              
919             Specifies the Teng::Schema instance to use.
920             If not specified, the value specified in C<schema_class> is loaded and
921             instantiated for you.
922              
923             =item * C<schema_class>
924              
925             Specifies the schema class to use.
926             By default {YOUR_MODEL_CLASS}::Schema is used.
927              
928             =item * C<txn_manager_class>
929              
930             Specifies the transaction manager class.
931             By default DBIx::TransactionManager is used.
932              
933             =item * C<suppress_row_objects>
934              
935             Specifies the row object creation mode. By default this value is C<false>.
936             If you specifies this to a C<true> value, no row object will be created when
937             a C<SELECT> statement is issued..
938              
939             =item * C<force_deflate_set_column>
940              
941             Specifies C<set_column>, C<set_columns> and column name method behaviour. By default this value is C<false>.
942             If you specifies this to a C<true> value, C<set_column> or column name method will deflate argument.
943              
944             =item * C<sql_builder>
945              
946             Speficies the SQL builder object. By default SQL::Maker is used, and as such,
947             if you provide your own SQL builder the interface needs to be compatible
948             with SQL::Maker.
949              
950             =item * C<sql_builder_class> : Str
951              
952             Speficies the SQL builder class name. By default SQL::Maker is used, and as such,
953             if you provide your own SQL builder the interface needs to be compatible
954             with SQL::Maker.
955              
956             Specified C<sql_builder_class> is instantiated with following:
957              
958             $sql_builder_class->new(
959             driver => $teng->{driver_name},
960             %{ $teng->{sql_builder_args} }
961             )
962              
963             This is not used when C<sql_builder> is specified.
964              
965             =item * C<sql_builder_args> : HashRef
966              
967             Speficies the arguments for constructor of C<sql_builder_class>. This is not used when C<sql_builder> is specified.
968              
969             =item * C<trace_ignore_if> : CodeRef
970              
971             Ignore to inject the SQL comment when trace_ignore_if's return value is true.
972              
973             =back
974              
975             =item C<$row = $teng-E<gt>insert($table_name, \%row_data)>
976              
977             Inserts a new record. Returns the inserted row object.
978              
979             my $row = $teng->insert('user',{
980             id => 1,
981             name => 'nekokak',
982             });
983              
984             If a primary key is available, it will be fetched after the insert -- so
985             an INSERT followed by SELECT is performed. If you do not want this, use
986             C<fast_insert>.
987              
988             =item C<$last_insert_id = $teng-E<gt>fast_insert($table_name, \%row_data);>
989              
990             insert new record and get last_insert_id.
991              
992             no creation row object.
993              
994             =item C<< $teng->do_insert >>
995              
996             Internal method called from C<insert> and C<fast_insert>. You can hook it on your responsibility.
997              
998             =item C<$teng-E<gt>bulk_insert($table_name, \@rows_data, \%opt)>
999              
1000             Accepts either an arrayref of hashrefs.
1001             each hashref should be a structure suitable
1002             for submitting to a Your::Model->insert(...) method.
1003             The second argument is an arrayref of hashrefs. All of the keys in these hashrefs must be exactly the same.
1004              
1005             insert many record by bulk.
1006              
1007             example:
1008              
1009             Your::Model->bulk_insert('user',[
1010             {
1011             id => 1,
1012             name => 'nekokak',
1013             },
1014             {
1015             id => 2,
1016             name => 'yappo',
1017             },
1018             {
1019             id => 3,
1020             name => 'walf443',
1021             },
1022             ]);
1023              
1024             You can specify C<$opt> like C<< { prefix => 'INSERT IGNORE INTO' } >> or C<< { update => { name => 'updated' } } >> optionally, which will be passed to query builder.
1025              
1026             =item C<$update_row_count = $teng-E<gt>update($table_name, \%update_row_data, [\%update_condition])>
1027              
1028             Calls UPDATE on C<$table_name>, with values specified in C<%update_ro_data>, and returns the number of rows updated. You may optionally specify C<%update_condition> to create a conditional update query.
1029              
1030             my $update_row_count = $teng->update('user',
1031             {
1032             name => 'nomaneko',
1033             },
1034             {
1035             id => 1
1036             }
1037             );
1038             # Executes UPDATE user SET name = 'nomaneko' WHERE id = 1
1039              
1040             You can also call update on a row object:
1041              
1042             my $row = $teng->single('user',{id => 1});
1043             $row->update({name => 'nomaneko'});
1044              
1045             You can use the set_column method:
1046              
1047             my $row = $teng->single('user', {id => 1});
1048             $row->set_column( name => 'yappo' );
1049             $row->update;
1050              
1051             you can column update by using column method:
1052              
1053             my $row = $teng->single('user', {id => 1});
1054             $row->name('yappo');
1055             $row->update;
1056              
1057             =item C<$updated_row_count = $teng-E<gt>do_update($table_name, \%set, \%where)>
1058              
1059             This is low level API for UPDATE. Normally, you should use update method instead of this.
1060              
1061             This method does not deflate \%args.
1062              
1063             =item C<$delete_row_count = $teng-E<gt>delete($table, \%delete_condition)>
1064              
1065             Deletes the specified record(s) from C<$table> and returns the number of rows deleted. You may optionally specify C<%delete_condition> to create a conditional delete query.
1066              
1067             my $rows_deleted = $teng->delete( 'user', {
1068             id => 1
1069             } );
1070             # Executes DELETE FROM user WHERE id = 1
1071              
1072             You can also call delete on a row object:
1073              
1074             my $row = $teng->single('user', {id => 1});
1075             $row->delete
1076              
1077             =item C<$itr = $teng-E<gt>search($table_name, [\%search_condition, [\%search_attr]])>
1078              
1079             simple search method.
1080             search method get Teng::Iterator's instance object.
1081              
1082             see L<Teng::Iterator>
1083              
1084             get iterator:
1085              
1086             my $itr = $teng->search('user',{id => 1},{order_by => 'id'});
1087              
1088             get rows:
1089              
1090             my @rows = $teng->search('user',{id => 1},{order_by => 'id'});
1091              
1092             =item C<$row = $teng-E<gt>single($table_name, \%search_condition)>
1093              
1094             get one record.
1095             give back one case of the beginning when it is acquired plural records by single method.
1096              
1097             my $row = $teng->single('user',{id =>1});
1098              
1099             =item C<$row = $teng-E<gt>new_row_from_hash($table_name, \%row_data, [$sql])>
1100              
1101             create row object from data. (not fetch from db.)
1102             It's useful in such as testing.
1103              
1104             my $row = $teng->new_row_from_hash('user', { id => 1, foo => "bar" });
1105             say $row->foo; # say bar
1106              
1107             =item C<$itr = $teng-E<gt>search_named($sql, [\%bind_values, [$table_name]])>
1108              
1109             execute named query
1110              
1111             my $itr = $teng->search_named(q{SELECT * FROM user WHERE id = :id}, {id => 1});
1112              
1113             If you give ArrayRef to value, that is expanded to "(?,?,?,?)" in SQL.
1114             It's useful in case use IN statement.
1115              
1116             # SELECT * FROM user WHERE id IN (?,?,?);
1117             # bind [1,2,3]
1118             my $itr = $teng->search_named(q{SELECT * FROM user WHERE id IN :ids}, {ids => [1, 2, 3]});
1119              
1120             If you give table_name. It is assumed the hint that makes Teng::Row's Object.
1121              
1122             =item C<$itr = $teng-E<gt>search_by_sql($sql, [\@bind_values, [$table_name]])>
1123              
1124             execute your SQL
1125              
1126             my $itr = $teng->search_by_sql(q{
1127             SELECT
1128             id, name
1129             FROM
1130             user
1131             WHERE
1132             id = ?
1133             },[ 1 ]);
1134              
1135             If $table is specified, it set table information to result iterator.
1136             So, you can use table row class to search_by_sql result.
1137              
1138             =item C<$row = $teng-E<gt>single_by_sql($sql, [\@bind_values, [$table_name]])>
1139              
1140             get one record from your SQL.
1141              
1142             my $row = $teng->single_by_sql(q{SELECT id,name FROM user WHERE id = ? LIMIT 1}, [1], 'user');
1143              
1144             This is a shortcut for
1145              
1146             my $row = $teng->search_by_sql(q{SELECT id,name FROM user WHERE id = ? LIMIT 1}, [1], 'user')->next;
1147              
1148             But optimized implementation.
1149              
1150             =item C<$row = $teng-E<gt>single_named($sql, [\%bind_values, [$table_name]])>
1151              
1152             get one record from execute named query
1153              
1154             my $row = $teng->single_named(q{SELECT id,name FROM user WHERE id = :id LIMIT 1}, {id => 1}, 'user');
1155              
1156             This is a shortcut for
1157              
1158             my $row = $teng->search_named(q{SELECT id,name FROM user WHERE id = :id LIMIT 1}, {id => 1}, 'user')->next;
1159              
1160             But optimized implementation.
1161              
1162             =item C<$sth = $teng-E<gt>execute($sql, [\@bind_values])>
1163              
1164             execute query and get statement handler.
1165             and will be inserted caller's file and line as a comment in the SQL if $ENV{TENG_SQL_COMMENT} or sql_comment is true value.
1166              
1167             =item C<$teng-E<gt>txn_scope>
1168              
1169             Creates a new transaction scope guard object.
1170              
1171             do {
1172             my $txn = $teng->txn_scope;
1173              
1174             $row->update({foo => 'bar'});
1175              
1176             $txn->commit;
1177             }
1178              
1179             If an exception occurs, or the guard object otherwise leaves the scope
1180             before C<< $txn->commit >> is called, the transaction will be rolled
1181             back by an explicit L</txn_rollback> call. In essence this is akin to
1182             using a L</txn_begin>/L</txn_commit> pair, without having to worry
1183             about calling L</txn_rollback> at the right places. Note that since there
1184             is no defined code closure, there will be no retries and other magic upon
1185             database disconnection.
1186              
1187             =item C<$txn_manager = $teng-E<gt>txn_manager>
1188              
1189             Create the transaction manager instance with specified C<txn_manager_class>.
1190              
1191             =item C<$teng-E<gt>txn_begin>
1192              
1193             start new transaction.
1194              
1195             =item C<$teng-E<gt>txn_commit>
1196              
1197             commit transaction.
1198              
1199             =item C<$teng-E<gt>txn_rollback>
1200              
1201             rollback transaction.
1202              
1203             =item C<$teng-E<gt>txn_end>
1204              
1205             finish transaction.
1206              
1207             =item C<$teng-E<gt>do($sql, [\%option, @bind_values])>
1208              
1209             Execute the query specified by C<$sql>, using C<%option> and C<@bind_values> as necessary. This pretty much a wrapper around L<http://search.cpan.org/dist/DBI/DBI.pm#do>
1210              
1211             =item C<$teng-E<gt>dbh>
1212              
1213             get database handle.
1214              
1215             =item C<$teng-E<gt>connect(\@connect_info)>
1216              
1217             connect database handle.
1218              
1219             connect_info is [$dsn, $user, $password, $options].
1220              
1221             If you give \@connect_info, create new database connection.
1222              
1223             =item C<$teng-E<gt>disconnect()>
1224              
1225             Disconnects from the currently connected database.
1226              
1227             =item C<$teng-E<gt>suppress_row_objects($flag)>
1228              
1229             set row object creation mode.
1230              
1231             =item C<$teng-E<gt>apply_sql_types($flag)>
1232              
1233             set SQL type application mode.
1234              
1235             see apply_sql_types in L<Teng::Iterator/METHODS>
1236              
1237             =item C<$teng-E<gt>guess_sql_types($flag)>
1238              
1239             set SQL type guessing mode.
1240             this implies apply_sql_types true.
1241              
1242             see guess_sql_types in L<Teng::Iterator/METHODS>
1243              
1244             =item C<$teng-E<gt>set_boolean_value($true, $false)>
1245              
1246             set scalar to correspond boolean.
1247             this is ignored when apply_sql_types is not true.
1248              
1249             $teng->set_boolean_value(JSON::XS::true, JSON::XS::false);
1250              
1251             =item C<$teng-E<gt>load_plugin();>
1252              
1253             $teng->load_plugin($plugin_class, $options);
1254              
1255             This imports plugin class's methods to C<$teng> class
1256             and it calls $plugin_class's init method if it has.
1257              
1258             $plugin_class->init($teng, $options);
1259              
1260             If you want to change imported method name, use C<alias> option.
1261             for example:
1262              
1263             YourDB->load_plugin('BulkInsert', { alias => { bulk_insert => 'isnert_bulk' } });
1264              
1265             BulkInsert's "bulk_insert" method is imported as "insert_bulk".
1266              
1267             =item C<$teng-E<gt>handle_error>
1268              
1269             handling error method.
1270              
1271             =item C<< $teng->connected >>
1272              
1273             check connected or not.
1274              
1275             =item C<< $teng->reconnect >>
1276              
1277             reconnect database
1278              
1279             =item C<< $teng->mode >>
1280              
1281             DEPRECATED AND *WILL* BE REMOVED. PLEASE USE C< no_ping > option.
1282              
1283             =item How do you use display the profiling result?
1284              
1285             use L<Devel::KYTProf>.
1286              
1287             =back
1288              
1289             =head1 TRIGGERS
1290              
1291             Teng does not support triggers (NOTE: do not confuse it with SQL triggers - we're talking about Perl level triggers). If you really want to hook into the various methods, use something like L<Moose>, L<Mouse>, and L<Class::Method::Modifiers>.
1292              
1293             =head1 SEE ALSO
1294              
1295             =head2 Fork
1296              
1297             This module was forked from L<DBIx::Skinny>, around version 0.0732.
1298             many incompatible changes have been made.
1299              
1300             =head1 BUGS AND LIMITATIONS
1301              
1302             No bugs have been reported.
1303              
1304             =head1 AUTHORS
1305              
1306             Atsushi Kobayashi C<< <nekokak __at__ gmail.com> >>
1307              
1308             Tokuhiro Matsuno E<lt>tokuhirom@gmail.comE<gt>
1309              
1310             Daisuke Maki C<< <daisuke@endeworks.jp> >>
1311              
1312             =head1 SUPPORT
1313              
1314             irc: #dbix-skinny@irc.perl.org
1315              
1316             ML: http://groups.google.com/group/dbix-skinny
1317              
1318             =head1 REPOSITORY
1319              
1320             git clone git://github.com/nekokak/p5-teng.git
1321              
1322             =head1 LICENCE AND COPYRIGHT
1323              
1324             Copyright (c) 2010, the Teng L</AUTHOR>. All rights reserved.
1325              
1326             This module is free software; you can redistribute it and/or
1327             modify it under the same terms as Perl itself. See L<perlartistic>.
1328              
1329             =cut
1330