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

Merge branch 'vtab'

Browse source
This commit is contained in:
Kenichi Ishigaki 2014-07-21 08:27:35 +09:00
commit 6a68dbadb3
17 changed files with 3307 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el Normal file
View file

@ -0,0 +1 @@
(( nil . ((c-basic-offset . 4))))

10
MANIFEST
View file

@ -7,6 +7,9 @@ inc/Test/NoWarnings/Warning.pm
lib/DBD/SQLite.pm
lib/DBD/SQLite/Cookbook.pod
lib/DBD/SQLite/Fulltext_search.pod
lib/DBD/SQLite/VirtualTable.pm
lib/DBD/SQLite/VirtualTable/FileContent.pm
lib/DBD/SQLite/VirtualTable/PerlData.pm
LICENSE
Makefile.PL
MANIFEST This list of files
@ -107,6 +110,13 @@ t/rt_78833_utf8_flag_for_column_names.t
t/rt_81536_multi_column_primary_key_info.t
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/02_find_function.t
t/virtual_table/10_filecontent.t
t/virtual_table/11_filecontent_fulltext.t
t/virtual_table/20_perldata.t
t/virtual_table/21_perldata_charinfo.t
typemap
util/getsqlite.pl
xt/meta.t

3
Makefile.PL
View file

@ -367,6 +367,9 @@ WriteMakefile(
clean => {
FILES => 'SQLite.xsi config.h tv.log *.old',
},
test => {
TESTS => 't/*.t t/**/*.t',
},
PL_FILES => {},
EXE_FILES => [],

15
SQLite.xs
View file

@ -283,6 +283,21 @@ db_status(dbh, reset = 0)
RETVAL
static int
create_module(dbh, name, perl_class)
SV *dbh
char *name
char *perl_class
ALIAS:
DBD::SQLite::db::sqlite_create_module = 1
CODE:
{
RETVAL = sqlite_db_create_module(aTHX_ dbh, name, perl_class);
}
OUTPUT:
RETVAL
MODULE = DBD::SQLite PACKAGE = DBD::SQLite::st
PROTOTYPES: DISABLE

967
dbdimp.c
View file

File diff suppressed because it is too large Load diff

3
dbdimp.h
View file

@ -110,10 +110,11 @@ int sqlite_db_profile(pTHX_ SV *dbh, SV *func);
HV* sqlite_db_table_column_metadata(pTHX_ SV *dbh, SV *dbname, SV *tablename, SV *columnname);
HV* _sqlite_db_status(pTHX_ SV *dbh, int reset);
SV* sqlite_db_filename(pTHX_ SV *dbh);
int sqlite_db_register_fts3_perl_tokenizer(pTHX_ SV *dbh);
HV* _sqlite_status(int reset);
HV* _sqlite_st_status(pTHX_ SV *sth, int reset);
int sqlite_db_create_module(pTHX_ SV *dbh, const char *name, const char *perl_class);
#ifdef SvUTF8_on

40
lib/DBD/SQLite.pm
View file

@ -56,6 +56,7 @@ sub driver {
DBD::SQLite::db->install_method('sqlite_db_filename', { O => 0x0004 });
DBD::SQLite::db->install_method('sqlite_db_status', { O => 0x0004 });
DBD::SQLite::st->install_method('sqlite_st_status', { O => 0x0004 });
DBD::SQLite::db->install_method('sqlite_create_module');
$methods_are_installed++;
}
@ -2159,6 +2160,13 @@ Returns a hash reference that holds a set of status information of SQLite statem
You may also pass 0 as an argument to reset the status.
=head2 $sth->sqlite_create_module()
Registers a name for a I<virtual table module>. Module names must be
registered before creating a new virtual table using the module and
before using a preexisting virtual table for the module.
Virtual tables are explained in L<DBD::SQLite::VirtualTable>.
=head1 DRIVER CONSTANTS
A subset of SQLite C constants are made available to Perl,
@ -2405,6 +2413,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 I<Perl code>:
see L<DBD::SQLite::VirtualTable> for using or implementing such
virtual tables. These 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 file contents. This is especially useful
in conjunction with a fulltext index; see L<DBD::SQLite::Fulltext_search>.
=item *
L<DBD::SQLite::VirtualTable::PerlData> : binds to a Perl array
within the Perl 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

827
lib/DBD/SQLite/VirtualTable.pm Normal file
View file

@ -0,0 +1,827 @@
#======================================================================
package DBD::SQLite::VirtualTable;
#======================================================================
use strict;
use warnings;
use Scalar::Util qw/weaken/;
use List::MoreUtils qw/part/;
use YAML::XS;
use Data::Dumper;
our $VERSION = '0.01';
our @ISA;
#----------------------------------------------------------------------
# methods for registering/destroying the module
#----------------------------------------------------------------------
sub CREATE_MODULE { my ($class, $mod_name) = @_; }
sub DESTROY_MODULE { my ($class, $mod_name) = @_; }
#----------------------------------------------------------------------
# methods for creating/destroying instances
#----------------------------------------------------------------------
sub CREATE { my $class = shift; return $class->NEW(@_); }
sub CONNECT { my $class = shift; return $class->NEW(@_); }
sub _PREPARE_SELF {
my ($class, $dbh_ref, $module_name, $db_name, $vtab_name, @args) = @_;
my @columns;
my %options;
# args containing '=' are options; others are column declarations
foreach my $arg (@args) {
if ($arg =~ /^([^=\s]+)\s*=\s*(.*)/) {
my ($key, $val) = ($1, $2);
$val =~ s/^"(.*)"$/$1/;
$options{$key} = $val;
}
else {
push @columns, $arg;
}
}
# build $self
my $self = {
dbh_ref => $dbh_ref,
module_name => $module_name,
db_name => $db_name,
vtab_name => $vtab_name,
columns => \@columns,
options => \%options,
};
weaken $self->{dbh_ref};
return $self;
}
sub NEW {
my $class = shift;
my $self = $class->_PREPARE_SELF(@_);
bless $self, $class;
}
sub VTAB_TO_DECLARE {
my $self = shift;
local $" = ", ";
my $sql = "CREATE TABLE $self->{vtab_name}(@{$self->{columns}})";
return $sql;
}
sub DROP { my $self = shift; }
sub DISCONNECT { my $self = shift; }
#----------------------------------------------------------------------
# methods for initiating a search
#----------------------------------------------------------------------
sub BEST_INDEX {
my ($self, $constraints, $order_by) = @_;
my $ix = 0;
foreach my $constraint (grep {$_->{usable}} @$constraints) {
$constraint->{argvIndex} = $ix++;
$constraint->{omit} = 0;
}
# stupid default values -- subclasses should put real values instead
my $outputs = {
idxNum => 1,
idxStr => "",
orderByConsumed => 0,
estimatedCost => 1.0,
estimatedRows => undef,
};
return $outputs;
}
sub OPEN {
my $self = shift;
my $class = ref $self;
my $cursor_class = $class . "::Cursor";
return $cursor_class->NEW($self, @_);
}
#----------------------------------------------------------------------
# methods for insert/delete/update
#----------------------------------------------------------------------
sub _SQLITE_UPDATE {
my ($self, $old_rowid, $new_rowid, @values) = @_;
if (! defined $old_rowid) {
return $self->INSERT($new_rowid, @values);
}
elsif (!@values) {
return $self->DELETE($old_rowid);
}
else {
return $self->UPDATE($old_rowid, $new_rowid, @values);
}
}
sub INSERT {
my ($self, $new_rowid, @values) = @_;
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";
}
#----------------------------------------------------------------------
# remaining methods of the sqlite API
#----------------------------------------------------------------------
sub BEGIN_TRANSACTION {return 0}
sub SYNC_TRANSACTION {return 0}
sub COMMIT_TRANSACTION {return 0}
sub ROLLBACK_TRANSACTION {return 0}
sub SAVEPOINT {return 0}
sub RELEASE {return 0}
sub ROLLBACK_TO {return 0}
sub FIND_FUNCTION {return 0}
sub RENAME {return 0}
#----------------------------------------------------------------------
# utility methods
#----------------------------------------------------------------------
sub dbh {
my $self = shift;
return ${$self->{dbh_ref}};
}
sub sqlite_table_info {
my $self = shift;
my $sql = "PRAGMA table_info($self->{vtab_name})";
return $self->dbh->selectall_arrayref($sql, {Slice => {}});
}
#======================================================================
package DBD::SQLite::VirtualTable::Cursor;
#======================================================================
use strict;
use warnings;
sub NEW {
my ($class, $vtable, @args) = @_;
my $self = {vtable => $vtable,
args => \@args};
bless $self, $class;
}
sub FILTER {
my ($self, $idxNum, $idxStr, @values) = @_;
die "FILTER() should be redefined in cursor subclass";
}
sub EOF {
my ($self) = @_;
die "EOF() should be redefined in cursor subclass";
}
sub NEXT {
my ($self) = @_;
die "NEXT() should be redefined in cursor subclass";
}
sub COLUMN {
my ($self, $idxCol) = @_;
die "COLUMN() should be redefined in cursor subclass";
}
sub ROWID {
my ($self) = @_;
die "ROWID() should be redefined in cursor subclass";
}
1;
__END__
=head1 NAME
DBD::SQLite::VirtualTable -- SQLite virtual tables implemented in Perl
=head1 SYNOPSIS
# register the virtual table module within sqlite
$dbh->sqlite_create_module(mod_name => "DBD::SQLite::VirtualTable::Subclass");
# create a virtual table
$dbh->do("CREATE VIRTUAL TABLE vtbl USING mod_name(arg1, arg2, ...)")
# use it as any regular table
my $sth = $dbh->prepare("SELECT * FROM vtbl WHERE ...");
B<Note> : VirtualTable subclasses or instances are not called
directly from Perl code; everything happens indirectly through SQL
statements within SQLite.
=head1 DESCRIPTION
This module is an abstract class for implementing SQLite virtual tables,
written in Perl. Such tables look like regular tables, and are accessed
through regular SQL instructions and regular L<DBI> API; but the implementation
is done through hidden calls to a Perl class.
This is the same idea as Perl's L<tied variables|perltie>, but
at the SQLite level.
The current abstract class cannot be used directly, so the
synopsis above is just to give a general idea. Concrete, usable
classes bundled with the present distribution are :
=over
=item *
L<DBD::SQLite::VirtualTable::FileContent> : implements a virtual
column that exposes file contents. This is especially useful
in conjunction with a fulltext index; see L<DBD::SQLite::Fulltext_search>.
=item *
L<DBD::SQLite::VirtualTable::PerlData> : binds to a Perl array
within the Perl 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.
The following chapters document the structure of the abstract class
and explain how to write new subclasses; this is meant for
B<module authors>, not for end users. If you just need to use a
virtual table module, refer to that module's documentation.
=head1 ARCHITECTURE
=head2 Classes
A virtual table module for SQLite is implemented through a pair
of classes :
=over
=item *
the B<table> class implements methods for creating or connecting
a virtual table, for destroying it, for opening new searches, etc.
=item *
the B<cursor> class implements methods for performing a specific
SQL statement
=back
=head2 Methods
Most methods in both classes are not called directly from Perl
code : instead, they are callbacks, called from the sqlite kernel.
Following common Perl conventions, such methods have names in
uppercase.
=head1 TABLE METHODS
=head2 Class methods for registering the module
=head3 CREATE_MODULE
$class->CREATE_MODULE($sqlite_module_name);
Called when the client code invokes
$dbh->sqlite_create_module($sqlite_module_name => $class);
The default implementation is empty.
=head3 DESTROY_MODULE
$class->DESTROY_MODULE();
Called automatically when the database handle is disconnected.
The default implementation is empty.
=head2 Class methods for creating a vtable instance
=head3 CREATE
$class->CREATE($dbh_ref, $module_name, $db_name, $vtab_name, @args);
Called when sqlite receives a statement
CREATE VIRTUAL TABLE $db_name.$vtab_name USING $module_name(@args)
The default implementation just calls L</NEW>.
=head3 CONNECT
$class->CONNECT($dbh_ref, $module_name, $db_name, $vtab_name, @args);
Called when attempting to access a virtual table that had been created
during previous database connection. The creation arguments were stored
within the sqlite database and are passed again to the CONNECT method.
The default implementation just calls L</NEW>.
=head3 _PREPARE_SELF
$class->_PREPARE_SELF($dbh_ref, $module_name, $db_name, $vtab_name, @args);
Prepares the datastructure for a virtual table instance. C<@args> is
just the collection of strings (comma-separated) that were given
within the C<CREATE VIRTUAL TABLE> statement; each subclass should
decide what to do with this information,
The method parses C<@args> to differentiate between I<options>
(strings of shape C<$key>=C<$value> or C<$key>=C<"$value">, stored in
C<< $self->{options} >>), and I<columns> (other C<@args>, stored in
C<< $self->{columns} >>). It creates a hashref with the following fields :
=over
=item C<dbh_ref>
a weak reference to the C<$dbh> database handle (see
L<Scalar::Util> for an explanation of weak references).
=item C<module_name>
name of the module as declared to sqlite (not to be confounded
with the Perl class name).
=item C<db_name>
name of the database (usuallly C<'main'> or C<'temp'>), but it
may also be an attached database
=item C<vtab_name>
name of the virtual table
=item C<columns>
arrayref of column declarations
=item C<options>
hashref of option declarations
=back
This method should not be redefined, since it performs
general work which is supposed to be useful for all subclasses.
Instead, subclasses may override the L</NEW> method.
=head3 NEW
$class->NEW($dbh_ref, $module_name, $db_name, $vtab_name, @args);
Instantiates a virtual table.
=head2 Instance methods called from the sqlite kernel
=head3 DROP
Called whenever a virtual table is destroyed from the
database through the C<DROP TABLE> SQL instruction.
Just after the C<DROP()> call, the Perl instance
will be destroyed (and will therefore automatically
call the C<DESTROY()> method if such a method is present).
The default implementation for DROP is empty.
B<Note> : this corresponds to the C<xDestroy> method
in the SQLite documentation; here it was not named
C<DESTROY>, to avoid any confusion with the standard
Perl method C<DESTROY> for object destruction.
=head3 DISCONNECT
Called for every virtual table just before the database handle
is disconnected.
Just after the C<DISCONNECT()> call, the Perl instance
will be destroyed (and will therefore automatically
call the C<DESTROY()> method if such a method is present).
The default implementation for DISCONNECT is empty.
=head3 VTAB_TO_DECLARE
This method is called automatically just after L</CREATE> or L</CONNECT>,
to register the columns of the virtual table within the sqlite kernel.
The method should return a string containing a SQL C<CREATE TABLE> statement;
but only the column declaration parts will be considered.
Columns may be declared with the special keyword "HIDDEN", which means that
they are used internally for the the virtual table implementation, and are
not visible to users -- see L<http://sqlite.org/c3ref/declare_vtab.html>
and L<http://www.sqlite.org/vtab.html#hiddencol> for detailed explanations.
The default implementation returns:
CREATE TABLE $self->{vtab_name}(@{$self->{columns}})
=head3 BEST_INDEX
my $index_info = $vtab->BEST_INDEX($constraints, $order_by)
This is the most complex method to redefined in subclasses.
This method will be called at the beginning of a new query on the
virtual table; the job of the method is to assemble some information
that will be used
=over
=item a)
by the sqlite kernel to decide about the best search strategy
=item b)
by the cursor L</FILTER> method to produce the desired subset
of rows from the virtual table.
=back
By calling this method, the SQLite core is saying to the virtual table
that it needs to access some subset of the rows in the virtual table
and it wants to know the most efficient way to do that access. The
C<BEST_INDEX> method replies with information that the SQLite core can
then use to conduct an efficient search of the virtual table.
The method takes as input a list of C<$constraints> and a list
of C<$order_by> instructions. It returns a hashref of indexing
properties, described below; furthermore, the method also adds
supplementary information within the input C<$constraints>.
Detailed explanations are given in
L<http://sqlite.org/vtab.html#xbestindex>.
=head4 Input constraints
Elements of the C<$constraints> arrayref correspond to
specific clauses of the C<WHERE ...> part of the SQL query.
Each constraint is a hashref with keys :
=over
=item C<col>
the integer index of the column on the left-hand side of the constraint
=item C<op>
the comparison operator, expressed as string containing
C<< '=' >>, C<< '>' >>, C<< '>=' >>, C<< '<' >>, C<< '<=' >> or C<< 'MATCH' >>.
=item C<usable>
a boolean indicating if that constraint is usable; some constraints
might not be usable because of the way tables are ordered in a join.
=back
The C<$constraints> arrayref is used both for input and for output.
While iterating over the array, the method should
add the following keys into usable constraints :
=over
=item C<argvIndex>
An index into the C<@values> array that will be passed to
the cursor's L</FILTER> method. In other words, if the current
constraint corresponds to the SQL fragment C<WHERE ... AND foo < 123 ...>,
and the corresponding C<argvIndex> takes value 5, this means that
the C<FILTER> method will receive C<123> in C<$values[5]>.
=item C<omit>
A boolean telling to the sqlite core that it can safely omit
to double check that constraint before returning the resultset
to the calling program; this means that the FILTER method has fulfilled
the filtering job on that constraint and there is no need to do any
further checking.
=back
The C<BEST_INDEX> method will not necessarily receive all constraints
from the SQL C<WHERE> clause : for example a constraint like
C<< col1 < col2 + col3 >> cannot be handled at this level.
Furthemore, the C<BEST_INDEX> might decide to ignore some of the
received constraints. This is why a second pass over the results
will be performed by the sqlite core.
=head4 "order_by" input information
The C<$order_by> arrayref corresponds to the C<ORDER BY> clauses
in the SQL query. Each entry is a hashref with keys :
=over
=item C<col>
the integer index of the column being ordered
=item C<desc>
a boolean telling of the ordering is DESCending or ascending
=back
This information could be used by some subclasses for
optimizing the query strategfy; but usually the sqlite core will
perform another sorting pass once all results are gathered.
=head4 Hashref information returned by BEST_INDEX
The method should return a hashref with the following keys :
=over
=item C<idxNum>
An arbitrary integer associated with that index; this information will
be passed back to L</FILTER>.
=item C<idxStr>
An arbitrary str associated with that index; this information will
be passed back to L</FILTER>.
=item C<orderByConsumed>
A boolean telling the sqlite core if the C<$order_by> information
has been taken into account or not.
=item C<estimatedCost>
A float that should be set to the estimated number of disk access
operations required to execute this query against the virtual
table. The SQLite core will often call BEST_INDEX multiple times with
different constraints, obtain multiple cost estimates, then choose the
query plan that gives the lowest estimate.
=item C<estimatedRows>
An integer giving the estimated number of rows returned by that query.
=back
=head3 OPEN
Called to instanciate a new cursor.
The default implementation appends C<"::Cursor"> to the current
classname and calls C<NEW()> within that cursor class.
=head3 _SQLITE_UPDATE
This is the dispatch method implementing the C<xUpdate()> callback
for virtual tables. The default implementation applies the algorithm
described in L<http://sqlite.org/vtab.html#xupdate> to decide
to call L</INSERT>, L</DELETE> or L</UPDATE>; so there is no reason
to override this method in subclasses.
=head3 INSERT
my $rowid = $vtab->INSERT($new_rowid, @values);
This method should be overridden in subclasses to implement
insertion of a new row into the virtual table.
The size of the C<@values> array corresponds to the
number of columns declared through L</VTAB_TO_DECLARE>.
The C<$new_rowid> may be explicitly given, or it may be
C<undef>, in which case the method must compute a new id
and return it as the result of the method call.
=head3 DELETE
$vtab->INSERT($old_rowid);
This method should be overridden in subclasses to implement
deletion of a row from the virtual table.
=head3 UPDATE
$vtab->UPDATE($old_rowid, $new_rowid, @values);
This method should be overridden in subclasses to implement
a row update within the virtual table. Usually C<$old_rowid> is equal
to C<$new_rowid>, which is a regular update; however, the rowid
could be changed from a SQL statement such as
UPDATE table SET rowid=rowid+1 WHERE ...;
=head3 FIND_FUNCTION
$vtab->FIND_FUNCTION($num_args, $func_name);
When a function uses a column from a virtual table as its first
argument, this method is called to see if the virtual table would like
to overload the function. Parameters are the number of arguments to
the function, and the name of the function. If no overloading is
desired, this method should return false. To overload the function,
this method should return a coderef to the function implementation.
Each virtual table keeps a cache of results from L<FIND_FUNCTION> calls,
so the method will be called only once for each pair
C<< ($num_args, $func_name) >>.
=head3 BEGIN_TRANSACTION
Called to begin a transaction on the virtual table.
=head3 SYNC_TRANSACTION
Called to signal the start of a two-phase commit on the virtual table.
=head3 SYNC_TRANSACTION
Called to commit a virtual table transaction.
=head3 ROLLBACK_TRANSACTION
Called to rollback a virtual table transaction.
=head3 RENAME
$vtab->RENAME($new_name)
Called to rename a virtual table.
=head3 SAVEPOINT
$vtab->SAVEPOINT($savepoint)
Called to signal the virtual table to save its current state
at savepoint C<$savepoint> (an integer).
=head3 ROLLBACK_TO
$vtab->ROLLBACK_TO($savepoint)
Called to signal the virtual table to return to the state
C<$savepoint>. This will invalidate all savepoints with values
greater than C<$savepoint>.
=head3 RELEASE
$vtab->RELEASE($savepoint)
Called to invalidate all savepoints with values
greater or equal to C<$savepoint>.
=head2 Utility instance methods
Methods in this section are in lower case, because they
are not called directly from the sqlite kernel; these
are utility methods to be called from other methods
described above.
=head3 dbh
This method returns the database handle (C<$dbh>) associated with
the current virtual table.
=head1 CURSOR METHODS
=head2 Class methods
=head3 NEW
my $cursor = $cursor_class->NEW($vtable, @args)
Instanciates a new cursor.
The default implementation just returns a blessed hashref
with keys C<vtable> and C<args>.
=head2 Instance methods
=head3 FILTER
$cursor->FILTER($idxNum, $idxStr, @values);
This method begins a search of a virtual table.
The C<$idxNum> and C<$idxStr> arguments correspond to values returned
by L</BEST_INDEX> for the chosen index. The specific meanings of
those values are unimportant to SQLite, as long as C<BEST_INDEX> and
C<FILTER> agree on what that meaning is.
The C<BEST_INDEX> method may have requested the values of certain
expressions using the C<argvIndex> values of the
C<$constraints> list. Those values are passed to C<FILTER> through
the C<@values> array.
If the virtual table contains one or more rows that match the search
criteria, then the cursor must be left point at the first
row. Subsequent calls to L</EOF> must return false. If there are
no rows match, then the cursor must be left in a state that will cause
L</EOF> to return true. The SQLite engine will use the
L</COLUMN> and L</ROWID> methods to access that row content. The L</NEXT>
method will be used to advance to the next row.
=head3 EOF
This method must return false if the cursor currently points to a
valid row of data, or true otherwise. This method is called by the SQL
engine immediately after each L</FILTER> and L</NEXT> invocation.
=head3 NEXT
This method advances the cursor to the next row of a
result set initiated by L</FILTER>. If the cursor is already pointing at
the last row when this method is called, then the cursor no longer
points to valid data and a subsequent call to the L</EOF> method must
return true. If the cursor is successfully advanced to
another row of content, then subsequent calls to L</EOF> must return
false.
=head3 COLUMN
my $value = $cursor->COLUMN($idxCol);
The SQLite core invokes this method in order to find the value for the
N-th column of the current row. N is zero-based so the first column is
numbered 0.
=head3 ROWID
my $value = $cursor->ROWID;
Returns the I<rowid> of row that the cursor is currently pointing at.
=head1 SEE ALSO
L<SQLite::VirtualTable> is another module for virtual tables written
in Perl, but designed for the reverse use case : instead of starting a
Perl program, and embedding the SQLite library into it, the intended
use is to start an sqlite program, and embed the Perl interpreter
into it.
=head1 AUTHOR
Laurent Dami E<lt>dami@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright Laurent Dami, 2014.
Parts of the code are borrowed from L<SQLite::VirtualTable>,
copyright (C) 2006, 2009 by Qindel Formacion y Servicios, S. L.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

333
lib/DBD/SQLite/VirtualTable/FileContent.pm Normal file
View file

@ -0,0 +1,333 @@
#======================================================================
package DBD::SQLite::VirtualTable::FileContent;
#======================================================================
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable';
use List::MoreUtils qw/none/;
my %option_ok = map {($_ => 1)} qw/source content_col path_col
expose root get_content/;
my %defaults = (
content_col => "content",
path_col => "path",
expose => "*",
get_content => "DBD::SQLite::VirtualTable::FileContent::get_content",
);
#----------------------------------------------------------------------
# object instanciation
#----------------------------------------------------------------------
sub NEW {
my $class = shift;
my $self = $class->_PREPARE_SELF(@_);
local $" = ", "; # for array interpolation in strings
# initial parameter check
!@{$self->{columns}}
or die "${class}->NEW(): illegal options: @{$self->{columns}}";
$self->{options}{source}
or die "${class}->NEW(): missing (source=...)";
my @bad_options = grep {!$option_ok{$_}} keys %{$self->{options}};
!@bad_options
or die "${class}->NEW(): bad options: @bad_options";
# defaults ... tempted to use //= but we still want to support perl 5.8 :-(
foreach my $k (keys %defaults) {
defined $self->{options}{$k}
or $self->{options}{$k} = $defaults{$k};
}
# get list of columns from the source table
my $src_table = $self->{options}{source};
my $sql = "PRAGMA table_info($src_table)";
my $dbh = ${$self->{dbh_ref}}; # can't use method ->dbh, not blessed yet
my $src_info = $dbh->selectall_arrayref($sql, {Slice => [1, 2]});
@$src_info
or die "${class}->NEW(source=$src_table): no such table in database";
# associate each source colname with its type info or " " (should eval true)
my %src_col = map { ($_->[0] => $_->[1] || " ") } @$src_info;
# check / complete the exposed columns
my @exposed_cols;
if ($self->{options}{expose} eq '*') {
@exposed_cols = map {$_->[0]} @$src_info;
}
else {
@exposed_cols = split /\s*,\s*/, $self->{options}{expose};
my @bad_cols = grep { !$src_col{$_} } @exposed_cols;
die "table $src_table has no column named @bad_cols" if @bad_cols;
}
none {$_ eq $self->{options}{content_col}} @exposed_cols
or die "$class: $self->{options}{content_col} cannot be both the "
. "content_col and an exposed col";
# build the list of columns for this table
$self->{columns} = [ "$self->{options}{content_col} TEXT",
map {"$_ $src_col{$_}"} @exposed_cols ];
# acquire a coderef to the get_content() implementation, which
# was given as a symbolic reference in %options
no strict 'refs';
$self->{get_content} = \ &{$self->{options}{get_content}};
bless $self, $class;
}
sub _build_headers {
my $self = shift;
my $cols = $self->sqlite_table_info;
# headers : names of columns, without type information
$self->{headers} = [ map {$_->{name}} @$cols ];
}
#----------------------------------------------------------------------
# method for initiating a search
#----------------------------------------------------------------------
sub BEST_INDEX {
my ($self, $constraints, $order_by) = @_;
$self->_build_headers if !$self->{headers};
my @conditions;
my $ix = 0;
foreach my $constraint (grep {$_->{usable}} @$constraints) {
my $col = $constraint->{col};
# if this is the content column, skip because we can't filter on it
next if $col == 0;
# for other columns, build a fragment for SQL WHERE on the underlying table
my $colname = $col == -1 ? "rowid" : $self->{headers}[$col];
push @conditions, "$colname $constraint->{op} ?";
$constraint->{argvIndex} = $ix++;
$constraint->{omit} = 1; # SQLite doesn't need to re-check the op
}
# TODO : exploit $order_by to add ordering clauses within idxStr
my $outputs = {
idxNum => 1,
idxStr => join(" AND ", @conditions),
orderByConsumed => 0,
estimatedCost => 1.0,
estimatedRows => undef,
};
return $outputs;
}
#----------------------------------------------------------------------
# method for preventing updates
#----------------------------------------------------------------------
sub _SQLITE_UPDATE {
my ($self, $old_rowid, $new_rowid, @values) = @_;
die "attempt to update a readonly virtual table";
}
#----------------------------------------------------------------------
# file slurping function (not a method!)
#----------------------------------------------------------------------
sub get_content {
my ($path, $root) = @_;
$path = "$root/$path" if $root;
my $content = "";
if (open my $fh, "<", $path) {
local $/; # slurp the whole file into a scalar
$content = <$fh>;
close $fh;
}
else {
warn "can't open $path";
}
return $content;
}
#======================================================================
package DBD::SQLite::VirtualTable::FileContent::Cursor;
#======================================================================
use strict;
use warnings;
use base "DBD::SQLite::VirtualTable::Cursor";
sub FILTER {
my ($self, $idxNum, $idxStr, @values) = @_;
my $vtable = $self->{vtable};
# build SQL
local $" = ", ";
my @cols = @{$vtable->{headers}};
$cols[0] = 'rowid'; # replace the content column by the rowid
push @cols, $vtable->{options}{path_col}; # path col in last position
my $sql = "SELECT @cols FROM $vtable->{options}{source}";
$sql .= " WHERE $idxStr" if $idxStr;
# request on the index table
my $dbh = $vtable->dbh;
$self->{sth} = $dbh->prepare($sql)
or die DBI->errstr;
$self->{sth}->execute(@values);
$self->{row} = $self->{sth}->fetchrow_arrayref;
return;
}
sub EOF {
my ($self) = @_;
return !$self->{row};
}
sub NEXT {
my ($self) = @_;
$self->{row} = $self->{sth}->fetchrow_arrayref;
}
sub COLUMN {
my ($self, $idxCol) = @_;
return $idxCol == 0 ? $self->file_content : $self->{row}[$idxCol];
}
sub ROWID {
my ($self) = @_;
return $self->{row}[0];
}
sub file_content {
my ($self) = @_;
my $root = $self->{vtable}{options}{root};
my $path = $self->{row}[-1];
my $get_content_func = $self->{vtable}{get_content};
return $get_content_func->($path, $root);
}
1;
__END__
=head1 NAME
DBD::SQLite::VirtualTable::FileContent -- virtual table for viewing file contents
=head1 SYNOPSIS
Within Perl :
$dbh->sqlite_create_module(fcontent => "DBD::SQLite::VirtualTable::FileContent");
Then, within SQL :
CREATE VIRTUAL TABLE tbl USING fcontent(
source = src_table,
content_col = content,
path_col = path,
expose = "path, col1, col2, col3", -- or "*"
root = "/foo/bar"
get_content = Foo::Bar::read_from_file
);
SELECT col1, path, content FROM tbl WHERE ...;
=head1 DESCRIPTION
A "FileContent" virtual table is bound to some underlying I<source
table>, which has a column containing paths to files. The virtual
table behaves like a database view on the source table, with an added
column which exposes the content from those files.
This is especially useful as an "external content" to some
fulltext table (see L<DBD::SQLite::Fulltext_search>) : the index
table stores some metadata about files, and then the fulltext engine
can index both the metadata and the file contents.
=head1 PARAMETERS
Parameters for creating a C<FileContent> virtual table are
specified within the C<CREATE VIRTUAL TABLE> statement, just
like regular column declarations, but with an '=' sign.
Authorized parameters are :
=over
=item C<source>
The name of the I<source table>.
This parameter is mandatory. All other parameters are optional.
=item C<content_col>
The name of the virtual column exposing file contents.
The default is C<content>.
=item C<path_col>
The name of the column in C<source> that contains paths to files.
The default is C<path>.
=item C<expose>
A comma-separated list (within double quotes) of source column names
to be exposed by the virtual table. The default is C<"*">, which means
all source columns.
=item C<root>
An optional root directory that will be prepended to the I<path> column
when opening files.
=item C<get_content>
Fully qualified name of a Perl function for reading file contents.
The default implementation just slurps the entire file into a string;
but this hook can point to more sophisticated implementations, like for
example a function that would remove html tags. The hooked function is
called like this :
$file_content = $get_content->($path, $root);
=back
=head1 AUTHOR
Laurent Dami E<lt>dami@cpan.orgE<gt>
=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

