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