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