456
lib/DBD/SQLite/VirtualTable/PerlData.pm Normal file
View file

@ -0,0 +1,456 @@
#======================================================================
package DBD::SQLite::VirtualTable::PerlData;
#======================================================================
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable';
use List::MoreUtils qw/mesh/;
# 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' => [ '=~', '=~' ],
);
#----------------------------------------------------------------------
# instanciation methods
#----------------------------------------------------------------------
sub NEW {
my $class = shift;
my $self = $class->_PREPARE_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};
bless $self, $class;
}
sub _build_headers_optypes {
my $self = shift;
my $cols = $self->sqlite_table_info;
# headers : names of columns, without type information
$self->{headers} = [ map {$_->{name}} @$cols ];
# optypes : either $NUM or $TEXT for each column
# (applying algorithm from datatype3.html" for type affinity)
$self->{optypes}
= [ map {$_->{type} =~ /INT|REAL|FLOA|DOUB/i ? $NUM : $TXT} @$cols ];
}
#----------------------------------------------------------------------
# method for initiating a search
#----------------------------------------------------------------------
sub BEST_INDEX {
my ($self, $constraints, $order_by) = @_;
$self->_build_headers_optypes if !$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 fragments will be gathered
# and eval-ed in FILTER(), for deciding which rows match the constraints.
if ($col == -1) {
# constraint on rowid
$member = '$i';
$optype = $NUM;
}
else {
# cnstraint on regular column
my $opts = $self->{options};
$member = $opts->{arrayrefs} ? "\$row->[$col]"
: $opts->{hashrefs} ? "\$row->{$self->{headers}[$col]}"
: $opts->{colref} ? "\$row"
: die "corrupted data in ->{options}";
$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 core -- see vtab.html in sqlite doc
$constraint->{argvIndex} = $ix++;
$constraint->{omit} = 1;
}
# further info for the SQLite core
my $outputs = {
idxNum => 1,
idxStr => (join(" && ", @conditions) || "1"),
orderByConsumed => 0,
estimatedCost => 1.0,
estimatedRows => undef,
};
return $outputs;
}
#----------------------------------------------------------------------
# methods for data update
#----------------------------------------------------------------------
sub _build_new_row {
my ($self, $values) = @_;
my $opts = $self->{options};
return $opts->{arrayrefs} ? $values
: $opts->{hashrefs} ? { mesh @{$self->{headers}}, @$values }
: $opts->{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 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) = @_;
# escape '\' and '}' in values before they are sprintf'ed into q{%s}
s/\\/\\\\/g, s/}/\\}/g foreach @values;
# build a method coderef to fetch matching rows
my $perl_code = 'sub {my ($self, $i) = @_; my $row = $self->row($i); '
. sprintf($idxStr, @values)
. '}';
# print STDERR $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});
my $opts = $self->{vtable}{options};
return $opts->{arrayrefs} ? $row->[$idxCol]
: $opts->{hashrefs} ? $row->{$self->{vtable}{headers}[$idxCol]}
: $opts->{colref} ? $row
: die "corrupted data in ->{options}";
}
sub ROWID {
my ($self) = @_;
return $self->{row_ix};
}
1;
__END__
=head1 NAME
DBD::SQLite::VirtualTable::PerlData -- virtual table hooked to Perl data
=head1 SYNOPSIS
Within Perl :
$dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData");
Then, within SQL :
CREATE VIRTUAL TABLE atbl USING perl(foo, bar, etc,
arrayrefs="some::global::var::aref")
CREATE VIRTUAL TABLE htbl USING perl(foo, bar, etc,
hashrefs="some::global::var::href")
CREATE VIRTUAL TABLE ctbl USING perl(single_col
colref="some::global::var::ref")
SELECT foo, bar FROM atbl WHERE ...;
=head1 DESCRIPTION
A C<PerlData> virtual table is a database view on some datastructure
within a Perl program. The data can be read or modified both from SQL
and from Perl. This is useful for simple import/export
operations, for debugging purposes, for joining data from different
sources, etc.
=head1 PARAMETERS
Parameters for creating a C<PerlData> virtual table are specified
within the C<CREATE VIRTUAL TABLE> statement, mixed with regular
column declarations, but with an '=' sign.
The only authorized (and mandatory) parameter is the one that
specifies the Perl datastructure to which the virtual table is bound.
It must be given as the fully qualified name of a global variable;
the parameter can be one of three different kinds :
=over
=item C<arrayrefs>
arrayref that contains an arrayref for each row.
Each such row will have a size equivalent to the number
of columns declared for the virtual table.
=item C<hashrefs>
arrayref that contains a hashref for each row.
Keys in each hashref should correspond to the
columns declared for the virtual table.
=item C<colref>
arrayref that contains a single scalar for each row;
obviously, this is a single-column virtual table.
=back
=head1 USAGE
=head2 Common part of all examples : declaring the module
In all examples below, the common part is that the Perl
program should connect to the database and then declare the
C<PerlData> virtual table module, like this
# connect to the database
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", '', '',
{RaiseError => 1, AutoCommit => 1});
# or any other options suitable to your needs
# register the module
$dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData");
Then create a global arrayref variable, using C<our> instead of C<my>,
so that the variable is stored in the symbol table of the enclosing module.
package Foo::Bar; # could as well be just "main"
our $rows = [ ... ];
Finally, create the virtual table and bind it to the global
variable (here we assume that C<@$rows> contains arrayrefs) :
$dbh->do('CREATE VIRTUAL TABLE temp.vtab'
.' USING perl(col1 INT, col2 TEXT, etc,
arrayrefs="Foo::Bar::rows');
In most cases, the virtual table will be for temporary use, which is
the reason why this example prepends C<temp.> in front of the table
name : this tells SQLite to cleanup that table when the database
handle will be disconnected, without the need to emit an explicit DROP
statement.
Column names (and optionally their types) are specified in the
virtual table declaration, just like for any regular table.
=head2 Arrayref example : statistics from files
Let's suppose we want to perform some searches over a collection of
files, where search constraints may be based on some of the fields
returned by L<stat>, such as the size of the file or its last modify
time. Here is a way to do it with a virtual table :
my @files = ... ; # list of files to inspect
# apply the L<stat> function to each file
our $file_stats = [ map {($_, stat $_)} @files];
# create a temporary virtual table
$dbh->do(<<"");
CREATE VIRTUAL TABLE temp.file_stats'
USING perl(path, dev, ino, mode, nlink, uid, gid, rdev, size,
atime, mtime, ctime, blksize, blocks,
arrayrefs="main::file_stats");
# search files
my $sth = $dbh->prepare(<<"");
SELECT * FROM file_stats
WHERE mtime BETWEEN ? AND ?
AND uid IN (...)
=head2 Hashref example : unicode characters
Given any unicode character, the L<Unicode::UCD/charinfo> function
returns a hashref with various bits of information about that character.
So this can be exploited in a virtual table :
use Unicode::UCD 'charinfo';
our $chars = [map {charinfo($_)} 0x300..0x400]; # arbitrary subrange
# create a temporary virtual table
$dbh->do(<<"");
CREATE VIRTUAL TABLE charinfo USING perl(
code, name, block, script, category,
hashrefs="main::chars"
)
# search characters
my $sth = $dbh->prepare(<<"");
SELECT * FROM charinfo
WHERE script='Greek'
AND name LIKE '%SIGMA%'
=head2 Colref example: SELECT WHERE ... IN ...
I<Note: The idea for the following example is borrowed from the
C<test_intarray.h> file in SQLite's source
(L<http://www.sqlite.org/src>).>
A C<colref> virtual table is designed to facilitate using an
array of values as the right-hand side of an IN operator. The
usual syntax for IN is to prepare a statement like this:
SELECT * FROM table WHERE x IN (?,?,?,...,?);
and then bind individual values to each of the ? slots; but this has
the disadvantage that the number of values must be known in
advance. Instead, we can store values in a Perl array, bind that array
to a virtual table, and then write a statement like this
SELECT * FROM table WHERE x IN perl_array;
Here is how such a program would look like :
# connect to the database
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", '', '',
{RaiseError => 1, AutoCommit => 1});
# Declare a global arrayref containing the values. Here we assume
# they are taken from @ARGV, but any other datasource would do.
# Note the use of "our" instead of "my".
our $valuess = \@ARGV;
# register the module and declare the virtual table
$dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData");
$dbh->do('CREATE VIRTUAL TABLE temp.intarray'
.' USING perl(i INT, colref="main::values');
# now we can SELECT from another table, using the intarray as a constraint
my $sql = "SELECT * FROM some_table WHERE some_col IN intarray";
my $result = $dbh->selectall_arrayref($sql);
Beware that the virtual table is read-write, so the statement below
would push 99 into @ARGV !
INSERT INTO intarray VALUES (99);
=head1 AUTHOR
Laurent Dami E<lt>dami@cpan.orgE<gt>
=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

139
t/virtual_table/00_base.t Normal file
View file

@ -0,0 +1,139 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
plan tests => 10;
my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 );
$dbh->sqlite_create_module(vtab => "DBD::SQLite::VirtualTable::T");
ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab(foo INTEGER, bar INTEGER)");
my $sql = "SELECT rowid, foo, bar FROM foobar ";
my $rows = $dbh->selectall_arrayref($sql, {Slice => {}});
is scalar(@$rows), 5, "got 5 rows";
is $rows->[0]{rowid}, 5, "rowid column";
is $rows->[0]{foo}, "auto_vivify:0", "foo column";
is $rows->[0]{bar}, "auto_vivify:1", "bar column";
$sql = "SELECT * FROM foobar ";
$rows = $dbh->selectall_arrayref($sql, {Slice => {}});
is scalar(@$rows), 5, "got 5 rows again";
is_deeply([sort keys %{$rows->[0]}], [qw/bar foo/], "col list OK");
$sql = "SELECT * FROM foobar WHERE foo > -1 and bar < 33";
$rows = $dbh->selectall_arrayref($sql, {Slice => {}});
is scalar(@$rows), 5, "got 5 rows (because of omitted constraints)";
package DBD::SQLite::VirtualTable::T;
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable';
use YAML;
sub NEW {
my $class = shift;
my $self = $class->_PREPARE_SELF(@_);
bless $self, $class;
# stupid pragma call, just to check that the dbh is OK
$self->dbh->do("PRAGMA application_id=999");
return $self;
}
sub BEST_INDEX {
my ($self, $constraints, $order_by) = @_;
# print STDERR Dump [BEST_INDEX => {
# where => $constraints,
# order => $order_by,
# }];
my $ix = 0;
foreach my $constraint (@$constraints) {
$constraint->{argvIndex} = $ix++;
$constraint->{omit} = 1; # to prevent sqlite core to check values
}
# TMP HACK -- should put real values instead
my $outputs = {
idxNum => 1,
idxStr => "foobar",
orderByConsumed => 0,
estimatedCost => 1.0,
estimatedRows => undef,
};
return $outputs;
}
package DBD::SQLite::VirtualTable::T::Cursor;
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable::Cursor';
use YAML;
sub NEW {
my $class = shift;
my $self = $class->SUPER::NEW(@_);
$self->{row_count} = 5;
return $self;
}
sub FILTER {
my ($self, $idxNum, $idxStr, @values) = @_;
return;
}
sub EOF {
my $self = shift;
return !$self->{row_count};
}
sub NEXT {
my $self = shift;
$self->{row_count}--;
}
sub COLUMN {
my ($self, $idxCol) = @_;
return "auto_vivify:$idxCol";
}
sub ROWID {
my ($self) = @_;
return $self->{row_count};
}
1;

76
t/virtual_table/01_destroy.t Normal file
View file

@ -0,0 +1,76 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
plan tests => 20;
my $dbfile = "tmp.sqlite";
my $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 );
ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT &&
!$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab created";
# create 2 separate SQLite modules from the same Perl class
$dbh->sqlite_create_module(vtab1 => "DBD::SQLite::VirtualTable::T");
$dbh->sqlite_create_module(vtab2 => "DBD::SQLite::VirtualTable::T");
ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT &&
!$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "still no vtab";
# create 2 virtual tables from module vtab1
ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab1(foo, bar)"), "create foobar";
ok $dbh->do("CREATE VIRTUAL TABLE barfoo USING vtab1(foo, bar)"), "create barfoo";
is $DBD::SQLite::VirtualTable::T::CREATE_COUNT, 2, "2 vtab created";
ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected";
# destructor is called when a vtable is dropped
ok !$DBD::SQLite::VirtualTable::T::DESTROY_COUNT, "no vtab destroyed";
ok $dbh->do("DROP TABLE foobar"), "dropped foobar";
is $DBD::SQLite::VirtualTable::T::DESTROY_COUNT, 1, "one vtab destroyed";
# all vtable and module destructors are called when the dbh is disconnected
undef $dbh;
is $DBD::SQLite::VirtualTable::T::DESTROY_COUNT, 2, "both vtab destroyed";
is $DBD::SQLite::VirtualTable::T::DISCONNECT_COUNT, 1, "1 vtab disconnected";
is $DBD::SQLite::VirtualTable::T::DROP_COUNT, 1, "1 vtab dropped";
is $DBD::SQLite::VirtualTable::T::DESTROY_MODULE_COUNT, 2, "2 modules destroyed";
# reconnect, check that we go through the CONNECT method
undef $DBD::SQLite::VirtualTable::T::CREATE_COUNT;
undef $DBD::SQLite::VirtualTable::T::CONNECT_COUNT;
$dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 );
$dbh->sqlite_create_module(vtab1 => "DBD::SQLite::VirtualTable::T");
ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created";
ok !$DBD::SQLite::VirtualTable::T::CONNECT_COUNT, "no vtab connected";
my $sth = $dbh->prepare("SELECT * FROM barfoo");
ok !$DBD::SQLite::VirtualTable::T::CREATE_COUNT, "no vtab created";
is $DBD::SQLite::VirtualTable::T::CONNECT_COUNT, 1, "1 vtab connected";
package DBD::SQLite::VirtualTable::T;
use base 'DBD::SQLite::VirtualTable';
our $CREATE_COUNT;
our $CONNECT_COUNT;
our $DESTROY_COUNT;
our $DESTROY_MODULE_COUNT;
our $DROP_COUNT;
our $DISCONNECT_COUNT;
sub CREATE {$CREATE_COUNT++; return shift->SUPER::CREATE(@_)}
sub CONNECT {$CONNECT_COUNT++; return shift->SUPER::CONNECT(@_)}
sub DROP {$DROP_COUNT++}
sub DISCONNECT {$DISCONNECT_COUNT++}
sub DESTROY {$DESTROY_COUNT++}
sub DESTROY_MODULE {$DESTROY_MODULE_COUNT++}
1;

