File Coverage

blib/lib/DBD/SQLeet.pm
Criterion Covered Total %
statement 303 317 95.5
branch 149 208 71.6
condition 85 137 62.0
subroutine 25 28 89.2
pod 0 1 0.0
total 562 691 81.3


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