← Index
NYTProf Performance Profile   « block view • line view • sub view »
For reply.pl
  Run on Thu Oct 21 22:40:13 2010
Reported on Thu Oct 21 22:44:43 2010

Filename/home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/x86_64-linux/DBD/SQLite.pm
StatementsExecuted 292 statements in 5.45ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
3143630µs2.97msDBD::SQLite::db::::prepare DBD::SQLite::db::prepare
111210µs210µsDBD::SQLite::::bootstrap DBD::SQLite::bootstrap (xsub)
111202µs206µsDBD::SQLite::::BEGIN@34 DBD::SQLite::BEGIN@34
322173µs929µsDBD::SQLite::db::::do DBD::SQLite::db::do
111167µs167µsDBD::SQLite::db::::_login DBD::SQLite::db::_login (xsub)
111110µs809µsDBD::SQLite::::driver DBD::SQLite::driver
11167µs351µsDBD::SQLite::dr::::connect DBD::SQLite::dr::connect
11140µs40µsDBD::SQLite::::BEGIN@3 DBD::SQLite::BEGIN@3
11119µs26µsDBD::SQLite::::BEGIN@4 DBD::SQLite::BEGIN@4
11117µs28µsDBD::SQLite::::BEGIN@5 DBD::SQLite::BEGIN@5
11114µs14µsDBD::SQLite::::BEGIN@12 DBD::SQLite::BEGIN@12
11113µs90µsDBD::SQLite::::BEGIN@30 DBD::SQLite::BEGIN@30
11113µs76µsDBD::SQLite::::BEGIN@8 DBD::SQLite::BEGIN@8
11112µs15µsDBD::SQLite::dr::::BEGIN@165 DBD::SQLite::dr::BEGIN@165
11110µs41µsDBD::SQLite::::BEGIN@10 DBD::SQLite::BEGIN@10
11110µs122µsDBD::SQLite::::BEGIN@9 DBD::SQLite::BEGIN@9
1119µs9µsDBD::SQLite::_WriteOnceHash::::TIEHASHDBD::SQLite::_WriteOnceHash::TIEHASH
2219µs9µsDBD::SQLite::_WriteOnceHash::::STOREDBD::SQLite::_WriteOnceHash::STORE
1116µs6µsDBD::SQLite::::BEGIN@6 DBD::SQLite::BEGIN@6
2214µs4µsDBD::SQLite::dr::::CORE:match DBD::SQLite::dr::CORE:match (opcode)
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::::_get_version DBD::SQLite::db::_get_version
0000s0sDBD::SQLite::db::::column_info DBD::SQLite::db::column_info
0000s0sDBD::SQLite::db::::get_info DBD::SQLite::db::get_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
3245µs140µs
# spent 40µs within DBD::SQLite::BEGIN@3 which was called: # once (40µs+0s) by DBI::install_driver at line 3
use 5.006;
# spent 40µs making 1 call to DBD::SQLite::BEGIN@3
4230µs232µs
# spent 26µs (19+6) within DBD::SQLite::BEGIN@4 which was called: # once (19µs+6µs) by DBI::install_driver at line 4
use strict;
# spent 26µs making 1 call to DBD::SQLite::BEGIN@4 # spent 6µs making 1 call to strict::import
5344µs239µs
# spent 28µs (17+11) within DBD::SQLite::BEGIN@5 which was called: # once (17µs+11µs) by DBI::install_driver at line 5
use DBI 1.57 ();
# spent 28µs making 1 call to DBD::SQLite::BEGIN@5 # spent 11µs making 1 call to UNIVERSAL::VERSION
6225µs16µs
# spent 6µs within DBD::SQLite::BEGIN@6 which was called: # once (6µs+0s) by DBI::install_driver at line 6
use DynaLoader ();
# spent 6µs making 1 call to DBD::SQLite::BEGIN@6
7
8230µs2139µs
# spent 76µs (13+63) within DBD::SQLite::BEGIN@8 which was called: # once (13µs+63µs) by DBI::install_driver at line 8
use vars qw($VERSION @ISA);
# spent 76µs making 1 call to DBD::SQLite::BEGIN@8 # spent 63µs making 1 call to vars::import
9230µs2234µs
# spent 122µs (10+112) within DBD::SQLite::BEGIN@9 which was called: # once (10µs+112µs) by DBI::install_driver at line 9
use vars qw{$err $errstr $drh $sqlite_version $sqlite_version_number};
# spent 122µs making 1 call to DBD::SQLite::BEGIN@9 # spent 112µs making 1 call to vars::import
10250µs272µs
# spent 41µs (10+31) within DBD::SQLite::BEGIN@10 which was called: # once (10µs+31µs) by DBI::install_driver at line 10
use vars qw{%COLLATION};
# spent 41µs making 1 call to DBD::SQLite::BEGIN@10 # spent 31µs making 1 call to vars::import
11
12
# spent 14µs within DBD::SQLite::BEGIN@12 which was called: # once (14µs+0s) by DBI::install_driver at line 25
BEGIN {
1311µs $VERSION = '1.31';
1416µs @ISA = 'DynaLoader';
15
16 # Initialize errors
1711µs $err = undef;
181700ns $errstr = undef;
19
20 # Driver singleton
211800ns $drh = undef;
22
23 # sqlite_version cache
2415µs $sqlite_version = undef;
25134µs114µs}
# spent 14µs making 1 call to DBD::SQLite::BEGIN@12
26
2718µs1607µs__PACKAGE__->bootstrap($VERSION);
# spent 607µs making 1 call to DynaLoader::bootstrap
28
29# New or old API?
30262µs2168µs
# spent 90µs (13+77) within DBD::SQLite::BEGIN@30 which was called: # once (13µs+77µs) by DBI::install_driver at line 30
use constant NEWAPI => ($DBI::VERSION >= 1.608);
# spent 90µs making 1 call to DBD::SQLite::BEGIN@30 # spent 77µs making 1 call to constant::import
31
3217µs19µstie %COLLATION, 'DBD::SQLite::_WriteOnceHash';
# spent 9µs making 1 call to DBD::SQLite::_WriteOnceHash::TIEHASH
33112µs15µs$COLLATION{perl} = sub { $_[0] cmp $_[1] };
# spent 5µs making 1 call to DBD::SQLite::_WriteOnceHash::STORE
343812µs3215µs
# spent 206µs (202+4) within DBD::SQLite::BEGIN@34 which was called: # once (202µs+4µs) by DBI::install_driver at line 34
$COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] };
# spent 206µs making 1 call to DBD::SQLite::BEGIN@34 # spent 4µs making 1 call to DBD::SQLite::_WriteOnceHash::STORE # spent 4µs making 1 call to locale::import
35
3611µsmy $methods_are_installed = 0;
37
38
# spent 809µs (110+699) within DBD::SQLite::driver which was called: # once (110µs+699µs) by DBI::install_driver at line 814 of DBI.pm
sub driver {
391800ns return $drh if $drh;
40
4113µs if (!$methods_are_installed && $DBI::VERSION >= 1.608) {
4214µs145µs DBI->setup_driver('DBD::SQLite');
# spent 45µs making 1 call to DBI::setup_driver
43
4419µs161µs DBD::SQLite::db->install_method('sqlite_last_insert_rowid');
# spent 61µs making 1 call to DBD::_::common::install_method
4514µs139µs DBD::SQLite::db->install_method('sqlite_busy_timeout');
# spent 39µs making 1 call to DBD::_::common::install_method
4614µs137µs DBD::SQLite::db->install_method('sqlite_create_function');
# spent 37µs making 1 call to DBD::_::common::install_method
4714µs137µs DBD::SQLite::db->install_method('sqlite_create_aggregate');
# spent 37µs making 1 call to DBD::_::common::install_method
4814µs138µs DBD::SQLite::db->install_method('sqlite_create_collation');
# spent 38µs making 1 call to DBD::_::common::install_method
4914µs137µs DBD::SQLite::db->install_method('sqlite_collation_needed');
# spent 37µs making 1 call to DBD::_::common::install_method
5014µs136µs DBD::SQLite::db->install_method('sqlite_progress_handler');
# spent 36µs making 1 call to DBD::_::common::install_method
5114µs140µs DBD::SQLite::db->install_method('sqlite_commit_hook');
# spent 40µs making 1 call to DBD::_::common::install_method
5214µs138µs DBD::SQLite::db->install_method('sqlite_rollback_hook');
# spent 38µs making 1 call to DBD::_::common::install_method
5314µs137µs DBD::SQLite::db->install_method('sqlite_update_hook');
# spent 37µs making 1 call to DBD::_::common::install_method
5415µs137µs DBD::SQLite::db->install_method('sqlite_set_authorizer');
# spent 37µs making 1 call to DBD::_::common::install_method
5514µs138µs DBD::SQLite::db->install_method('sqlite_backup_from_file');
# spent 38µs making 1 call to DBD::_::common::install_method
5614µs141µs DBD::SQLite::db->install_method('sqlite_backup_to_file');
# spent 41µs making 1 call to DBD::_::common::install_method
5714µs140µs DBD::SQLite::db->install_method('sqlite_enable_load_extension');
# spent 40µs making 1 call to DBD::_::common::install_method
5814µs137µs DBD::SQLite::db->install_method('sqlite_register_fts3_perl_tokenizer');
# spent 37µs making 1 call to DBD::_::common::install_method
5911µs $methods_are_installed++;
60 }
61
6218µs161µs $drh = DBI::_new_drh( "$_[0]::dr", {
# spent 61µs making 1 call to DBI::_new_drh
63 Name => 'SQLite',
64 Version => $VERSION,
65 Attribution => 'DBD::SQLite by Matt Sergeant et al',
66 } );
67
6814µs return $drh;
69}
70
71sub CLONE {
72 undef $drh;
73}
74
75
76package DBD::SQLite::dr;
77
78
# spent 351µs (67+284) within DBD::SQLite::dr::connect which was called: # once (67µs+284µs) by DBI::dr::connect at line 665 of DBI.pm
sub connect {
7912µs my ($drh, $dbname, $user, $auth, $attr) = @_;
80
81 # Default PrintWarn to the value of $^W
8212µs unless ( defined $attr->{PrintWarn} ) {
83 $attr->{PrintWarn} = $^W ? 1 : 0;
84 }
85
8615µs148µs my $dbh = DBI::_new_dbh( $drh, {
# spent 48µs making 1 call to DBI::_new_dbh
87 Name => $dbname,
88 } );
89
9011µs my $real = $dbname;
9118µs12µs if ( $dbname =~ /=/ ) {
# spent 2µs making 1 call to DBD::SQLite::dr::CORE:match
9213µs foreach my $attrib ( split(/;/, $dbname) ) {
9312µs my ($key, $value) = split(/=/, $attrib, 2);
9413µs if ( $key eq 'dbname' ) {
95 $real = $value;
96 } else {
97 $attr->{$key} = $value;
98 }
99 }
100 }
101
102 # To avoid unicode and long file name problems on Windows,
103 # convert to the shortname if the file (or parent directory) exists.
10416µs12µs if ( $^O =~ /MSWin32/ and $real ne ':memory:' and $real ne '') {
# spent 2µs making 1 call to DBD::SQLite::dr::CORE:match
105 require Win32;
106 require File::Basename;
107 my ($file, $dir, $suffix) = File::Basename::fileparse($real);
108 my $short = Win32::GetShortPathName($real);
109 if ( $short && -f $short ) {
110 # Existing files will work directly.
111 $real = $short;
112 } elsif ( -d $dir ) {
113 # We are creating a new file.
114 # Does the directory it's in at least exist?
115 $real = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix;
116 } else {
117 # SQLite can't do mkpath anyway.
118 # So let it go through as it and fail.
119 }
120 }
121
122 # Hand off to the actual login function
1231175µs1167µs DBD::SQLite::db::_login($dbh, $real, $user, $auth, $attr) or return undef;
# spent 167µs making 1 call to DBD::SQLite::db::_login
124
125 # Register the on-demand collation installer, REGEXP function and
126 # perl tokenizer
12712µs if ( DBD::SQLite::NEWAPI ) {
128114µs17µs $dbh->sqlite_collation_needed( \&install_collation );
# spent 7µs making 1 call to DBI::db::sqlite_collation_needed
129110µs14µs $dbh->sqlite_create_function( "REGEXP", 2, \&regexp );
# spent 4µs making 1 call to DBI::db::sqlite_create_function
130162µs155µs $dbh->sqlite_register_fts3_perl_tokenizer();
# spent 55µs making 1 call to DBI::db::sqlite_register_fts3_perl_tokenizer
131 } else {
132 $dbh->func( \&install_collation, "collation_needed" );
133 $dbh->func( "REGEXP", 2, \&regexp, "create_function" );
134 $dbh->func( "register_fts3_perl_tokenizer" );
135 }
136
137 # HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings
138 # in DBD::SQLite we set Warn to false if PrintWarn is false.
13912µs unless ( $attr->{PrintWarn} ) {
140 $attr->{Warn} = 0;
141 }
142
14315µs return $dbh;
144}
145
146sub install_collation {
147 my $dbh = shift;
148 my $name = shift;
149 my $collation = $DBD::SQLite::COLLATION{$name};
150 unless ($collation) {
151 warn "Can't install unknown collation: $name" if $dbh->{PrintWarn};
152 return;
153 }
154 if ( DBD::SQLite::NEWAPI ) {
155 $dbh->sqlite_create_collation( $name => $collation );
156 } else {
157 $dbh->func( $name => $collation, "create_collation" );
158 }
159}
160
161# default implementation for sqlite 'REGEXP' infix operator.
162# Note : args are reversed, i.e. "a REGEXP b" calls REGEXP(b, a)
163# (see http://www.sqlite.org/vtab.html#xfindfunction)
164sub regexp {
16521.56ms219µs
# spent 15µs (12+4) within DBD::SQLite::dr::BEGIN@165 which was called: # once (12µs+4µs) by DBI::install_driver at line 165
use locale;
# spent 15µs making 1 call to DBD::SQLite::dr::BEGIN@165 # spent 4µs making 1 call to locale::import
166 return scalar($_[1] =~ $_[0]);
167}
168
169package DBD::SQLite::db;
170
171
# spent 2.97ms (630µs+2.34) within DBD::SQLite::db::prepare which was called 31 times, avg 96µs/call: # 26 times (527µs+1.63ms) by DBI::db::prepare at line 158 of Hailo/Storage/Schema.pm, avg 83µs/call # 3 times (61µs+585µs) by DBI::db::prepare at line 192, avg 215µs/call # once (21µs+68µs) by DBI::db::prepare at line 143 of Hailo/Storage.pm # once (20µs+62µs) by DBI::db::prepare at line 174 of Hailo/Storage.pm
sub prepare {
1723141µs my $dbh = shift;
1733143µs my $sql = shift;
1743136µs $sql = '' unless defined $sql;
175
17631185µs311.03ms my $sth = DBI::_new_sth( $dbh, {
# spent 1.03ms making 31 calls to DBI::_new_sth, avg 33µs/call
177 Statement => $sql,
178 } );
179
180311.49ms311.31ms DBD::SQLite::st::_prepare($sth, $sql, @_) or return undef;
# spent 1.31ms making 31 calls to DBD::SQLite::st::_prepare, avg 42µs/call
181
18231159µs return $sth;
183}
184
185
# spent 929µs (173+755) within DBD::SQLite::db::do which was called 3 times, avg 310µs/call: # 2 times (100µs+257µs) by DBI::db::do at line 115 of Hailo/Storage/SQLite.pm, avg 178µs/call # once (73µs+499µs) by DBI::db::do at line 248 of Hailo/Storage.pm
sub do {
18638µs my ($dbh, $statement, $attr, @bind_values) = @_;
187
18837µs my @copy = @{[@bind_values]};
18934µs my $rows = 0;
190
19134µs927µs while ($statement) {
# spent 21µs making 6 calls to DBI::common::DESTROY, avg 3µs/call # spent 6µs making 3 calls to DBD::_mem::common::DESTROY, avg 2µs/call
192338µs61.32ms my $sth = $dbh->prepare($statement, $attr) or return undef;
# spent 672µs making 3 calls to DBI::db::prepare, avg 224µs/call # spent 646µs making 3 calls to DBD::SQLite::db::prepare, avg 215µs/call
193383µs638µs $sth->execute(splice @copy, 0, $sth->{NUM_OF_PARAMS}) or return undef;
# spent 24µs making 3 calls to DBI::st::execute, avg 8µs/call # spent 14µs making 3 calls to DBI::common::FETCH, avg 5µs/call
194326µs39µs $rows += $sth->rows;
# spent 9µs making 3 calls to DBI::st::rows, avg 3µs/call
195 # XXX: not sure why but $dbh->{sqlite...} wouldn't work here
196394µs39µs last unless $dbh->FETCH('sqlite_allow_multiple_statements');
# spent 9µs making 3 calls to DBI::common::FETCH, avg 3µs/call
197 $statement = $sth->{sqlite_unprepared_statements};
198 }
199
200 # always return true if no error
201317µs return ($rows == 0) ? "0E0" : $rows;
202}
203
204sub _get_version {
205 return ( DBD::SQLite::db::FETCH($_[0], 'sqlite_version') );
206}
207
20814µsmy %info = (
209 17 => 'SQLite', # SQL_DBMS_NAME
210 18 => \&_get_version, # SQL_DBMS_VER
211 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR
212);
213
214sub get_info {
215 my($dbh, $info_type) = @_;
216 my $v = $info{int($info_type)};
217 $v = $v->($dbh) if ref $v eq 'CODE';
218 return $v;
219}
220
221sub _attached_database_list {
222 my $dbh = shift;
223 my @attached;
224
225 my $sth_databases = $dbh->prepare( 'PRAGMA database_list' );
226 $sth_databases->execute;
227 while ( my $db_info = $sth_databases->fetchrow_hashref ) {
228 push @attached, $db_info->{name} if $db_info->{seq} >= 2;
229 }
230 return @attached;
231}
232
233# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
234# Based on DBD::Oracle's
235# See also http://www.ch-werner.de/sqliteodbc/html/sqlite3odbc_8c.html#a213
236sub table_info {
237 my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val, $attr) = @_;
238
239 my @where = ();
240 my $sql;
241 if ( defined($cat_val) && $cat_val eq '%'
242 && defined($sch_val) && $sch_val eq ''
243 && defined($tbl_val) && $tbl_val eq '') { # Rule 19a
244 $sql = <<'END_SQL';
245SELECT NULL TABLE_CAT
246 , NULL TABLE_SCHEM
247 , NULL TABLE_NAME
248 , NULL TABLE_TYPE
249 , NULL REMARKS
250END_SQL
251 }
252 elsif ( defined($cat_val) && $cat_val eq ''
253 && defined($sch_val) && $sch_val eq '%'
254 && defined($tbl_val) && $tbl_val eq '') { # Rule 19b
255 $sql = <<'END_SQL';
256SELECT NULL TABLE_CAT
257 , t.tn TABLE_SCHEM
258 , NULL TABLE_NAME
259 , NULL TABLE_TYPE
260 , NULL REMARKS
261FROM (
262 SELECT 'main' tn
263 UNION SELECT 'temp' tn
264END_SQL
265 for my $db_name (_attached_database_list($dbh)) {
266 $sql .= " UNION SELECT '$db_name' tn\n";
267 }
268 $sql .= ") t\n";
269 }
270 elsif ( defined($cat_val) && $cat_val eq ''
271 && defined($sch_val) && $sch_val eq ''
272 && defined($tbl_val) && $tbl_val eq ''
273 && defined($typ_val) && $typ_val eq '%') { # Rule 19c
274 $sql = <<'END_SQL';
275SELECT NULL TABLE_CAT
276 , NULL TABLE_SCHEM
277 , NULL TABLE_NAME
278 , t.tt TABLE_TYPE
279 , NULL REMARKS
280FROM (
281 SELECT 'TABLE' tt UNION
282 SELECT 'VIEW' tt UNION
283 SELECT 'LOCAL TEMPORARY' tt
284) t
285ORDER BY TABLE_TYPE
286END_SQL
287 }
288 else {
289 $sql = <<'END_SQL';
290SELECT *
291FROM
292(
293SELECT NULL TABLE_CAT
294 , TABLE_SCHEM
295 , tbl_name TABLE_NAME
296 , TABLE_TYPE
297 , NULL REMARKS
298 , sql sqlite_sql
299FROM (
300 SELECT 'main' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql
301 FROM sqlite_master
302UNION ALL
303 SELECT 'temp' TABLE_SCHEM, tbl_name, 'LOCAL TEMPORARY' TABLE_TYPE, sql
304 FROM sqlite_temp_master
305END_SQL
306
307 for my $db_name (_attached_database_list($dbh)) {
308 $sql .= <<"END_SQL";
309UNION ALL
310 SELECT '$db_name' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql
311 FROM "$db_name".sqlite_master
312END_SQL
313 }
314
315 $sql .= <<'END_SQL';
316UNION ALL
317 SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
318UNION ALL
319 SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
320)
321)
322END_SQL
323 $attr = {} unless ref $attr eq 'HASH';
324 my $escape = defined $attr->{Escape} ? " ESCAPE '$attr->{Escape}'" : '';
325 if ( defined $sch_val ) {
326 push @where, "TABLE_SCHEM LIKE '$sch_val'$escape";
327 }
328 if ( defined $tbl_val ) {
329 push @where, "TABLE_NAME LIKE '$tbl_val'$escape";
330 }
331 if ( defined $typ_val ) {
332 my $table_type_list;
333 $typ_val =~ s/^\s+//;
334 $typ_val =~ s/\s+$//;
335 my @ttype_list = split (/\s*,\s*/, $typ_val);
336 foreach my $table_type (@ttype_list) {
337 if ($table_type !~ /^'.*'$/) {
338 $table_type = "'" . $table_type . "'";
339 }
340 }
341 $table_type_list = join(', ', @ttype_list);
342 push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list;
343 }
344 $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
345 $sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n";
346 }
347 my $sth = $dbh->prepare($sql) or return undef;
348 $sth->execute or return undef;
349 $sth;
350}
351
352sub primary_key_info {
353 my ($dbh, $catalog, $schema, $table, $attr) = @_;
354
355 # Escape the schema and table name
356 $schema =~ s/([\\_%])/\\$1/g if defined $schema;
357 my $escaped = $table;
358 $escaped =~ s/([\\_%])/\\$1/g;
359 $attr ||= {};
360 $attr->{Escape} = '\\';
361 my $sth_tables = $dbh->table_info($catalog, $schema, $escaped, undef, $attr);
362
363 # This is a hack but much simpler than using pragma index_list etc
364 # also the pragma doesn't list 'INTEGER PRIMARY KEY' autoinc PKs!
365 my @pk_info;
366 while ( my $row = $sth_tables->fetchrow_hashref ) {
367 my $sql = $row->{sqlite_sql} or next;
368 next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si;
369 my @pk = split /\s*,\s*/, $2 || '';
370 unless ( @pk ) {
371 my $prefix = $1;
372 $prefix =~ s/.*create\s+table\s+.*?\(\s*//si;
373 $prefix = (split /\s*,\s*/, $prefix)[-1];
374 @pk = (split /\s+/, $prefix)[0]; # take first word as name
375 }
376 my $key_seq = 0;
377 foreach my $pk_field (@pk) {
378 $pk_field =~ s/(["'`])(.+)\1/$2/; # dequote
379 $pk_field =~ s/\[(.+)\]/$1/; # dequote
380 push @pk_info, {
381 TABLE_SCHEM => $row->{TABLE_SCHEM},
382 TABLE_NAME => $row->{TABLE_NAME},
383 COLUMN_NAME => $pk_field,
384 KEY_SEQ => ++$key_seq,
385 PK_NAME => 'PRIMARY KEY',
386 };
387 }
388 }
389
390 my $sponge = DBI->connect("DBI:Sponge:", '','')
391 or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
392 my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME);
393 my $sth = $sponge->prepare( "primary_key_info $table", {
394 rows => [ map { [ @{$_}{@names} ] } @pk_info ],
395 NUM_OF_FIELDS => scalar @names,
396 NAME => \@names,
397 }) or return $dbh->DBI::set_err(
398 $sponge->err,
399 $sponge->errstr,
400 );
401 return $sth;
402}
403
404sub type_info_all {
405 return; # XXX code just copied from DBD::Oracle, not yet thought about
406# return [
407# {
408# TYPE_NAME => 0,
409# DATA_TYPE => 1,
410# COLUMN_SIZE => 2,
411# LITERAL_PREFIX => 3,
412# LITERAL_SUFFIX => 4,
413# CREATE_PARAMS => 5,
414# NULLABLE => 6,
415# CASE_SENSITIVE => 7,
416# SEARCHABLE => 8,
417# UNSIGNED_ATTRIBUTE => 9,
418# FIXED_PREC_SCALE => 10,
419# AUTO_UNIQUE_VALUE => 11,
420# LOCAL_TYPE_NAME => 12,
421# MINIMUM_SCALE => 13,
422# MAXIMUM_SCALE => 14,
423# SQL_DATA_TYPE => 15,
424# SQL_DATETIME_SUB => 16,
425# NUM_PREC_RADIX => 17,
426# },
427# [ 'CHAR', 1, 255, '\'', '\'', 'max length', 1, 1, 3,
428# undef, '0', '0', undef, undef, undef, 1, undef, undef
429# ],
430# [ 'NUMBER', 3, 38, undef, undef, 'precision,scale', 1, '0', 3,
431# '0', '0', '0', undef, '0', 38, 3, undef, 10
432# ],
433# [ 'DOUBLE', 8, 15, undef, undef, undef, 1, '0', 3,
434# '0', '0', '0', undef, undef, undef, 8, undef, 10
435# ],
436# [ 'DATE', 9, 19, '\'', '\'', undef, 1, '0', 3,
437# undef, '0', '0', undef, '0', '0', 11, undef, undef
438# ],
439# [ 'VARCHAR', 12, 1024*1024, '\'', '\'', 'max length', 1, 1, 3,
440# undef, '0', '0', undef, undef, undef, 12, undef, undef
441# ]
442# ];
443}
444
44516µsmy @COLUMN_INFO = qw(
446 TABLE_CAT
447 TABLE_SCHEM
448 TABLE_NAME
449 COLUMN_NAME
450 DATA_TYPE
451 TYPE_NAME
452 COLUMN_SIZE
453 BUFFER_LENGTH
454 DECIMAL_DIGITS
455 NUM_PREC_RADIX
456 NULLABLE
457 REMARKS
458 COLUMN_DEF
459 SQL_DATA_TYPE
460 SQL_DATETIME_SUB
461 CHAR_OCTET_LENGTH
462 ORDINAL_POSITION
463 IS_NULLABLE
464);
465
466sub column_info {
467 my ($dbh, $cat_val, $sch_val, $tbl_val, $col_val) = @_;
468
469 if ( defined $col_val and $col_val eq '%' ) {
470 $col_val = undef;
471 }
472
473 # Get a list of all tables ordered by TABLE_SCHEM, TABLE_NAME
474 my $sql = <<'END_SQL';
475SELECT TABLE_SCHEM, tbl_name TABLE_NAME
476FROM (
477 SELECT 'main' TABLE_SCHEM, tbl_name
478 FROM sqlite_master
479 WHERE type IN ('table','view')
480UNION ALL
481 SELECT 'temp' TABLE_SCHEM, tbl_name
482 FROM sqlite_temp_master
483 WHERE type IN ('table','view')
484END_SQL
485
486 for my $db_name (_attached_database_list($dbh)) {
487 $sql .= <<"END_SQL";
488UNION ALL
489 SELECT '$db_name' TABLE_SCHEM, tbl_name
490 FROM "$db_name".sqlite_master
491 WHERE type IN ('table','view')
492END_SQL
493 }
494
495 $sql .= <<'END_SQL';
496UNION ALL
497 SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name
498UNION ALL
499 SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name
500)
501END_SQL
502
503 my @where;
504 if ( defined $sch_val ) {
505 push @where, "TABLE_SCHEM LIKE '$sch_val'";
506 }
507 if ( defined $tbl_val ) {
508 push @where, "TABLE_NAME LIKE '$tbl_val'";
509 }
510 $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
511 $sql .= " ORDER BY TABLE_SCHEM, TABLE_NAME\n";
512 my $sth_tables = $dbh->prepare($sql) or return undef;
513 $sth_tables->execute or return undef;
514
515 # Taken from Fey::Loader::SQLite
516 my @cols;
517 while ( my ($schema, $table) = $sth_tables->fetchrow_array ) {
518 my $sth_columns = $dbh->prepare(qq{PRAGMA "$schema".table_info("$table")});
519 $sth_columns->execute;
520
521 for ( my $position = 1; my $col_info = $sth_columns->fetchrow_hashref; $position++ ) {
522 if ( defined $col_val ) {
523 # This must do a LIKE comparison
524 my $sth = $dbh->prepare("SELECT '$col_info->{name}' LIKE '$col_val'") or return undef;
525 $sth->execute or return undef;
526 # Skip columns that don't match $col_val
527 next unless ($sth->fetchrow_array)[0];
528 }
529
530 my %col = (
531 TABLE_SCHEM => $schema,
532 TABLE_NAME => $table,
533 COLUMN_NAME => $col_info->{name},
534 ORDINAL_POSITION => $position,
535 );
536
537 my $type = $col_info->{type};
538 if ( $type =~ s/(\w+) ?\((\d+)(?:,(\d+))?\)/$1/ ) {
539 $col{COLUMN_SIZE} = $2;
540 $col{DECIMAL_DIGITS} = $3;
541 }
542
543 $col{TYPE_NAME} = $type;
544
545 if ( defined $col_info->{dflt_value} ) {
546 $col{COLUMN_DEF} = $col_info->{dflt_value}
547 }
548
549 if ( $col_info->{notnull} ) {
550 $col{NULLABLE} = 0;
551 $col{IS_NULLABLE} = 'NO';
552 } else {
553 $col{NULLABLE} = 1;
554 $col{IS_NULLABLE} = 'YES';
555 }
556
557 push @cols, \%col;
558 }
559 $sth_columns->finish;
560 }
561 $sth_tables->finish;
562
563 my $sponge = DBI->connect("DBI:Sponge:", '','')
564 or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
565 $sponge->prepare( "column_info", {
566 rows => [ map { [ @{$_}{@COLUMN_INFO} ] } @cols ],
567 NUM_OF_FIELDS => scalar @COLUMN_INFO,
568 NAME => [ @COLUMN_INFO ],
569 } ) or return $dbh->DBI::set_err(
570 $sponge->err,
571 $sponge->errstr,
572 );
573}
574
575#======================================================================
576# An internal tied hash package used for %DBD::SQLite::COLLATION, to
577# prevent people from unintentionally overriding globally registered collations.
578
579package DBD::SQLite::_WriteOnceHash;
580
58111µsrequire Tie::Hash;
582
58317µsour @ISA = qw(Tie::StdHash);
584
585
# spent 9µs within DBD::SQLite::_WriteOnceHash::TIEHASH which was called: # once (9µs+0s) by DBI::install_driver at line 32
sub TIEHASH {
586111µs bless {}, $_[0];
587}
588
589
# spent 9µs within DBD::SQLite::_WriteOnceHash::STORE which was called 2 times, avg 5µs/call: # once (5µs+0s) by DBI::install_driver at line 33 # once (4µs+0s) by DBI::install_driver at line 34
sub STORE {
59023µs ! exists $_[0]->{$_[1]} or die "entry $_[1] already registered";
591210µs $_[0]->{$_[1]} = $_[2];
592}
593
594sub DELETE {
595 die "deletion of entry $_[1] is forbidden";
596}
597
598110µs1;
599
600__END__
 
# spent 210µs within DBD::SQLite::bootstrap which was called: # once (210µs+0s) by DynaLoader::bootstrap at line 219 of DynaLoader.pm
sub DBD::SQLite::bootstrap; # xsub
# spent 167µs within DBD::SQLite::db::_login which was called: # once (167µs+0s) by DBD::SQLite::dr::connect at line 123
sub DBD::SQLite::db::_login; # xsub
# spent 4µs within DBD::SQLite::dr::CORE:match which was called 2 times, avg 2µs/call: # once (2µs+0s) by DBD::SQLite::dr::connect at line 91 # once (2µs+0s) by DBD::SQLite::dr::connect at line 104
sub DBD::SQLite::dr::CORE:match; # opcode