173
t/virtual_table/02_find_function.t Normal file
View file

@ -0,0 +1,173 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
plan tests => 15;
my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 );
$dbh->sqlite_create_module(vtab => "DBD::SQLite::VirtualTable::T");
ok $dbh->do("CREATE VIRTUAL TABLE foobar USING vtab(foo INTEGER, bar INTEGER)"),
"created foobar";
# overload functions "abs" and "substr"
$DBD::SQLite::VirtualTable::T::funcs{abs}{overloaded}
= sub {my $val = shift; return "fake_abs($val)" };
$DBD::SQLite::VirtualTable::T::funcs{substr}{overloaded}
= sub {my ($val, $offset, $len) = @_; return "fake_substr($val, $offset, $len)" };
# make a first query
my $row = $dbh->selectrow_hashref(<<"");
SELECT abs(foo) afoo,
abs(bar) abar,
substr(foo, 3, 5) sfoo,
trim(foo) tfoo
FROM foobar
is $DBD::SQLite::VirtualTable::T::funcs{abs}{calls}, 1, "abs called";
is $DBD::SQLite::VirtualTable::T::funcs{substr}{calls}, 1, "substr called";
is $DBD::SQLite::VirtualTable::T::funcs{trim}{calls}, 1, "trim called";
is_deeply $row, { 'abar' => 'fake_abs(1)',
'afoo' => 'fake_abs(0)',
'sfoo' => 'fake_substr(0, 3, 5)',
'tfoo' => '0' }, "func results";
# new query : FIND_FUNCTION should not be called again
$row = $dbh->selectrow_hashref(<<"");
SELECT abs(foo) afoo,
abs(bar) abar,
substr(foo, 3, 5) sfoo,
trim(foo) tfoo
FROM foobar
is $DBD::SQLite::VirtualTable::T::funcs{abs}{calls}, 1, "abs still 1";
is $DBD::SQLite::VirtualTable::T::funcs{substr}{calls}, 1, "substr still 1";
is $DBD::SQLite::VirtualTable::T::funcs{trim}{calls}, 1, "trim still 1";
# new table : should issue new calls to FIND_FUNCTION
ok $dbh->do("CREATE VIRTUAL TABLE barfoo USING vtab(foo INTEGER, bar INTEGER)"),
"created barfoo";
$row = $dbh->selectrow_hashref(<<"");
SELECT abs(foo) afoo,
abs(bar) abar,
substr(foo, 3, 5) sfoo,
trim(foo) tfoo
FROM barfoo
is $DBD::SQLite::VirtualTable::T::funcs{abs}{calls}, 2, "abs now 2";
is $DBD::SQLite::VirtualTable::T::funcs{substr}{calls}, 2, "substr now 2";
is $DBD::SQLite::VirtualTable::T::funcs{trim}{calls}, 2, "trim now 2";
# drop table : should free references to functions
ok $dbh->do("DROP TABLE foobar");
# drop connection
undef $dbh;
note "done";
package DBD::SQLite::VirtualTable::T;
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable';
use YAML;
sub BEST_INDEX {
my ($self, $constraints, $order_by) = @_;
my $ix = 0;
foreach my $constraint (@$constraints) {
$constraint->{argvIndex} = $ix++;
$constraint->{omit} = 1; # to prevent sqlite core to check values
}
my $outputs = {
idxNum => 1,
idxStr => "foobar",
orderByConsumed => 0,
estimatedCost => 1.0,
estimatedRows => undef,
};
return $outputs;
}
our %funcs;
sub FIND_FUNCTION {
my ($self, $n_arg, $function_name) = @_;
$funcs{$function_name}{calls} += 1;
my $func = $funcs{$function_name}{overloaded};
return $func;
}
package DBD::SQLite::VirtualTable::T::Cursor;
use strict;
use warnings;
use base 'DBD::SQLite::VirtualTable::Cursor';
use YAML;
sub NEW {
my $class = shift;
my $self = $class->DBD::SQLite::VirtualTable::Cursor::NEW(@_);
$self->{row_count} = 5;
return $self;
}
sub FILTER {
my ($self, $idxNum, $idxStr, @values) = @_;
return;
}
sub EOF {
my $self = shift;
return !$self->{row_count};
}
sub NEXT {
my $self = shift;
$self->{row_count}--;
}
sub COLUMN {
my ($self, $idxCol) = @_;
return $idxCol;
}
sub ROWID {
my ($self) = @_;
return $self->{row_count};
}
1;

