simcop2387/DBD-SQLite-SQLcipher
1
0
Fork 0
mirror of https://github.com/DBD-SQLite/DBD-SQLite synced 2025-06-07 22:28:47 -04:00
Code Issues Releases Wiki Activity

Some minor normalising and tydying up of the Perl code.

Browse source 
Adding some more explicit versions.
This commit is contained in:
Adam Kennedy 2009-04-03 18:19:15 +00:00
parent 055d3393e1
commit 8ddf75e5f0
3 changed files with 208 additions and 199 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

195
lib/DBD/SQLite.pm
View file

@ -1,22 +1,20 @@
package DBD::SQLite; package DBD::SQLite;
use 5.005; use 5.00503;
use strict; use strict;
use DBI (); use DBI ();
use DynaLoader(); use DynaLoader ();
use vars qw($VERSION @ISA); use vars qw($VERSION @ISA);
use vars qw{$err $errstr $state $drh $sqlite_version};
BEGIN { BEGIN {
$VERSION = '1.19_06'; $VERSION = '1.19_06';
@ISA = ('DynaLoader'); @ISA = ('DynaLoader');
$drh = undef;
} }
use vars qw{$err $errstr $state $drh $sqlite_version};
__PACKAGE__->bootstrap($VERSION); __PACKAGE__->bootstrap($VERSION);
$drh = undef;
sub driver { sub driver {
return $drh if $drh; return $drh if $drh;
my ($class, $attr) = @_; my ($class, $attr) = @_;
@ -26,7 +24,7 @@ sub driver {
$drh = DBI::_new_drh($class, { $drh = DBI::_new_drh($class, {
Name => 'SQLite', Name => 'SQLite',
Version => $VERSION, Version => $VERSION,
Attribution => 'DBD::SQLite by Matt Sergeant', Attribution => 'DBD::SQLite by Matt Sergeant et al',
}); });
return $drh; return $drh;
@ -41,18 +39,17 @@ package DBD::SQLite::dr;
sub connect { sub connect {
my ($drh, $dbname, $user, $auth, $attr) = @_; my ($drh, $dbname, $user, $auth, $attr) = @_;
my $dbh = DBI::_new_dbh($drh, { my $dbh = DBI::_new_dbh( $drh, {
Name => $dbname, Name => $dbname,
}); } );
my $real_dbname = $dbname; my $real_dbname = $dbname;
if ($dbname =~ /=/) { if ( $dbname =~ /=/ ) {
foreach my $attrib (split(/;/, $dbname)) { foreach my $attrib ( split(/;/, $dbname ) ) {
my ($k, $v) = split(/=/, $attrib, 2); my ($k, $v) = split(/=/, $attrib, 2);
if ($k eq 'dbname') { if ($k eq 'dbname') {
$real_dbname = $v; $real_dbname = $v;
} } else {
else {
# TODO: add to attribs # TODO: add to attribs
} }
} }
@ -62,7 +59,7 @@ sub connect {
# install perl collations # install perl collations
my $perl_collation = sub {$_[0] cmp $_[1]}; my $perl_collation = sub {$_[0] cmp $_[1]};
my $perl_locale_collation = sub {use locale; $_[0] cmp $_[1]}; my $perl_locale_collation = sub { use locale; $_[0] cmp $_[1] };
$dbh->func( "perl", $perl_collation, "create_collation" ); $dbh->func( "perl", $perl_collation, "create_collation" );
$dbh->func( "perllocale", $perl_locale_collation, "create_collation" ); $dbh->func( "perllocale", $perl_locale_collation, "create_collation" );
@ -85,8 +82,7 @@ sub prepare {
} }
sub _get_version { sub _get_version {
my ($dbh) = @_; return( DBD::SQLite::db::FETCH($_[0], 'sqlite_version') );
return (DBD::SQLite::db::FETCH($dbh, 'sqlite_version'));
} }
my %info = ( my %info = (
@ -103,40 +99,40 @@ sub get_info {
} }
sub table_info { sub table_info {
my ($dbh, $CatVal, $SchVal, $TblVal, $TypVal) = @_; my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val) = @_;
# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables # SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
# Based on DBD::Oracle's # Based on DBD::Oracle's
# See also http://www.ch-werner.de/sqliteodbc/html/sqliteodbc_8c.html#a117 # See also http://www.ch-werner.de/sqliteodbc/html/sqliteodbc_8c.html#a117
my @Where = (); my @where = ();
my $Sql; my $sql;
if ( defined($CatVal) && $CatVal eq '%' if ( defined($cat_val) && $cat_val eq '%'
&& defined($SchVal) && $SchVal eq '' && defined($sch_val) && $sch_val eq ''
&& defined($TblVal) && $TblVal eq '') { # Rule 19a && defined($tbl_val) && $tbl_val eq '') { # Rule 19a
$Sql = <<'SQL'; $sql = <<'END_SQL';
SELECT NULL TABLE_CAT SELECT NULL TABLE_CAT
, NULL TABLE_SCHEM , NULL TABLE_SCHEM
, NULL TABLE_NAME , NULL TABLE_NAME
, NULL TABLE_TYPE , NULL TABLE_TYPE
, NULL REMARKS , NULL REMARKS
SQL END_SQL
} }
elsif ( defined($SchVal) && $SchVal eq '%' elsif ( defined($sch_val) && $sch_val eq '%'
&& defined($CatVal) && $CatVal eq '' && defined($cat_val) && $cat_val eq ''
&& defined($TblVal) && $TblVal eq '') { # Rule 19b && defined($tbl_val) && $tbl_val eq '') { # Rule 19b
$Sql = <<'SQL'; $sql = <<'END_SQL';
SELECT NULL TABLE_CAT SELECT NULL TABLE_CAT
, NULL TABLE_SCHEM , NULL TABLE_SCHEM
, NULL TABLE_NAME , NULL TABLE_NAME
, NULL TABLE_TYPE , NULL TABLE_TYPE
, NULL REMARKS , NULL REMARKS
SQL END_SQL
} }
elsif ( defined($TypVal) && $TypVal eq '%' elsif ( defined($typ_val) && $typ_val eq '%'
&& defined($CatVal) && $CatVal eq '' && defined($cat_val) && $cat_val eq ''
&& defined($SchVal) && $SchVal eq '' && defined($sch_val) && $sch_val eq ''
&& defined($TblVal) && $TblVal eq '') { # Rule 19c && defined($tbl_val) && $tbl_val eq '') { # Rule 19c
$Sql = <<'SQL'; $sql = <<'END_SQL';
SELECT NULL TABLE_CAT SELECT NULL TABLE_CAT
, NULL TABLE_SCHEM , NULL TABLE_SCHEM
, NULL TABLE_NAME , NULL TABLE_NAME
@ -148,10 +144,10 @@ FROM (
SELECT 'LOCAL TEMPORARY' tt SELECT 'LOCAL TEMPORARY' tt
) t ) t
ORDER BY TABLE_TYPE ORDER BY TABLE_TYPE
SQL END_SQL
} }
else { else {
$Sql = <<'SQL'; $sql = <<'END_SQL';
SELECT * SELECT *
FROM FROM
( (
@ -175,55 +171,50 @@ UNION ALL
SELECT 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql SELECT 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql
) )
) )
SQL END_SQL
if ( defined $TblVal ) { if ( defined $tbl_val ) {
push @Where, "TABLE_NAME LIKE '$TblVal'"; push @where, "TABLE_NAME LIKE '$tbl_val'";
} }
if ( defined $TypVal ) { if ( defined $typ_val ) {
my $table_type_list; my $table_type_list;
$TypVal =~ s/^\s+//; $typ_val =~ s/^\s+//;
$TypVal =~ s/\s+$//; $typ_val =~ s/\s+$//;
my @ttype_list = split (/\s*,\s*/, $TypVal); my @ttype_list = split (/\s*,\s*/, $typ_val);
foreach my $table_type (@ttype_list) { foreach my $table_type (@ttype_list) {
if ($table_type !~ /^'.*'$/) { if ($table_type !~ /^'.*'$/) {
$table_type = "'" . $table_type . "'"; $table_type = "'" . $table_type . "'";
} }
$table_type_list = join(", ", @ttype_list); $table_type_list = join(", ", @ttype_list);
} }
push @Where, "TABLE_TYPE IN (\U$table_type_list)" push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list;
if $table_type_list;
} }
$Sql .= ' WHERE ' . join("\n AND ", @Where ) . "\n" if @Where; $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where;
$Sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n"; $sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n";
} }
my $sth = $dbh->prepare($Sql) or return undef; my $sth = $dbh->prepare($sql) or return undef;
$sth->execute or return undef; $sth->execute or return undef;
$sth; $sth;
} }
sub primary_key_info { sub primary_key_info {
my($dbh, $catalog, $schema, $table) = @_; my($dbh, $catalog, $schema, $table) = @_;
my @pk_info; # This is a hack but much simpler than using pragma index_list etc
my $sth_tables = $dbh->table_info($catalog, $schema, $table, '');
# this is a hack but much simpler than using pragma index_list etc
# also the pragma doesn't list 'INTEGER PRIMARK KEY' autoinc PKs! # also the pragma doesn't list 'INTEGER PRIMARK KEY' autoinc PKs!
my @pk_info;
my $sth_tables = $dbh->table_info($catalog, $schema, $table, '');
while ( my $row = $sth_tables->fetchrow_hashref ) { while ( my $row = $sth_tables->fetchrow_hashref ) {
my $sql = $row->{sqlite_sql} or next; my $sql = $row->{sqlite_sql} or next;
next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si; next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si;
my @pk = split /\s*,\s*/, $2 || ''; my @pk = split /\s*,\s*/, $2 || '';
unless (@pk) { unless ( @pk ) {
my $prefix = $1; my $prefix = $1;
$prefix =~ s/.*create\s+table\s+.*?\(\s*//si; $prefix =~ s/.*create\s+table\s+.*?\(\s*//si;
$prefix = (split /\s*,\s*/, $prefix)[-1]; $prefix = (split /\s*,\s*/, $prefix)[-1];
@pk = (split /\s+/, $prefix)[0]; # take first word as name @pk = (split /\s+/, $prefix)[0]; # take first word as name
} }
#warn "GOT PK $row->{TABLE_NAME} (@pk)\n";
my $key_seq = 0; my $key_seq = 0;
for my $pk_field (@pk) { foreach my $pk_field (@pk) {
push @pk_info, { push @pk_info, {
TABLE_SCHEM => $row->{TABLE_SCHEM}, TABLE_SCHEM => $row->{TABLE_SCHEM},
TABLE_NAME => $row->{TABLE_NAME}, TABLE_NAME => $row->{TABLE_NAME},
@ -237,17 +228,20 @@ sub primary_key_info {
my $sponge = DBI->connect("DBI:Sponge:", '','') my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME); my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME);
my $sth = $sponge->prepare("column_info $table", { my $sth = $sponge->prepare( "column_info $table", {
rows => [ map { [ @{$_}{@names} ] } @pk_info ], rows => [ map { [ @{$_}{@names} ] } @pk_info ],
NUM_OF_FIELDS => scalar @names, NUM_OF_FIELDS => scalar @names,
NAME => \@names, NAME => \@names,
}) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr()); }) or return $dbh->DBI::set_err(
$sponge->err(),
$sponge->errstr()
);
return $sth; return $sth;
} }
sub type_info_all { sub type_info_all {
my ($dbh) = @_; my ($dbh) = @_;
return; # XXX code just copied from DBD::Oracle, not yet thought about return; # XXX code just copied from DBD::Oracle, not yet thought about
my $names = { my $names = {
TYPE_NAME => 0, TYPE_NAME => 0,
DATA_TYPE => 1, DATA_TYPE => 1,
@ -259,14 +253,14 @@ return; # XXX code just copied from DBD::Oracle, not yet thought about
CASE_SENSITIVE => 7, CASE_SENSITIVE => 7,
SEARCHABLE => 8, SEARCHABLE => 8,
UNSIGNED_ATTRIBUTE => 9, UNSIGNED_ATTRIBUTE => 9,
FIXED_PREC_SCALE =>10, FIXED_PREC_SCALE => 10,
AUTO_UNIQUE_VALUE =>11, AUTO_UNIQUE_VALUE => 11,
LOCAL_TYPE_NAME =>12, LOCAL_TYPE_NAME => 12,
MINIMUM_SCALE =>13, MINIMUM_SCALE => 13,
MAXIMUM_SCALE =>14, MAXIMUM_SCALE => 14,
SQL_DATA_TYPE =>15, SQL_DATA_TYPE => 15,
SQL_DATETIME_SUB=>16, SQL_DATETIME_SUB => 16,
NUM_PREC_RADIX =>17, NUM_PREC_RADIX => 17,
}; };
my $ti = [ my $ti = [
$names, $names,
@ -294,13 +288,15 @@ return; # XXX code just copied from DBD::Oracle, not yet thought about
sub column_info { sub column_info {
my($dbh, $catalog, $schema, $table, $column) = @_; my($dbh, $catalog, $schema, $table, $column) = @_;
$column = undef if ( defined $column and $column eq '%' ) {
if defined $column && $column eq '%'; $column = undef;
}
my $sth_columns = $dbh->prepare( qq{PRAGMA table_info('$table')} ); my $sth_columns = $dbh->prepare( "PRAGMA table_info('$table')" );
$sth_columns->execute; $sth_columns->execute;
my @names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME my @names = qw(
TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME
DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH
DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE
REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB
@ -311,10 +307,10 @@ sub column_info {
while ( my $col_info = $sth_columns->fetchrow_hashref ) { while ( my $col_info = $sth_columns->fetchrow_hashref ) {
next if defined $column && $column ne $col_info->{name}; next if defined $column && $column ne $col_info->{name};
my %col; my %col = (
TABLE_NAME => $table,
$col{TABLE_NAME} = $table; COLUMN_NAME => $col_info->{name},
$col{COLUMN_NAME} = $col_info->{name}; );
my $type = $col_info->{type}; my $type = $col_info->{type};
if ( $type =~ s/(\w+)\((\d+)(?:,(\d+))?\)/$1/ ) { if ( $type =~ s/(\w+)\((\d+)(?:,(\d+))?\)/$1/ ) {
@ -324,21 +320,21 @@ sub column_info {
$col{TYPE_NAME} = $type; $col{TYPE_NAME} = $type;
if ( defined $col_info->{dflt_value} ) {
$col{COLUMN_DEF} = $col_info->{dflt_value} $col{COLUMN_DEF} = $col_info->{dflt_value}
if defined $col_info->{dflt_value}; }
if ( $col_info->{notnull} ) { if ( $col_info->{notnull} ) {
$col{NULLABLE} = 0; $col{NULLABLE} = 0;
$col{IS_NULLABLE} = 'NO'; $col{IS_NULLABLE} = 'NO';
} } else {
else {
$col{NULLABLE} = 1; $col{NULLABLE} = 1;
$col{IS_NULLABLE} = 'YES'; $col{IS_NULLABLE} = 'YES';
} }
for my $key (@names) { foreach my $key ( @names ) {
$col{$key} = undef next if exists $col{$key};
unless exists $col{$key}; $col{$key} = undef;
} }
push @cols, \%col; push @cols, \%col;
@ -346,16 +342,23 @@ sub column_info {
my $sponge = DBI->connect("DBI:Sponge:", '','') my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
my $sth = $sponge->prepare("column_info $table", { my $sth = $sponge->prepare( "column_info $table", {
rows => [ map { [ @{$_}{@names} ] } @cols ], rows => [ map { [ @{$_}{@names} ] } @cols ],
NUM_OF_FIELDS => scalar @names, NUM_OF_FIELDS => scalar @names,
NAME => \@names, NAME => \@names,
}) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr()); } ) or return $dbh->DBI::set_err(
$sponge->err,
$sponge->errstr,
);
return $sth; return $sth;
} }
1;
__END__ __END__
=pod
=head1 NAME =head1 NAME
DBD::SQLite - Self Contained RDBMS in a DBI Driver DBD::SQLite - Self Contained RDBMS in a DBI Driver
@ -438,12 +441,11 @@ updates:
use DBI qw(:sql_types); use DBI qw(:sql_types);
$dbh->{unicode} = 1; $dbh->{unicode} = 1;
my $sth = $dbh->prepare my $sth = $dbh->prepare("INSERT INTO mytable (blobcolumn) VALUES (?)");
("INSERT INTO mytable (blobcolumn) VALUES (?)"); # Binary_data will be stored as is.
$sth->bind_param(1, $binary_data, SQL_BLOB); # binary_data will $sth->bind_param(1, $binary_data, SQL_BLOB);
# be stored as-is.
Defining the column type as BLOB in the DDL is B<not> sufficient. Defining the column type as C<BLOB> in the DDL is B<not> sufficient.
=back =back
@ -458,7 +460,7 @@ Otherwise, it is the hidden ROWID column. See the sqlite docs for details.
Note: You can now use $dbh->last_insert_id() if you have a recent version of Note: You can now use $dbh->last_insert_id() if you have a recent version of
DBI. DBI.
=head2 $dbh->func( 'busy_timeout' ) =head2 $dbh->func('busy_timeout')
Retrieve the current busy timeout. Retrieve the current busy timeout.
@ -586,7 +588,8 @@ Here is a simple aggregate function which returns the variance
The aggregate function can then be used as: The aggregate function can then be used as:
SELECT group_name, variance(score) FROM results SELECT group_name, variance(score)
FROM results
GROUP BY group_name; GROUP BY group_name;
=head1 BLOBS =head1 BLOBS
@ -640,7 +643,8 @@ queries on the data.
Queries like count(*) and avg(bytes) took fractions of a second to return, Queries like count(*) and avg(bytes) took fractions of a second to return,
but what surprised me most of all was: but what surprised me most of all was:
SELECT url, count(*) as count FROM access_log SELECT url, count(*) as count
FROM access_log
GROUP BY url GROUP BY url
ORDER BY count desc ORDER BY count desc
LIMIT 20 LIMIT 20
@ -694,7 +698,7 @@ L<http://rt.cpan.org/Public/Bug/Display.html?id=35449>
L<http://rt.cpan.org/Public/Bug/Display.html?id=29629> L<http://rt.cpan.org/Public/Bug/Display.html?id=29629>
(patch required) (patch required)
Switch tests to Test::More to support more advanced testing behaviours Switch tests to L<Test::More> to support more advanced testing behaviours
=head1 AUTHOR =head1 AUTHOR
@ -710,7 +714,7 @@ Max Maischein E<lt>corion@cpan.orgE<gt>
=head1 COPYRIGHT =head1 COPYRIGHT
The bundled SQLite is Public Domain. The bundled SQLite code in this distribution is Public Domain.
DBD::SQLite is copyright 2002 - 2007 Matt Sergeant. DBD::SQLite is copyright 2002 - 2007 Matt Sergeant.
@ -718,7 +722,8 @@ Some parts copyright 2008 Francis J. Lacoste and Wolfgang Sourdeau.
Some parts copyright 2008 - 2009 Adam Kennedy. Some parts copyright 2008 - 2009 Adam Kennedy.
Some parts taken from L<DBD::SQLite::Amalgamation>. Some parts derived from L<DBD::SQLite::Amalgamation>
copyright 2008 Audrey Tang.
This program is free software; you can redistribute This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself. it and/or modify it under the same terms as Perl itself.

1
t/08create_function.t
View file

@ -1,5 +1,6 @@
#!/usr/bin/perl #!/usr/bin/perl
use 5.005_03;
use strict; use strict;
BEGIN { BEGIN {
$| = 1; $| = 1;

5
t/11unicode.t
View file

@ -47,7 +47,10 @@ sub is_utf8 {
### Test code starts here ### Test code starts here
Testing(); our $numTests; $numTests = 14; Testing(); Testing();
use vars qw{$numTests};
$numTests = 14;
Testing();
# First, some UTF-8 framework self-test: # First, some UTF-8 framework self-test: