From: Rob Kinyon Date: Fri, 1 Jan 2010 02:50:53 +0000 (-0500) Subject: Getting everything ready for release of 1.0019_001 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=67e9b86f22e8dacf29904f0163be3b23fae91074;p=dbsrgits%2FDBM-Deep.git Getting everything ready for release of 1.0019_001 --- diff --git a/Build.PL b/Build.PL index d811d78..d5e0f76 100644 --- a/Build.PL +++ b/Build.PL @@ -1,8 +1,27 @@ 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 => { @@ -11,10 +30,6 @@ my $build = Module::Build->new( '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', @@ -30,6 +45,36 @@ my $build = Module::Build->new( '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; diff --git a/Changes b/Changes index 8971f15..9253f60 100644 --- a/Changes +++ b/Changes @@ -1,7 +1,23 @@ 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) diff --git a/MANIFEST b/MANIFEST index 56d1b9d..a7745fe 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5,20 +5,30 @@ lib/DBM/Deep.pod 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 @@ -80,6 +90,7 @@ t/etc/db-0-983 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 diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 1ae5d39..b595076 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -5,17 +5,13 @@ use 5.006_000; 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; diff --git a/lib/DBM/Deep.pod b/lib/DBM/Deep.pod index 6d0a263..6970168 100644 --- a/lib/DBM/Deep.pod +++ b/lib/DBM/Deep.pod @@ -45,11 +45,114 @@ Windows. =head1 VERSION DIFFERENCES +B: 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 for more information. + B: 1.0000 has significant file format differences from prior versions. THere is a backwards-compatibility layer at C. Files created by 1.0000 or higher are B 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 that use the same DB file. This is an +optional parameter, and defaults to 1 (enabled). See L 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. + +=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 takes. + +=back + +B: 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 @@ -65,7 +168,7 @@ method, which gets you a blessed I tied hash (or array) reference. 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 below). +hash, unless otherwise specified (see L 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): @@ -79,7 +182,7 @@ locking, autoflush, etc. This is done by passing an inline hash (or hashref): Notice that the filename is now specified I 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 below for the complete list. +See L below for the complete list. You can also start with an array instead of a hash. For this, you must specify the C parameter: @@ -108,7 +211,7 @@ variable at any time using tied() - please see L for more info. 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 just below for the +a hash containing one or more options (see L just below for the complete list). tie %hash, "DBM::Deep", { @@ -124,31 +227,6 @@ DBM::Deep objects. These apply to both the OO- and tie- based approaches. =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 @@ -165,15 +243,6 @@ one of these two constants: This only takes effect when beginning a new file. This is an optional parameter, and defaults to C<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 that use the same DB file. This is an -optional parameter, and defaults to 1 (enabled). See L below for -more. - =item * autoflush Specifies whether autoflush is to be enabled on the underlying filehandle. @@ -259,7 +328,7 @@ With DBM::Deep you can access your databases using Perl's standard hash/array syntax. Because all DBM::Deep objects are I 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 section above. This simply tells you how to use DBM::Deep +L section above. This simply tells you how to use DBM::Deep using regular hashes and arrays, rather than calling functions like C and C (although those work too). It is entirely up to you how to want to access your databases. @@ -393,8 +462,8 @@ q.v. L for more info. 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 is called. +extending the size of the datafile. But, that freespace just sits in the +datafile unless C is called. =item * import() @@ -500,7 +569,7 @@ Returns undef if array is empty. Returns the element value. 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 below for +method is not recommended with large arrays -- see L below for details. my $elem = $db->shift(); @@ -518,7 +587,7 @@ No return value. This method is not recommended with large arrays -- see Performs exactly like Perl's built-in function of the same name. See L for usage -- it is too complicated to document here. This method is -not recommended with large arrays -- see L below for details. +not recommended with large arrays -- see L below for details. =back @@ -549,7 +618,7 @@ Here are some examples of using arrays: =head1 LOCKING Enable or disable automatic file locking by passing a boolean value to the -C parameter when constructing your DBM::Deep object (see L +C parameter when constructing your DBM::Deep object (see L above). my $db = DBM::Deep->new( @@ -560,7 +629,7 @@ above). This causes DBM::Deep to C 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 does NOT work for files over NFS. See L does NOT work for files over NFS. See L below for more. =head2 Explicit Locking @@ -860,7 +929,7 @@ of every version prior to the current version. =head1 TODO The following are items that are planned to be added in future releases. These -are separate from the L below. +are separate from the L below. =head2 Sub-Transactions @@ -981,7 +1050,7 @@ NFS. I've heard about setting up your NFS server with a locking daemon, then using C 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, see the L section above. +locking scheme like C, see the L section above. =head2 Copying Objects diff --git a/lib/DBM/Deep/Engine/Sector.pm b/lib/DBM/Deep/Engine/Sector.pm deleted file mode 100644 index 9bbf29c..0000000 --- a/lib/DBM/Deep/Engine/Sector.pm +++ /dev/null @@ -1,37 +0,0 @@ -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 diff --git a/lib/DBM/Deep/SQL/Array.pm b/lib/DBM/Deep/SQL/Array.pm deleted file mode 100644 index 9afd8b1..0000000 --- a/lib/DBM/Deep/SQL/Array.pm +++ /dev/null @@ -1,598 +0,0 @@ -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; - diff --git a/lib/DBM/Deep/SQL/Hash.pm b/lib/DBM/Deep/SQL/Hash.pm deleted file mode 100644 index 7eddf0f..0000000 --- a/lib/DBM/Deep/SQL/Hash.pm +++ /dev/null @@ -1,557 +0,0 @@ -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; - diff --git a/lib/DBM/Deep/SQL/Util.pm b/lib/DBM/Deep/SQL/Util.pm deleted file mode 100644 index 6f7f043..0000000 --- a/lib/DBM/Deep/SQL/Util.pm +++ /dev/null @@ -1,117 +0,0 @@ -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__ diff --git a/t/common.pm b/t/common.pm index f34c900..0103885 100644 --- a/t/common.pm +++ b/t/common.pm @@ -49,7 +49,7 @@ sub new_dbm { 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}, ); @@ -66,7 +66,7 @@ sub new_dbm { }; 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}, },