62
t/virtual_table/10_filecontent.t Normal file
View file

@ -0,0 +1,62 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
use FindBin;
plan tests => 13;
my $dbh = connect_ok( RaiseError => 1, PrintError => 0, AutoCommit => 1 );
# create index table
$dbh->do(<<"");
CREATE TABLE base (id INTEGER PRIMARY KEY, foo TEXT, path TEXT, bar TEXT)
$dbh->do(<<"");
INSERT INTO base VALUES(1, 'foo1', '00_base.t', 'bar1')
$dbh->do(<<"");
INSERT INTO base VALUES(2, 'foo2', '10_filecontent.t', 'bar2')
# start tests
ok $dbh->sqlite_create_module(fs => "DBD::SQLite::VirtualTable::FileContent"),
"create_module";
ok $dbh->do(<<""), "create vtable";
CREATE VIRTUAL TABLE vfs USING fs(source = base,
expose = "path, foo, bar",
root = "$FindBin::Bin")
my $sql = "SELECT content, bar, rowid FROM vfs WHERE foo='foo2'";
my $rows = $dbh->selectall_arrayref($sql, {Slice => {}});
is scalar(@$rows), 1, "got 1 row";
is $rows->[0]{bar}, 'bar2', 'got bar2';
is $rows->[0]{rowid}, 2, 'got rowid';
like $rows->[0]{content}, qr/VIRTUAL TABLE vfs/, 'file content';
$sql = "SELECT * FROM vfs ORDER BY rowid";
$rows = $dbh->selectall_arrayref($sql, {Slice => {}});
is scalar(@$rows), 2, "got 2 rows";
is_deeply([sort keys %{$rows->[0]}], [qw/bar content foo path/], "col list OK");
is $rows->[0]{bar}, 'bar1', 'got bar1';
is $rows->[1]{bar}, 'bar2', 'got bar2';
# expensive request (reads content from all files in table) !
$sql = "SELECT * FROM vfs WHERE content LIKE '%filesys%'";
$rows = $dbh->selectall_arrayref($sql, {Slice => {}});
is scalar(@$rows), 1, "got 1 row";

