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