Profile of DBD/SQLite.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:11 2016

Filename | /usr/local/lib/perl/5.18.2/DBD/SQLite.pm
Statements | Executed 2208980 statements in 21.9s

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
368127 | 2 | 2 | 4.56s | 30.6s | DBD::SQLite::db::::prepare DBD::SQLite::db::prepare
12 | 1 | 1 | 487ms | 487ms | DBD::SQLite::db::::_do DBD::SQLite::db::_do (xsub)
1 | 1 | 1 | 10.0ms | 11.3ms | DBD::SQLite::::BEGIN@5 DBD::SQLite::BEGIN@5
23 | 1 | 1 | 1.95ms | 663ms | DBD::SQLite::db::::do DBD::SQLite::db::do
1 | 1 | 1 | 418µs | 418µs | DBD::SQLite::::bootstrap DBD::SQLite::bootstrap (xsub)
1 | 1 | 1 | 218µs | 298µs | DBD::SQLite::::BEGIN@26 DBD::SQLite::BEGIN@26
1 | 1 | 1 | 128µs | 128µs | DBD::SQLite::db::::_login DBD::SQLite::db::_login (xsub)
1 | 1 | 1 | 101µs | 556µs | DBD::SQLite::::driver DBD::SQLite::driver
1 | 1 | 1 | 44µs | 285µs | DBD::SQLite::dr::::connect DBD::SQLite::dr::connect
1 | 1 | 1 | 18µs | 18µs | DBD::SQLite::::BEGIN@3 DBD::SQLite::BEGIN@3
1 | 1 | 1 | 12µs | 55µs | DBD::SQLite::::BEGIN@20 DBD::SQLite::BEGIN@20
1 | 1 | 1 | 7µs | 22µs | DBD::SQLite::::BEGIN@4 DBD::SQLite::BEGIN@4
1 | 1 | 1 | 7µs | 18µs | DBD::SQLite::dr::::BEGIN@185 DBD::SQLite::dr::BEGIN@185
2 | 2 | 1 | 7µs | 7µs | DBD::SQLite::_WriteOnceHash::::STOREDBD::SQLite::_WriteOnceHash::STORE
1 | 1 | 1 | 5µs | 5µs | DBD::SQLite::::BEGIN@6 DBD::SQLite::BEGIN@6
3 | 3 | 1 | 4µs | 4µs | DBD::SQLite::dr::::CORE:match DBD::SQLite::dr::CORE:match (opcode)
1 | 1 | 1 | 2µs | 2µs | DBD::SQLite::_WriteOnceHash::::TIEHASHDBD::SQLite::_WriteOnceHash::TIEHASH
0 | 0 | 0 | 0s | 0s | DBD::SQLite::::CLONE DBD::SQLite::CLONE
0 | 0 | 0 | 0s | 0s | DBD::SQLite::_WriteOnceHash::::DELETEDBD::SQLite::_WriteOnceHash::DELETE
0 | 0 | 0 | 0s | 0s | DBD::SQLite::::__ANON__[:25] DBD::SQLite::__ANON__[:25]
0 | 0 | 0 | 0s | 0s | DBD::SQLite::::__ANON__[:26] DBD::SQLite::__ANON__[:26]
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::_attached_database_list DBD::SQLite::db::_attached_database_list
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::_get_version DBD::SQLite::db::_get_version
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::column_info DBD::SQLite::db::column_info
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::foreign_key_info DBD::SQLite::db::foreign_key_info
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::get_info DBD::SQLite::db::get_info
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::ping DBD::SQLite::db::ping
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::primary_key_info DBD::SQLite::db::primary_key_info
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::statistics_info DBD::SQLite::db::statistics_info
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::table_info DBD::SQLite::db::table_info
0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::::type_info_all DBD::SQLite::db::type_info_all
0 | 0 | 0 | 0s | 0s | DBD::SQLite::dr::::install_collation DBD::SQLite::dr::install_collation
0 | 0 | 0 | 0s | 0s | DBD::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package DBD::SQLite;
2 |  |  |  |  |
3 | 2 | 46µs | 1 | 18µs | # spent 18µs within DBD::SQLite::BEGIN@3 which was called: # once (18µs+0s) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 3 use 5.006; # spent 18µs making 1 call to DBD::SQLite::BEGIN@3
4 | 2 | 24µs | 2 | 37µs | # spent 22µs (7+15) within DBD::SQLite::BEGIN@4 which was called: # once (7µs+15µs) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 4 use strict; # spent 22µs making 1 call to DBD::SQLite::BEGIN@4 # spent 15µs making 1 call to strict::import
5 | 3 | 161µs | 2 | 11.3ms | # spent 11.3ms (10.0+1.25) within DBD::SQLite::BEGIN@5 which was called: # once (10.0ms+1.25ms) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 5 use DBI 1.57 (); # spent 11.3ms making 1 call to DBD::SQLite::BEGIN@5 # spent 10µs making 1 call to UNIVERSAL::VERSION
6 | 2 | 72µs | 1 | 5µs | # spent 5µs within DBD::SQLite::BEGIN@6 which was called: # once (5µs+0s) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 6 use DynaLoader (); # spent 5µs making 1 call to DBD::SQLite::BEGIN@6
7 |  |  |  |  |
8 | 1 | 600ns |  |  | our $VERSION = '1.48';
9 | 1 | 6µs |  |  | our @ISA = 'DynaLoader';
10 |  |  |  |  |
11 |  |  |  |  | # sqlite_version cache (set in the XS bootstrap)
12 | 1 | 200ns |  |  | our ($sqlite_version, $sqlite_version_number);
13 |  |  |  |  |
14 |  |  |  |  | # not sure if we still need these...
15 | 1 | 100ns |  |  | our ($err, $errstr);
16 |  |  |  |  |
17 | 1 | 7µs | 1 | 625µs | __PACKAGE__->bootstrap($VERSION); # spent 625µs making 1 call to DynaLoader::bootstrap
18 |  |  |  |  |
19 |  |  |  |  | # New or old API?
20 | 2 | 64µs | 2 | 99µs | # spent 55µs (12+44) within DBD::SQLite::BEGIN@20 which was called: # once (12µs+44µs) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 20 use constant NEWAPI => ($DBI::VERSION >= 1.608); # spent 55µs making 1 call to DBD::SQLite::BEGIN@20 # spent 44µs making 1 call to constant::import
21 |  |  |  |  |
22 |  |  |  |  | # global registry of collation functions, initialized with 2 builtins
23 | 1 | 200ns |  |  | our %COLLATION;
24 | 1 | 3µs | 1 | 2µs | tie %COLLATION, 'DBD::SQLite::_WriteOnceHash'; # spent 2µs making 1 call to DBD::SQLite::_WriteOnceHash::TIEHASH
25 | 1 | 6µs | 1 | 5µs | $COLLATION{perl} = sub { $_[0] cmp $_[1] }; # spent 5µs making 1 call to DBD::SQLite::_WriteOnceHash::STORE
26 | 3 | 734µs | 3 | 354µs | # spent 298µs (218+80) within DBD::SQLite::BEGIN@26 which was called: # once (218µs+80µs) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 26 $COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] }; # spent 298µs making 1 call to DBD::SQLite::BEGIN@26 # spent 55µs making 1 call to locale::import # spent 1µs making 1 call to DBD::SQLite::_WriteOnceHash::STORE
27 |  |  |  |  |
28 | 1 | 200ns |  |  | our $drh;
29 | 1 | 200ns |  |  | my $methods_are_installed = 0;
30 |  |  |  |  |
31 |  |  |  |  | # spent 556µs (101+455) within DBD::SQLite::driver which was called: # once (101µs+455µs) by DBI::install_driver at line 831 of DBI.pm sub driver {
32 | 1 | 400ns |  |  | return $drh if $drh;
33 |  |  |  |  |
34 | 1 | 800ns |  |  | if (!$methods_are_installed && DBD::SQLite::NEWAPI ) {
35 | 1 | 2µs | 1 | 17µs | DBI->setup_driver('DBD::SQLite'); # spent 17µs making 1 call to DBI::setup_driver
36 |  |  |  |  |
37 | 1 | 6µs | 1 | 42µs | DBD::SQLite::db->install_method('sqlite_last_insert_rowid'); # spent 42µs making 1 call to DBD::_::common::install_method
38 | 1 | 1µs | 1 | 17µs | DBD::SQLite::db->install_method('sqlite_busy_timeout'); # spent 17µs making 1 call to DBD::_::common::install_method
39 | 1 | 1µs | 1 | 23µs | DBD::SQLite::db->install_method('sqlite_create_function'); # spent 23µs making 1 call to DBD::_::common::install_method
40 | 1 | 1µs | 1 | 16µs | DBD::SQLite::db->install_method('sqlite_create_aggregate'); # spent 16µs making 1 call to DBD::_::common::install_method
41 | 1 | 1µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_create_collation'); # spent 15µs making 1 call to DBD::_::common::install_method
42 | 1 | 1µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_collation_needed'); # spent 15µs making 1 call to DBD::_::common::install_method
43 | 1 | 1µs | 1 | 14µs | DBD::SQLite::db->install_method('sqlite_progress_handler'); # spent 14µs making 1 call to DBD::_::common::install_method
44 | 1 | 1µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_commit_hook'); # spent 15µs making 1 call to DBD::_::common::install_method
45 | 1 | 1µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_rollback_hook'); # spent 15µs making 1 call to DBD::_::common::install_method
46 | 1 | 2µs | 1 | 17µs | DBD::SQLite::db->install_method('sqlite_update_hook'); # spent 17µs making 1 call to DBD::_::common::install_method
47 | 1 | 1µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_set_authorizer'); # spent 15µs making 1 call to DBD::_::common::install_method
48 | 1 | 1µs | 1 | 14µs | DBD::SQLite::db->install_method('sqlite_backup_from_file'); # spent 14µs making 1 call to DBD::_::common::install_method
49 | 1 | 1µs | 1 | 14µs | DBD::SQLite::db->install_method('sqlite_backup_to_file'); # spent 14µs making 1 call to DBD::_::common::install_method
50 | 1 | 1µs | 1 | 17µs | DBD::SQLite::db->install_method('sqlite_enable_load_extension'); # spent 17µs making 1 call to DBD::_::common::install_method
51 | 1 | 1µs | 1 | 14µs | DBD::SQLite::db->install_method('sqlite_load_extension'); # spent 14µs making 1 call to DBD::_::common::install_method
52 | 1 | 1µs | 1 | 16µs | DBD::SQLite::db->install_method('sqlite_register_fts3_perl_tokenizer'); # spent 16µs making 1 call to DBD::_::common::install_method
53 | 1 | 2µs | 1 | 16µs | DBD::SQLite::db->install_method('sqlite_trace', { O => 0x0004 }); # spent 16µs making 1 call to DBD::_::common::install_method
54 | 1 | 2µs | 1 | 18µs | DBD::SQLite::db->install_method('sqlite_profile', { O => 0x0004 }); # spent 18µs making 1 call to DBD::_::common::install_method
55 | 1 | 2µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_table_column_metadata', { O => 0x0004 }); # spent 15µs making 1 call to DBD::_::common::install_method
56 | 1 | 2µs | 1 | 17µs | DBD::SQLite::db->install_method('sqlite_db_filename', { O => 0x0004 }); # spent 17µs making 1 call to DBD::_::common::install_method
57 | 1 | 2µs | 1 | 18µs | DBD::SQLite::db->install_method('sqlite_db_status', { O => 0x0004 }); # spent 18µs making 1 call to DBD::_::common::install_method
58 | 1 | 5µs | 1 | 18µs | DBD::SQLite::st->install_method('sqlite_st_status', { O => 0x0004 }); # spent 18µs making 1 call to DBD::_::common::install_method
59 | 1 | 1µs | 1 | 15µs | DBD::SQLite::db->install_method('sqlite_create_module'); # spent 15µs making 1 call to DBD::_::common::install_method
60 |  |  |  |  |
61 | 1 | 800ns |  |  | $methods_are_installed++;
62 |  |  |  |  | }
63 |  |  |  |  |
64 | 1 | 9µs | 1 | 42µs | $drh = DBI::_new_drh( "$_[0]::dr", { # spent 42µs making 1 call to DBI::_new_drh
65 |  |  |  |  | Name => 'SQLite',
66 |  |  |  |  | Version => $VERSION,
67 |  |  |  |  | Attribution => 'DBD::SQLite by Matt Sergeant et al',
68 |  |  |  |  | } );
69 |  |  |  |  |
70 | 1 | 2µs |  |  | return $drh;
71 |  |  |  |  | }
72 |  |  |  |  |
73 |  |  |  |  | sub CLONE {
74 |  |  |  |  | undef $drh;
75 |  |  |  |  | }
76 |  |  |  |  |
77 |  |  |  |  |
78 |  |  |  |  | package # hide from PAUSE
79 |  |  |  |  | DBD::SQLite::dr;
80 |  |  |  |  |
81 |  |  |  |  | # spent 285µs (44+241) within DBD::SQLite::dr::connect which was called: # once (44µs+241µs) by DBI::dr::connect at line 681 of DBI.pm sub connect {
82 | 1 | 900ns |  |  | my ($drh, $dbname, $user, $auth, $attr) = @_;
83 |  |  |  |  |
84 |  |  |  |  | # Default PrintWarn to the value of $^W
85 |  |  |  |  | # unless ( defined $attr->{PrintWarn} ) {
86 |  |  |  |  | # $attr->{PrintWarn} = $^W ? 1 : 0;
87 |  |  |  |  | # }
88 |  |  |  |  |
89 | 1 | 3µs | 1 | 19µs | my $dbh = DBI::_new_dbh( $drh, { # spent 19µs making 1 call to DBI::_new_dbh
90 |  |  |  |  | Name => $dbname,
91 |  |  |  |  | } );
92 |  |  |  |  |
93 | 1 | 400ns |  |  | my $real = $dbname;
94 | 1 | 5µs | 1 | 900ns | if ( $dbname =~ /=/ ) { # spent 900ns making 1 call to DBD::SQLite::dr::CORE:match
95 | 1 | 2µs |  |  | foreach my $attrib ( split(/;/, $dbname) ) {
96 | 1 | 2µs |  |  | my ($key, $value) = split(/=/, $attrib, 2);
97 | 1 | 6µs | 1 | 2µs | if ( $key =~ /^(?:db(?:name)?|database)$/ ) { # spent 2µs making 1 call to DBD::SQLite::dr::CORE:match
98 |  |  |  |  | $real = $value;
99 |  |  |  |  | } elsif ( $key eq 'uri' ) {
100 |  |  |  |  | $real = $value;
101 |  |  |  |  | $attr->{sqlite_open_flags} |= DBD::SQLite::OPEN_URI();
102 |  |  |  |  | } else {
103 |  |  |  |  | $attr->{$key} = $value;
104 |  |  |  |  | }
105 |  |  |  |  | }
106 |  |  |  |  | }
107 |  |  |  |  |
108 | 1 | 600ns |  |  | if (my $flags = $attr->{sqlite_open_flags}) {
109 |  |  |  |  | unless ($flags & (DBD::SQLite::OPEN_READONLY() | DBD::SQLite::OPEN_READWRITE())) {
110 |  |  |  |  | $attr->{sqlite_open_flags} |= DBD::SQLite::OPEN_READWRITE() | DBD::SQLite::OPEN_CREATE();
111 |  |  |  |  | }
112 |  |  |  |  | }
113 |  |  |  |  |
114 |  |  |  |  | # To avoid unicode and long file name problems on Windows,
115 |  |  |  |  | # convert to the shortname if the file (or parent directory) exists.
116 | 1 | 3µs | 1 | 800ns | if ( $^O =~ /MSWin32/ and $real ne ':memory:' and $real ne '' and $real !~ /^file:/ and !-f $real ) { # spent 800ns making 1 call to DBD::SQLite::dr::CORE:match
117 |  |  |  |  | require File::Basename;
118 |  |  |  |  | my ($file, $dir, $suffix) = File::Basename::fileparse($real);
119 |  |  |  |  | # We are creating a new file.
120 |  |  |  |  | # Does the directory it's in at least exist?
121 |  |  |  |  | if ( -d $dir ) {
122 |  |  |  |  | require Win32;
123 |  |  |  |  | $real = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix;
124 |  |  |  |  | } else {
125 |  |  |  |  | # SQLite can't do mkpath anyway.
126 |  |  |  |  | # So let it go through as it and fail.
127 |  |  |  |  | }
128 |  |  |  |  | }
129 |  |  |  |  |
130 |  |  |  |  | # Hand off to the actual login function
131 | 1 | 134µs | 1 | 128µs | DBD::SQLite::db::_login($dbh, $real, $user, $auth, $attr) or return undef; # spent 128µs making 1 call to DBD::SQLite::db::_login
132 |  |  |  |  |
133 |  |  |  |  | # Register the on-demand collation installer, REGEXP function and
134 |  |  |  |  | # perl tokenizer
135 | 1 | 500ns |  |  | if ( DBD::SQLite::NEWAPI ) {
136 | 1 | 11µs | 1 | 6µs | $dbh->sqlite_collation_needed( \&install_collation ); # spent 6µs making 1 call to DBI::db::sqlite_collation_needed
137 | 1 | 8µs | 1 | 4µs | $dbh->sqlite_create_function( "REGEXP", 2, \&regexp ); # spent 4µs making 1 call to DBI::db::sqlite_create_function
138 | 1 | 86µs | 1 | 79µs | $dbh->sqlite_register_fts3_perl_tokenizer(); # spent 79µs making 1 call to DBI::db::sqlite_register_fts3_perl_tokenizer
139 |  |  |  |  | } else {
140 |  |  |  |  | $dbh->func( \&install_collation, "collation_needed" );
141 |  |  |  |  | $dbh->func( "REGEXP", 2, \&regexp, "create_function" );
142 |  |  |  |  | $dbh->func( "register_fts3_perl_tokenizer" );
143 |  |  |  |  | }
144 |  |  |  |  |
145 |  |  |  |  | # HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings
146 |  |  |  |  | # in DBD::SQLite we set Warn to false if PrintWarn is false.
147 |  |  |  |  |
148 |  |  |  |  | # NOTE: According to the explanation by timbunce,
149 |  |  |  |  | # "Warn is meant to report on bad practices or problems with
150 |  |  |  |  | # the DBI itself (hence always on by default), while PrintWarn
151 |  |  |  |  | # is meant to report warnings coming from the database."
152 |  |  |  |  | # That is, if you want to disable an ineffective rollback warning
153 |  |  |  |  | # etc (due to bad practices), you should turn off Warn,
154 |  |  |  |  | # and to silence other warnings, turn off PrintWarn.
155 |  |  |  |  | # Warn and PrintWarn are independent, and turning off PrintWarn
156 |  |  |  |  | # does not silence those warnings that should be controlled by
157 |  |  |  |  | # Warn.
158 |  |  |  |  |
159 |  |  |  |  | # unless ( $attr->{PrintWarn} ) {
160 |  |  |  |  | # $attr->{Warn} = 0;
161 |  |  |  |  | # }
162 |  |  |  |  |
163 | 1 | 4µs |  |  | return $dbh;
164 |  |  |  |  | }
165 |  |  |  |  |
166 |  |  |  |  | sub install_collation {
167 |  |  |  |  | my $dbh = shift;
168 |  |  |  |  | my $name = shift;
169 |  |  |  |  | my $collation = $DBD::SQLite::COLLATION{$name};
170 |  |  |  |  | unless ($collation) {
171 |  |  |  |  | warn "Can't install unknown collation: $name" if $dbh->{PrintWarn};
172 |  |  |  |  | return;
173 |  |  |  |  | }
174 |  |  |  |  | if ( DBD::SQLite::NEWAPI ) {
175 |  |  |  |  | $dbh->sqlite_create_collation( $name => $collation );
176 |  |  |  |  | } else {
177 |  |  |  |  | $dbh->func( $name => $collation, "create_collation" );
178 |  |  |  |  | }
179 |  |  |  |  | }
180 |  |  |  |  |
181 |  |  |  |  | # default implementation for sqlite 'REGEXP' infix operator.
182 |  |  |  |  | # Note : args are reversed, i.e. "a REGEXP b" calls REGEXP(b, a)
183 |  |  |  |  | # (see http://www.sqlite.org/vtab.html#xfindfunction)
184 |  |  |  |  | sub regexp {
185 | 2 | 2.58ms | 2 | 28µs | # spent 18µs (7+11) within DBD::SQLite::dr::BEGIN@185 which was called: # once (7µs+11µs) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 185 use locale; # spent 18µs making 1 call to DBD::SQLite::dr::BEGIN@185 # spent 11µs making 1 call to locale::import
186 |  |  |  |  | return if !defined $_[0] || !defined $_[1];
187 |  |  |  |  | return scalar($_[1] =~ $_[0]);
188 |  |  |  |  | }
189 |  |  |  |  |
190 |  |  |  |  | package # hide from PAUSE
191 |  |  |  |  | DBD::SQLite::db;
192 |  |  |  |  |
193 |  |  |  |  | # spent 30.6s (4.56+26.0) within DBD::SQLite::db::prepare which was called 368127 times, avg 83µs/call: # 368116 times (4.56s+26.0s) by DBI::db::prepare at line 758 of lib/Test/PONAPI/Repository/MockDB.pm, avg 83µs/call # 11 times (302µs+1.81ms) by DBI::db::prepare at line 224, avg 192µs/call sub prepare {
194 | 368127 | 134ms |  |  | my $dbh = shift;
195 | 368127 | 114ms |  |  | my $sql = shift;
196 | 368127 | 119ms |  |  | $sql = '' unless defined $sql;
197 |  |  |  |  |
198 | 368127 | 1.10s | 368127 | 9.71s | my $sth = DBI::_new_sth( $dbh, { # spent 9.71s making 368127 calls to DBI::_new_sth, avg 26µs/call
199 |  |  |  |  | Statement => $sql,
200 |  |  |  |  | } );
201 |  |  |  |  |
202 | 368127 | 18.2s | 368127 | 16.3s | DBD::SQLite::st::_prepare($sth, $sql, @_) or return undef; # spent 16.3s making 368127 calls to DBD::SQLite::st::_prepare, avg 44µs/call
203 |  |  |  |  |
204 | 368127 | 1.61s |  |  | return $sth;
205 |  |  |  |  | }
206 |  |  |  |  |
207 |  |  |  |  | # spent 663ms (1.95+662) within DBD::SQLite::db::do which was called 23 times, avg 28.8ms/call: # 23 times (1.95ms+662ms) by DBI::db::do at line 37 of lib/Test/PONAPI/Repository/MockDB/Loader.pm, avg 28.8ms/call sub do {
208 | 23 | 84µs |  |  | my ($dbh, $statement, $attr, @bind_values) = @_;
209 |  |  |  |  |
210 |  |  |  |  | # shortcut
211 | 23 | 487ms | 23 | 487ms | if (defined $statement && !defined $attr && !@bind_values) { # spent 487ms making 12 calls to DBD::SQLite::db::_do, avg 40.5ms/call # spent 56µs making 11 calls to DBI::common::FETCH, avg 5µs/call
212 |  |  |  |  | # _do() (i.e. sqlite3_exec()) runs semicolon-separate SQL
213 |  |  |  |  | # statements, which is handy but insecure sometimes.
214 |  |  |  |  | # Use this only when it's safe or explicitly allowed.
215 |  |  |  |  | if (index($statement, ';') == -1 or $dbh->FETCH('sqlite_allow_multiple_statements')) {
216 |  |  |  |  | return DBD::SQLite::db::_do($dbh, $statement);
217 |  |  |  |  | }
218 |  |  |  |  | }
219 |  |  |  |  |
220 | 11 | 38µs |  |  | my @copy = @{[@bind_values]};
221 | 11 | 8µs |  |  | my $rows = 0;
222 |  |  |  |  |
223 | 11 | 8µs | 33 | 171µs | while ($statement) { # spent 130µs making 22 calls to DBI::common::DESTROY, avg 6µs/call # spent 41µs making 11 calls to DBD::_mem::common::DESTROY, avg 4µs/call
224 | 11 | 170µs | 22 | 4.34ms | my $sth = $dbh->prepare($statement, $attr) or return undef; # spent 2.23ms making 11 calls to DBI::db::prepare, avg 202µs/call # spent 2.12ms making 11 calls to DBD::SQLite::db::prepare, avg 192µs/call
225 | 11 | 173ms | 22 | 172ms | $sth->execute(splice @copy, 0, $sth->{NUM_OF_PARAMS}) or return undef; # spent 172ms making 11 calls to DBI::st::execute, avg 15.7ms/call # spent 99µs making 11 calls to DBI::common::FETCH, avg 9µs/call
226 | 11 | 204µs | 11 | 97µs | $rows += $sth->rows; # spent 97µs making 11 calls to DBI::st::rows, avg 9µs/call
227 |  |  |  |  | # XXX: not sure why but $dbh->{sqlite...} wouldn't work here
228 | 11 | 659µs | 11 | 85µs | last unless $dbh->FETCH('sqlite_allow_multiple_statements'); # spent 85µs making 11 calls to DBI::common::FETCH, avg 8µs/call
229 |  |  |  |  | $statement = $sth->{sqlite_unprepared_statements};
230 |  |  |  |  | }
231 |  |  |  |  |
232 |  |  |  |  | # always return true if no error
233 | 11 | 109µs |  |  | return ($rows == 0) ? "0E0" : $rows;
234 |  |  |  |  | }
235 |  |  |  |  |
236 |  |  |  |  | sub ping {
237 |  |  |  |  | my $dbh = shift;
238 |  |  |  |  |
239 |  |  |  |  | # $file may be undef (ie. in-memory/temporary database)
240 |  |  |  |  | my $file = DBD::SQLite::NEWAPI ? $dbh->sqlite_db_filename
241 |  |  |  |  | : $dbh->func("db_filename");
242 |  |  |  |  |
243 |  |  |  |  | return 0 if $file && !-f $file;
244 |  |  |  |  | return $dbh->FETCH('Active') ? 1 : 0;
245 |  |  |  |  | }
246 |  |  |  |  |
247 |  |  |  |  | sub _get_version {
248 |  |  |  |  | return ( DBD::SQLite::db::FETCH($_[0], 'sqlite_version') );
249 |  |  |  |  | }
250 |  |  |  |  |
251 | 1 | 3µs |  |  | my %info = (
252 |  |  |  |  | 17 => 'SQLite', # SQL_DBMS_NAME
253 |  |  |  |  | 18 => \&_get_version, # SQL_DBMS_VER
254 |  |  |  |  | 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR
255 |  |  |  |  | );
256 |  |  |  |  |
257 |  |  |  |  | sub get_info {
258 |  |  |  |  | my($dbh, $info_type) = @_;
259 |  |  |  |  | my $v = $info{int($info_type)};
260 |  |  |  |  | $v = $v->($dbh) if ref $v eq 'CODE';
261 |  |  |  |  | return $v;
262 |  |  |  |  | }
263 |  |  |  |  |
264 |  |  |  |  | sub _attached_database_list {
265 |  |  |  |  | my $dbh = shift;
266 |  |  |  |  | my @attached;
267 |  |  |  |  |
268 |  |  |  |  | my $sth_databases = $dbh->prepare( 'PRAGMA database_list' );
269 |  |  |  |  | $sth_databases->execute;
270 |  |  |  |  | while ( my $db_info = $sth_databases->fetchrow_hashref ) {
271 |  |  |  |  | push @attached, $db_info->{name} if $db_info->{seq} >= 2;
272 |  |  |  |  | }
273 |  |  |  |  | return @attached;
274 |  |  |  |  | }
275 |  |  |  |  |
276 |  |  |  |  | # SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
277 |  |  |  |  | # Based on DBD::Oracle's
278 |  |  |  |  | # See also http://www.ch-werner.de/sqliteodbc/html/sqlite3odbc_8c.html#a213
279 |  |  |  |  | sub table_info {
280 |  |  |  |  | my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val, $attr) = @_;
281 |  |  |  |  |
282 |  |  |  |  | my @where = ();
283 |  |  |  |  | my $sql;
284 |  |  |  |  | if ( defined($cat_val) && $cat_val eq '%'
285 |  |  |  |  | && defined($sch_val) && $sch_val eq ''
286 |  |  |  |  | && defined($tbl_val) && $tbl_val eq '') { # Rule 19a
287 |  |  |  |  | $sql = <<'END_SQL';
288 |  |  |  |  | SELECT NULL TABLE_CAT
289 |  |  |  |  | , NULL TABLE_SCHEM
290 |  |  |  |  | , NULL TABLE_NAME
291 |  |  |  |  | , NULL TABLE_TYPE
292 |  |  |  |  | , NULL REMARKS
293 |  |  |  |  | END_SQL
294 |  |  |  |  | }
295 |  |  |  |  | elsif ( defined($cat_val) && $cat_val eq ''
296 |  |  |  |  | && defined($sch_val) && $sch_val eq '%'
297 |  |  |  |  | && defined($tbl_val) && $tbl_val eq '') { # Rule 19b
298 |  |  |  |  | $sql = <<'END_SQL';
299 |  |  |  |  | SELECT NULL TABLE_CAT
300 |  |  |  |  | , t.tn TABLE_SCHEM
301 |  |  |  |  | , NULL TABLE_NAME
302 |  |  |  |  | , NULL TABLE_TYPE
303 |  |  |  |  | , NULL REMARKS
304 |  |  |  |  | FROM (
305 |  |  |  |  | SELECT 'main' tn
306 |  |  |  |  | UNION SELECT 'temp' tn
307 |  |  |  |  | END_SQL
308 |  |  |  |  | for my $db_name (_attached_database_list($dbh)) {
309 |  |  |  |  | $sql .= " UNION SELECT '$db_name' tn\n";
310 |  |  |  |  | }
311 |  |  |  |  | $sql .= ") t\n";
312 |  |  |  |  | }
313 |  |  |  |  | elsif ( defined($cat_val) && $cat_val eq ''
314 |  |  |  |  | && defined($sch_val) && $sch_val eq ''
315 |  |  |  |  | && defined($tbl_val) && $tbl_val eq ''
316 |  |  |  |  | && defined($typ_val) && $typ_val eq '%') { # Rule 19c
317 |  |  |  |  | $sql = <<'END_SQL';
318 |  |  |  |  | SELECT NULL TABLE_CAT
319 |  |  |  |  | , NULL TABLE_SCHEM
320 |  |  |  |  | , NULL TABLE_NAME
321 |  |  |  |  | , t.tt TABLE_TYPE
322 |  |  |  |  | , NULL REMARKS
323 |  |  |  |  | FROM (
324 |  |  |  |  | SELECT 'TABLE' tt UNION
325 |  |  |  |  | SELECT 'VIEW' tt UNION
326 |  |  |  |  | SELECT 'LOCAL TEMPORARY' tt UNION
327 |  |  |  |  | SELECT 'SYSTEM TABLE' tt
328 |  |  |  |  | ) t
329 |  |  |  |  | ORDER BY TABLE_TYPE
330 |  |  |  |  | END_SQL
331 |  |  |  |  | }
332 |  |  |  |  | else {
333 |  |  |  |  | $sql = <<'END_SQL';
334 |  |  |  |  | SELECT *
335 |  |  |  |  | FROM
336 |  |  |  |  | (
337 |  |  |  |  | SELECT NULL TABLE_CAT
338 |  |  |  |  | , TABLE_SCHEM
339 |  |  |  |  | , tbl_name TABLE_NAME
340 |  |  |  |  | , TABLE_TYPE
341 |  |  |  |  | , NULL REMARKS
342 |  |  |  |  | , sql sqlite_sql
343 |  |  |  |  | FROM (
344 |  |  |  |  | SELECT 'main' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql
345 |  |  |  |  | FROM sqlite_master
346 |  |  |  |  | UNION ALL
347 |  |  |  |  | SELECT 'temp' TABLE_SCHEM, tbl_name, 'LOCAL TEMPORARY' TABLE_TYPE, sql
348 |  |  |  |  | FROM sqlite_temp_master
349 |  |  |  |  | END_SQL
350 |  |  |  |  |
351 |  |  |  |  | for my $db_name (_attached_database_list($dbh)) {
352 |  |  |  |  | $sql .= <<"END_SQL";
353 |  |  |  |  | UNION ALL
354 |  |  |  |  | SELECT '$db_name' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql
355 |  |  |  |  | FROM "$db_name".sqlite_master
356 |  |  |  |  | END_SQL
357 |  |  |  |  | }
358 |  |  |  |  |
359 |  |  |  |  | $sql .= <<'END_SQL';
360 |  |  |  |  | UNION ALL
361 |  |  |  |  | SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
362 |  |  |  |  | UNION ALL
363 |  |  |  |  | SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
364 |  |  |  |  | )
365 |  |  |  |  | )
366 |  |  |  |  | END_SQL
367 |  |  |  |  | $attr = {} unless ref $attr eq 'HASH';
368 |  |  |  |  | my $escape = defined $attr->{Escape} ? " ESCAPE '$attr->{Escape}'" : '';
369 |  |  |  |  | if ( defined $sch_val ) {
370 |  |  |  |  | push @where, "TABLE_SCHEM LIKE '$sch_val'$escape";
371 |  |  |  |  | }
372 |  |  |  |  | if ( defined $tbl_val ) {
373 |  |  |  |  | push @where, "TABLE_NAME LIKE '$tbl_val'$escape";
374 |  |  |  |  | }
375 |  |  |  |  | if ( defined $typ_val ) {
376 |  |  |  |  | my $table_type_list;
377 |  |  |  |  | $typ_val =~ s/^\s+//;
378 |  |  |  |  | $typ_val =~ s/\s+$//;
379 |  |  |  |  | my @ttype_list = split (/\s*,\s*/, $typ_val);
380 |  |  |  |  | foreach my $table_type (@ttype_list) {
381 |  |  |  |  | if ($table_type !~ /^'.*'$/) {
382 |  |  |  |  | $table_type = "'" . $table_type . "'";
383 |  |  |  |  | }
384 |  |  |  |  | }
385 |  |  |  |  | $table_type_list = join(', ', @ttype_list);
386 |  |  |  |  | push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list;
387 |  |  |  |  | }
388 |  |  |  |  | $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
389 |  |  |  |  | $sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n";
390 |  |  |  |  | }
391 |  |  |  |  | my $sth = $dbh->prepare($sql) or return undef;
392 |  |  |  |  | $sth->execute or return undef;
393 |  |  |  |  | $sth;
394 |  |  |  |  | }
395 |  |  |  |  |
396 |  |  |  |  | sub primary_key_info {
397 |  |  |  |  | my ($dbh, $catalog, $schema, $table, $attr) = @_;
398 |  |  |  |  |
399 |  |  |  |  | my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}});
400 |  |  |  |  |
401 |  |  |  |  | my @pk_info;
402 |  |  |  |  | for my $database (@$databases) {
403 |  |  |  |  | my $dbname = $database->{name};
404 |  |  |  |  | next if defined $schema && $schema ne '%' && $schema ne $dbname;
405 |  |  |  |  |
406 |  |  |  |  | my $quoted_dbname = $dbh->quote_identifier($dbname);
407 |  |  |  |  |
408 |  |  |  |  | my $master_table =
409 |  |  |  |  | ($dbname eq 'main') ? 'sqlite_master' :
410 |  |  |  |  | ($dbname eq 'temp') ? 'sqlite_temp_master' :
411 |  |  |  |  | $quoted_dbname.'.sqlite_master';
412 |  |  |  |  |
413 |  |  |  |  | my $sth = $dbh->prepare("SELECT name, sql FROM $master_table WHERE type = ?");
414 |  |  |  |  | $sth->execute("table");
415 |  |  |  |  | while(my $row = $sth->fetchrow_hashref) {
416 |  |  |  |  | my $tbname = $row->{name};
417 |  |  |  |  | next if defined $table && $table ne '%' && $table ne $tbname;
418 |  |  |  |  |
419 |  |  |  |  | my $quoted_tbname = $dbh->quote_identifier($tbname);
420 |  |  |  |  | my $t_sth = $dbh->prepare("PRAGMA $quoted_dbname.table_info($quoted_tbname)");
421 |  |  |  |  | $t_sth->execute;
422 |  |  |  |  | my @pk;
423 |  |  |  |  | while(my $col = $t_sth->fetchrow_hashref) {
424 |  |  |  |  | push @pk, $col->{name} if $col->{pk};
425 |  |  |  |  | }
426 |  |  |  |  |
427 |  |  |  |  | # If there're multiple primary key columns, we need to
428 |  |  |  |  | # find their order from one of the auto-generated unique
429 |  |  |  |  | # indices (note that single column integer primary key
430 |  |  |  |  | # doesn't create an index).
431 |  |  |  |  | if (@pk > 1 and $row->{sql} =~ /\bPRIMARY\s+KEY\s*\(\s*
432 |  |  |  |  | (
433 |  |  |  |  | (?:
434 |  |  |  |  | (
435 |  |  |  |  | [a-z_][a-z0-9_]*
436 |  |  |  |  | | (["'`])(?:\3\3|(?!\3).)+?\3(?!\3)
437 |  |  |  |  | | \[[^\]]+\]
438 |  |  |  |  | )
439 |  |  |  |  | \s*,\s*
440 |  |  |  |  | )+
441 |  |  |  |  | (
442 |  |  |  |  | [a-z_][a-z0-9_]*
443 |  |  |  |  | | (["'`])(?:\5\5|(?!\5).)+?\5(?!\5)
444 |  |  |  |  | | \[[^\]]+\]
445 |  |  |  |  | )
446 |  |  |  |  | )
447 |  |  |  |  | \s*\)/six) {
448 |  |  |  |  | my $pk_sql = $1;
449 |  |  |  |  | @pk = ();
450 |  |  |  |  | while($pk_sql =~ /
451 |  |  |  |  | (
452 |  |  |  |  | [a-z_][a-z0-9_]*
453 |  |  |  |  | | (["'`])(?:\2\2|(?!\2).)+?\2(?!\2)
454 |  |  |  |  | | \[([^\]]+)\]
455 |  |  |  |  | )
456 |  |  |  |  | (?:\s*,\s*|$)
457 |  |  |  |  | /sixg) {
458 |  |  |  |  | my($col, $quote, $brack) = ($1, $2, $3);
459 |  |  |  |  | if ( defined $quote ) {
460 |  |  |  |  | # Dequote "'`
461 |  |  |  |  | $col = substr $col, 1, -1;
462 |  |  |  |  | $col =~ s/$quote$quote/$quote/g;
463 |  |  |  |  | } elsif ( defined $brack ) {
464 |  |  |  |  | # Dequote []
465 |  |  |  |  | $col = $brack;
466 |  |  |  |  | }
467 |  |  |  |  | push @pk, $col;
468 |  |  |  |  | }
469 |  |  |  |  | }
470 |  |  |  |  |
471 |  |  |  |  | my $key_name = $row->{sql} =~ /\bCONSTRAINT\s+(\S+|"[^"]+")\s+PRIMARY\s+KEY\s*\(/i ? $1 : 'PRIMARY KEY';
472 |  |  |  |  | my $key_seq = 0;
473 |  |  |  |  | foreach my $pk_field (@pk) {
474 |  |  |  |  | push @pk_info, {
475 |  |  |  |  | TABLE_SCHEM => $dbname,
476 |  |  |  |  | TABLE_NAME => $tbname,
477 |  |  |  |  | COLUMN_NAME => $pk_field,
478 |  |  |  |  | KEY_SEQ => ++$key_seq,
479 |  |  |  |  | PK_NAME => $key_name,
480 |  |  |  |  | };
481 |  |  |  |  | }
482 |  |  |  |  | }
483 |  |  |  |  | }
484 |  |  |  |  |
485 |  |  |  |  | my $sponge = DBI->connect("DBI:Sponge:", '','')
486 |  |  |  |  | or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
487 |  |  |  |  | my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME);
488 |  |  |  |  | my $sth = $sponge->prepare( "primary_key_info", {
489 |  |  |  |  | rows => [ map { [ @{$_}{@names} ] } @pk_info ],
490 |  |  |  |  | NUM_OF_FIELDS => scalar @names,
491 |  |  |  |  | NAME => \@names,
492 |  |  |  |  | }) or return $dbh->DBI::set_err(
493 |  |  |  |  | $sponge->err,
494 |  |  |  |  | $sponge->errstr,
495 |  |  |  |  | );
496 |  |  |  |  | return $sth;
497 |  |  |  |  | }
498 |  |  |  |  |
499 |  |  |  |  |
500 | 1 | 3µs |  |  | our %DBI_code_for_rule = ( # from DBI doc; curiously, they are not exported
501 |  |  |  |  | # by the DBI module.
502 |  |  |  |  | # codes for update/delete constraints
503 |  |  |  |  | 'CASCADE' => 0,
504 |  |  |  |  | 'RESTRICT' => 1,
505 |  |  |  |  | 'SET NULL' => 2,
506 |  |  |  |  | 'NO ACTION' => 3,
507 |  |  |  |  | 'SET DEFAULT' => 4,
508 |  |  |  |  |
509 |  |  |  |  | # codes for deferrability
510 |  |  |  |  | 'INITIALLY DEFERRED' => 5,
511 |  |  |  |  | 'INITIALLY IMMEDIATE' => 6,
512 |  |  |  |  | 'NOT DEFERRABLE' => 7,
513 |  |  |  |  | );
514 |  |  |  |  |
515 |  |  |  |  |
516 | 1 | 2µs |  |  | my @FOREIGN_KEY_INFO_ODBC = (
517 |  |  |  |  | 'PKTABLE_CAT', # The primary (unique) key table catalog identifier.
518 |  |  |  |  | 'PKTABLE_SCHEM', # The primary (unique) key table schema identifier.
519 |  |  |  |  | 'PKTABLE_NAME', # The primary (unique) key table identifier.
520 |  |  |  |  | 'PKCOLUMN_NAME', # The primary (unique) key column identifier.
521 |  |  |  |  | 'FKTABLE_CAT', # The foreign key table catalog identifier.
522 |  |  |  |  | 'FKTABLE_SCHEM', # The foreign key table schema identifier.
523 |  |  |  |  | 'FKTABLE_NAME', # The foreign key table identifier.
524 |  |  |  |  | 'FKCOLUMN_NAME', # The foreign key column identifier.
525 |  |  |  |  | 'KEY_SEQ', # The column sequence number (starting with 1).
526 |  |  |  |  | 'UPDATE_RULE', # The referential action for the UPDATE rule.
527 |  |  |  |  | 'DELETE_RULE', # The referential action for the DELETE rule.
528 |  |  |  |  | 'FK_NAME', # The foreign key name.
529 |  |  |  |  | 'PK_NAME', # The primary (unique) key name.
530 |  |  |  |  | 'DEFERRABILITY', # The deferrability of the foreign key constraint.
531 |  |  |  |  | 'UNIQUE_OR_PRIMARY', # qualifies the key referenced by the foreign key
532 |  |  |  |  | );
533 |  |  |  |  |
534 |  |  |  |  | # Column names below are not used, but listed just for completeness's sake.
535 |  |  |  |  | # Maybe we could add an option so that the user can choose which field
536 |  |  |  |  | # names will be returned; the DBI spec is not very clear about ODBC vs. CLI.
537 | 1 | 2µs |  |  | my @FOREIGN_KEY_INFO_SQL_CLI = qw(
538 |  |  |  |  | UK_TABLE_CAT
539 |  |  |  |  | UK_TABLE_SCHEM
540 |  |  |  |  | UK_TABLE_NAME
541 |  |  |  |  | UK_COLUMN_NAME
542 |  |  |  |  | FK_TABLE_CAT
543 |  |  |  |  | FK_TABLE_SCHEM
544 |  |  |  |  | FK_TABLE_NAME
545 |  |  |  |  | FK_COLUMN_NAME
546 |  |  |  |  | ORDINAL_POSITION
547 |  |  |  |  | UPDATE_RULE
548 |  |  |  |  | DELETE_RULE
549 |  |  |  |  | FK_NAME
550 |  |  |  |  | UK_NAME
551 |  |  |  |  | DEFERABILITY
552 |  |  |  |  | UNIQUE_OR_PRIMARY
553 |  |  |  |  | );
554 |  |  |  |  |
555 |  |  |  |  | sub foreign_key_info {
556 |  |  |  |  | my ($dbh, $pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table) = @_;
557 |  |  |  |  |
558 |  |  |  |  | my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}});
559 |  |  |  |  |
560 |  |  |  |  | my @fk_info;
561 |  |  |  |  | my %table_info;
562 |  |  |  |  | for my $database (@$databases) {
563 |  |  |  |  | my $dbname = $database->{name};
564 |  |  |  |  | next if defined $fk_schema && $fk_schema ne '%' && $fk_schema ne $dbname;
565 |  |  |  |  |
566 |  |  |  |  | my $quoted_dbname = $dbh->quote_identifier($dbname);
567 |  |  |  |  | my $master_table =
568 |  |  |  |  | ($dbname eq 'main') ? 'sqlite_master' :
569 |  |  |  |  | ($dbname eq 'temp') ? 'sqlite_temp_master' :
570 |  |  |  |  | $quoted_dbname.'.sqlite_master';
571 |  |  |  |  |
572 |  |  |  |  | my $tables = $dbh->selectall_arrayref("SELECT name FROM $master_table WHERE type = ?", undef, "table");
573 |  |  |  |  | for my $table (@$tables) {
574 |  |  |  |  | my $tbname = $table->[0];
575 |  |  |  |  | next if defined $fk_table && $fk_table ne '%' && $fk_table ne $tbname;
576 |  |  |  |  |
577 |  |  |  |  | my $quoted_tbname = $dbh->quote_identifier($tbname);
578 |  |  |  |  | my $sth = $dbh->prepare("PRAGMA $quoted_dbname.foreign_key_list($quoted_tbname)");
579 |  |  |  |  | $sth->execute;
580 |  |  |  |  | while(my $row = $sth->fetchrow_hashref) {
581 |  |  |  |  | next if defined $pk_table && $pk_table ne '%' && $pk_table ne $row->{table};
582 |  |  |  |  |
583 |  |  |  |  | unless ($table_info{$row->{table}}) {
584 |  |  |  |  | my $quoted_tb = $dbh->quote_identifier($row->{table});
585 |  |  |  |  | for my $db (@$databases) {
586 |  |  |  |  | my $quoted_db = $dbh->quote_identifier($db->{name});
587 |  |  |  |  | my $t_sth = $dbh->prepare("PRAGMA $quoted_db.table_info($quoted_tb)");
588 |  |  |  |  | $t_sth->execute;
589 |  |  |  |  | my $cols = {};
590 |  |  |  |  | while(my $r = $t_sth->fetchrow_hashref) {
591 |  |  |  |  | $cols->{$r->{name}} = $r->{pk};
592 |  |  |  |  | }
593 |  |  |  |  | if (keys %$cols) {
594 |  |  |  |  | $table_info{$row->{table}} = {
595 |  |  |  |  | schema => $db->{name},
596 |  |  |  |  | columns => $cols,
597 |  |  |  |  | };
598 |  |  |  |  | last;
599 |  |  |  |  | }
600 |  |  |  |  | }
601 |  |  |  |  | }
602 |  |  |  |  |
603 |  |  |  |  | next if defined $pk_schema && $pk_schema ne '%' && $pk_schema ne $table_info{$row->{table}}{schema};
604 |  |  |  |  |
605 |  |  |  |  | push @fk_info, {
606 |  |  |  |  | PKTABLE_CAT => undef,
607 |  |  |  |  | PKTABLE_SCHEM => $table_info{$row->{table}}{schema},
608 |  |  |  |  | PKTABLE_NAME => $row->{table},
609 |  |  |  |  | PKCOLUMN_NAME => $row->{to},
610 |  |  |  |  | FKTABLE_CAT => undef,
611 |  |  |  |  | FKTABLE_SCHEM => $dbname,
612 |  |  |  |  | FKTABLE_NAME => $tbname,
613 |  |  |  |  | FKCOLUMN_NAME => $row->{from},
614 |  |  |  |  | KEY_SEQ => $row->{seq} + 1,
615 |  |  |  |  | UPDATE_RULE => $DBI_code_for_rule{$row->{on_update}},
616 |  |  |  |  | DELETE_RULE => $DBI_code_for_rule{$row->{on_delete}},
617 |  |  |  |  | FK_NAME => undef,
618 |  |  |  |  | PK_NAME => undef,
619 |  |  |  |  | DEFERRABILITY => undef,
620 |  |  |  |  | UNIQUE_OR_PRIMARY => $table_info{$row->{table}}{columns}{$row->{to}} ? 'PRIMARY' : 'UNIQUE',
621 |  |  |  |  | };
622 |  |  |  |  | }
623 |  |  |  |  | }
624 |  |  |  |  | }
625 |  |  |  |  |
626 |  |  |  |  | my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "")
627 |  |  |  |  | or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
628 |  |  |  |  | my $sponge_sth = $sponge_dbh->prepare("foreign_key_info", {
629 |  |  |  |  | NAME => \@FOREIGN_KEY_INFO_ODBC,
630 |  |  |  |  | rows => [ map { [@{$_}{@FOREIGN_KEY_INFO_ODBC} ] } @fk_info ],
631 |  |  |  |  | NUM_OF_FIELDS => scalar(@FOREIGN_KEY_INFO_ODBC),
632 |  |  |  |  | }) or return $dbh->DBI::set_err(
633 |  |  |  |  | $sponge_dbh->err,
634 |  |  |  |  | $sponge_dbh->errstr,
635 |  |  |  |  | );
636 |  |  |  |  | return $sponge_sth;
637 |  |  |  |  | }
638 |  |  |  |  |
639 | 1 | 3µs |  |  | my @STATISTICS_INFO_ODBC = (
640 |  |  |  |  | 'TABLE_CAT', # The catalog identifier.
641 |  |  |  |  | 'TABLE_SCHEM', # The schema identifier.
642 |  |  |  |  | 'TABLE_NAME', # The table identifier.
643 |  |  |  |  | 'NON_UNIQUE', # Unique index indicator.
644 |  |  |  |  | 'INDEX_QUALIFIER', # Index qualifier identifier.
645 |  |  |  |  | 'INDEX_NAME', # The index identifier.
646 |  |  |  |  | 'TYPE', # The type of information being returned.
647 |  |  |  |  | 'ORDINAL_POSITION', # Column sequence number (starting with 1).
648 |  |  |  |  | 'COLUMN_NAME', # The column identifier.
649 |  |  |  |  | 'ASC_OR_DESC', # Column sort sequence.
650 |  |  |  |  | 'CARDINALITY', # Cardinality of the table or index.
651 |  |  |  |  | 'PAGES', # Number of storage pages used by this table or index.
652 |  |  |  |  | 'FILTER_CONDITION', # The index filter condition as a string.
653 |  |  |  |  | );
654 |  |  |  |  |
655 |  |  |  |  | sub statistics_info {
656 |  |  |  |  | my ($dbh, $catalog, $schema, $table, $unique_only, $quick) = @_;
657 |  |  |  |  |
658 |  |  |  |  | my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}});
659 |  |  |  |  |
660 |  |  |  |  | my @statistics_info;
661 |  |  |  |  | for my $database (@$databases) {
662 |  |  |  |  | my $dbname = $database->{name};
663 |  |  |  |  | next if defined $schema && $schema ne '%' && $schema ne $dbname;
664 |  |  |  |  |
665 |  |  |  |  | my $quoted_dbname = $dbh->quote_identifier($dbname);
666 |  |  |  |  | my $master_table =
667 |  |  |  |  | ($dbname eq 'main') ? 'sqlite_master' :
668 |  |  |  |  | ($dbname eq 'temp') ? 'sqlite_temp_master' :
669 |  |  |  |  | $quoted_dbname.'.sqlite_master';
670 |  |  |  |  |
671 |  |  |  |  | my $tables = $dbh->selectall_arrayref("SELECT name FROM $master_table WHERE type = ?", undef, "table");
672 |  |  |  |  | for my $table_ref (@$tables) {
673 |  |  |  |  | my $tbname = $table_ref->[0];
674 |  |  |  |  | next if defined $table && $table ne '%' && $table ne $tbname;
675 |  |  |  |  |
676 |  |  |  |  | my $quoted_tbname = $dbh->quote_identifier($tbname);
677 |  |  |  |  | my $sth = $dbh->prepare("PRAGMA $quoted_dbname.index_list($quoted_tbname)");
678 |  |  |  |  | $sth->execute;
679 |  |  |  |  | while(my $row = $sth->fetchrow_hashref) {
680 |  |  |  |  |
681 |  |  |  |  | next if defined $unique_only && $unique_only && $row->{unique};
682 |  |  |  |  | my $quoted_idx = $dbh->quote_identifier($row->{name});
683 |  |  |  |  | for my $db (@$databases) {
684 |  |  |  |  | my $quoted_db = $dbh->quote_identifier($db->{name});
685 |  |  |  |  | my $i_sth = $dbh->prepare("PRAGMA $quoted_db.index_info($quoted_idx)");
686 |  |  |  |  | $i_sth->execute;
687 |  |  |  |  | my $cols = {};
688 |  |  |  |  | while(my $info = $i_sth->fetchrow_hashref) {
689 |  |  |  |  | push @statistics_info, {
690 |  |  |  |  | TABLE_CAT => undef,
691 |  |  |  |  | TABLE_SCHEM => $db->{name},
692 |  |  |  |  | TABLE_NAME => $tbname,
693 |  |  |  |  | NON_UNIQUE => $row->{unique} ? 0 : 1,
694 |  |  |  |  | INDEX_QUALIFIER => undef,
695 |  |  |  |  | INDEX_NAME => $row->{name},
696 |  |  |  |  | TYPE => 'btree', # see http://www.sqlite.org/version3.html esp. "Traditional B-trees are still used for indices"
697 |  |  |  |  | ORDINAL_POSITION => $info->{seqno} + 1,
698 |  |  |  |  | COLUMN_NAME => $info->{name},
699 |  |  |  |  | ASC_OR_DESC => undef,
700 |  |  |  |  | CARDINALITY => undef,
701 |  |  |  |  | PAGES => undef,
702 |  |  |  |  | FILTER_CONDITION => undef,
703 |  |  |  |  | };
704 |  |  |  |  | }
705 |  |  |  |  | }
706 |  |  |  |  | }
707 |  |  |  |  | }
708 |  |  |  |  | }
709 |  |  |  |  |
710 |  |  |  |  | my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "")
711 |  |  |  |  | or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
712 |  |  |  |  | my $sponge_sth = $sponge_dbh->prepare("statistics_info", {
713 |  |  |  |  | NAME => \@STATISTICS_INFO_ODBC,
714 |  |  |  |  | rows => [ map { [@{$_}{@STATISTICS_INFO_ODBC} ] } @statistics_info ],
715 |  |  |  |  | NUM_OF_FIELDS => scalar(@STATISTICS_INFO_ODBC),
716 |  |  |  |  | }) or return $dbh->DBI::set_err(
717 |  |  |  |  | $sponge_dbh->err,
718 |  |  |  |  | $sponge_dbh->errstr,
719 |  |  |  |  | );
720 |  |  |  |  | return $sponge_sth;
721 |  |  |  |  | }
722 |  |  |  |  |
723 |  |  |  |  | sub type_info_all {
724 |  |  |  |  | return; # XXX code just copied from DBD::Oracle, not yet thought about
725 |  |  |  |  | # return [
726 |  |  |  |  | # {
727 |  |  |  |  | # TYPE_NAME => 0,
728 |  |  |  |  | # DATA_TYPE => 1,
729 |  |  |  |  | # COLUMN_SIZE => 2,
730 |  |  |  |  | # LITERAL_PREFIX => 3,
731 |  |  |  |  | # LITERAL_SUFFIX => 4,
732 |  |  |  |  | # CREATE_PARAMS => 5,
733 |  |  |  |  | # NULLABLE => 6,
734 |  |  |  |  | # CASE_SENSITIVE => 7,
735 |  |  |  |  | # SEARCHABLE => 8,
736 |  |  |  |  | # UNSIGNED_ATTRIBUTE => 9,
737 |  |  |  |  | # FIXED_PREC_SCALE => 10,
738 |  |  |  |  | # AUTO_UNIQUE_VALUE => 11,
739 |  |  |  |  | # LOCAL_TYPE_NAME => 12,
740 |  |  |  |  | # MINIMUM_SCALE => 13,
741 |  |  |  |  | # MAXIMUM_SCALE => 14,
742 |  |  |  |  | # SQL_DATA_TYPE => 15,
743 |  |  |  |  | # SQL_DATETIME_SUB => 16,
744 |  |  |  |  | # NUM_PREC_RADIX => 17,
745 |  |  |  |  | # },
746 |  |  |  |  | # [ 'CHAR', 1, 255, '\'', '\'', 'max length', 1, 1, 3,
747 |  |  |  |  | # undef, '0', '0', undef, undef, undef, 1, undef, undef
748 |  |  |  |  | # ],
749 |  |  |  |  | # [ 'NUMBER', 3, 38, undef, undef, 'precision,scale', 1, '0', 3,
750 |  |  |  |  | # '0', '0', '0', undef, '0', 38, 3, undef, 10
751 |  |  |  |  | # ],
752 |  |  |  |  | # [ 'DOUBLE', 8, 15, undef, undef, undef, 1, '0', 3,
753 |  |  |  |  | # '0', '0', '0', undef, undef, undef, 8, undef, 10
754 |  |  |  |  | # ],
755 |  |  |  |  | # [ 'DATE', 9, 19, '\'', '\'', undef, 1, '0', 3,
756 |  |  |  |  | # undef, '0', '0', undef, '0', '0', 11, undef, undef
757 |  |  |  |  | # ],
758 |  |  |  |  | # [ 'VARCHAR', 12, 1024*1024, '\'', '\'', 'max length', 1, 1, 3,
759 |  |  |  |  | # undef, '0', '0', undef, undef, undef, 12, undef, undef
760 |  |  |  |  | # ]
761 |  |  |  |  | # ];
762 |  |  |  |  | }
763 |  |  |  |  |
764 | 1 | 2µs |  |  | my @COLUMN_INFO = qw(
765 |  |  |  |  | TABLE_CAT
766 |  |  |  |  | TABLE_SCHEM
767 |  |  |  |  | TABLE_NAME
768 |  |  |  |  | COLUMN_NAME
769 |  |  |  |  | DATA_TYPE
770 |  |  |  |  | TYPE_NAME
771 |  |  |  |  | COLUMN_SIZE
772 |  |  |  |  | BUFFER_LENGTH
773 |  |  |  |  | DECIMAL_DIGITS
774 |  |  |  |  | NUM_PREC_RADIX
775 |  |  |  |  | NULLABLE
776 |  |  |  |  | REMARKS
777 |  |  |  |  | COLUMN_DEF
778 |  |  |  |  | SQL_DATA_TYPE
779 |  |  |  |  | SQL_DATETIME_SUB
780 |  |  |  |  | CHAR_OCTET_LENGTH
781 |  |  |  |  | ORDINAL_POSITION
782 |  |  |  |  | IS_NULLABLE
783 |  |  |  |  | );
784 |  |  |  |  |
785 |  |  |  |  | sub column_info {
786 |  |  |  |  | my ($dbh, $cat_val, $sch_val, $tbl_val, $col_val) = @_;
787 |  |  |  |  |
788 |  |  |  |  | if ( defined $col_val and $col_val eq '%' ) {
789 |  |  |  |  | $col_val = undef;
790 |  |  |  |  | }
791 |  |  |  |  |
792 |  |  |  |  | # Get a list of all tables ordered by TABLE_SCHEM, TABLE_NAME
793 |  |  |  |  | my $sql = <<'END_SQL';
794 |  |  |  |  | SELECT TABLE_SCHEM, tbl_name TABLE_NAME
795 |  |  |  |  | FROM (
796 |  |  |  |  | SELECT 'main' TABLE_SCHEM, tbl_name
797 |  |  |  |  | FROM sqlite_master
798 |  |  |  |  | WHERE type IN ('table','view')
799 |  |  |  |  | UNION ALL
800 |  |  |  |  | SELECT 'temp' TABLE_SCHEM, tbl_name
801 |  |  |  |  | FROM sqlite_temp_master
802 |  |  |  |  | WHERE type IN ('table','view')
803 |  |  |  |  | END_SQL
804 |  |  |  |  |
805 |  |  |  |  | for my $db_name (_attached_database_list($dbh)) {
806 |  |  |  |  | $sql .= <<"END_SQL";
807 |  |  |  |  | UNION ALL
808 |  |  |  |  | SELECT '$db_name' TABLE_SCHEM, tbl_name
809 |  |  |  |  | FROM "$db_name".sqlite_master
810 |  |  |  |  | WHERE type IN ('table','view')
811 |  |  |  |  | END_SQL
812 |  |  |  |  | }
813 |  |  |  |  |
814 |  |  |  |  | $sql .= <<'END_SQL';
815 |  |  |  |  | UNION ALL
816 |  |  |  |  | SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name
817 |  |  |  |  | UNION ALL
818 |  |  |  |  | SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name
819 |  |  |  |  | )
820 |  |  |  |  | END_SQL
821 |  |  |  |  |
822 |  |  |  |  | my @where;
823 |  |  |  |  | if ( defined $sch_val ) {
824 |  |  |  |  | push @where, "TABLE_SCHEM LIKE '$sch_val'";
825 |  |  |  |  | }
826 |  |  |  |  | if ( defined $tbl_val ) {
827 |  |  |  |  | push @where, "TABLE_NAME LIKE '$tbl_val'";
828 |  |  |  |  | }
829 |  |  |  |  | $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
830 |  |  |  |  | $sql .= " ORDER BY TABLE_SCHEM, TABLE_NAME\n";
831 |  |  |  |  | my $sth_tables = $dbh->prepare($sql) or return undef;
832 |  |  |  |  | $sth_tables->execute or return undef;
833 |  |  |  |  |
834 |  |  |  |  | # Taken from Fey::Loader::SQLite
835 |  |  |  |  | my @cols;
836 |  |  |  |  | while ( my ($schema, $table) = $sth_tables->fetchrow_array ) {
837 |  |  |  |  | my $sth_columns = $dbh->prepare(qq{PRAGMA "$schema".table_info("$table")});
838 |  |  |  |  | $sth_columns->execute;
839 |  |  |  |  |
840 |  |  |  |  | for ( my $position = 1; my $col_info = $sth_columns->fetchrow_hashref; $position++ ) {
841 |  |  |  |  | if ( defined $col_val ) {
842 |  |  |  |  | # This must do a LIKE comparison
843 |  |  |  |  | my $sth = $dbh->prepare("SELECT '$col_info->{name}' LIKE '$col_val'") or return undef;
844 |  |  |  |  | $sth->execute or return undef;
845 |  |  |  |  | # Skip columns that don't match $col_val
846 |  |  |  |  | next unless ($sth->fetchrow_array)[0];
847 |  |  |  |  | }
848 |  |  |  |  |
849 |  |  |  |  | my %col = (
850 |  |  |  |  | TABLE_SCHEM => $schema,
851 |  |  |  |  | TABLE_NAME => $table,
852 |  |  |  |  | COLUMN_NAME => $col_info->{name},
853 |  |  |  |  | ORDINAL_POSITION => $position,
854 |  |  |  |  | );
855 |  |  |  |  |
856 |  |  |  |  | my $type = $col_info->{type};
857 |  |  |  |  | if ( $type =~ s/(\w+) ?\((\d+)(?:,(\d+))?\)/$1/ ) {
858 |  |  |  |  | $col{COLUMN_SIZE} = $2;
859 |  |  |  |  | $col{DECIMAL_DIGITS} = $3;
860 |  |  |  |  | }
861 |  |  |  |  |
862 |  |  |  |  | $col{TYPE_NAME} = $type;
863 |  |  |  |  |
864 |  |  |  |  | if ( defined $col_info->{dflt_value} ) {
865 |  |  |  |  | $col{COLUMN_DEF} = $col_info->{dflt_value}
866 |  |  |  |  | }
867 |  |  |  |  |
868 |  |  |  |  | if ( $col_info->{notnull} ) {
869 |  |  |  |  | $col{NULLABLE} = 0;
870 |  |  |  |  | $col{IS_NULLABLE} = 'NO';
871 |  |  |  |  | } else {
872 |  |  |  |  | $col{NULLABLE} = 1;
873 |  |  |  |  | $col{IS_NULLABLE} = 'YES';
874 |  |  |  |  | }
875 |  |  |  |  |
876 |  |  |  |  | push @cols, \%col;
877 |  |  |  |  | }
878 |  |  |  |  | $sth_columns->finish;
879 |  |  |  |  | }
880 |  |  |  |  | $sth_tables->finish;
881 |  |  |  |  |
882 |  |  |  |  | my $sponge = DBI->connect("DBI:Sponge:", '','')
883 |  |  |  |  | or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
884 |  |  |  |  | $sponge->prepare( "column_info", {
885 |  |  |  |  | rows => [ map { [ @{$_}{@COLUMN_INFO} ] } @cols ],
886 |  |  |  |  | NUM_OF_FIELDS => scalar @COLUMN_INFO,
887 |  |  |  |  | NAME => [ @COLUMN_INFO ],
888 |  |  |  |  | } ) or return $dbh->DBI::set_err(
889 |  |  |  |  | $sponge->err,
890 |  |  |  |  | $sponge->errstr,
891 |  |  |  |  | );
892 |  |  |  |  | }
893 |  |  |  |  |
894 |  |  |  |  | #======================================================================
895 |  |  |  |  | # An internal tied hash package used for %DBD::SQLite::COLLATION, to
896 |  |  |  |  | # prevent people from unintentionally overriding globally registered collations.
897 |  |  |  |  |
898 |  |  |  |  | package # hide from PAUSE
899 |  |  |  |  | DBD::SQLite::_WriteOnceHash;
900 |  |  |  |  |
901 | 1 | 900ns |  |  | require Tie::Hash;
902 |  |  |  |  |
903 | 1 | 19µs |  |  | our @ISA = qw(Tie::StdHash);
904 |  |  |  |  |
905 |  |  |  |  | # spent 2µs within DBD::SQLite::_WriteOnceHash::TIEHASH which was called: # once (2µs+0s) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 24 sub TIEHASH {
906 | 1 | 4µs |  |  | bless {}, $_[0];
907 |  |  |  |  | }
908 |  |  |  |  |
909 |  |  |  |  | # spent 7µs within DBD::SQLite::_WriteOnceHash::STORE which was called 2 times, avg 3µs/call: # once (5µs+0s) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 25 # once (1µs+0s) by Test::PONAPI::Repository::MockDB::BEGIN@7 at line 26 sub STORE {
910 | 2 | 4µs |  |  | ! exists $_[0]->{$_[1]} or die "entry $_[1] already registered";
911 | 2 | 6µs |  |  | $_[0]->{$_[1]} = $_[2];
912 |  |  |  |  | }
913 |  |  |  |  |
914 |  |  |  |  | sub DELETE {
915 |  |  |  |  | die "deletion of entry $_[1] is forbidden";
916 |  |  |  |  | }
917 |  |  |  |  |
918 | 1 | 13µs |  |  | 1;
919 |  |  |  |  |
920 |  |  |  |  | __END__
|  |  |  |  | # spent 418µs within DBD::SQLite::bootstrap which was called: # once (418µs+0s) by DynaLoader::bootstrap at line 207 of DynaLoader.pm sub DBD::SQLite::bootstrap; # xsub
|  |  |  |  | # spent 487ms within DBD::SQLite::db::_do which was called 12 times, avg 40.5ms/call: # 12 times (487ms+0s) by DBD::SQLite::db::do at line 211, avg 40.5ms/call sub DBD::SQLite::db::_do; # xsub
|  |  |  |  | # spent 128µs within DBD::SQLite::db::_login which was called: # once (128µs+0s) by DBD::SQLite::dr::connect at line 131 sub DBD::SQLite::db::_login; # xsub
|  |  |  |  | # spent 4µs within DBD::SQLite::dr::CORE:match which was called 3 times, avg 1µs/call: # once (2µs+0s) by DBD::SQLite::dr::connect at line 97 # once (900ns+0s) by DBD::SQLite::dr::connect at line 94 # once (800ns+0s) by DBD::SQLite::dr::connect at line 116 sub DBD::SQLite::dr::CORE:match; # opcode