mirror of
https://github.com/DBD-SQLite/DBD-SQLite
synced 2025-06-07 14:19:10 -04:00
bug corrections & addition of class VirtualTable/PerlData
This commit is contained in:
Laurent Dami
parent
78984a9de8
commit
d6a77c88ea
11 changed files with 473 additions and 42 deletions
7
MANIFEST
7
MANIFEST
|
|
@ -8,7 +8,8 @@ lib/DBD/SQLite.pm
|
|||
lib/DBD/SQLite/Cookbook.pod
|
||||
lib/DBD/SQLite/Fulltext_search.pod
|
||||
lib/DBD/SQLite/VirtualTable.pm
|
||||
lib/DBD/SQLite/VirtualTable/Filesys.pm
|
||||
lib/DBD/SQLite/VirtualTable/FileContent.pm
|
||||
lib/DBD/SQLite/VirtualTable/PerlData.pm
|
||||
LICENSE
|
||||
Makefile.PL
|
||||
MANIFEST This list of files
|
||||
|
|
@ -111,7 +112,9 @@ t/rt_88228_sqlite_3_8_0_crash.t
|
|||
t/rt_96878_fts_contentless_table.t
|
||||
t/virtual_table/00_base.t
|
||||
t/virtual_table/01_destroy.t
|
||||
t/virtual_table/10_filesys.t
|
||||
t/virtual_table/10_filecontent.t
|
||||
t/virtual_table/11_filecontent_fulltext.t
|
||||
t/virtual_table/20_perldata.t
|
||||
typemap
|
||||
util/getsqlite.pl
|
||||
xt/meta.t
|
||||
|
|
|
|||
7
dbdimp.c
7
dbdimp.c
|
|
@ -3111,8 +3111,11 @@ static int perl_vt_BestIndex(sqlite3_vtab *pVTab, sqlite3_index_info *pIdxInfo){
|
|||
pIdxInfo->idxNum = (val && SvOK(*val)) ? SvIV(*val) : 0;
|
||||
val = hv_fetch(hv, "idxStr", 6, FALSE);
|
||||
if (val && SvOK(*val)) {
|
||||
char *str = SvPVutf8_nolen(*val);
|
||||
pIdxInfo->idxStr = sqlite3_mprintf(str);
|
||||
STRLEN len;
|
||||
char *str = SvPVutf8(*val, len);
|
||||
pIdxInfo->idxStr = sqlite3_malloc(len+1);
|
||||
memcpy(pIdxInfo->idxStr, str, len);
|
||||
pIdxInfo->idxStr[len] = 0;
|
||||
pIdxInfo->needToFreeIdxStr = 1;
|
||||
}
|
||||
val = hv_fetch(hv, "orderByConsumed", 15, FALSE);
|
||||
|
|
|
|||
|
|
@ -2406,6 +2406,38 @@ For more detail, please see the SQLite R-Tree page
|
|||
queries using callbacks, as mentioned in the prior link, have not been
|
||||
implemented yet.
|
||||
|
||||
=head1 VIRTUAL TABLES IMPLEMENTED IN PERL
|
||||
|
||||
SQLite has a concept of "virtual tables" which look like regular
|
||||
tables but are implemented internally through specific functions.
|
||||
The fulltext or R* tree features described in the previous chapters
|
||||
are examples of such virtual tables, implemented in C code.
|
||||
|
||||
C<DBD::SQLite> also supports virtual tables implemented in Perl code:
|
||||
see L<DBD::SQLite::VirtualTable>. This can have many interesting uses
|
||||
for joining regular DBMS data with some other kind of data within your
|
||||
Perl programs. Bundled with the present distribution are :
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
L<DBD::SQLite::VirtualTable::FileContent> : implements a virtual
|
||||
column that exposes content from files. This is especially useful
|
||||
in conjuction with a fulltext index; see L<DBD::SQLite::Fulltext_search>.
|
||||
|
||||
=item *
|
||||
|
||||
L<DBD::SQLite::VirtualTable::PerlData> : binds to a Perl array
|
||||
within your main program. This can be used for simple import/export
|
||||
operations, for debugging purposes, for joining data from different
|
||||
sources, etc.
|
||||
|
||||
=back
|
||||
|
||||
Other Perl virtual tables may also be published separately on CPAN.
|
||||
|
||||
|
||||
=head1 FOR DBD::SQLITE EXTENSION AUTHORS
|
||||
|
||||
Since 1.30_01, you can retrieve the bundled sqlite C source and/or
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
# TODO : fix bug with column name / type
|
||||
|
||||
package DBD::SQLite::VirtualTable;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
|
@ -24,7 +26,6 @@ sub CONNECT {
|
|||
return $class->NEW(@_);
|
||||
}
|
||||
|
||||
|
||||
sub NEW { # called when instanciating a virtual table
|
||||
my ($class, $dbh_ref, $module_name, $db_name, $vtab_name, @args) = @_;
|
||||
|
||||
|
|
@ -70,12 +71,6 @@ sub initialize {
|
|||
}
|
||||
|
||||
|
||||
sub connect {
|
||||
my $class = shift;
|
||||
|
||||
warn "TODO -- VTAB called connect() instead of new()";
|
||||
return $class->new(@_);
|
||||
}
|
||||
|
||||
|
||||
sub DROP {
|
||||
|
|
@ -132,7 +127,7 @@ sub OPEN {
|
|||
|
||||
my $cursor_class = $class . "::Cursor";
|
||||
|
||||
return $cursor_class->new($self, @_);
|
||||
return $cursor_class->NEW($self, @_);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -140,8 +135,6 @@ sub OPEN {
|
|||
sub _SQLITE_UPDATE {
|
||||
my ($self, $old_rowid, $new_rowid, @values) = @_;
|
||||
|
||||
warn "CURSOR->_SQLITE_UPDATE";
|
||||
|
||||
if (! defined $old_rowid) {
|
||||
return $self->INSERT($new_rowid, @values);
|
||||
}
|
||||
|
|
@ -156,19 +149,20 @@ sub _SQLITE_UPDATE {
|
|||
sub INSERT {
|
||||
my ($self, $new_rowid, @values) = @_;
|
||||
|
||||
warn "vtab->insert()";
|
||||
my $new_computed_rowid;
|
||||
return $new_computed_rowid;
|
||||
die "INSERT() should be redefined in subclass";
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $old_rowid) = @_;
|
||||
|
||||
die "DELETE() should be redefined in subclass";
|
||||
}
|
||||
|
||||
sub UPDATE {
|
||||
my ($self, $old_rowid, $new_rowid, @values) = @_;
|
||||
}
|
||||
|
||||
die "UPDATE() should be redefined in subclass";
|
||||
}
|
||||
|
||||
|
||||
sub BEGIN_TRANSACTION {return 0}
|
||||
|
|
@ -189,7 +183,7 @@ package DBD::SQLite::VirtualTable::Cursor;
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub new {
|
||||
sub NEW {
|
||||
my ($class, $vtable, @args) = @_;
|
||||
my $self = {vtable => $vtable,
|
||||
args => \@args};
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
package DBD::SQLite::VirtualTable::Filesys;
|
||||
package DBD::SQLite::VirtualTable::FileContent;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'DBD::SQLite::VirtualTable';
|
||||
|
|
@ -6,12 +6,12 @@ use base 'DBD::SQLite::VirtualTable';
|
|||
|
||||
=head1 NAME
|
||||
|
||||
DBD::SQLite::VirtualTable::Filesys -- virtual table for viewing file contents
|
||||
DBD::SQLite::VirtualTable::FileContent -- virtual table for viewing file contents
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
-- $dbh->sqlite_create_module(filesys => "DBD::SQLite::VirtualTable::Filesys");
|
||||
-- $dbh->sqlite_create_module(filesys => "DBD::SQLite::VirtualTable::FileContent");
|
||||
|
||||
CREATE VIRTUAL TABLE tbl USING filesys(file_content,
|
||||
index_table = idx,
|
||||
|
|
@ -20,9 +20,11 @@ DBD::SQLite::VirtualTable::Filesys -- virtual table for viewing file contents
|
|||
root = "/foo/bar")
|
||||
|
||||
|
||||
-- OR : expose = *
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A "Filesys" virtual table is like a database view on some underlying
|
||||
A "FileContent" virtual table is like a database view on some underlying
|
||||
I<index table>, which has a column containing paths to
|
||||
files; the virtual table then adds a supplementary column which exposes
|
||||
the content from those files.
|
||||
|
|
@ -45,10 +47,10 @@ sub initialize {
|
|||
|
||||
# verifications
|
||||
@{$self->{columns}} == 1
|
||||
or die "Filesys virtual table should declare exactly 1 content column";
|
||||
or die "FileContent virtual table should declare exactly 1 content column";
|
||||
for my $opt (qw/index_table path_col/) {
|
||||
$self->{options}{$opt}
|
||||
or die "Filesys virtual table: option '$opt' is missing";
|
||||
or die "FileContent virtual table: option '$opt' is missing";
|
||||
}
|
||||
|
||||
# get list of columns from the index table
|
||||
|
|
@ -111,7 +113,7 @@ sub BEST_INDEX {
|
|||
return $outputs;
|
||||
}
|
||||
|
||||
package DBD::SQLite::VirtualTable::Filesys::Cursor;
|
||||
package DBD::SQLite::VirtualTable::FileContent::Cursor;
|
||||
use 5.010;
|
||||
use strict;
|
||||
use warnings;
|
||||
292
lib/DBD/SQLite/VirtualTable/PerlData.pm
Normal file
292
lib/DBD/SQLite/VirtualTable/PerlData.pm
Normal file
|
|
@ -0,0 +1,292 @@
|
|||
package DBD::SQLite::VirtualTable::PerlData;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'DBD::SQLite::VirtualTable';
|
||||
use List::MoreUtils qw/mesh/;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBD::SQLite::VirtualTable::PerlData -- virtual table for connecting to perl data
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
-- $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData");
|
||||
|
||||
CREATE VIRTUAL TABLE tbl USING perl(foo, bar, etc,
|
||||
arrayrefs="some_global_variable")
|
||||
|
||||
CREATE VIRTUAL TABLE tbl USING perl(foo, bar, etc,
|
||||
hashrefs="some_global_variable")
|
||||
|
||||
CREATE VIRTUAL TABLE tbl USING perl(single_col
|
||||
colref="some_global_variable")
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
# private data for translating comparison operators from Sqlite to Perl
|
||||
my $TXT = 0;
|
||||
my $NUM = 1;
|
||||
my %SQLOP2PERLOP = (
|
||||
# TXT NUM
|
||||
'=' => [ 'eq', '==' ],
|
||||
'<' => [ 'lt', '<' ],
|
||||
'<=' => [ 'le', '<=' ],
|
||||
'>' => [ 'gt', '>' ],
|
||||
'>=' => [ 'ge', '>=' ],
|
||||
'MATCH' => [ '=~', '=~' ],
|
||||
);
|
||||
|
||||
|
||||
sub initialize {
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
|
||||
# verifications
|
||||
my $n_cols = @{$self->{columns}};
|
||||
$n_cols > 0
|
||||
or die "$class: no declared columns";
|
||||
!$self->{options}{colref} || $n_cols == 1
|
||||
or die "$class: must have exactly 1 column when using 'colref'";
|
||||
my $symbolic_ref = $self->{options}{arrayrefs}
|
||||
|| $self->{options}{hashrefs}
|
||||
|| $self->{options}{colref}
|
||||
or die "$class: missing option 'arrayrefs' or 'hashrefs' or 'colref'";
|
||||
|
||||
# bind to the Perl variable
|
||||
no strict "refs";
|
||||
defined ${$symbolic_ref}
|
||||
or die "$class: can't find global variable \$$symbolic_ref";
|
||||
$self->{rows} = \${$symbolic_ref};
|
||||
}
|
||||
|
||||
|
||||
sub initialize_bis {
|
||||
my $self = shift;
|
||||
|
||||
# the code below cannot happen within initialize() because VTAB_TO_DECLARE()
|
||||
# has not been called until the end of NEW(). So we do it here, which is
|
||||
# called lazily at the first invocation if BEST_INDEX().
|
||||
|
||||
# get names and types of columns after they have been parsed by sqlite
|
||||
my $sth = $self->dbh->prepare("PRAGMA table_info($self->{vtab_name})");
|
||||
$sth->execute;
|
||||
|
||||
# build private data 'headers' and 'optypes'
|
||||
while (my $row = $sth->fetch) {
|
||||
my ($colname, $coltype) = @{$row}[1, 2];
|
||||
push @{$self->{headers}}, $colname;
|
||||
|
||||
# apply algorithm from datatype3.html" for type affinity
|
||||
push @{$self->{optypes}}, $coltype =~ /INT|REAL|FLOA|DOUB/i ? $NUM : $TXT;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub BEST_INDEX {
|
||||
my ($self, $constraints, $order_by) = @_;
|
||||
|
||||
$self->initialize_bis if not exists $self->{headers};
|
||||
|
||||
# for each constraint, build a Perl code fragment. Those will be gathered
|
||||
# in FILTER() for deciding which rows match the constraints.
|
||||
my @conditions;
|
||||
my $ix = 0;
|
||||
foreach my $constraint (grep {$_->{usable}} @$constraints) {
|
||||
my $col = $constraint->{col};
|
||||
my ($member, $optype);
|
||||
|
||||
# build a Perl code fragment. Those will be gathered
|
||||
# in FILTER() for deciding which rows match the constraints.
|
||||
if ($col == -1) {
|
||||
# constraint on rowid
|
||||
$member = '$i';
|
||||
$optype = $NUM;
|
||||
}
|
||||
else {
|
||||
my $get_col = $self->{options}{arrayrefs} ? "->[$col]"
|
||||
: $self->{options}{hashrefs} ? "->{$self->{headers}[$col]}"
|
||||
: $self->{options}{colref} ? ""
|
||||
: die "corrupted data in ->{options}";
|
||||
$member = '$self->row($i)' . $get_col;
|
||||
$optype = $self->{optypes}[$col];
|
||||
}
|
||||
my $op = $SQLOP2PERLOP{$constraint->{op}}[$optype];
|
||||
my $quote = $op eq '=~' ? 'qr' : 'q';
|
||||
push @conditions, "($member $op ${quote}{%s})";
|
||||
|
||||
# info passed back to the sqlite kernel -- see vtab.html in sqlite doc
|
||||
$constraint->{argvIndex} = $ix++;
|
||||
$constraint->{omit} = 1;
|
||||
}
|
||||
|
||||
# further info for the sqlite kernel
|
||||
my $outputs = {
|
||||
idxNum => 1,
|
||||
idxStr => (join(" && ", @conditions) || "1"),
|
||||
orderByConsumed => 0,
|
||||
estimatedCost => 1.0,
|
||||
estimatedRows => undef,
|
||||
};
|
||||
|
||||
return $outputs;
|
||||
}
|
||||
|
||||
|
||||
sub _build_new_row {
|
||||
my ($self, $values) = @_;
|
||||
|
||||
return $self->{options}{arrayrefs} ? $values
|
||||
: $self->{options}{hashrefs} ? { mesh @{$self->{headers}}, @$values }
|
||||
: $self->{options}{colref} ? $values->[0]
|
||||
: die "corrupted data in ->{options}";
|
||||
}
|
||||
|
||||
|
||||
sub INSERT {
|
||||
my ($self, $new_rowid, @values) = @_;
|
||||
|
||||
my $new_row = $self->_build_new_row(\@values);
|
||||
|
||||
if (defined $new_rowid) {
|
||||
not ${$self->{rows}}->[$new_rowid]
|
||||
or die "can't INSERT : rowid $new_rowid already in use";
|
||||
${$self->{rows}}->[$new_rowid] = $new_row;
|
||||
}
|
||||
else {
|
||||
push @${$self->{rows}}, $new_row;
|
||||
return $#${$self->{rows}};
|
||||
}
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $old_rowid) = @_;
|
||||
|
||||
delete ${$self->{rows}}->[$old_rowid];
|
||||
}
|
||||
|
||||
sub UPDATE {
|
||||
my ($self, $old_rowid, $new_rowid, @values) = @_;
|
||||
|
||||
my $new_row = $self->_build_new_row(\@values);
|
||||
|
||||
if ($new_rowid == $old_rowid) {
|
||||
${$self->{rows}}->[$old_rowid] = $new_row;
|
||||
}
|
||||
else {
|
||||
delete ${$self->{rows}}->[$old_rowid];
|
||||
${$self->{rows}}->[$new_rowid] = $new_row;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
package DBD::SQLite::VirtualTable::PerlData::Cursor;
|
||||
use 5.010;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base "DBD::SQLite::VirtualTable::Cursor";
|
||||
|
||||
|
||||
sub row {
|
||||
my ($self, $i) = @_;
|
||||
return ${$self->{vtable}{rows}}->[$i];
|
||||
}
|
||||
|
||||
sub FILTER {
|
||||
my ($self, $idxNum, $idxStr, @values) = @_;
|
||||
|
||||
# build a method coderef to fetch matching rows
|
||||
my $perl_code = sprintf "sub {my (\$self, \$i) = \@_; $idxStr}", @values;
|
||||
|
||||
# print STDERR "PERL $perl_code\n";
|
||||
|
||||
$self->{is_wanted_row} = eval $perl_code
|
||||
or die "couldn't eval q{$perl_code} : $@";
|
||||
|
||||
# position the cursor to the first matching row (or to eof)
|
||||
$self->{row_ix} = -1;
|
||||
$self->NEXT;
|
||||
}
|
||||
|
||||
|
||||
sub EOF {
|
||||
my ($self) = @_;
|
||||
|
||||
return $self->{row_ix} > $#${$self->{vtable}{rows}};
|
||||
}
|
||||
|
||||
sub NEXT {
|
||||
my ($self) = @_;
|
||||
|
||||
do {
|
||||
$self->{row_ix} += 1
|
||||
} until $self->EOF || $self->{is_wanted_row}->($self, $self->{row_ix});
|
||||
}
|
||||
|
||||
|
||||
sub COLUMN {
|
||||
my ($self, $idxCol) = @_;
|
||||
|
||||
my $row = $self->row($self->{row_ix});
|
||||
|
||||
|
||||
return $self->{vtable}{options}{arrayrefs} ? $row->[$idxCol]
|
||||
: $self->{vtable}{options}{hashrefs} ?
|
||||
$row->{$self->{vtable}{headers}[$idxCol]}
|
||||
: $self->{vtable}{options}{colref} ? $row
|
||||
: die "corrupted data in ->{options}";
|
||||
}
|
||||
|
||||
sub ROWID {
|
||||
my ($self) = @_;
|
||||
|
||||
return $self->{row_ix};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DBD::SQLite::VirtualTable -- Abstract parent class for implementing virtual tables
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package My::Virtual::Table;
|
||||
use parent 'DBD::SQLite::VirtualTable';
|
||||
|
||||
sub ...
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
TODO
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
TODO
|
||||
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright Laurent Dami, 2014.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -1,5 +1,4 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
|
|
@ -86,10 +85,10 @@ use warnings;
|
|||
use base 'DBD::SQLite::VirtualTable::Cursor';
|
||||
use YAML;
|
||||
|
||||
sub new {
|
||||
sub NEW {
|
||||
my $class = shift;
|
||||
|
||||
my $self = $class->SUPER::new(@_);
|
||||
my $self = $class->SUPER::NEW(@_);
|
||||
$self->{row_count} = 5;
|
||||
|
||||
return $self;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
|
|
|
|||
|
|
@ -8,11 +8,11 @@ BEGIN {
|
|||
|
||||
use t::lib::Test qw/connect_ok/;
|
||||
use Test::More;
|
||||
# use Test::NoWarnings;
|
||||
use Test::NoWarnings;
|
||||
use DBI qw(:sql_types);
|
||||
use FindBin;
|
||||
|
||||
plan tests => 12;
|
||||
plan tests => 13;
|
||||
|
||||
my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 );
|
||||
|
||||
|
|
@ -24,12 +24,12 @@ $dbh->do(<<"");
|
|||
INSERT INTO base VALUES(1, 'foo1', '00_base.t', 'bar1')
|
||||
|
||||
$dbh->do(<<"");
|
||||
INSERT INTO base VALUES(2, 'foo2', '10_filesys.t', 'bar2')
|
||||
INSERT INTO base VALUES(2, 'foo2', '10_filecontent.t', 'bar2')
|
||||
|
||||
|
||||
# start tests
|
||||
|
||||
ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys"),
|
||||
ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"),
|
||||
"create_module";
|
||||
|
||||
|
||||
|
|
@ -1,6 +1,4 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# TMP HACK
|
||||
use strict;
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
|
|
@ -15,19 +13,23 @@ use FindBin;
|
|||
my $dbfile = "tmp.sqlite";
|
||||
|
||||
my @tests = (
|
||||
["VirtualTable" => qw[lib/DBD/SQLite/VirtualTable.pm
|
||||
lib/DBD/SQLite/VirtualTable/Filesys.pm]],
|
||||
["VirtualTable" => qw[lib/DBD/SQLite.pm
|
||||
lib/DBD/SQLite/VirtualTable.pm
|
||||
lib/DBD/SQLite/VirtualTable/FileContent.pm
|
||||
lib/DBD/SQLite/VirtualTable/PerlData.pm]],
|
||||
["install_method" => qw[lib/DBD/SQLite.pm]],
|
||||
['"use strict"' => qw[inc/Test/NoWarnings.pm
|
||||
inc/Test/NoWarnings/Warning.pm
|
||||
lib/DBD/SQLite.pm
|
||||
lib/DBD/SQLite/VirtualTable.pm
|
||||
lib/DBD/SQLite/VirtualTable/Filesys.pm
|
||||
lib/DBD/SQLite/VirtualTable/FileContent.pm
|
||||
lib/DBD/SQLite/VirtualTable/PerlData.pm
|
||||
t/lib/Test.pm
|
||||
util/getsqlite.pl]],
|
||||
['"use strict" AND "use warnings"' => qw[inc/Test/NoWarnings.pm
|
||||
lib/DBD/SQLite/VirtualTable.pm
|
||||
lib/DBD/SQLite/VirtualTable/Filesys.pm
|
||||
lib/DBD/SQLite/VirtualTable/FileContent.pm
|
||||
lib/DBD/SQLite/VirtualTable/PerlData.pm
|
||||
]],
|
||||
);
|
||||
|
||||
|
|
@ -51,7 +53,7 @@ $sth->execute($_) foreach @perl_files;
|
|||
|
||||
|
||||
# create vtab table
|
||||
$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys");
|
||||
$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent");
|
||||
$dbh->do(<<"");
|
||||
CREATE VIRTUAL TABLE vfs USING fs(content,
|
||||
index_table = files,
|
||||
|
|
@ -89,7 +91,7 @@ foreach my $test (@tests) {
|
|||
# see if data was properly stored: disconnect, reconnect and test again
|
||||
undef $dbh;
|
||||
$dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 );
|
||||
$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::Filesys");
|
||||
$dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent");
|
||||
|
||||
foreach my $test (@tests) {
|
||||
my ($pattern, @expected) = @$test;
|
||||
105
t/virtual_table/20_perldata.t
Normal file
105
t/virtual_table/20_perldata.t
Normal file
|
|
@ -0,0 +1,105 @@
|
|||
#!/usr/bin/perl
|
||||
use strict;
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
$^W = 1;
|
||||
}
|
||||
|
||||
|
||||
use t::lib::Test qw/connect_ok/;
|
||||
use Test::More;
|
||||
use Test::NoWarnings;
|
||||
use DBI qw(:sql_types);
|
||||
use FindBin;
|
||||
|
||||
our $perl_rows = [
|
||||
[1, 2, 'three'],
|
||||
[4, 5, 'six' ],
|
||||
[7, 8, 'nine' ],
|
||||
];
|
||||
|
||||
plan tests => 24;
|
||||
|
||||
my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 );
|
||||
|
||||
ok $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"),
|
||||
"create_module";
|
||||
|
||||
#======================================================================
|
||||
# test the arrayrefs implementation
|
||||
#======================================================================
|
||||
|
||||
ok $dbh->do(<<""), "create vtable";
|
||||
CREATE VIRTUAL TABLE vtb USING perl(a INT, b INT, c TEXT,
|
||||
arrayrefs="main::perl_rows")
|
||||
|
||||
my $sql = "SELECT * FROM vtb";
|
||||
my $res = $dbh->selectall_arrayref($sql, {Slice => {}});
|
||||
is scalar(@$res), 3, "got 3 rows";
|
||||
is $res->[0]{a}, 1, 'got 1 in a';
|
||||
is $res->[0]{b}, 2, 'got 2 in b';
|
||||
|
||||
|
||||
$sql = "SELECT * FROM vtb WHERE b < 8 ORDER BY a DESC";
|
||||
$res = $dbh->selectall_arrayref($sql, {Slice => {}});
|
||||
is scalar(@$res), 2, "got 2 rows";
|
||||
is $res->[0]{a}, 4, 'got 4 in first a';
|
||||
is $res->[1]{a}, 1, 'got 1 in second a';
|
||||
|
||||
|
||||
$sql = "SELECT rowid FROM vtb WHERE c = 'six'";
|
||||
$res = $dbh->selectall_arrayref($sql, {Slice => {}});
|
||||
is_deeply $res, [{rowid => 1}], $sql;
|
||||
|
||||
$sql = "SELECT c FROM vtb WHERE c MATCH '^.i' ORDER BY c";
|
||||
$res = $dbh->selectcol_arrayref($sql);
|
||||
is_deeply $res, [qw/nine six/], $sql;
|
||||
|
||||
|
||||
$dbh->do("INSERT INTO vtb(a, b, c) VALUES (11, 22, 33)");
|
||||
my $row_id = $dbh->last_insert_id('', '', '', '');
|
||||
is $row_id, 3, 'new rowid is 3';
|
||||
is scalar(@$perl_rows), 4, 'perl_rows expanded';
|
||||
is_deeply $perl_rows->[-1], [11, 22, 33], 'new row is correct';
|
||||
|
||||
|
||||
#======================================================================
|
||||
# test the hashref implementation
|
||||
#======================================================================
|
||||
our $perl_hrows = [ map {my %row; @row{qw/a b c/} = @$_; \%row} @$perl_rows];
|
||||
|
||||
ok $dbh->do(<<""), "create vtable";
|
||||
CREATE VIRTUAL TABLE temp.vtb2 USING perl(a INT, b INT, c TEXT,
|
||||
hashrefs="main::perl_hrows")
|
||||
|
||||
$sql = "SELECT * FROM vtb2 WHERE b < 8 ORDER BY a DESC";
|
||||
$res = $dbh->selectall_arrayref($sql, {Slice => {}});
|
||||
is scalar(@$res), 2, "got 2 rows";
|
||||
is $res->[0]{a}, 4, 'got 4 in first a';
|
||||
is $res->[1]{a}, 1, 'got 1 in second a';
|
||||
|
||||
|
||||
#======================================================================
|
||||
# test the colref implementation
|
||||
#======================================================================
|
||||
|
||||
our $integers = [1 .. 10];
|
||||
ok $dbh->do(<<""), "create vtable intarray";
|
||||
CREATE VIRTUAL TABLE intarray USING perl(i INT, colref="main::integers")
|
||||
|
||||
$sql = "SELECT i FROM intarray WHERE i BETWEEN 0 AND 5";
|
||||
$res = $dbh->selectcol_arrayref($sql);
|
||||
is_deeply $res, [1 .. 5], $sql;
|
||||
|
||||
|
||||
$sql = "INSERT INTO intarray VALUES (98), (99)";
|
||||
ok $dbh->do($sql), $sql;
|
||||
is_deeply $integers, [1 .. 10, 98, 99], "added 2 ints";
|
||||
|
||||
|
||||
# test below inspired by sqlite "test_intarray.{h,c})
|
||||
$integers = [ 1, 7 ];
|
||||
$sql = "SELECT a FROM vtb WHERE a IN intarray";
|
||||
$res = $dbh->selectcol_arrayref($sql);
|
||||
is_deeply $res, [ 1, 7 ], "intarray as a virtual table";
|
||||
|
||||
Loading…
Add table
Reference in a new issue