377 lines
9.9 KiB
Perl
377 lines
9.9 KiB
Perl
|
# -*- perl -*-
|
||
|
#
|
||
|
# DBD::Mem - A DBI driver for in-memory tables
|
||
|
#
|
||
|
# This module is currently maintained by
|
||
|
#
|
||
|
# Jens Rehsack
|
||
|
#
|
||
|
# Copyright (C) 2016,2017 by Jens Rehsack
|
||
|
#
|
||
|
# All rights reserved.
|
||
|
#
|
||
|
# You may distribute this module under the terms of either the GNU
|
||
|
# General Public License or the Artistic License, as specified in
|
||
|
# the Perl README file.
|
||
|
|
||
|
require 5.008;
|
||
|
use strict;
|
||
|
|
||
|
#################
|
||
|
package DBD::Mem;
|
||
|
#################
|
||
|
use base qw( DBI::DBD::SqlEngine );
|
||
|
use vars qw($VERSION $ATTRIBUTION $drh);
|
||
|
$VERSION = '0.001';
|
||
|
$ATTRIBUTION = 'DBD::Mem by Jens Rehsack';
|
||
|
|
||
|
# no need to have driver() unless you need private methods
|
||
|
#
|
||
|
sub driver ($;$)
|
||
|
{
|
||
|
my ( $class, $attr ) = @_;
|
||
|
return $drh if ($drh);
|
||
|
|
||
|
# do the real work in DBI::DBD::SqlEngine
|
||
|
#
|
||
|
$attr->{Attribution} = 'DBD::Mem by Jens Rehsack';
|
||
|
$drh = $class->SUPER::driver($attr);
|
||
|
|
||
|
return $drh;
|
||
|
}
|
||
|
|
||
|
sub CLONE
|
||
|
{
|
||
|
undef $drh;
|
||
|
}
|
||
|
|
||
|
#####################
|
||
|
package DBD::Mem::dr;
|
||
|
#####################
|
||
|
$DBD::Mem::dr::imp_data_size = 0;
|
||
|
@DBD::Mem::dr::ISA = qw(DBI::DBD::SqlEngine::dr);
|
||
|
|
||
|
# you could put some :dr private methods here
|
||
|
|
||
|
# you may need to over-ride some DBI::DBD::SqlEngine::dr methods here
|
||
|
# but you can probably get away with just letting it do the work
|
||
|
# in most cases
|
||
|
|
||
|
#####################
|
||
|
package DBD::Mem::db;
|
||
|
#####################
|
||
|
$DBD::Mem::db::imp_data_size = 0;
|
||
|
@DBD::Mem::db::ISA = qw(DBI::DBD::SqlEngine::db);
|
||
|
|
||
|
use Carp qw/carp/;
|
||
|
|
||
|
sub set_versions
|
||
|
{
|
||
|
my $this = $_[0];
|
||
|
$this->{mem_version} = $DBD::Mem::VERSION;
|
||
|
return $this->SUPER::set_versions();
|
||
|
}
|
||
|
|
||
|
sub init_valid_attributes
|
||
|
{
|
||
|
my $dbh = shift;
|
||
|
|
||
|
# define valid private attributes
|
||
|
#
|
||
|
# attempts to set non-valid attrs in connect() or
|
||
|
# with $dbh->{attr} will throw errors
|
||
|
#
|
||
|
# the attrs here *must* start with mem_ or foo_
|
||
|
#
|
||
|
# see the STORE methods below for how to check these attrs
|
||
|
#
|
||
|
$dbh->{mem_valid_attrs} = {
|
||
|
mem_version => 1, # verbose DBD::Mem version
|
||
|
mem_valid_attrs => 1, # DBD::Mem::db valid attrs
|
||
|
mem_readonly_attrs => 1, # DBD::Mem::db r/o attrs
|
||
|
mem_meta => 1, # DBD::Mem public access for f_meta
|
||
|
mem_tables => 1, # DBD::Mem public access for f_meta
|
||
|
};
|
||
|
$dbh->{mem_readonly_attrs} = {
|
||
|
mem_version => 1, # verbose DBD::Mem version
|
||
|
mem_valid_attrs => 1, # DBD::Mem::db valid attrs
|
||
|
mem_readonly_attrs => 1, # DBD::Mem::db r/o attrs
|
||
|
mem_meta => 1, # DBD::Mem public access for f_meta
|
||
|
};
|
||
|
|
||
|
$dbh->{mem_meta} = "mem_tables";
|
||
|
|
||
|
return $dbh->SUPER::init_valid_attributes();
|
||
|
}
|
||
|
|
||
|
sub get_mem_versions
|
||
|
{
|
||
|
my ( $dbh, $table ) = @_;
|
||
|
$table ||= '';
|
||
|
|
||
|
my $meta;
|
||
|
my $class = $dbh->{ImplementorClass};
|
||
|
$class =~ s/::db$/::Table/;
|
||
|
$table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 );
|
||
|
$meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) );
|
||
|
|
||
|
return sprintf( "%s using %s", $dbh->{mem_version}, $AnyData2::VERSION );
|
||
|
}
|
||
|
|
||
|
package DBD::Mem::st;
|
||
|
|
||
|
use strict;
|
||
|
use warnings;
|
||
|
|
||
|
our $imp_data_size = 0;
|
||
|
our @ISA = qw(DBI::DBD::SqlEngine::st);
|
||
|
|
||
|
############################
|
||
|
package DBD::Mem::Statement;
|
||
|
############################
|
||
|
|
||
|
@DBD::Mem::Statement::ISA = qw(DBI::DBD::SqlEngine::Statement);
|
||
|
|
||
|
|
||
|
sub open_table ($$$$$)
|
||
|
{
|
||
|
my ( $self, $data, $table, $createMode, $lockMode ) = @_;
|
||
|
|
||
|
my $class = ref $self;
|
||
|
$class =~ s/::Statement/::Table/;
|
||
|
|
||
|
my $flags = {
|
||
|
createMode => $createMode,
|
||
|
lockMode => $lockMode,
|
||
|
};
|
||
|
if( defined( $data->{Database}->{mem_table_data}->{$table} ) && $data->{Database}->{mem_table_data}->{$table})
|
||
|
{
|
||
|
my $t = $data->{Database}->{mem_tables}->{$table};
|
||
|
$t->seek( $data, 0, 0 );
|
||
|
return $t;
|
||
|
}
|
||
|
|
||
|
return $self->SUPER::open_table($data, $table, $createMode, $lockMode);
|
||
|
}
|
||
|
|
||
|
# ====== DataSource ============================================================
|
||
|
|
||
|
package DBD::Mem::DataSource;
|
||
|
|
||
|
use strict;
|
||
|
use warnings;
|
||
|
|
||
|
use Carp;
|
||
|
|
||
|
@DBD::Mem::DataSource::ISA = "DBI::DBD::SqlEngine::DataSource";
|
||
|
|
||
|
sub complete_table_name ($$;$)
|
||
|
{
|
||
|
my ( $self, $meta, $table, $respect_case ) = @_;
|
||
|
$table;
|
||
|
}
|
||
|
|
||
|
sub open_data ($)
|
||
|
{
|
||
|
my ( $self, $meta, $attrs, $flags ) = @_;
|
||
|
defined $meta->{data_tbl} or $meta->{data_tbl} = [];
|
||
|
}
|
||
|
|
||
|
########################
|
||
|
package DBD::Mem::Table;
|
||
|
########################
|
||
|
|
||
|
# shamelessly stolen from SQL::Statement::RAM
|
||
|
|
||
|
use Carp qw/croak/;
|
||
|
|
||
|
@DBD::Mem::Table::ISA = qw(DBI::DBD::SqlEngine::Table);
|
||
|
|
||
|
use Carp qw(croak);
|
||
|
|
||
|
sub new
|
||
|
{
|
||
|
#my ( $class, $tname, $col_names, $data_tbl ) = @_;
|
||
|
my ( $class, $data, $attrs, $flags ) = @_;
|
||
|
my $self = $class->SUPER::new($data, $attrs, $flags);
|
||
|
|
||
|
my $meta = $self->{meta};
|
||
|
$self->{records} = $meta->{data_tbl};
|
||
|
$self->{index} = 0;
|
||
|
|
||
|
$self;
|
||
|
}
|
||
|
|
||
|
sub bootstrap_table_meta
|
||
|
{
|
||
|
my ( $self, $dbh, $meta, $table ) = @_;
|
||
|
|
||
|
defined $meta->{sql_data_source} or $meta->{sql_data_source} = "DBD::Mem::DataSource";
|
||
|
|
||
|
$meta;
|
||
|
}
|
||
|
|
||
|
sub fetch_row
|
||
|
{
|
||
|
my ( $self, $data ) = @_;
|
||
|
|
||
|
return $self->{row} =
|
||
|
( $self->{records} and ( $self->{index} < scalar( @{ $self->{records} } ) ) )
|
||
|
? [ @{ $self->{records}->[ $self->{index}++ ] } ]
|
||
|
: undef;
|
||
|
}
|
||
|
|
||
|
sub push_row
|
||
|
{
|
||
|
my ( $self, $data, $fields ) = @_;
|
||
|
my $currentRow = $self->{index};
|
||
|
$self->{index} = $currentRow + 1;
|
||
|
$self->{records}->[$currentRow] = $fields;
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
sub truncate
|
||
|
{
|
||
|
my $self = shift;
|
||
|
return splice @{ $self->{records} }, $self->{index}, 1;
|
||
|
}
|
||
|
|
||
|
sub push_names
|
||
|
{
|
||
|
my ( $self, $data, $names ) = @_;
|
||
|
my $meta = $self->{meta};
|
||
|
$meta->{col_names} = $self->{col_names} = $names;
|
||
|
$self->{org_col_names} = [ @{$names} ];
|
||
|
$self->{col_nums} = {};
|
||
|
$self->{col_nums}{ $names->[$_] } = $_ for ( 0 .. scalar @$names - 1 );
|
||
|
}
|
||
|
|
||
|
sub drop ($)
|
||
|
{
|
||
|
my ($self, $data) = @_;
|
||
|
delete $data->{Database}{sql_meta}{$self->{table}};
|
||
|
return 1;
|
||
|
} # drop
|
||
|
|
||
|
sub seek
|
||
|
{
|
||
|
my ( $self, $data, $pos, $whence ) = @_;
|
||
|
return unless defined $self->{records};
|
||
|
|
||
|
my ($currentRow) = $self->{index};
|
||
|
if ( $whence == 0 )
|
||
|
{
|
||
|
$currentRow = $pos;
|
||
|
}
|
||
|
elsif ( $whence == 1 )
|
||
|
{
|
||
|
$currentRow += $pos;
|
||
|
}
|
||
|
elsif ( $whence == 2 )
|
||
|
{
|
||
|
$currentRow = @{ $self->{records} } + $pos;
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
croak $self . "->seek: Illegal whence argument ($whence)";
|
||
|
}
|
||
|
|
||
|
$currentRow < 0 and
|
||
|
croak "Illegal row number: $currentRow";
|
||
|
$self->{index} = $currentRow;
|
||
|
}
|
||
|
|
||
|
1;
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
DBD::Mem - a DBI driver for Mem & MLMem files
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use DBI;
|
||
|
$dbh = DBI->connect('dbi:Mem:', undef, undef, {});
|
||
|
$dbh = DBI->connect('dbi:Mem:', undef, undef, {RaiseError => 1});
|
||
|
|
||
|
# or
|
||
|
$dbh = DBI->connect('dbi:Mem:');
|
||
|
$dbh = DBI->connect('DBI:Mem(RaiseError=1):');
|
||
|
|
||
|
and other variations on connect() as shown in the L<DBI> docs and
|
||
|
<DBI::DBD::SqlEngine metadata|DBI::DBD::SqlEngine/Metadata>.
|
||
|
|
||
|
Use standard DBI prepare, execute, fetch, placeholders, etc.,
|
||
|
see L<QUICK START> for an example.
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
DBD::Mem is a database management system that works right out of the box.
|
||
|
If you have a standard installation of Perl and DBI you can begin creating,
|
||
|
accessing, and modifying simple database tables without any further modules.
|
||
|
You can add other modules (e.g., SQL::Statement) for improved functionality.
|
||
|
|
||
|
DBD::Mem doesn't store any data persistently - all data has the lifetime of
|
||
|
the instantiated C<$dbh>. The main reason to use DBD::Mem is to use extended
|
||
|
features of L<SQL::Statement> where temporary tables are required. One can
|
||
|
use DBD::Mem to simulate C<VIEWS> or sub-queries.
|
||
|
|
||
|
Bundling C<DBD::Mem> with L<DBI> will allow us further compatibility checks
|
||
|
of L<DBI::DBD::SqlEngine> beyond the capabilities of L<DBD::File> and
|
||
|
L<DBD::DBM>. This will ensure DBI provided basis for drivers like
|
||
|
L<DBD::AnyData2> or L<DBD::Amazon> are better prepared and tested for
|
||
|
not-file based backends.
|
||
|
|
||
|
=head2 Metadata
|
||
|
|
||
|
There're no new meta data introduced by C<DBD::Mem>. See
|
||
|
L<DBI::DBD::SqlEngine/Metadata> for full description.
|
||
|
|
||
|
=head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS
|
||
|
|
||
|
If you need help installing or using DBD::Mem, please write to the DBI
|
||
|
users mailing list at L<mailto:dbi-users@perl.org> or to the
|
||
|
comp.lang.perl.modules newsgroup on usenet. I cannot always answer
|
||
|
every question quickly but there are many on the mailing list or in
|
||
|
the newsgroup who can.
|
||
|
|
||
|
DBD developers for DBD's which rely on DBI::DBD::SqlEngine or DBD::Mem or
|
||
|
use one of them as an example are suggested to join the DBI developers
|
||
|
mailing list at L<mailto:dbi-dev@perl.org> and strongly encouraged to join our
|
||
|
IRC channel at L<irc://irc.perl.org/dbi>.
|
||
|
|
||
|
If you have suggestions, ideas for improvements, or bugs to report, please
|
||
|
report a bug as described in DBI. Do not mail any of the authors directly,
|
||
|
you might not get an answer.
|
||
|
|
||
|
When reporting bugs, please send the output of C<< $dbh->mem_versions($table) >>
|
||
|
for a table that exhibits the bug and as small a sample as you can make of
|
||
|
the code that produces the bug. And of course, patches are welcome, too
|
||
|
:-).
|
||
|
|
||
|
If you need enhancements quickly, you can get commercial support as
|
||
|
described at L<http://dbi.perl.org/support/> or you can contact Jens Rehsack
|
||
|
at rehsack@cpan.org for commercial support.
|
||
|
|
||
|
=head1 AUTHOR AND COPYRIGHT
|
||
|
|
||
|
This module is written by Jens Rehsack < rehsack AT cpan.org >.
|
||
|
|
||
|
Copyright (c) 2016- by Jens Rehsack, all rights reserved.
|
||
|
|
||
|
You may freely distribute and/or modify this module under the terms of
|
||
|
either the GNU General Public License (GPL) or the Artistic License, as
|
||
|
specified in the Perl README file.
|
||
|
|
||
|
=head1 SEE ALSO
|
||
|
|
||
|
L<DBI> for the Database interface of the Perl Programming Language.
|
||
|
|
||
|
L<SQL::Statement> and L<DBI::SQL::Nano> for the available SQL engines.
|
||
|
|
||
|
L<SQL::Statement::RAM> where the implementation is shamelessly stolen from
|
||
|
to allow DBI bundled Pure-Perl drivers increase the test coverage.
|
||
|
|
||
|
L<DBD::SQLite> using C<dbname=:memory:> for an incredible fast in-memory database engine.
|
||
|
|
||
|
=cut
|