diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm index 27e228a..cf46fa9 100644 --- a/lib/DBD/SQLite.pm +++ b/lib/DBD/SQLite.pm @@ -1,22 +1,20 @@ package DBD::SQLite; -use 5.005; +use 5.00503; use strict; -use DBI (); -use DynaLoader(); +use DBI (); +use DynaLoader (); use vars qw($VERSION @ISA); +use vars qw{$err $errstr $state $drh $sqlite_version}; BEGIN { - $VERSION = '1.19_06'; - @ISA = ('DynaLoader'); + $VERSION = '1.19_06'; + @ISA = ('DynaLoader'); + $drh = undef; } -use vars qw{$err $errstr $state $drh $sqlite_version}; - __PACKAGE__->bootstrap($VERSION); -$drh = undef; - sub driver { return $drh if $drh; my ($class, $attr) = @_; @@ -26,7 +24,7 @@ sub driver { $drh = DBI::_new_drh($class, { Name => 'SQLite', Version => $VERSION, - Attribution => 'DBD::SQLite by Matt Sergeant', + Attribution => 'DBD::SQLite by Matt Sergeant et al', }); return $drh; @@ -41,18 +39,17 @@ package DBD::SQLite::dr; sub connect { my ($drh, $dbname, $user, $auth, $attr) = @_; - my $dbh = DBI::_new_dbh($drh, { + my $dbh = DBI::_new_dbh( $drh, { Name => $dbname, - }); + } ); my $real_dbname = $dbname; - if ($dbname =~ /=/) { - foreach my $attrib (split(/;/, $dbname)) { + if ( $dbname =~ /=/ ) { + foreach my $attrib ( split(/;/, $dbname ) ) { my ($k, $v) = split(/=/, $attrib, 2); if ($k eq 'dbname') { $real_dbname = $v; - } - else { + } else { # TODO: add to attribs } } @@ -62,7 +59,7 @@ sub connect { # install perl collations 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( "perllocale", $perl_locale_collation, "create_collation" ); @@ -85,8 +82,7 @@ sub prepare { } sub _get_version { - my ($dbh) = @_; - return (DBD::SQLite::db::FETCH($dbh, 'sqlite_version')); + return( DBD::SQLite::db::FETCH($_[0], 'sqlite_version') ); } my %info = ( @@ -94,7 +90,7 @@ my %info = ( 18 => \&_get_version, # SQL_DBMS_VER 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR ); - + sub get_info { my($dbh, $info_type) = @_; my $v = $info{int($info_type)}; @@ -103,40 +99,40 @@ sub get_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 # Based on DBD::Oracle's # See also http://www.ch-werner.de/sqliteodbc/html/sqliteodbc_8c.html#a117 - my @Where = (); - my $Sql; - if ( defined($CatVal) && $CatVal eq '%' - && defined($SchVal) && $SchVal eq '' - && defined($TblVal) && $TblVal eq '') { # Rule 19a - $Sql = <<'SQL'; + my @where = (); + my $sql; + if ( defined($cat_val) && $cat_val eq '%' + && defined($sch_val) && $sch_val eq '' + && defined($tbl_val) && $tbl_val eq '') { # Rule 19a + $sql = <<'END_SQL'; SELECT NULL TABLE_CAT , NULL TABLE_SCHEM , NULL TABLE_NAME , NULL TABLE_TYPE , NULL REMARKS -SQL +END_SQL } - elsif ( defined($SchVal) && $SchVal eq '%' - && defined($CatVal) && $CatVal eq '' - && defined($TblVal) && $TblVal eq '') { # Rule 19b - $Sql = <<'SQL'; + elsif ( defined($sch_val) && $sch_val eq '%' + && defined($cat_val) && $cat_val eq '' + && defined($tbl_val) && $tbl_val eq '') { # Rule 19b + $sql = <<'END_SQL'; SELECT NULL TABLE_CAT , NULL TABLE_SCHEM , NULL TABLE_NAME , NULL TABLE_TYPE , NULL REMARKS -SQL +END_SQL } - elsif ( defined($TypVal) && $TypVal eq '%' - && defined($CatVal) && $CatVal eq '' - && defined($SchVal) && $SchVal eq '' - && defined($TblVal) && $TblVal eq '') { # Rule 19c - $Sql = <<'SQL'; + elsif ( defined($typ_val) && $typ_val eq '%' + && defined($cat_val) && $cat_val eq '' + && defined($sch_val) && $sch_val eq '' + && defined($tbl_val) && $tbl_val eq '') { # Rule 19c + $sql = <<'END_SQL'; SELECT NULL TABLE_CAT , NULL TABLE_SCHEM , NULL TABLE_NAME @@ -148,10 +144,10 @@ FROM ( SELECT 'LOCAL TEMPORARY' tt ) t ORDER BY TABLE_TYPE -SQL +END_SQL } else { - $Sql = <<'SQL'; + $sql = <<'END_SQL'; SELECT * FROM ( @@ -175,116 +171,114 @@ UNION ALL SELECT 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql ) ) -SQL - if ( defined $TblVal ) { - push @Where, "TABLE_NAME LIKE '$TblVal'"; +END_SQL + if ( defined $tbl_val ) { + push @where, "TABLE_NAME LIKE '$tbl_val'"; } - if ( defined $TypVal ) { + if ( defined $typ_val ) { my $table_type_list; - $TypVal =~ s/^\s+//; - $TypVal =~ s/\s+$//; - my @ttype_list = split (/\s*,\s*/, $TypVal); + $typ_val =~ s/^\s+//; + $typ_val =~ s/\s+$//; + my @ttype_list = split (/\s*,\s*/, $typ_val); foreach my $table_type (@ttype_list) { if ($table_type !~ /^'.*'$/) { $table_type = "'" . $table_type . "'"; } $table_type_list = join(", ", @ttype_list); } - push @Where, "TABLE_TYPE IN (\U$table_type_list)" - if $table_type_list; + push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list; } - $Sql .= ' WHERE ' . join("\n AND ", @Where ) . "\n" if @Where; - $Sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n"; + $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; + $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; } - sub primary_key_info { my($dbh, $catalog, $schema, $table) = @_; - my @pk_info; - - my $sth_tables = $dbh->table_info($catalog, $schema, $table, ''); - - # this is a hack but much simpler than using pragma index_list etc + # This is a hack but much simpler than using pragma index_list etc # 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 ) { my $sql = $row->{sqlite_sql} or next; - next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si; - my @pk = split /\s*,\s*/, $2 || ''; - unless (@pk) { - my $prefix = $1; - $prefix =~ s/.*create\s+table\s+.*?\(\s*//si; - $prefix = (split /\s*,\s*/, $prefix)[-1]; - @pk = (split /\s+/, $prefix)[0]; # take first word as name - } - #warn "GOT PK $row->{TABLE_NAME} (@pk)\n"; - my $key_seq = 0; - for my $pk_field (@pk) { - push @pk_info, { - TABLE_SCHEM => $row->{TABLE_SCHEM}, - TABLE_NAME => $row->{TABLE_NAME}, - COLUMN_NAME => $pk_field, - KEY_SEQ => ++$key_seq, - PK_NAME => 'PRIMARY KEY', - }; - } + next unless $sql =~ /(.*?)\s*PRIMARY\s+KEY\s*(?:\(\s*(.*?)\s*\))?/si; + my @pk = split /\s*,\s*/, $2 || ''; + unless ( @pk ) { + my $prefix = $1; + $prefix =~ s/.*create\s+table\s+.*?\(\s*//si; + $prefix = (split /\s*,\s*/, $prefix)[-1]; + @pk = (split /\s+/, $prefix)[0]; # take first word as name + } + my $key_seq = 0; + foreach my $pk_field (@pk) { + push @pk_info, { + TABLE_SCHEM => $row->{TABLE_SCHEM}, + TABLE_NAME => $row->{TABLE_NAME}, + COLUMN_NAME => $pk_field, + KEY_SEQ => ++$key_seq, + PK_NAME => 'PRIMARY KEY', + }; + } } my $sponge = DBI->connect("DBI:Sponge:", '','') 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 $sth = $sponge->prepare("column_info $table", { - rows => [ map { [ @{$_}{@names} ] } @pk_info ], + my $sth = $sponge->prepare( "column_info $table", { + rows => [ map { [ @{$_}{@names} ] } @pk_info ], NUM_OF_FIELDS => scalar @names, - NAME => \@names, - }) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr()); + NAME => \@names, + }) or return $dbh->DBI::set_err( + $sponge->err(), + $sponge->errstr() + ); return $sth; } sub type_info_all { 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 = { - TYPE_NAME => 0, - DATA_TYPE => 1, - COLUMN_SIZE => 2, - LITERAL_PREFIX => 3, - LITERAL_SUFFIX => 4, - CREATE_PARAMS => 5, - NULLABLE => 6, - CASE_SENSITIVE => 7, - SEARCHABLE => 8, - UNSIGNED_ATTRIBUTE => 9, - FIXED_PREC_SCALE =>10, - AUTO_UNIQUE_VALUE =>11, - LOCAL_TYPE_NAME =>12, - MINIMUM_SCALE =>13, - MAXIMUM_SCALE =>14, - SQL_DATA_TYPE =>15, - SQL_DATETIME_SUB=>16, - NUM_PREC_RADIX =>17, + TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + FIXED_PREC_SCALE => 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + SQL_DATA_TYPE => 15, + SQL_DATETIME_SUB => 16, + NUM_PREC_RADIX => 17, }; my $ti = [ - $names, - [ 'CHAR', 1, 255, '\'', '\'', 'max length', 1, 1, 3, - undef, '0', '0', undef, undef, undef, 1, undef, undef - ], - [ 'NUMBER', 3, 38, undef, undef, 'precision,scale', 1, '0', 3, - '0', '0', '0', undef, '0', 38, 3, undef, 10 - ], - [ 'DOUBLE', 8, 15, undef, undef, undef, 1, '0', 3, - '0', '0', '0', undef, undef, undef, 8, undef, 10 - ], - [ 'DATE', 9, 19, '\'', '\'', undef, 1, '0', 3, - undef, '0', '0', undef, '0', '0', 11, undef, undef - ], - [ 'VARCHAR', 12, 1024*1024, '\'', '\'', 'max length', 1, 1, 3, - undef, '0', '0', undef, undef, undef, 12, undef, undef - ] + $names, + [ 'CHAR', 1, 255, '\'', '\'', 'max length', 1, 1, 3, + undef, '0', '0', undef, undef, undef, 1, undef, undef + ], + [ 'NUMBER', 3, 38, undef, undef, 'precision,scale', 1, '0', 3, + '0', '0', '0', undef, '0', 38, 3, undef, 10 + ], + [ 'DOUBLE', 8, 15, undef, undef, undef, 1, '0', 3, + '0', '0', '0', undef, undef, undef, 8, undef, 10 + ], + [ 'DATE', 9, 19, '\'', '\'', undef, 1, '0', 3, + undef, '0', '0', undef, '0', '0', 11, undef, undef + ], + [ 'VARCHAR', 12, 1024*1024, '\'', '\'', 'max length', 1, 1, 3, + undef, '0', '0', undef, undef, undef, 12, undef, undef + ] ]; return $ti; } @@ -294,51 +288,53 @@ return; # XXX code just copied from DBD::Oracle, not yet thought about sub column_info { my($dbh, $catalog, $schema, $table, $column) = @_; - $column = undef - if defined $column && $column eq '%'; + if ( defined $column and $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; - my @names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME - DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH - DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE - REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB - CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE - ); + my @names = qw( + TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME + DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH + DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE + REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB + CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE + ); my @cols; while ( my $col_info = $sth_columns->fetchrow_hashref ) { next if defined $column && $column ne $col_info->{name}; - my %col; - - $col{TABLE_NAME} = $table; - $col{COLUMN_NAME} = $col_info->{name}; + my %col = ( + TABLE_NAME => $table, + COLUMN_NAME => $col_info->{name}, + ); my $type = $col_info->{type}; if ( $type =~ s/(\w+)\((\d+)(?:,(\d+))?\)/$1/ ) { - $col{COLUMN_SIZE} = $2; + $col{COLUMN_SIZE} = $2; $col{DECIMAL_DIGITS} = $3; } $col{TYPE_NAME} = $type; - $col{COLUMN_DEF} = $col_info->{dflt_value} - if defined $col_info->{dflt_value}; + if ( defined $col_info->{dflt_value} ) { + $col{COLUMN_DEF} = $col_info->{dflt_value} + } if ( $col_info->{notnull} ) { - $col{NULLABLE} = 0; + $col{NULLABLE} = 0; $col{IS_NULLABLE} = 'NO'; - } - else { - $col{NULLABLE} = 1; + } else { + $col{NULLABLE} = 1; $col{IS_NULLABLE} = 'YES'; } - for my $key (@names) { - $col{$key} = undef - unless exists $col{$key}; + foreach my $key ( @names ) { + next if exists $col{$key}; + $col{$key} = undef; } push @cols, \%col; @@ -346,16 +342,23 @@ sub column_info { my $sponge = DBI->connect("DBI:Sponge:", '','') or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); - my $sth = $sponge->prepare("column_info $table", { - rows => [ map { [ @{$_}{@names} ] } @cols ], + my $sth = $sponge->prepare( "column_info $table", { + rows => [ map { [ @{$_}{@names} ] } @cols ], NUM_OF_FIELDS => scalar @names, - NAME => \@names, - }) or return $dbh->DBI::set_err($sponge->err(), $sponge->errstr()); + NAME => \@names, + } ) or return $dbh->DBI::set_err( + $sponge->err, + $sponge->errstr, + ); return $sth; } +1; + __END__ +=pod + =head1 NAME DBD::SQLite - Self Contained RDBMS in a DBI Driver @@ -436,14 +439,13 @@ blob-style behavior for B columns under C<< $dbh->{unicode} = 1 explicitly using the 3-argument form of L when doing updates: - use DBI qw(:sql_types); - $dbh->{unicode} = 1; - my $sth = $dbh->prepare - ("INSERT INTO mytable (blobcolumn) VALUES (?)"); - $sth->bind_param(1, $binary_data, SQL_BLOB); # binary_data will - # be stored as-is. + use DBI qw(:sql_types); + $dbh->{unicode} = 1; + my $sth = $dbh->prepare("INSERT INTO mytable (blobcolumn) VALUES (?)"); + # Binary_data will be stored as is. + $sth->bind_param(1, $binary_data, SQL_BLOB); -Defining the column type as BLOB in the DDL is B sufficient. +Defining the column type as C in the DDL is B sufficient. =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 DBI. -=head2 $dbh->func( 'busy_timeout' ) +=head2 $dbh->func('busy_timeout') Retrieve the current busy timeout. @@ -492,11 +494,11 @@ This should be a reference to the function's implementation. For example, here is how to define a now() function which returns the current number of seconds since the epoch: - $dbh->func( 'now', 0, sub { return time }, 'create_function' ); + $dbh->func( 'now', 0, sub { return time }, 'create_function' ); After this, it could be use from SQL as: - INSERT INTO mytable ( now() ); + INSERT INTO mytable ( now() ); =head2 $dbh->func( $name, $argc, $pkg, 'create_aggregate' ) @@ -549,45 +551,46 @@ after new(). Here is a simple aggregate function which returns the variance (example adapted from pysqlite): - package variance; - - sub new { bless [], shift; } - - sub step { - my ( $self, $value ) = @_; - - push @$self, $value; - } - - sub finalize { - my $self = $_[0]; - - my $n = @$self; - - # Variance is NULL unless there is more than one row - return undef unless $n || $n == 1; - - my $mu = 0; - foreach my $v ( @$self ) { - $mu += $v; - } - $mu /= $n; - - my $sigma = 0; - foreach my $v ( @$self ) { - $sigma += ($x - $mu)**2; - } - $sigma = $sigma / ($n - 1); - - return $sigma; - } - - $dbh->func( "variance", 1, 'variance', "create_aggregate" ); + package variance; + + sub new { bless [], shift; } + + sub step { + my ( $self, $value ) = @_; + + push @$self, $value; + } + + sub finalize { + my $self = $_[0]; + + my $n = @$self; + + # Variance is NULL unless there is more than one row + return undef unless $n || $n == 1; + + my $mu = 0; + foreach my $v ( @$self ) { + $mu += $v; + } + $mu /= $n; + + my $sigma = 0; + foreach my $v ( @$self ) { + $sigma += ($x - $mu)**2; + } + $sigma = $sigma / ($n - 1); + + return $sigma; + } + + $dbh->func( "variance", 1, 'variance', "create_aggregate" ); The aggregate function can then be used as: - SELECT group_name, variance(score) FROM results - GROUP BY group_name; + SELECT group_name, variance(score) + FROM results + GROUP BY group_name; =head1 BLOBS @@ -599,7 +602,7 @@ BLOB use the following code: use DBI qw(:sql_types); my $dbh = DBI->connect("dbi:sqlite:/path/to/db","",""); - + my $blob = `cat foo.jpg`; my $sth = $dbh->prepare("INSERT INTO mytable VALUES (1, ?)"); $sth->bind_param(1, $blob, SQL_BLOB); @@ -611,7 +614,7 @@ And then retrieval just works: $sth->execute(); my $row = $sth->fetch; my $blobo = $row->[1]; - + # now $blobo == $blob =head1 NOTES @@ -640,10 +643,11 @@ queries on the data. Queries like count(*) and avg(bytes) took fractions of a second to return, but what surprised me most of all was: - SELECT url, count(*) as count FROM access_log - GROUP BY url - ORDER BY count desc - LIMIT 20 + SELECT url, count(*) as count + FROM access_log + GROUP BY url + ORDER BY count desc + LIMIT 20 To discover the top 20 hit URLs on the site (http://axkit.org), and it returned within 2 seconds. I'm seriously considering switching my log @@ -694,7 +698,7 @@ L L (patch required) -Switch tests to Test::More to support more advanced testing behaviours +Switch tests to L to support more advanced testing behaviours =head1 AUTHOR @@ -710,7 +714,7 @@ Max Maischein Ecorion@cpan.orgE =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. @@ -718,7 +722,8 @@ Some parts copyright 2008 Francis J. Lacoste and Wolfgang Sourdeau. Some parts copyright 2008 - 2009 Adam Kennedy. -Some parts taken from L. +Some parts derived from L +copyright 2008 Audrey Tang. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/t/08create_function.t b/t/08create_function.t index 2e0be5b..93170c7 100644 --- a/t/08create_function.t +++ b/t/08create_function.t @@ -1,5 +1,6 @@ #!/usr/bin/perl +use 5.005_03; use strict; BEGIN { $| = 1; diff --git a/t/11unicode.t b/t/11unicode.t index 25aa5e7..ba49e65 100644 --- a/t/11unicode.t +++ b/t/11unicode.t @@ -47,7 +47,10 @@ sub is_utf8 { ### 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: