| 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 | DBD::SQLite::db::prepare |
| 12 | 1 | 1 | 487ms | 487ms | DBD::SQLite::db::_do (xsub) |
| 1 | 1 | 1 | 10.0ms | 11.3ms | DBD::SQLite::BEGIN@5 |
| 23 | 1 | 1 | 1.95ms | 663ms | DBD::SQLite::db::do |
| 1 | 1 | 1 | 418µs | 418µs | DBD::SQLite::bootstrap (xsub) |
| 1 | 1 | 1 | 218µs | 298µs | DBD::SQLite::BEGIN@26 |
| 1 | 1 | 1 | 128µs | 128µs | DBD::SQLite::db::_login (xsub) |
| 1 | 1 | 1 | 101µs | 556µs | DBD::SQLite::driver |
| 1 | 1 | 1 | 44µs | 285µs | DBD::SQLite::dr::connect |
| 1 | 1 | 1 | 18µs | 18µs | DBD::SQLite::BEGIN@3 |
| 1 | 1 | 1 | 12µs | 55µs | DBD::SQLite::BEGIN@20 |
| 1 | 1 | 1 | 7µs | 22µs | DBD::SQLite::BEGIN@4 |
| 1 | 1 | 1 | 7µs | 18µs | DBD::SQLite::dr::BEGIN@185 |
| 2 | 2 | 1 | 7µs | 7µs | DBD::SQLite::_WriteOnceHash::STORE |
| 1 | 1 | 1 | 5µs | 5µs | DBD::SQLite::BEGIN@6 |
| 3 | 3 | 1 | 4µs | 4µs | DBD::SQLite::dr::CORE:match (opcode) |
| 1 | 1 | 1 | 2µs | 2µs | DBD::SQLite::_WriteOnceHash::TIEHASH |
| 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__[:25] |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::__ANON__[:26] |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::_attached_database_list |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::_get_version |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::column_info |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::foreign_key_info |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::get_info |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::ping |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::primary_key_info |
| 0 | 0 | 0 | 0s | 0s | DBD::SQLite::db::statistics_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 | 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 |