use Module::Build;
use strict;
+use warnings FATAL => 'all';
-my $build = Module::Build->new(
+my $class = Module::Build->subclass(
+ class => "Module::Build::Custom",
+ code => <<'SUBCLASS' );
+
+sub ACTION_test {
+ my $self = shift;
+ if ( $self->notes('TEST_MYSQL_DSN') ) {
+ $ENV{$_} = $self->notes($_) for qw(
+ TEST_MYSQL_DSN TEST_MYSQL_USER TEST_MYSQL_PASS
+ );
+ }
+ if ( $self->notes( 'LONG_TESTS' ) ) {
+ $ENV{LONG_TESTS} = 1;
+ }
+ $self->SUPER::ACTION_test;
+}
+SUBCLASS
+
+my $build = $class->new(
module_name => 'DBM::Deep',
license => 'perl',
requires => {
'Scalar::Util' => '1.14',
'Digest::MD5' => '1.00',
},
- recommends => {
- 'DBIx::Abstract' => '1.006',
- 'Storable' => '2.21',
- },
build_requires => {
'File::Path' => '0.01',
'File::Temp' => '0.01',
'META.yml', '*.bak', '*.gz', 'Makefile.PL', 'cover_db',
],
test_files => 't/??_*.t',
+ auto_features => {
+ dbi_engine => {
+ description => 'DBI support (mysql only so far)',
+ requires => {
+ 'DBI' => '1.5',
+ 'DBD::mysql' => '4.001',
+ },
+ },
+ },
);
+if ( $build->y_n( "Run the long-running tests", 'n' ) ) {
+ $build->notes( 'LONG_TESTS' => 1 );
+}
+
+if ( $build->features( 'dbi_engine' ) ) {
+ if ( $build->y_n( "Run the tests against the DBI engine (for MySQL only)?", 'n' ) ) {
+ my ($dsn, $user, $pass) = ('') x 3;
+ $dsn = $build->prompt( "\tWhat is the full DSN (for example 'dbi:mysql:test')" );
+ if ( $dsn ) {
+ $user = $build->prompt( "\tWhat is the username?" );
+ if ( $user ) {
+ $pass = $build->prompt( "\tWhat is the password?" );
+ }
+ }
+
+ $build->notes( 'TEST_MYSQL_DSN' => $dsn );
+ $build->notes( 'TEST_MYSQL_USER' => $user );
+ $build->notes( 'TEST_MYSQL_PASS' => $pass );
+ }
+}
+
$build->create_build_script;
Revision history for DBM::Deep.
-1.0015 Nov 22 20:00:00 2009 EST
- - DBM::Deep::SQL added
+1.0019_001 Dec 31 22:00:00 2009 EST
+ (This is the first developer release for 1.0020.)
+ (This version is compatible with 1.0014)
+ - DBM::Deep has been refactored to allow for multiple engines. There are two
+ engines built so far:
+ - File (the original engine)
+ - DBI (an engine based on DBI)
+ - The DBI engine has only been tested on MySQL and isn't transactional.
+ - InnoDB sucks horribly. When run in a sufficient isolation mode, it
+ creates deadlocks.
+ - A custom Build.PL has been written to allow for running tests under
+ CPAN.pm against the various engines.
+ - This also allows running the long tests under CPAN.pm
+ - This has meant a ton of refactoring. Hopefullly, this refactoring will
+ allow finding some of the niggly bugs more easily. Those tests have not
+ been enabled yet. That's the next developer release.
+ - Hopefully, this multi-engine support will allow deprecation of the file
+ format in the future.
1.0014 Jun 13 23:15:00 2008 EST
- (This version is compatible with 1.0013)
lib/DBM/Deep/Array.pm
lib/DBM/Deep/Cookbook.pod
lib/DBM/Deep/Engine.pm
-lib/DBM/Deep/Engine/Sector.pm
-lib/DBM/Deep/Engine/Sector/BucketList.pm
-lib/DBM/Deep/Engine/Sector/Data.pm
-lib/DBM/Deep/Engine/Sector/Index.pm
-lib/DBM/Deep/Engine/Sector/Null.pm
-lib/DBM/Deep/Engine/Sector/Reference.pm
-lib/DBM/Deep/Engine/Sector/Scalar.pm
-lib/DBM/Deep/Storage/File.pm
+lib/DBM/Deep/Engine/DBI.pm
+lib/DBM/Deep/Engine/File.pm
lib/DBM/Deep/Hash.pm
lib/DBM/Deep/Internals.pod
lib/DBM/Deep/Iterator.pm
-lib/DBM/Deep/Iterator/BucketList.pm
-lib/DBM/Deep/Iterator/Index.pm
+lib/DBM/Deep/Iterator/DBI.pm
+lib/DBM/Deep/Iterator/File.pm
+lib/DBM/Deep/Iterator/File/BucketList.pm
+lib/DBM/Deep/Iterator/File/Index.pm
lib/DBM/Deep/Null.pm
+lib/DBM/Deep/Sector.pm
+lib/DBM/Deep/Sector/DBI.pm
+lib/DBM/Deep/Sector/DBI/Reference.pm
+lib/DBM/Deep/Sector/DBI/Scalar.pm
+lib/DBM/Deep/Sector/File.pm
+lib/DBM/Deep/Sector/File/BucketList.pm
+lib/DBM/Deep/Sector/File/Data.pm
+lib/DBM/Deep/Sector/File/Index.pm
+lib/DBM/Deep/Sector/File/Null.pm
+lib/DBM/Deep/Sector/File/Reference.pm
+lib/DBM/Deep/Sector/File/Scalar.pm
+lib/DBM/Deep/Storage.pm
+lib/DBM/Deep/Storage/DBI.pm
+lib/DBM/Deep/Storage/File.pm
Makefile.PL
MANIFEST
META.yml
t/etc/db-0-99_04
t/etc/db-1-0000
t/etc/db-1-0003
+etc/mysql_tables.sql
utils/lib/DBM/Deep/09830.pm
utils/lib/DBM/Deep/10002.pm
utils/upgrade_db.pl
use strict;
use warnings FATAL => 'all';
-our $VERSION = q(1.0015);
+our $VERSION = q(1.0019_001);
use Scalar::Util ();
use DBM::Deep::Engine::DBI ();
use DBM::Deep::Engine::File ();
-use DBM::Deep::SQL::Util;
-use DBM::Deep::SQL::Array;
-use DBM::Deep::SQL::Hash;
-
use overload
'""' => sub { overload::StrVal( $_[0] ) },
fallback => 1;
=head1 VERSION DIFFERENCES
+B<NOTE>: 1.0020 introduces different engines which are backed by different types
+of storage. There is the original storage (called 'File') and a database storage
+(called 'DBI'). q.v. L</PLUGINS> for more information.
+
B<NOTE>: 1.0000 has significant file format differences from prior versions.
THere is a backwards-compatibility layer at C<utils/upgrade_db.pl>. Files
created by 1.0000 or higher are B<NOT> compatible with scripts using prior
versions.
+=head1 PLUGINS
+
+DBM::Deep is a wrapper around different storage engines. These are:
+
+=head2 File
+
+This is the traditional storage engine, storing the data to a custom file
+format. The parameters accepted are:
+
+=over 4
+
+=item * file
+
+Filename of the DB file to link the handle to. You can pass a full absolute
+filesystem path, partial path, or a plain filename if the file is in the
+current working directory. This is a required parameter (though q.v. fh).
+
+=item * fh
+
+If you want, you can pass in the fh instead of the file. This is most useful for
+doing something like:
+
+ my $db = DBM::Deep->new( { fh => \*DATA } );
+
+You are responsible for making sure that the fh has been opened appropriately
+for your needs. If you open it read-only and attempt to write, an exception will
+be thrown. If you open it write-only or append-only, an exception will be thrown
+immediately as DBM::Deep needs to read from the fh.
+
+=item * file_offset
+
+This is the offset within the file that the DBM::Deep db starts. Most of the
+time, you will not need to set this. However, it's there if you want it.
+
+If you pass in fh and do not set this, it will be set appropriately.
+
+=item * locking
+
+Specifies whether locking is to be enabled. DBM::Deep uses Perl's flock()
+function to lock the database in exclusive mode for writes, and shared mode
+for reads. Pass any true value to enable. This affects the base DB handle
+I<and any child hashes or arrays> that use the same DB file. This is an
+optional parameter, and defaults to 1 (enabled). See L</LOCKING> below for
+more.
+
+=back
+
+=head2 DBI
+
+This is a storage engine that stores the data in a relational database. Funnily
+enough, this engine doesn't work with transactions (yet) as InnoDB doesn't do
+what DBM::Deep needs it to do.
+
+The parameters accepted are:
+
+=over 4
+
+=item * dbh
+
+This is a DBH that's already been opened with L<DBI/connect>.
+
+=item * dbi
+
+This is a hashref containing:
+
+=over 4
+
+=item * dsn
+
+=item * username
+
+=item * password
+
+=item * connect_args
+
+=back
+
+Theses correspond to the 4 parameters L<DBI/connect> takes.
+
+=back
+
+B<NOTE>: This has only been tested with MySQL (with disappointing results). I
+plan on extending this to work with SQLite and PostgreSQL in the next release.
+Oracle, Sybase, and other engines will come later.
+
+=head2 Planned engines
+
+There are plans to extend this functionality to (at least) the following:
+
+=over 4
+
+=item * BDB (and other hash engines like memcached)
+
+=item * NoSQL engines (such as Tokyo Cabinet)
+
+=item * DBIx::Class (and other ORMs)
+
+=back
+
=head1 SETUP
Construction can be done OO-style (which is the recommended way), or using
This opens a new database handle, mapped to the file "foo.db". If this
file does not exist, it will automatically be created. DB files are
opened in "r+" (read/write) mode, and the type of object returned is a
-hash, unless otherwise specified (see L<OPTIONS> below).
+hash, unless otherwise specified (see L</OPTIONS> below).
You can pass a number of options to the constructor to specify things like
locking, autoflush, etc. This is done by passing an inline hash (or hashref):
Notice that the filename is now specified I<inside> the hash with
the "file" parameter, as opposed to being the sole argument to the
constructor. This is required if any options are specified.
-See L<OPTIONS> below for the complete list.
+See L</OPTIONS> below for the complete list.
You can also start with an array instead of a hash. For this, you must
specify the C<type> parameter:
my $db = tie @array, "DBM::Deep", "bar.db";
As with the OO constructor, you can replace the DB filename parameter with
-a hash containing one or more options (see L<OPTIONS> just below for the
+a hash containing one or more options (see L</OPTIONS> just below for the
complete list).
tie %hash, "DBM::Deep", {
=over
-=item * file
-
-Filename of the DB file to link the handle to. You can pass a full absolute
-filesystem path, partial path, or a plain filename if the file is in the
-current working directory. This is a required parameter (though q.v. fh).
-
-=item * fh
-
-If you want, you can pass in the fh instead of the file. This is most useful for doing
-something like:
-
- my $db = DBM::Deep->new( { fh => \*DATA } );
-
-You are responsible for making sure that the fh has been opened appropriately for your
-needs. If you open it read-only and attempt to write, an exception will be thrown. If you
-open it write-only or append-only, an exception will be thrown immediately as DBM::Deep
-needs to read from the fh.
-
-=item * file_offset
-
-This is the offset within the file that the DBM::Deep db starts. Most of the time, you will
-not need to set this. However, it's there if you want it.
-
-If you pass in fh and do not set this, it will be set appropriately.
-
=item * type
This parameter specifies what type of object to create, a hash or array. Use
This only takes effect when beginning a new file. This is an optional
parameter, and defaults to C<<DBM::Deep->TYPE_HASH>>.
-=item * locking
-
-Specifies whether locking is to be enabled. DBM::Deep uses Perl's flock()
-function to lock the database in exclusive mode for writes, and shared mode
-for reads. Pass any true value to enable. This affects the base DB handle
-I<and any child hashes or arrays> that use the same DB file. This is an
-optional parameter, and defaults to 1 (enabled). See L<LOCKING> below for
-more.
-
=item * autoflush
Specifies whether autoflush is to be enabled on the underlying filehandle.
syntax. Because all DBM::Deep objects are I<tied> to hashes or arrays, you can
treat them as such. DBM::Deep will intercept all reads/writes and direct them
to the right place -- the DB file. This has nothing to do with the
-L<TIE CONSTRUCTION> section above. This simply tells you how to use DBM::Deep
+L</TIE CONSTRUCTION> section above. This simply tells you how to use DBM::Deep
using regular hashes and arrays, rather than calling functions like C<get()>
and C<put()> (although those work too). It is entirely up to you how to want
to access your databases.
This will compress the datafile so that it takes up as little space as possible.
There is a freespace manager so that when space is freed up, it is used before
-extending the size of the datafile. But, that freespace just sits in the datafile
-unless C<optimize()> is called.
+extending the size of the datafile. But, that freespace just sits in the
+datafile unless C<optimize()> is called.
=item * import()
Fetches the first element in the array, deletes it, then shifts all the
remaining elements over to take up the space. Returns the element value. This
-method is not recommended with large arrays -- see L<LARGE ARRAYS> below for
+method is not recommended with large arrays -- see L</LARGE ARRAYS> below for
details.
my $elem = $db->shift();
Performs exactly like Perl's built-in function of the same name. See L<perldoc
-f splice> for usage -- it is too complicated to document here. This method is
-not recommended with large arrays -- see L<LARGE ARRAYS> below for details.
+not recommended with large arrays -- see L</LARGE ARRAYS> below for details.
=back
=head1 LOCKING
Enable or disable automatic file locking by passing a boolean value to the
-C<locking> parameter when constructing your DBM::Deep object (see L<SETUP>
+C<locking> parameter when constructing your DBM::Deep object (see L</SETUP>
above).
my $db = DBM::Deep->new(
This causes DBM::Deep to C<flock()> the underlying filehandle with exclusive
mode for writes, and shared mode for reads. This is required if you have
multiple processes accessing the same database file, to avoid file corruption.
-Please note that C<flock()> does NOT work for files over NFS. See L<DB OVER
+Please note that C<flock()> does NOT work for files over NFS. See L</DB OVER
NFS> below for more.
=head2 Explicit Locking
=head1 TODO
The following are items that are planned to be added in future releases. These
-are separate from the L<CAVEATS, ISSUES & BUGS> below.
+are separate from the L</CAVEATS, ISSUES & BUGS> below.
=head2 Sub-Transactions
using C<lockf()> to lock your files, but your mileage may vary there as well.
From what I understand, there is no real way to do it. However, if you need
access to the underlying filehandle in DBM::Deep for using some other kind of
-locking scheme like C<lockf()>, see the L<LOW-LEVEL ACCESS> section above.
+locking scheme like C<lockf()>, see the L</LOW-LEVEL ACCESS> section above.
=head2 Copying Objects
+++ /dev/null
-package DBM::Deep::Engine::Sector;
-
-use 5.006_000;
-
-use strict;
-use warnings FATAL => 'all';
-
-1;
-__END__
-
-new({
- engine =>
- type =>
- offset =>
-})
- _init( $args )
-staleness
-get_data_for({
- key_md5 =>
- allow_head =>
-})
-get_data_location_for({
- key_md5 =>
- allow_head =>
-})
-write_data({
- key =>
- key_md5 =>
- value => $value_sector,
-})
-size
-get_classname
-delete_key({
- key_md5 =>
- allow_head =>
-})
-get_refcount
+++ /dev/null
-package DBM::Deep::SQL::Array;
-
-use strict;
-use warnings FATAL => 'all';
-
-BEGIN {
- use base 'DBM::Deep::SQL::Util';
-
- use Storable 'nfreeze', 'thaw';
-}
-
-sub _get_self
-{
- eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0];
-}
-
-sub _size
-{
- my ($obj) = @_;
- my $sq = $obj->_select(
- 'table' => 'rec_array_item',
- 'fields' => 'max(pos)',
- 'where' => {
- 'array' => $obj->{'id'},
- },
- );
- if (defined $sq->[0]->[0])
- {
- return $sq->[0]->[0] + 1;
- }
- return 0;
-}
-
-sub _clear
-{
- my ($obj) = @_;
- my $sz = $obj->_size();
- foreach my $i (1..$sz)
- {
- $obj->_delete($i - 1);
- }
- $obj->{'cache'} = [];
-}
-
-sub _delete
-{
- my ($obj, $i) = @_;
- my $q = $obj->_select(
- 'table' => 'rec_array_item',
- 'fields' => ['value_type', 'value_data', 'id'],
- 'where' => {
- 'array' => $obj->{'id'},
- 'pos' => $i,
- },
- );
- if (scalar @$q)
- {
- my $dt = $q->[0]->[0];
- if ($dt eq 'text' || $dt eq 'data')
- {
- $obj->_delete_sql('rec_value_'. $dt, {'id' => $q->[0]->[1]});
- }
- elsif ($dt eq 'hash')
- {
- my $rec = $obj->_tiehash($q->[0]->[1]);
- %$rec = ();
- $obj->_delete_sql('rec_hash', {'id' => $q->[0]->[1]});
- $obj->_delete_sql('rec_item', {'id' => $q->[0]->[1]});
- }
- elsif ($dt eq 'array')
- {
- my $rec = $obj->_tiearray($q->[0]->[1]);
- @$rec = ();
- $obj->_delete_sql('rec_array', {'id' => $q->[0]->[1]});
- $obj->_delete_sql('rec_item', {'id' => $q->[0]->[1]});
- }
- $obj->_delete_sql('rec_array_item', {'id' => $q->[0]->[2]});
- }
- delete $obj->{'cache'}->[$i];
-}
-
-sub _set_cache
-{
- my ($obj, $pos, $val) = @_;
- $obj->{'cache'}->[$pos] = $val;
-}
-
-sub _get_cache
-{
- my ($obj, $pos, $vref) = @_;
- if (exists $obj->{'cache'}->[$pos])
- {
- $$vref = $obj->{'cache'}->[$pos];
- return 1;
- }
- return undef;
-}
-
-sub _exists
-{
- my ($obj, $i) = @_;
- if (exists $obj->{'cache'}->[$i])
- {
- return 1;
- }
- my $c = $obj->_select(
- 'table' => 'rec_array_item',
- 'fields' => 'count(id)',
- 'where' => {
- 'array' => $obj->{'id'},
- 'pos' => $i,
- },
- )->[0]->[0];
- return $c;
-}
-
-sub _data
-{
- my ($obj, $i) = @_;
- my $q = $obj->_select(
- 'table' => 'rec_array_item',
- 'fields' => ['value_type', 'value_data'],
- 'where' => {
- 'array' => $obj->{'id'},
- 'pos' => $i,
- },
- );
- if (scalar @$q)
- {
- my $dt = $q->[0]->[0];
- my $val = $q->[0]->[1];
- if ($dt eq 'value')
- {
- return $val;
- }
- elsif ($dt eq 'text')
- {
- my $dq = $obj->_select(
- 'table' => 'rec_value_text',
- 'fields' => 'data',
- 'where' => {
- 'id' => $val,
- },
- );
- return $dq->[0]->[0];
- }
- elsif ($dt eq 'data')
- {
- my $dq = $obj->_select(
- 'table' => 'rec_value_data',
- 'fields' => 'data',
- 'where' => {
- 'id' => $val,
- },
- );
- if (scalar @$dq)
- {
- my $rec = thaw($dq->[0]->[0]);
- return $rec;
- }
- return undef;
- }
- elsif ($dt eq 'array')
- {
- my $rec = $obj->_tiearray($val);
- if ($obj->{'prefetch'})
- {
- (tied(@$rec))->_prefetch();
- }
- return $rec;
- }
- elsif ($dt eq 'hash')
- {
- my $rec = $obj->_tiehash($val);
- if ($obj->{'prefetch'})
- {
- (tied(%$rec))->_prefetch();
- }
- return $rec;
- }
- }
- return undef;
-}
-
-sub _tiearray
-{
- my ($obj, $id) = @_;
- my $rec = undef;
- tie(@$rec, 'DBM::Deep::SQL::Array', (
- 'dbi' => $obj->{'dbi'},
- 'id' => $id,
- 'prefetch' => $obj->{'prefetch'},
- ));
- bless $rec, 'DBM::Deep::SQL::Array';
- return $rec;
-}
-
-sub _tiehash
-{
- my ($obj, $id) = @_;
- my $rec = undef;
- tie(%$rec, 'DBM::Deep::SQL::Hash', (
- 'dbi' => $obj->{'dbi'},
- 'id' => $id,
- 'prefetch' => $obj->{'prefetch'},
- ));
- bless $rec, 'DBM::Deep::SQL::Hash';
- return $rec;
-}
-
-sub _prefetch
-{
- my ($obj) = @_;
- my $pd = $obj->_select(
- 'table' => 'rec_array_item',
- 'fields' => ['pos', 'value_type', 'value_data'],
- 'where' => {
- 'array' => $obj->{'id'},
- },
- );
- my @data = ();
- my @datapos = ();
- my @text = ();
- my @textpos = ();
- my @array = ();
- foreach my $r (@$pd)
- {
- my $i = $r->[0];
- my $vt = $r->[1];
- my $val = $r->[2];
- if ($vt eq 'value')
- {
- $array[$i] = $val;
- }
- elsif ($vt eq 'text')
- {
- push @textpos, $i;
- push @text, $val;
- }
- elsif ($vt eq 'data')
- {
- push @datapos, $i;
- push @data, $val;
- }
- elsif ($vt eq 'array')
- {
- my $rec = $obj->_tiearray($val);
- if ($obj->{'prefetch'})
- {
- (tied(@$rec))->_prefetch();
- }
- $array[$i] = $rec;
- }
- elsif ($vt eq 'hash')
- {
- my $rec = $obj->_tiehash($val);
- if ($obj->{'prefetch'})
- {
- (tied(@$rec))->_prefetch();
- }
- $array[$i] = $rec;
- }
- }
- if (scalar @text)
- {
- my $ids = join(',', @text);
- my $tq = $obj->_select(
- 'table' => 'rec_value_text',
- 'fields' => ['id', 'data'],
- 'where' => "id in ($ids)",
- );
- my %data = map {$_->[0] => $_->[1]} @$tq;
- foreach my $x (0..$#text)
- {
- my $id = $text[$x];
- my $i = $textpos[$x];
- $array[$i] = $data{$id};
- }
- }
- if (scalar @data)
- {
- my $ids = join(',', @data);
- my $tq = $obj->_select(
- 'table' => 'rec_value_data',
- 'fields' => ['id', 'data'],
- 'where' => "id in ($ids)",
- );
- my %d = map {$_->[0] => $_->[1]} @$tq;
- foreach my $x (0..$#data)
- {
- my $id = $data[$x];
- my $i = $datapos[$x];
- if (defined $d{$id})
- {
- $array[$i] = thaw($d{$id});
- }
- }
- }
- return $obj->{'cache'} = \@array;
-}
-
-sub TIEARRAY
-{
- my $class = shift;
- my %prm = @_;
- my $obj = \%prm;
- $obj->{'cache'} = [];
- bless $obj, $class;
- return $obj;
-}
-
-sub FETCH
-{
- my ($tobj, $i) = @_;
- my $obj = $tobj->_get_self();
- my $val = undef;
- if ($obj->_get_cache($i, \$val))
- {
- return $val;
- }
- $val = $obj->_data($i);
- if (defined $val)
- {
- $obj->_set_cache($i, $val);
- }
- return $val;
-}
-
-sub STORE
-{
- my ($tobj, $i, $val) = @_;
- my $obj = $tobj->_get_self();
- my $dval = $val;
- my $vt;
- $val = '' unless (defined $val);
- if (ref $val)
- {
- my $done = 0;
- unless ($obj->{'serialize'})
- {
- if ($val =~ /HASH/)
- {
- my $id = $obj->_create('hash');
- my $ta = $obj->_tiehash($id);
- $dval = $ta;
- foreach my $k (keys %$val)
- {
- $ta->{$k} = $val->{$k};
- }
- $vt = 'hash';
- $val = $id;
- $done = 1;
- }
- elsif ($val =~ /ARRAY/)
- {
- my $id = $obj->_create('array');
- my $ta = $obj->_tiearray($id);
- $dval = $ta;
- foreach my $i (0..$#{$val})
- {
- $ta->[$i] = $val->[$i];
- }
- $vt = 'array';
- $val = $id;
- $done = 1;
- }
- }
- unless ($done)
- {
- my $data = nfreeze($val);
- $val = $obj->_create('value_data', {
- 'data' => $data,
- });
- $vt = 'data';
- }
- }
- elsif (length($val) > 255)
- {
- $val = $obj->_create('value_text', {
- 'data' => $val,
- });
- $vt = 'text';
- }
- else
- {
- $vt = 'value';
- }
- my $c = $obj->_select(
- 'table' => 'rec_array_item',
- 'fields' => ['value_type', 'id'],
- 'where' => {
- 'array' => $obj->{'id'},
- 'pos' => $i,
- },
- );
- my $create = 1;
- if (scalar @$c)
- {
- if ($c->[0]->[0] eq 'value')
- {
- $create = 0;
- $obj->_update(
- 'table' => 'rec_array_item',
- 'fields' => {
- 'value_type' => $vt,
- 'value_data' => $val,
- },
- 'where' => {
- 'id' => $c->[0]->[1],
- },
- );
- }
- else
- {
- $obj->_delete($i);
- }
- }
- if ($create)
- {
- $obj->_create('array_item', {
- 'array' => $obj->{'id'},
- 'pos' => $i,
- 'value_data' => $val,
- 'value_type' => $vt,
- });
- }
- $obj->_set_cache($i, $dval);
- return $dval;
-}
-
-sub FETCHSIZE
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- return $obj->_size();
-}
-
-sub EXISTS
-{
- my ($tobj, $i) = @_;
- my $obj = $tobj->_get_self();
- return $obj->_exists($i);
-}
-
-sub DELETE
-{
- my ($tobj, $i) = @_;
- my $obj = $tobj->_get_self();
- return $obj->_delete($i);
-}
-
-sub CLEAR
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- return $obj->_clear();
-}
-
-sub PUSH
-{
- my ($tobj, @list) = @_;
- my $obj = $tobj->_get_self();
- my $last = $obj->_size();
- foreach my $i (0..$#list)
- {
- $tobj->STORE($last + $i, $list[$i]);
- }
- return $obj->_size();
-}
-
-sub POP
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- my $top = $obj->_size();
- unless ($top > 0)
- {
- return undef;
- }
- my $val = $obj->_data($top - 1);
- $obj->_delete($top - 1);
- return $val;
-}
-
-sub SHIFT
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- my $top = $obj->_size();
- unless ($top > 0)
- {
- return undef;
- }
- my $val = $obj->_data(0);
- $obj->_delete(0);
- my $sql = 'update rec_array_item set pos=pos-1 where array=? order by pos asc';
- $obj->{'dbi'}->query($sql, $obj->{'id'});
- return $val;
-}
-
-sub UNSHIFT
-{
- my ($tobj, $val) = @_;
- my $obj = $tobj->_get_self();
- my $top = $obj->_size();
- if ($top > 0)
- {
- my $sql = 'update rec_array_item set pos=pos+1 where array=? order by pos desc';
- $obj->{'dbi'}->query($sql, $obj->{'id'});
- }
- return $tobj->STORE(0, $val);
-}
-
-sub EXTEND
-{
- # Not needed
- return;
-}
-
-sub SPLICE
-{
- my ($tobj, $offset, $len, @list) = @_;
- my $obj = $tobj->_get_self();
- my $cache = $obj->{'cache'};
- $obj->{'cache'} = [];
- unless (defined $offset)
- {
- $offset = 0;
- }
- if (length($offset) < 0)
- {
- die('Splice with negative offset not supported'); # TODO
- }
- unless (defined $len)
- {
- $len = $obj->_size() - $offset;
- }
- if (length($len) < 0)
- {
- die('Splice with negative length not supported'); # TODO
- }
- if ($offset < $#{$cache} || $offset == 0)
- {
- splice(@$cache, $offset, $len, @list);
- }
- else
- {
- $cache = [];
- }
- my $lc = (wantarray) ? 1 : 0;
- my @res = ();
- if ($len > 0)
- {
- foreach my $i (0..($len - 1))
- {
- my $k = $offset + $i;
- if ($lc || $i == ($len - 1))
- {
- my $rc = $tobj->FETCH($k);
- my $cl = $obj->_clone_tree($rc);
- push @res, $cl;
- }
- $obj->_delete($k);
- }
- }
- my $elems = scalar @list;
- my $diff = $elems - $len;
- if ($elems > 0 || $diff < 0)
- {
- my $st = $offset + $len - 1;
- my $dir = ($diff > 0) ? 'desc' : 'asc';
- my $sql = 'update rec_array_item set pos=pos+? where array=? and pos > ? order by pos '. $dir;
- $obj->{'dbi'}->query($sql, $diff, $obj->{'id'}, $st);
- foreach my $i (0..$#list)
- {
- $tobj->STORE($offset + $i, $list[$i]);
- }
- }
- $obj->{'cache'} = $cache;
- if ($lc)
- {
- return @res;
- }
- else
- {
- return $res[0];
- }
-}
-
-sub id
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- return $obj->{'id'};
-}
-
-1;
-
+++ /dev/null
-package DBM::Deep::SQL::Hash;
-
-use strict;
-use warnings FATAL => 'all';
-
-BEGIN {
- use base 'DBM::Deep::SQL::Util';
-
- use Digest::MD5 'md5_base64';
- use Storable 'nfreeze', 'thaw';
-}
-
-sub _get_self
-{
- eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0];
-}
-
-sub _clear
-{
- my ($obj) = @_;
- my $ks = $obj->_get_keys();
- foreach my $k (@$ks)
- {
- $obj->_delete($k);
- }
- $obj->{'cache'} = {};
-}
-
-sub _get_keys
-{
- my ($obj) = @_;
- if (exists $obj->{'keys'})
- {
- my @ks = keys %{$obj->{'keys'}};
- return (wantarray()) ? @ks : \@ks;
- }
- my $q = $obj->_select(
- 'table' => 'rec_hash_item',
- 'fields' => ['key_type', 'key_data'],
- 'where' => {
- 'hash' => $obj->{'id'},
- },
- );
- my @textkey = ();
- my @textkeypos = ();
- my $kcache = $obj->{'keys'} = {};
- my @ks = ();
- foreach my $i (0..$#{$q})
- {
- my $row = $q->[$i];
- my $kt = $row->[0];
- my $k = $row->[1];
- if ($kt eq 'text')
- {
- push @ks, undef;
- push @textkey, $k;
- push @textkeypos, $i;
- }
- else
- {
- push @ks, $k;
- $kcache->{$k} = undef;
- }
- }
- if (scalar @textkey)
- {
- my $ids = join(',', @textkey);
- my $tq = $obj->_select(
- 'table' => 'rec_value_text',
- 'fields' => ['id', 'data'],
- 'where' => "id in ($ids)",
- );
- my %data = map {$_->[0] => $_->[1]} @$tq;
- foreach my $x (0..$#textkey)
- {
- my $id = $textkey[$x];
- my $i = $textkeypos[$x];
- my $nk = $data{$id};
- $ks[$i] = $nk;
- $kcache->{$nk} = undef;
- }
- }
- return (wantarray()) ? @ks : \@ks;
-}
-
-sub _delete
-{
- my ($obj, $k) = @_;
- my $hcode = md5_base64($k);
- my $q = $obj->_select(
- 'table' => 'rec_hash_item',
- 'fields' => ['value_type', 'value_data', 'id', 'key_type', 'key_data'],
- 'where' => {
- 'hash' => $obj->{'id'},
- 'key_hash' => $hcode,
- },
- );
- if (scalar @$q)
- {
- my $kt = $q->[0]->[3];
- if ($kt eq 'text')
- {
- $obj->_delete_sql('rec_value_text', {'id' => $q->[0]->[4]});
- }
- my $dt = $q->[0]->[0];
- if ($dt eq 'text' || $dt eq 'data')
- {
- $obj->_delete_sql('rec_value_'. $dt, {'id' => $q->[0]->[1]});
- }
- elsif ($dt eq 'hash')
- {
- my $rec = $obj->_tiehash($q->[0]->[1]);
- %$rec = ();
- $obj->_delete_sql('rec_hash', {'id' => $q->[0]->[1]});
- $obj->_delete_sql('rec_item', {'id' => $q->[0]->[1]});
- }
- elsif ($dt eq 'array')
- {
- my $rec = $obj->_tiearray($q->[0]->[1]);
- @$rec = ();
- $obj->_delete_sql('rec_array', {'id' => $q->[0]->[1]});
- $obj->_delete_sql('rec_item', {'id' => $q->[0]->[1]});
- }
- $obj->_delete_sql('rec_hash_item', {'id' => $q->[0]->[2]});
- }
- delete $obj->{'cache'}->{$k};
- if (exists $obj->{'keys'})
- {
- delete $obj->{'keys'}->{$k};
- }
-}
-
-sub _set_cache
-{
- my ($obj, $k, $val) = @_;
- $obj->{'cache'}->{$k} = $val;
- if (exists $obj->{'keys'})
- {
- $obj->{'keys'}->{$k} = undef;
- }
-}
-
-sub _get_cache
-{
- my ($obj, $k, $vref) = @_;
- if (exists $obj->{'cache'}->{$k})
- {
- $$vref = $obj->{'cache'}->{$k};
- return 1;
- }
- return undef;
-}
-
-sub _exists
-{
- my ($obj, $k) = @_;
- if (exists $obj->{'cache'}->{$k})
- {
- return 1;
- }
- my $hcode = md5_base64($k);
- my $c = $obj->_select(
- 'table' => 'rec_hash_item',
- 'fields' => 'count(id)',
- 'where' => {
- 'hash' => $obj->{'id'},
- 'key_hash' => $hcode,
- },
- )->[0]->[0];
- return $c;
-}
-
-sub _data
-{
- my ($obj, $k) = @_;
- my $hcode = md5_base64($k);
- my $q = $obj->_select(
- 'table' => 'rec_hash_item',
- 'fields' => ['value_type', 'value_data'],
- 'where' => {
- 'hash' => $obj->{'id'},
- 'key_hash' => $hcode,
- },
- );
- if (scalar @$q)
- {
- my $dt = $q->[0]->[0];
- my $val = $q->[0]->[1];
- if ($dt eq 'value')
- {
- return $val;
- }
- elsif ($dt eq 'text')
- {
- my $dq = $obj->_select(
- 'table' => 'rec_value_text',
- 'fields' => 'data',
- 'where' => {
- 'id' => $val,
- },
- );
- return $dq->[0]->[0];
- }
- elsif ($dt eq 'data')
- {
- my $dq = $obj->_select(
- 'table' => 'rec_value_data',
- 'fields' => 'data',
- 'where' => {
- 'id' => $val,
- },
- );
- if (scalar @$dq)
- {
- my $rec = thaw($dq->[0]->[0]);
- return $rec;
- }
- return undef;
- }
- elsif ($dt eq 'array')
- {
- my $rec = $obj->_tiearray($val);
- if ($obj->{'prefetch'})
- {
- (tied(@$rec))->_prefetch();
- }
- return $rec;
- }
- elsif ($dt eq 'hash')
- {
- my $rec = $obj->_tiehash($val);
- if ($obj->{'prefetch'})
- {
- (tied(%$rec))->_prefetch();
- }
- return $rec;
- }
- }
- return undef;
-}
-
-sub _prefetch
-{
- my ($obj) = @_;
- my $pd = $obj->_select(
- 'table' => 'rec_hash_item',
- 'fields' => ['key_type', 'key_data', 'value_type', 'value_data'],
- 'where' => {
- 'hash' => $obj->{'id'},
- },
- );
- my @data = ();
- my @datapos = ();
- my @text = ();
- my @textpos = ();
- my %hash = ();
- my @textkey = ();
- my @textkeypos = ();
- foreach my $i (0..$#{$pd})
- {
- my $row = $pd->[$i];
- my $kt = $row->[0];
- my $k = $row->[1];
- if ($kt eq 'text')
- {
- push @textkey, $k;
- push @textkeypos, $i;
- }
- }
- if (scalar @textkey)
- {
- my $ids = join(',', @textkey);
- my $tq = $obj->_select(
- 'table' => 'rec_value_text',
- 'fields' => ['id', 'data'],
- 'where' => "id in ($ids)",
- );
- my %data = map {$_->[0] => $_->[1]} @$tq;
- foreach my $x (0..$#textkey)
- {
- my $id = $textkey[$x];
- my $i = $textkeypos[$x];
- $pd->[$i]->[1] = $data{$id};
- }
- }
- foreach my $r (@$pd)
- {
- my $k = $r->[1];
- my $vt = $r->[2];
- my $val = $r->[3];
- if ($vt eq 'value')
- {
- $hash{$k} = $val;
- }
- elsif ($vt eq 'text')
- {
- push @textpos, $k;
- push @text, $val;
- }
- elsif ($vt eq 'value')
- {
- push @datapos, $k;
- push @data, $val;
- }
- elsif ($vt eq 'array')
- {
- my $rec = $obj->_tiearray($val);
- if ($obj->{'prefetch'})
- {
- (tied(@$rec))->_prefetch();
- }
- $hash{$k} = $rec;
- }
- elsif ($vt eq 'hash')
- {
- my $rec = $obj->_tiehash($val);
- if ($obj->{'prefetch'})
- {
- (tied(@$rec))->_prefetch();
- }
- $hash{$k} = $rec;
- }
- }
- if (scalar @text)
- {
- my $ids = join(',', @text);
- my $tq = $obj->_select(
- 'table' => 'rec_value_text',
- 'fields' => ['id', 'data'],
- 'where' => "id in ($ids)",
- );
- my %data = map {$_->[0] => $_->[1]} @$tq;
- foreach my $x (0..$#text)
- {
- my $id = $text[$x];
- my $k = $textpos[$x];
- $hash{$k} = $data{$id};
- }
- }
- if (scalar @data)
- {
- my $ids = join(',', @data);
- my $tq = $obj->_select(
- 'table' => 'rec_value_data',
- 'fields' => ['id', 'data'],
- 'where' => "id in ($ids)",
- );
- my %d = map {$_->[0] => $_->[1]} @$tq;
- foreach my $x (0..$#data)
- {
- my $id = $data[$x];
- my $k = $datapos[$x];
- if (defined $d{$id})
- {
- $hash{$k} = thaw($d{$id});
- }
- }
- }
- return $obj->{'cache'} = \%hash;
-}
-
-sub TIEHASH
-{
- my $class = shift;
- my %prm = @_;
- my $obj = \%prm;
- $obj->{'sort'} = 1;
- $obj->{'cache'} = {};
- bless $obj, $class;
- return $obj;
-}
-
-sub FETCH
-{
- my ($tobj, $k) = @_;
- my $obj = $tobj->_get_self();
- my $val = undef;
- if ($obj->_get_cache($k, \$val))
- {
- return $val;
- }
- $val = $obj->_data($k);
- if (defined $val)
- {
- $obj->_set_cache($k, $val);
- }
- return $val;
-}
-
-sub STORE
-{
- my ($tobj, $k, $val) = @_;
- my $dval = $val;
- my $obj = $tobj->_get_self();
- my $vt;
- $val = '' unless (defined $val);
- if (ref $val) {
- my $done = 0;
- unless ($obj->{'serialize'}) {
- if ($val =~ /HASH/) {
- my $id = $obj->_create('hash');
- my $ta = $obj->_tiehash($id);
- $dval = $ta;
- foreach my $k (keys %$val) {
- $ta->{$k} = $val->{$k};
- }
- $vt = 'hash';
- $val = $id;
- $done = 1;
- }
- elsif ($val =~ /ARRAY/) {
- my $id = $obj->_create('array');
- my $ta = $obj->_tiearray($id);
- $dval = $ta;
- foreach my $i (0..$#{$val}) {
- $ta->[$i] = $val->[$i];
- }
- $vt = 'array';
- $val = $id;
- $done = 1;
- }
- }
- unless ($done) {
- my $data = nfreeze($val);
- $val = $obj->_create('value_data', {
- 'data' => $data,
- });
- $vt = 'data';
- }
- }
- elsif (length($val) > 255) {
- $val = $obj->_create('value_data', {
- 'data' => $val,
- });
- $vt = 'text';
- }
- else {
- $vt = 'value';
- }
- my $hcode = md5_base64($k);
- my $c = $obj->_select(
- 'table' => 'rec_hash_item',
- 'fields' => ['value_type', 'id'],
- 'where' => {
- 'hash' => $obj->{'id'},
- 'key_hash' => $hcode,
- },
- );
- my $create = 1;
- if (scalar @$c) {
- if ($c->[0]->[0] eq 'value') {
- $create = 0;
- $obj->_update(
- 'table' => 'rec_hash_item',
- 'fields' => {
- 'value_type' => $vt,
- 'value_data' => $val,
- },
- 'where' => {
- 'id' => $c->[0]->[1],
- },
- );
- }
- else {
- $obj->_delete($k);
- }
- }
- if ($create) {
- my $kt;
- if (length($k) > 255) {
- $k = $obj->_create('value_text', {
- 'data' => $k,
- });
- $kt = 'text';
- }
- else {
- $kt = 'value';
- }
- $obj->_create('hash_item', {
- 'hash' => $obj->{'id'},
- 'key_hash' => $hcode,
- 'key_data' => $k,
- 'key_type' => $kt,
- 'value_data' => $val,
- 'value_type' => $vt,
- });
- }
- $obj->_set_cache($k, $dval);
- return $dval;
-}
-
-sub EXISTS
-{
- my ($tobj, $k) = @_;
- my $obj = $tobj->_get_self();
- $k = '' unless defined ($k);
- return $obj->_exists($k);
-}
-
-sub DELETE
-{
- my ($tobj, $i) = @_;
- my $obj = $tobj->_get_self();
- $obj->_delete($i);
-}
-
-sub CLEAR
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- $obj->_clear();
-}
-
-sub FIRSTKEY
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- if ($obj->{'sort'})
- {
- $obj->{'keys_sorted'} = [sort $obj->_get_keys()];
- return shift @{$obj->{'keys_sorted'}};
- }
- else
- {
- $obj->_get_keys();
- return each %{$obj->{'keys'}};
- }
-}
-
-sub NEXTKEY
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- if ($obj->{'sort'} && exists $obj->{'keys_sorted'})
- {
- return shift @{$obj->{'keys_sorted'}};
- }
- else
- {
- return each %{$obj->{'keys'}};
- }
-}
-
-sub SCALAR
-{
- # TODO
-}
-
-sub id
-{
- my ($tobj) = @_;
- my $obj = $tobj->_get_self();
- return $obj->{'id'};
-}
-
-1;
-
+++ /dev/null
-package DBM::Deep::SQL::Util;
-
-use strict;
-use warnings FATAL => 'all';
-
-sub _create {
- my ($obj, $type, $data) = @_;
- if ($type eq 'hash' || $type eq 'array') {
- $obj->_insert(
- 'table' => 'rec_item',
- 'fields' => {
- 'item_type' => $type,
- },
- );
- my $id = $obj->_lastid();
- $obj->_insert(
- 'table' => 'rec_'. $type,
- 'fields' => {
- 'id' => $id,
- },
- );
- return $id;
- }
- else {
- $obj->_insert(
- 'table' => 'rec_'. $type,
- 'fields' => $data,
- );
- return $obj->_lastid();
- }
-}
-
-sub _lastid {
- my ($obj) = @_;
- my $sth = $obj->{'dbi'}->query('select last_insert_id()');
- my $q = $sth->fetchall_arrayref();
- return $q->[0]->[0];
-}
-
-sub _select {
- my ($obj, @arg) = @_;
- my %prm = @arg;
- my $sth = $obj->{'dbi'}->select(\%prm);
- return $sth->fetchall_arrayref();
-}
-
-sub _insert {
- my ($obj, @arg) = @_;
- my %prm = @arg;
- return $obj->{'dbi'}->insert(\%prm);
-}
-
-sub _update {
- my ($obj, @arg) = @_;
- my %prm = @arg;
- return $obj->{'dbi'}->update(\%prm);
-}
-
-sub _delete_sql {
- my ($obj, $table, $where) = @_;
- return $obj->{'dbi'}->delete($table, $where);
-}
-
-sub _clone_tree {
- my ($obj, $data) = @_;
- if (ref($data)) {
- if ($data =~ /HASH/) {
- my %nv = ();
- foreach my $k (keys %$data) {
- $nv{$k} = $obj->_clone_tree($data->{$k});
- }
- return \%nv;
- }
- elsif ($data =~ /ARRAY/) {
- my @nv = ();
- foreach my $i (0..$#{$data}) {
- $nv[$i] = $obj->_clone_tree($data->[$i]);
- }
- return \@nv;
- }
- elsif ($data =~ /SCALAR/) {
- my $nv = $obj->_clone_tree($$data);
- return \$nv;
- }
- }
- else {
- my $nv = $data;
- return $nv;
- }
-}
-
-sub _tiearray {
- my ($obj, $id) = @_;
- my $rec = undef;
- tie(@$rec, 'DBM::Deep::SQL::Array', (
- 'dbi' => $obj->{'dbi'},
- 'id' => $id,
- 'prefetch' => $obj->{'prefetch'},
- ));
- bless $rec, 'DBM::Deep::SQL::Array';
- return $rec;
-}
-
-sub _tiehash {
- my ($obj, $id) = @_;
- my $rec = undef;
- tie(%$rec, 'DBM::Deep::SQL::Hash', (
- 'dbi' => $obj->{'dbi'},
- 'id' => $id,
- 'prefetch' => $obj->{'prefetch'},
- ));
- bless $rec, 'DBM::Deep::SQL::Hash';
- return $rec;
-}
-
-1;
-__END__
if ( $ENV{TEST_MYSQL_DSN} ) {
push @reset_funcs, sub {
my $dbh = DBI->connect(
- "dbi:mysql:$ENV{TEST_MYSQL_DSN}",
+ $ENV{TEST_MYSQL_DSN},
$ENV{TEST_MYSQL_USER},
$ENV{TEST_MYSQL_PASS},
);
};
push @extra_args, [
dbi => {
- dsn => "dbi:mysql:$ENV{TEST_MYSQL_DSN}",
+ dsn => $ENV{TEST_MYSQL_DSN},
user => $ENV{TEST_MYSQL_USER},
password => $ENV{TEST_MYSQL_PASS},
},
projects / dbsrgits/DBM-Deep.git / commitdiff