mirror of
https://github.com/DBD-SQLite/DBD-SQLite
synced 2025-06-07 14:19:10 -04:00
315 lines
8 KiB
Perl
315 lines
8 KiB
Perl
#======================================================================
|
|
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 {
|
|
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 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) = @_;
|
|
|
|
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 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;
|
|
|
|
$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::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.
|
|
The Perl data must be given as a fully qualified name of a global variable;
|
|
it can be one of three different kinds :
|
|
|
|
=over
|
|
|
|
=item C<arrayrefs>
|
|
|
|
arrayref that contains an arrayref for each row
|
|
|
|
=item C<hashrefs>
|
|
|
|
arrayref that contains a hashref for each row
|
|
|
|
=item C<colref>
|
|
|
|
arrayref that contains a single scalar for each row
|
|
(obviously this is a single-column virtual table)
|
|
|
|
=back
|
|
|
|
=head1 USAGE
|
|
|
|
[TODO]
|
|
|
|
=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
|