101
t/virtual_table/11_filecontent_fulltext.t Normal file
View file

@ -0,0 +1,101 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
use FindBin;
my $dbfile = "tmp.sqlite";
my @tests = (
["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/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/FileContent.pm
lib/DBD/SQLite/VirtualTable/PerlData.pm
]],
);
plan tests => 3 + 3 * @tests;
# find out perl files in this distrib
my $distrib_dir = "$FindBin::Bin/../..";
open my $fh, "<", "$distrib_dir/MANIFEST" or die "open $distrib_dir/MANIFEST: $!";
my @files = <$fh>;
close $fh;
chomp foreach @files;
my @perl_files = grep {/\.(pl|pm|pod)$/} @files;
# open database
my $dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 );
# create the source table and populate it
$dbh->do("CREATE TABLE files (id INTEGER PRIMARY KEY, path TEXT)");
my $sth = $dbh->prepare("INSERT INTO files(path) VALUES (?)");
$sth->execute($_) foreach @perl_files;
# create the virtual table
$dbh->sqlite_create_module(fc => "DBD::SQLite::VirtualTable::FileContent");
$dbh->do(<<"");
CREATE VIRTUAL TABLE vfc USING fc(source = files,
expose = "path",
root = "$distrib_dir")
# create the fulltext indexing table and populate it
$dbh->do('CREATE VIRTUAL TABLE fts USING fts4(content="vfc")');
note "building fts index....";
$dbh->do("INSERT INTO fts(fts) VALUES ('rebuild')");
note "done";
# start tests
my $sql = "SELECT path FROM fts WHERE fts MATCH ?";
foreach my $test (@tests) {
my ($pattern, @expected) = @$test;
my $paths = $dbh->selectcol_arrayref($sql, {}, $pattern);
is_deeply([sort @$paths], \@expected, "search '$pattern'");
}
# remove one document
my $remove_path = 'lib/DBD/SQLite/VirtualTable.pm';
$dbh->do("DELETE FROM fts WHERE path='$remove_path'");
# test again
foreach my $test (@tests) {
my ($pattern, @expected) = @$test;
@expected = grep {$_ ne $remove_path} @expected;
my $paths = $dbh->selectcol_arrayref($sql, {}, $pattern);
is_deeply([sort @$paths], \@expected, "search '$pattern' -- no $remove_path");
}
# see if data was properly stored: disconnect, reconnect and test again
$dbh->disconnect;
undef $dbh;
$dbh = connect_ok( dbfile => $dbfile, RaiseError => 1, AutoCommit => 1 );
$dbh->sqlite_create_module(fc => "DBD::SQLite::VirtualTable::FileContent");
foreach my $test (@tests) {
my ($pattern, @expected) = @$test;
@expected = grep {$_ ne $remove_path} @expected;
my $paths = $dbh->selectcol_arrayref($sql, {}, $pattern);
is_deeply([sort @$paths], \@expected, "search '$pattern' -- after reconnect");
}

121
t/virtual_table/20_perldata.t Normal file
View file

@ -0,0 +1,121 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
use FindBin;
our $perl_rows = [
[1, 2, 'three'],
[4, 5, 'six' ],
[7, 8, 'nine' ],
];
plan tests => 29;
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 ], "IN intarray";
# same thing with strings
our $strings = [qw/one two three/];
ok $dbh->do(<<""), "create vtable strarray";
CREATE VIRTUAL TABLE strarray USING perl(str TEXT, colref="main::strings")
$sql = "INSERT INTO strarray VALUES ('aa'), ('bb')";
ok $dbh->do($sql), $sql;
is_deeply $strings, [qw/one two three aa bb/], "added 2 strings";
$sql = "SELECT a FROM vtb WHERE c IN strarray";
$res = $dbh->selectcol_arrayref($sql);
is_deeply $res, [ 1 ], "IN strarray";
$sql = "SELECT a FROM vtb WHERE c IN (SELECT str FROM strarray WHERE str > 'a')";
$res = $dbh->selectcol_arrayref($sql);
is_deeply $res, [ 1 ], "IN SELECT FROM strarray";

52
t/virtual_table/21_perldata_charinfo.t Normal file
View file

@ -0,0 +1,52 @@
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
# test the example described in
# L<DBD::SQLite::VirtualTable::PerlData/"Hashref example : unicode characters">
use t::lib::Test qw/connect_ok/;
use Test::More;
use Test::NoWarnings;
use Unicode::UCD 'charinfo';
our $chars = [map {charinfo($_)} 0x300..0x400];
plan tests => 10;
my $dbh = connect_ok( RaiseError => 1, AutoCommit => 1 );
ok $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"),
"create_module";
ok $dbh->do(<<""), "create table";
CREATE VIRTUAL TABLE charinfo USING perl(
code, name, block, script, category,
hashrefs="main::chars")
my $sql = "SELECT * FROM charinfo WHERE script='Greek' AND name LIKE '%SIGMA%'";
my $res = $dbh->selectall_arrayref($sql, {Slice => {}});
ok scalar(@$res), "found sigma letters";
is $res->[0]{block}, "Greek and Coptic", "letter in proper block";
# The former example used SQLite's LIKE operator; now do the same with MATCH
# which gets translated to a Perl regex
$sql = "SELECT * FROM charinfo WHERE script='Greek' AND name MATCH 'SIGMA'";
$res = $dbh->selectall_arrayref($sql, {Slice => {}});
ok scalar(@$res), "found sigma letters";
is $res->[0]{block}, "Greek and Coptic", "letter in proper block";
# the following does not work because \b gets escaped as a literal
#$sql = "SELECT * FROM charinfo WHERE script='Greek' AND name MATCH '\\bSIGMA\\b'";
# but the following does work because the REGEXP operator is handled
# outside of the BEST_INDEX / FILTER methods
$sql = "SELECT * FROM charinfo WHERE script='Greek' AND name REGEXP '\\bSIGMA\\b'";
$res = $dbh->selectall_arrayref($sql, {Slice => {}});
ok scalar(@$res), "found sigma letters";
is $res->[0]{block}, "Greek and Coptic", "letter in proper block";