mirror of
https://github.com/DBD-SQLite/DBD-SQLite
synced 2025-06-07 14:19:10 -04:00
Some minor normalising and tydying up of the Perl code.
Adding some more explicit versions.
This commit is contained in:
Adam Kennedy
parent
055d3393e1
commit
8ddf75e5f0
3 changed files with 208 additions and 199 deletions
|
|
@ -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<some> columns under C<< $dbh->{unicode} = 1
|
|||
explicitly using the 3-argument form of L<DBI/bind_param> 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<not> sufficient.
|
||||
Defining the column type as C<BLOB> in the DDL is B<not> 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<http://rt.cpan.org/Public/Bug/Display.html?id=35449>
|
|||
L<http://rt.cpan.org/Public/Bug/Display.html?id=29629>
|
||||
(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
|
||||
|
||||
|
|
@ -710,7 +714,7 @@ Max Maischein E<lt>corion@cpan.orgE<gt>
|
|||
|
||||
=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<DBD::SQLite::Amalgamation>.
|
||||
Some parts derived from L<DBD::SQLite::Amalgamation>
|
||||
copyright 2008 Audrey Tang.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use 5.005_03;
|
||||
use strict;
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue