Filename | /usr/local/lib/perl/5.18.2/DBD/SQLite.pm |
Statements | Executed 2208980 statements in 21.9s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
368127 | 2 | 2 | 4.56s | 30.6s | prepare | DBD::SQLite::db::
12 | 1 | 1 | 487ms | 487ms | _do (xsub) | DBD::SQLite::db::
1 | 1 | 1 | 10.0ms | 11.3ms | BEGIN@5 | DBD::SQLite::
23 | 1 | 1 | 1.95ms | 663ms | do | DBD::SQLite::db::
1 | 1 | 1 | 418µs | 418µs | bootstrap (xsub) | DBD::SQLite::
1 | 1 | 1 | 218µs | 298µs | BEGIN@26 | DBD::SQLite::
1 | 1 | 1 | 128µs | 128µs | _login (xsub) | DBD::SQLite::db::
1 | 1 | 1 | 101µs | 556µs | driver | DBD::SQLite::
1 | 1 | 1 | 44µs | 285µs | connect | DBD::SQLite::dr::
1 | 1 | 1 | 18µs | 18µs | BEGIN@3 | DBD::SQLite::
1 | 1 | 1 | 12µs | 55µs | BEGIN@20 | DBD::SQLite::
1 | 1 | 1 | 7µs | 22µs | BEGIN@4 | DBD::SQLite::
1 | 1 | 1 | 7µs | 18µs | BEGIN@185 | DBD::SQLite::dr::
2 | 2 | 1 | 7µs | 7µs | STORE | DBD::SQLite::_WriteOnceHash::
1 | 1 | 1 | 5µs | 5µs | BEGIN@6 | DBD::SQLite::
3 | 3 | 1 | 4µs | 4µs | CORE:match (opcode) | DBD::SQLite::dr::
1 | 1 | 1 | 2µs | 2µs | TIEHASH | DBD::SQLite::_WriteOnceHash::
0 | 0 | 0 | 0s | 0s | CLONE | DBD::SQLite::
0 | 0 | 0 | 0s | 0s | DELETE | DBD::SQLite::_WriteOnceHash::
0 | 0 | 0 | 0s | 0s | __ANON__[:25] | DBD::SQLite::
0 | 0 | 0 | 0s | 0s | __ANON__[:26] | DBD::SQLite::
0 | 0 | 0 | 0s | 0s | _attached_database_list | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | _get_version | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | column_info | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | foreign_key_info | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | get_info | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | ping | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | primary_key_info | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | statistics_info | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | table_info | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | type_info_all | DBD::SQLite::db::
0 | 0 | 0 | 0s | 0s | install_collation | DBD::SQLite::dr::
0 | 0 | 0 | 0s | 0s | regexp | DBD::SQLite::dr::
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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
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 | ||||
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, \®exp ); # 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, \®exp, "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 # 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 | ||||
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 | ||||
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 | ||||
906 | 1 | 4µs | bless {}, $_[0]; | ||
907 | } | ||||
908 | |||||
909 | 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 | |||||
# 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 | |||||
# 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::dr::CORE:match; # opcode |