← Index
NYTProf Performance Profile   « block view • line view • sub view »
For xt/tapper-mcp-scheduler-with-db-longrun.t
  Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:24:03 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/DBD/SQLite.pm
StatementsExecuted 1683 statements in 7.94s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
711111.0ms7.93sDBD::SQLite::db::::do DBD::SQLite::db::do
145223.70ms37.2msDBD::SQLite::db::::prepare DBD::SQLite::db::prepare
6111.15ms1.15msDBD::SQLite::db::::_login DBD::SQLite::db::_login (xsub)
611301µs2.13msDBD::SQLite::dr::::connect DBD::SQLite::dr::connect
111248µs248µsDBD::SQLite::::bootstrap DBD::SQLite::bootstrap (xsub)
11169µs486µsDBD::SQLite::::driver DBD::SQLite::driver
183152µs52µsDBD::SQLite::dr::::CORE:match DBD::SQLite::dr::CORE:match (opcode)
11135µs35µsDBD::SQLite::::BEGIN@3 DBD::SQLite::BEGIN@3
41135µs64µsDBD::SQLite::db::::get_info DBD::SQLite::db::get_info
41121µs29µsDBD::SQLite::db::::_get_version DBD::SQLite::db::_get_version
11114µs24µsDBD::SQLite::::BEGIN@5 DBD::SQLite::BEGIN@5
11112µs64µsDBD::SQLite::::BEGIN@30 DBD::SQLite::BEGIN@30
11110µs10µsDBD::SQLite::::BEGIN@12 DBD::SQLite::BEGIN@12
11110µs14µsDBD::SQLite::::BEGIN@4 DBD::SQLite::BEGIN@4
11110µs13µsDBD::SQLite::::BEGIN@34 DBD::SQLite::BEGIN@34
1119µs9µsDBD::SQLite::_WriteOnceHash::::TIEHASHDBD::SQLite::_WriteOnceHash::TIEHASH
1118µs51µsDBD::SQLite::::BEGIN@8 DBD::SQLite::BEGIN@8
4118µs8µsDBD::SQLite::db::::FETCH DBD::SQLite::db::FETCH (xsub)
1118µs10µsDBD::SQLite::dr::::BEGIN@178 DBD::SQLite::dr::BEGIN@178
1116µs55µsDBD::SQLite::::BEGIN@9 DBD::SQLite::BEGIN@9
1116µs24µsDBD::SQLite::::BEGIN@10 DBD::SQLite::BEGIN@10
2215µs5µsDBD::SQLite::_WriteOnceHash::::STOREDBD::SQLite::_WriteOnceHash::STORE
1114µs4µsDBD::SQLite::::BEGIN@6 DBD::SQLite::BEGIN@6
0000s0sDBD::SQLite::::CLONE DBD::SQLite::CLONE
0000s0sDBD::SQLite::_WriteOnceHash::::DELETEDBD::SQLite::_WriteOnceHash::DELETE
0000s0sDBD::SQLite::::__ANON__[:33] DBD::SQLite::__ANON__[:33]
0000s0sDBD::SQLite::::__ANON__[:34] DBD::SQLite::__ANON__[:34]
0000s0sDBD::SQLite::db::::_attached_database_list DBD::SQLite::db::_attached_database_list
0000s0sDBD::SQLite::db::::column_info DBD::SQLite::db::column_info
0000s0sDBD::SQLite::db::::primary_key_info DBD::SQLite::db::primary_key_info
0000s0sDBD::SQLite::db::::table_info DBD::SQLite::db::table_info
0000s0sDBD::SQLite::db::::type_info_all DBD::SQLite::db::type_info_all
0000s0sDBD::SQLite::dr::::install_collation DBD::SQLite::dr::install_collation
0000s0sDBD::SQLite::dr::::regexp DBD::SQLite::dr::regexp
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package DBD::SQLite;
2
3346µs135µs
# spent 35µs within DBD::SQLite::BEGIN@3 which was called: # once (35µs+0s) by DBI::install_driver at line 3
use 5.006;
# spent 35µs making 1 call to DBD::SQLite::BEGIN@3
4322µs218µs
# spent 14µs (10+4) within DBD::SQLite::BEGIN@4 which was called: # once (10µs+4µs) by DBI::install_driver at line 4
use strict;
# spent 14µs making 1 call to DBD::SQLite::BEGIN@4 # spent 4µs making 1 call to strict::import
5336µs233µs
# spent 24µs (14+9) within DBD::SQLite::BEGIN@5 which was called: # once (14µs+9µs) by DBI::install_driver at line 5
use DBI 1.57 ();
# spent 24µs making 1 call to DBD::SQLite::BEGIN@5 # spent 9µs making 1 call to UNIVERSAL::VERSION
6320µs14µs
# spent 4µs within DBD::SQLite::BEGIN@6 which was called: # once (4µs+0s) by DBI::install_driver at line 6
use DynaLoader ();
# spent 4µs making 1 call to DBD::SQLite::BEGIN@6
7
8323µs294µs
# spent 51µs (8+43) within DBD::SQLite::BEGIN@8 which was called: # once (8µs+43µs) by DBI::install_driver at line 8
use vars qw($VERSION @ISA);
# spent 51µs making 1 call to DBD::SQLite::BEGIN@8 # spent 43µs making 1 call to vars::import
9318µs2104µs
# spent 55µs (6+49) within DBD::SQLite::BEGIN@9 which was called: # once (6µs+49µs) by DBI::install_driver at line 9
use vars qw{$err $errstr $drh $sqlite_version $sqlite_version_number};
# spent 55µs making 1 call to DBD::SQLite::BEGIN@9 # spent 49µs making 1 call to vars::import
10347µs242µs
# spent 24µs (6+18) within DBD::SQLite::BEGIN@10 which was called: # once (6µs+18µs) by DBI::install_driver at line 10
use vars qw{%COLLATION};
# spent 24µs making 1 call to DBD::SQLite::BEGIN@10 # spent 18µs making 1 call to vars::import
11
12
# spent 10µs within DBD::SQLite::BEGIN@12 which was called: # once (10µs+0s) by DBI::install_driver at line 25
BEGIN {
131300ns $VERSION = '1.35';
1417µs @ISA = 'DynaLoader';
15
16 # Initialize errors
171300ns $err = undef;
181100ns $errstr = undef;
19
20 # Driver singleton
211200ns $drh = undef;
22
23 # sqlite_version cache
2413µs $sqlite_version = undef;
25132µs110µs}
# spent 10µs making 1 call to DBD::SQLite::BEGIN@12
26
2717µs1566µs__PACKAGE__->bootstrap($VERSION);
# spent 566µs making 1 call to DynaLoader::bootstrap
28
29# New or old API?
30358µs2116µs
# spent 64µs (12+52) within DBD::SQLite::BEGIN@30 which was called: # once (12µs+52µs) by DBI::install_driver at line 30
use constant NEWAPI => ($DBI::VERSION >= 1.608);
# spent 64µs making 1 call to DBD::SQLite::BEGIN@30 # spent 52µs making 1 call to constant::import
31
3215µs19µstie %COLLATION, 'DBD::SQLite::_WriteOnceHash';
# spent 9µs making 1 call to DBD::SQLite::_WriteOnceHash::TIEHASH
33113µs13µs$COLLATION{perl} = sub { $_[0] cmp $_[1] };
# spent 3µs making 1 call to DBD::SQLite::_WriteOnceHash::STORE
344558µs317µs
# spent 13µs (10+3) within DBD::SQLite::BEGIN@34 which was called: # once (10µs+3µs) by DBI::install_driver at line 34
$COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] };
# spent 13µs making 1 call to DBD::SQLite::BEGIN@34 # spent 3µs making 1 call to locale::import # spent 2µs making 1 call to DBD::SQLite::_WriteOnceHash::STORE
35
361400nsmy $methods_are_installed = 0;
37
38
# spent 486µs (69+417) within DBD::SQLite::driver which was called: # once (69µs+417µs) by DBI::install_driver at line 808 of DBI.pm
sub driver {
391400ns return $drh if $drh;
40
4113µs if (!$methods_are_installed && $DBI::VERSION >= 1.608) {
4211µs118µs DBI->setup_driver('DBD::SQLite');
# spent 18µs making 1 call to DBI::setup_driver
43
4417µs152µs DBD::SQLite::db->install_method('sqlite_last_insert_rowid');
# spent 52µs making 1 call to DBD::_::common::install_method
4512µs122µs DBD::SQLite::db->install_method('sqlite_busy_timeout');
# spent 22µs making 1 call to DBD::_::common::install_method
4612µs120µs DBD::SQLite::db->install_method('sqlite_create_function');
# spent 20µs making 1 call to DBD::_::common::install_method
4712µs119µs DBD::SQLite::db->install_method('sqlite_create_aggregate');
# spent 19µs making 1 call to DBD::_::common::install_method
4812µs120µs DBD::SQLite::db->install_method('sqlite_create_collation');
# spent 20µs making 1 call to DBD::_::common::install_method
4912µs118µs DBD::SQLite::db->install_method('sqlite_collation_needed');
# spent 18µs making 1 call to DBD::_::common::install_method
5012µs123µs DBD::SQLite::db->install_method('sqlite_progress_handler');
# spent 23µs making 1 call to DBD::_::common::install_method
5112µs119µs DBD::SQLite::db->install_method('sqlite_commit_hook');
# spent 19µs making 1 call to DBD::_::common::install_method
5212µs119µs DBD::SQLite::db->install_method('sqlite_rollback_hook');
# spent 19µs making 1 call to DBD::_::common::install_method
5312µs122µs DBD::SQLite::db->install_method('sqlite_update_hook');
# spent 22µs making 1 call to DBD::_::common::install_method
5412µs119µs DBD::SQLite::db->install_method('sqlite_set_authorizer');
# spent 19µs making 1 call to DBD::_::common::install_method
5512µs121µs DBD::SQLite::db->install_method('sqlite_backup_from_file');
# spent 21µs making 1 call to DBD::_::common::install_method
5611µs121µs DBD::SQLite::db->install_method('sqlite_backup_to_file');
# spent 21µs making 1 call to DBD::_::common::install_method
5712µs118µs DBD::SQLite::db->install_method('sqlite_enable_load_extension');
# spent 18µs making 1 call to DBD::_::common::install_method
5812µs122µs DBD::SQLite::db->install_method('sqlite_register_fts3_perl_tokenizer');
# spent 22µs making 1 call to DBD::_::common::install_method
59
6011µs $methods_are_installed++;
61 }
62
6316µs163µs $drh = DBI::_new_drh( "$_[0]::dr", {
# spent 63µs making 1 call to DBI::_new_drh
64 Name => 'SQLite',
65 Version => $VERSION,
66 Attribution => 'DBD::SQLite by Matt Sergeant et al',
67 } );
68
6913µs return $drh;
70}
71
72sub CLONE {
73 undef $drh;
74}
75
76
77package DBD::SQLite::dr;
78
79
# spent 2.13ms (301µs+1.83) within DBD::SQLite::dr::connect which was called 6 times, avg 355µs/call: # 6 times (301µs+1.83ms) by DBI::dr::connect at line 658 of DBI.pm, avg 355µs/call
sub connect {
80612µs my ($drh, $dbname, $user, $auth, $attr) = @_;
81
82 # Default PrintWarn to the value of $^W
83 # unless ( defined $attr->{PrintWarn} ) {
84 # $attr->{PrintWarn} = $^W ? 1 : 0;
85 # }
86
87628µs6292µs my $dbh = DBI::_new_dbh( $drh, {
# spent 292µs making 6 calls to DBI::_new_dbh, avg 49µs/call
88 Name => $dbname,
89 } );
90
9165µs my $real = $dbname;
92634µs612µs if ( $dbname =~ /=/ ) {
# spent 12µs making 6 calls to DBD::SQLite::dr::CORE:match, avg 2µs/call
93623µs foreach my $attrib ( split(/;/, $dbname) ) {
94617µs my ($key, $value) = split(/=/, $attrib, 2);
95654µs630µs if ( $key =~ /^(?:db(?:name)?|database)$/ ) {
# spent 30µs making 6 calls to DBD::SQLite::dr::CORE:match, avg 5µs/call
96 $real = $value;
97 } else {
98 $attr->{$key} = $value;
99 }
100 }
101 }
102
103 # To avoid unicode and long file name problems on Windows,
104 # convert to the shortname if the file (or parent directory) exists.
105632µs610µs if ( $^O =~ /MSWin32/ and $real ne ':memory:' and $real ne '') {
# spent 10µs making 6 calls to DBD::SQLite::dr::CORE:match, avg 2µs/call
106 require Win32;
107 require File::Basename;
108 my ($file, $dir, $suffix) = File::Basename::fileparse($real);
109 my $short = Win32::GetShortPathName($real);
110 if ( $short && -f $short ) {
111 # Existing files will work directly.
112 $real = $short;
113 } elsif ( -d $dir ) {
114 # We are creating a new file.
115 # Does the directory it's in at least exist?
116 $real = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix;
117 } else {
118 # SQLite can't do mkpath anyway.
119 # So let it go through as it and fail.
120 }
121 }
122
123 # Hand off to the actual login function
12461.18ms61.15ms DBD::SQLite::db::_login($dbh, $real, $user, $auth, $attr) or return undef;
# spent 1.15ms making 6 calls to DBD::SQLite::db::_login, avg 191µs/call
125
126 # Register the on-demand collation installer, REGEXP function and
127 # perl tokenizer
12866µs if ( DBD::SQLite::NEWAPI ) {
129661µs629µs $dbh->sqlite_collation_needed( \&install_collation );
# spent 29µs making 6 calls to DBI::db::sqlite_collation_needed, avg 5µs/call
130659µs628µs $dbh->sqlite_create_function( "REGEXP", 2, \&regexp );
# spent 28µs making 6 calls to DBI::db::sqlite_create_function, avg 5µs/call
1316308µs6280µs $dbh->sqlite_register_fts3_perl_tokenizer();
# spent 280µs making 6 calls to DBI::db::sqlite_register_fts3_perl_tokenizer, avg 47µs/call
132 } else {
133 $dbh->func( \&install_collation, "collation_needed" );
134 $dbh->func( "REGEXP", 2, \&regexp, "create_function" );
135 $dbh->func( "register_fts3_perl_tokenizer" );
136 }
137
138 # HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings
139 # in DBD::SQLite we set Warn to false if PrintWarn is false.
140
141 # NOTE: According to the explanation by timbunce,
142 # "Warn is meant to report on bad practices or problems with
143 # the DBI itself (hence always on by default), while PrintWarn
144 # is meant to report warnings coming from the database."
145 # That is, if you want to disable an ineffective rollback warning
146 # etc (due to bad practices), you should turn off Warn,
147 # and to silence other warnings, turn off PrintWarn.
148 # Warn and PrintWarn are independent, and turning off PrintWarn
149 # does not silence those warnings that should be controlled by
150 # Warn.
151
152 # unless ( $attr->{PrintWarn} ) {
153 # $attr->{Warn} = 0;
154 # }
155
156625µs return $dbh;
157}
158
159sub install_collation {
160 my $dbh = shift;
161 my $name = shift;
162 my $collation = $DBD::SQLite::COLLATION{$name};
163 unless ($collation) {
164 warn "Can't install unknown collation: $name" if $dbh->{PrintWarn};
165 return;
166 }
167 if ( DBD::SQLite::NEWAPI ) {
168 $dbh->sqlite_create_collation( $name => $collation );
169 } else {
170 $dbh->func( $name => $collation, "create_collation" );
171 }
172}
173
174# default implementation for sqlite 'REGEXP' infix operator.
175# Note : args are reversed, i.e. "a REGEXP b" calls REGEXP(b, a)
176# (see http://www.sqlite.org/vtab.html#xfindfunction)
177sub regexp {
17831.44ms211µs
# spent 10µs (8+2) within DBD::SQLite::dr::BEGIN@178 which was called: # once (8µs+2µs) by DBI::install_driver at line 178
use locale;
# spent 10µs making 1 call to DBD::SQLite::dr::BEGIN@178 # spent 2µs making 1 call to locale::import
179 return if !defined $_[0] || !defined $_[1];
180 return scalar($_[1] =~ $_[0]);
181}
182
183package DBD::SQLite::db;
184
185
# spent 37.2ms (3.70+33.5) within DBD::SQLite::db::prepare which was called 145 times, avg 257µs/call: # 74 times (1.54ms+14.5ms) by DBI::db::prepare at line 1706 of DBI.pm, avg 217µs/call # 71 times (2.16ms+19.0ms) by DBI::db::prepare at line 206, avg 298µs/call
sub prepare {
186145163µs my $dbh = shift;
187145176µs my $sql = shift;
18814595µs $sql = '' unless defined $sql;
189
1901451.29ms14510.8ms my $sth = DBI::_new_sth( $dbh, {
# spent 10.8ms making 145 calls to DBI::_new_sth, avg 74µs/call
191 Statement => $sql,
192 } );
193
19414523.9ms14522.7ms DBD::SQLite::st::_prepare($sth, $sql, @_) or return undef;
# spent 22.7ms making 145 calls to DBD::SQLite::st::_prepare, avg 157µs/call
195
196143951µs return $sth;
197}
198
199
# spent 7.93s (11.0ms+7.91) within DBD::SQLite::db::do which was called 71 times, avg 112ms/call: # 71 times (11.0ms+7.91s) by DBI::db::do at line 2762 of DBIx/Class/Storage/DBI.pm, avg 112ms/call
sub do {
20071207µs my ($dbh, $statement, $attr, @bind_values) = @_;
201
20271209µs my @copy = @{[@bind_values]};
2037154µs my $rows = 0;
204
2057157µs2131.34ms while ($statement) {
# spent 1.02ms making 142 calls to DBI::common::DESTROY, avg 7µs/call # spent 316µs making 71 calls to DBD::_mem::common::DESTROY, avg 4µs/call
206711.17ms14243.2ms my $sth = $dbh->prepare($statement, $attr) or return undef;
# spent 22.0ms making 71 calls to DBI::db::prepare, avg 310µs/call # spent 21.2ms making 71 calls to DBD::SQLite::db::prepare, avg 298µs/call
207717.89s1427.89s $sth->execute(splice @copy, 0, $sth->{NUM_OF_PARAMS}) or return undef;
# spent 7.89s making 71 calls to DBI::st::execute, avg 111ms/call # spent 441µs making 71 calls to DBI::common::FETCH, avg 6µs/call
208712.02ms71870µs $rows += $sth->rows;
# spent 870µs making 71 calls to DBI::st::rows, avg 12µs/call
209 # XXX: not sure why but $dbh->{sqlite...} wouldn't work here
210716.32ms71860µs last unless $dbh->FETCH('sqlite_allow_multiple_statements');
# spent 860µs making 71 calls to DBI::common::FETCH, avg 12µs/call
211 $statement = $sth->{sqlite_unprepared_statements};
212 }
213
214 # always return true if no error
215711.17ms return ($rows == 0) ? "0E0" : $rows;
216}
217
218
# spent 29µs (21+8) within DBD::SQLite::db::_get_version which was called 4 times, avg 7µs/call: # 4 times (21µs+8µs) by DBD::SQLite::db::get_info at line 231, avg 7µs/call
sub _get_version {
219432µs48µs return ( DBD::SQLite::db::FETCH($_[0], 'sqlite_version') );
# spent 8µs making 4 calls to DBD::SQLite::db::FETCH, avg 2µs/call
220}
221
22215µsmy %info = (
223 17 => 'SQLite', # SQL_DBMS_NAME
224 18 => \&_get_version, # SQL_DBMS_VER
225 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR
226);
227
228
# spent 64µs (35+29) within DBD::SQLite::db::get_info which was called 4 times, avg 16µs/call: # 4 times (35µs+29µs) by DBI::db::get_info at line 1116 of DBIx/Class/Storage/DBI.pm, avg 16µs/call
sub get_info {
22943µs my($dbh, $info_type) = @_;
23049µs my $v = $info{int($info_type)};
231410µs429µs $v = $v->($dbh) if ref $v eq 'CODE';
# spent 29µs making 4 calls to DBD::SQLite::db::_get_version, avg 7µs/call
232415µs return $v;
233}
234
235sub _attached_database_list {
236 my $dbh = shift;
237 my @attached;
238
239 my $sth_databases = $dbh->prepare( 'PRAGMA database_list' );
240 $sth_databases->execute;
241 while ( my $db_info = $sth_databases->fetchrow_hashref ) {
242 push @attached, $db_info->{name} if $db_info->{seq} >= 2;
243 }
244 return @attached;
245}
246
247# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
248# Based on DBD::Oracle's
249# See also http://www.ch-werner.de/sqliteodbc/html/sqlite3odbc_8c.html#a213
250sub table_info {
251 my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val, $attr) = @_;
252
253 my @where = ();
254 my $sql;
255 if ( defined($cat_val) && $cat_val eq '%'
256 && defined($sch_val) && $sch_val eq ''
257 && defined($tbl_val) && $tbl_val eq '') { # Rule 19a
258 $sql = <<'END_SQL';
259SELECT NULL TABLE_CAT
260 , NULL TABLE_SCHEM
261 , NULL TABLE_NAME
262 , NULL TABLE_TYPE
263 , NULL REMARKS
264END_SQL
265 }
266 elsif ( defined($cat_val) && $cat_val eq ''
267 && defined($sch_val) && $sch_val eq '%'
268 && defined($tbl_val) && $tbl_val eq '') { # Rule 19b
269 $sql = <<'END_SQL';
270SELECT NULL TABLE_CAT
271 , t.tn TABLE_SCHEM
272 , NULL TABLE_NAME
273 , NULL TABLE_TYPE
274 , NULL REMARKS
275FROM (
276 SELECT 'main' tn
277 UNION SELECT 'temp' tn
278END_SQL
279 for my $db_name (_attached_database_list($dbh)) {
280 $sql .= " UNION SELECT '$db_name' tn\n";
281 }
282 $sql .= ") t\n";
283 }
284 elsif ( defined($cat_val) && $cat_val eq ''
285 && defined($sch_val) && $sch_val eq ''
286 && defined($tbl_val) && $tbl_val eq ''
287 && defined($typ_val) && $typ_val eq '%') { # Rule 19c
288 $sql = <<'END_SQL';
289SELECT NULL TABLE_CAT
290 , NULL TABLE_SCHEM
291 , NULL TABLE_NAME
292 , t.tt TABLE_TYPE
293 , NULL REMARKS
294FROM (
295 SELECT 'TABLE' tt UNION
296 SELECT 'VIEW' tt UNION
297 SELECT 'LOCAL TEMPORARY' tt
298) t
299ORDER BY TABLE_TYPE
300END_SQL
301 }
302 else {
303 $sql = <<'END_SQL';
304SELECT *
305FROM
306(
307SELECT NULL TABLE_CAT
308 , TABLE_SCHEM
309 , tbl_name TABLE_NAME
310 , TABLE_TYPE
311 , NULL REMARKS
312 , sql sqlite_sql
313FROM (
314 SELECT 'main' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql
315 FROM sqlite_master
316UNION ALL
317 SELECT 'temp' TABLE_SCHEM, tbl_name, 'LOCAL TEMPORARY' TABLE_TYPE, sql
318 FROM sqlite_temp_master
319END_SQL
320
321 for my $db_name (_attached_database_list($dbh)) {
322 $sql .= <<"END_SQL";
323UNION ALL
324 SELECT '$db_name' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql
325 FROM "$db_name".sqlite_master
326END_SQL
327 }
328
329 $sql .= <<'END_SQL';
330UNION ALL
331 SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
332UNION ALL
333 SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
334)
335)
336END_SQL
337 $attr = {} unless ref $attr eq 'HASH';
338 my $escape = defined $attr->{Escape} ? " ESCAPE '$attr->{Escape}'" : '';
339 if ( defined $sch_val ) {
340 push @where, "TABLE_SCHEM LIKE '$sch_val'$escape";
341 }
342 if ( defined $tbl_val ) {
343 push @where, "TABLE_NAME LIKE '$tbl_val'$escape";
344 }
345 if ( defined $typ_val ) {
346 my $table_type_list;
347 $typ_val =~ s/^\s+//;
348 $typ_val =~ s/\s+$//;
349 my @ttype_list = split (/\s*,\s*/, $typ_val);
350 foreach my $table_type (@ttype_list) {
351 if ($table_type !~ /^'.*'$/) {
352 $table_type = "'" . $table_type . "'";
353 }
354 }
355 $table_type_list = join(', ', @ttype_list);
356 push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list;
357 }
358 $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
359 $sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n";
360 }
361 my $sth = $dbh->prepare($sql) or return undef;
362 $sth->execute or return undef;
363 $sth;
364}
365
366sub primary_key_info {
367 my ($dbh, $catalog, $schema, $table, $attr) = @_;
368
369 # Escape the schema and table name
370 $schema =~ s/([\\_%])/\\$1/g if defined $schema;
371 my $escaped = $table;
372 $escaped =~ s/([\\_%])/\\$1/g;
373 $attr ||= {};
374 $attr->{Escape} = '\\';
375 my $sth_tables = $dbh->table_info($catalog, $schema, $escaped, undef, $attr);
376
377 # This is a hack but much simpler than using pragma index_list etc
378 # also the pragma doesn't list 'INTEGER PRIMARY KEY' autoinc PKs!
379 my @pk_info;
380 while ( my $row = $sth_tables->fetchrow_hashref ) {
381 my $sql = $row->{sqlite_sql} or next;
382 next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si;
383 my @pk = split /\s*,\s*/, $2 || '';
384 unless ( @pk ) {
385 my $prefix = $1;
386 $prefix =~ s/.*create\s+table\s+.*?\(\s*//si;
387 $prefix = (split /\s*,\s*/, $prefix)[-1];
388 @pk = (split /\s+/, $prefix)[0]; # take first word as name
389 }
390 my $key_seq = 0;
391 foreach my $pk_field (@pk) {
392 $pk_field =~ s/(["'`])(.+)\1/$2/; # dequote
393 $pk_field =~ s/\[(.+)\]/$1/; # dequote
394 push @pk_info, {
395 TABLE_SCHEM => $row->{TABLE_SCHEM},
396 TABLE_NAME => $row->{TABLE_NAME},
397 COLUMN_NAME => $pk_field,
398 KEY_SEQ => ++$key_seq,
399 PK_NAME => 'PRIMARY KEY',
400 };
401 }
402 }
403
404 my $sponge = DBI->connect("DBI:Sponge:", '','')
405 or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
406 my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME);
407 my $sth = $sponge->prepare( "primary_key_info $table", {
408 rows => [ map { [ @{$_}{@names} ] } @pk_info ],
409 NUM_OF_FIELDS => scalar @names,
410 NAME => \@names,
411 }) or return $dbh->DBI::set_err(
412 $sponge->err,
413 $sponge->errstr,
414 );
415 return $sth;
416}
417
418sub type_info_all {
419 return; # XXX code just copied from DBD::Oracle, not yet thought about
420# return [
421# {
422# TYPE_NAME => 0,
423# DATA_TYPE => 1,
424# COLUMN_SIZE => 2,
425# LITERAL_PREFIX => 3,
426# LITERAL_SUFFIX => 4,
427# CREATE_PARAMS => 5,
428# NULLABLE => 6,
429# CASE_SENSITIVE => 7,
430# SEARCHABLE => 8,
431# UNSIGNED_ATTRIBUTE => 9,
432# FIXED_PREC_SCALE => 10,
433# AUTO_UNIQUE_VALUE => 11,
434# LOCAL_TYPE_NAME => 12,
435# MINIMUM_SCALE => 13,
436# MAXIMUM_SCALE => 14,
437# SQL_DATA_TYPE => 15,
438# SQL_DATETIME_SUB => 16,
439# NUM_PREC_RADIX => 17,
440# },
441# [ 'CHAR', 1, 255, '\'', '\'', 'max length', 1, 1, 3,
442# undef, '0', '0', undef, undef, undef, 1, undef, undef
443# ],
444# [ 'NUMBER', 3, 38, undef, undef, 'precision,scale', 1, '0', 3,
445# '0', '0', '0', undef, '0', 38, 3, undef, 10
446# ],
447# [ 'DOUBLE', 8, 15, undef, undef, undef, 1, '0', 3,
448# '0', '0', '0', undef, undef, undef, 8, undef, 10
449# ],
450# [ 'DATE', 9, 19, '\'', '\'', undef, 1, '0', 3,
451# undef, '0', '0', undef, '0', '0', 11, undef, undef
452# ],
453# [ 'VARCHAR', 12, 1024*1024, '\'', '\'', 'max length', 1, 1, 3,
454# undef, '0', '0', undef, undef, undef, 12, undef, undef
455# ]
456# ];
457}
458
45913µsmy @COLUMN_INFO = qw(
460 TABLE_CAT
461 TABLE_SCHEM
462 TABLE_NAME
463 COLUMN_NAME
464 DATA_TYPE
465 TYPE_NAME
466 COLUMN_SIZE
467 BUFFER_LENGTH
468 DECIMAL_DIGITS
469 NUM_PREC_RADIX
470 NULLABLE
471 REMARKS
472 COLUMN_DEF
473 SQL_DATA_TYPE
474 SQL_DATETIME_SUB
475 CHAR_OCTET_LENGTH
476 ORDINAL_POSITION
477 IS_NULLABLE
478);
479
480sub column_info {
481 my ($dbh, $cat_val, $sch_val, $tbl_val, $col_val) = @_;
482
483 if ( defined $col_val and $col_val eq '%' ) {
484 $col_val = undef;
485 }
486
487 # Get a list of all tables ordered by TABLE_SCHEM, TABLE_NAME
488 my $sql = <<'END_SQL';
489SELECT TABLE_SCHEM, tbl_name TABLE_NAME
490FROM (
491 SELECT 'main' TABLE_SCHEM, tbl_name
492 FROM sqlite_master
493 WHERE type IN ('table','view')
494UNION ALL
495 SELECT 'temp' TABLE_SCHEM, tbl_name
496 FROM sqlite_temp_master
497 WHERE type IN ('table','view')
498END_SQL
499
500 for my $db_name (_attached_database_list($dbh)) {
501 $sql .= <<"END_SQL";
502UNION ALL
503 SELECT '$db_name' TABLE_SCHEM, tbl_name
504 FROM "$db_name".sqlite_master
505 WHERE type IN ('table','view')
506END_SQL
507 }
508
509 $sql .= <<'END_SQL';
510UNION ALL
511 SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name
512UNION ALL
513 SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name
514)
515END_SQL
516
517 my @where;
518 if ( defined $sch_val ) {
519 push @where, "TABLE_SCHEM LIKE '$sch_val'";
520 }
521 if ( defined $tbl_val ) {
522 push @where, "TABLE_NAME LIKE '$tbl_val'";
523 }
524 $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
525 $sql .= " ORDER BY TABLE_SCHEM, TABLE_NAME\n";
526 my $sth_tables = $dbh->prepare($sql) or return undef;
527 $sth_tables->execute or return undef;
528
529 # Taken from Fey::Loader::SQLite
530 my @cols;
531 while ( my ($schema, $table) = $sth_tables->fetchrow_array ) {
532 my $sth_columns = $dbh->prepare(qq{PRAGMA "$schema".table_info("$table")});
533 $sth_columns->execute;
534
535 for ( my $position = 1; my $col_info = $sth_columns->fetchrow_hashref; $position++ ) {
536 if ( defined $col_val ) {
537 # This must do a LIKE comparison
538 my $sth = $dbh->prepare("SELECT '$col_info->{name}' LIKE '$col_val'") or return undef;
539 $sth->execute or return undef;
540 # Skip columns that don't match $col_val
541 next unless ($sth->fetchrow_array)[0];
542 }
543
544 my %col = (
545 TABLE_SCHEM => $schema,
546 TABLE_NAME => $table,
547 COLUMN_NAME => $col_info->{name},
548 ORDINAL_POSITION => $position,
549 );
550
551 my $type = $col_info->{type};
552 if ( $type =~ s/(\w+) ?\((\d+)(?:,(\d+))?\)/$1/ ) {
553 $col{COLUMN_SIZE} = $2;
554 $col{DECIMAL_DIGITS} = $3;
555 }
556
557 $col{TYPE_NAME} = $type;
558
559 if ( defined $col_info->{dflt_value} ) {
560 $col{COLUMN_DEF} = $col_info->{dflt_value}
561 }
562
563 if ( $col_info->{notnull} ) {
564 $col{NULLABLE} = 0;
565 $col{IS_NULLABLE} = 'NO';
566 } else {
567 $col{NULLABLE} = 1;
568 $col{IS_NULLABLE} = 'YES';
569 }
570
571 push @cols, \%col;
572 }
573 $sth_columns->finish;
574 }
575 $sth_tables->finish;
576
577 my $sponge = DBI->connect("DBI:Sponge:", '','')
578 or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
579 $sponge->prepare( "column_info", {
580 rows => [ map { [ @{$_}{@COLUMN_INFO} ] } @cols ],
581 NUM_OF_FIELDS => scalar @COLUMN_INFO,
582 NAME => [ @COLUMN_INFO ],
583 } ) or return $dbh->DBI::set_err(
584 $sponge->err,
585 $sponge->errstr,
586 );
587}
588
589#======================================================================
590# An internal tied hash package used for %DBD::SQLite::COLLATION, to
591# prevent people from unintentionally overriding globally registered collations.
592
593package DBD::SQLite::_WriteOnceHash;
594
59511µsrequire Tie::Hash;
596
597114µsour @ISA = qw(Tie::StdHash);
598
599
# spent 9µs within DBD::SQLite::_WriteOnceHash::TIEHASH which was called: # once (9µs+0s) by DBI::install_driver at line 32
sub TIEHASH {
600112µs bless {}, $_[0];
601}
602
603
# spent 5µs within DBD::SQLite::_WriteOnceHash::STORE which was called 2 times, avg 2µs/call: # once (3µs+0s) by DBI::install_driver at line 33 # once (2µs+0s) by DBI::install_driver at line 34
sub STORE {
60422µs ! exists $_[0]->{$_[1]} or die "entry $_[1] already registered";
60527µs $_[0]->{$_[1]} = $_[2];
606}
607
608sub DELETE {
609 die "deletion of entry $_[1] is forbidden";
610}
611
612112µs1;
613
614__END__
 
# spent 248µs within DBD::SQLite::bootstrap which was called: # once (248µs+0s) by DynaLoader::bootstrap at line 223 of DynaLoader.pm
sub DBD::SQLite::bootstrap; # xsub
# spent 8µs within DBD::SQLite::db::FETCH which was called 4 times, avg 2µs/call: # 4 times (8µs+0s) by DBD::SQLite::db::_get_version at line 219, avg 2µs/call
sub DBD::SQLite::db::FETCH; # xsub
# spent 1.15ms within DBD::SQLite::db::_login which was called 6 times, avg 191µs/call: # 6 times (1.15ms+0s) by DBD::SQLite::dr::connect at line 124, avg 191µs/call
sub DBD::SQLite::db::_login; # xsub
# spent 52µs within DBD::SQLite::dr::CORE:match which was called 18 times, avg 3µs/call: # 6 times (30µs+0s) by DBD::SQLite::dr::connect at line 95, avg 5µs/call # 6 times (12µs+0s) by DBD::SQLite::dr::connect at line 92, avg 2µs/call # 6 times (10µs+0s) by DBD::SQLite::dr::connect at line 105, avg 2µs/call
sub DBD::SQLite::dr::CORE:match; # opcode