From: Rob Kinyon Date: Thu, 26 Nov 2009 04:34:35 +0000 (-0500) Subject: Added files and deps for SQL backend. THIS STILL NEEDS LOTS OF WORK AND WILL LIKELY... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4f0f6fff0474a896cad8bbb80d8c0ccce3d87bf9;p=dbsrgits%2FDBM-Deep.git Added files and deps for SQL backend. THIS STILL NEEDS LOTS OF WORK AND WILL LIKELY CHANGE DRAMATICALLY BEFORE RELEASE TO CPAN. --- diff --git a/Build.PL b/Build.PL index bccfd26..e020412 100644 --- a/Build.PL +++ b/Build.PL @@ -11,6 +11,10 @@ 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', diff --git a/Changes b/Changes index 794c0e6..8971f15 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for DBM::Deep. +1.0015 Nov 22 20:00:00 2009 EST + - DBM::Deep::SQL added + 1.0014 Jun 13 23:15:00 2008 EST - (This version is compatible with 1.0013) - Fix for RT#36781 (t/44 has an unrequired dependency) diff --git a/etc/mysql_tables.sql b/etc/mysql_tables.sql new file mode 100644 index 0000000..7a402a9 --- /dev/null +++ b/etc/mysql_tables.sql @@ -0,0 +1,50 @@ +CREATE TABLE `rec_array` ( + `id` bigint(20) unsigned NOT NULL, + PRIMARY KEY (`id`) +); + +CREATE TABLE `rec_array_item` ( + `id` bigint(20) unsigned NOT NULL AUTO_INCREMENT, + `array` bigint(20) NOT NULL, + `pos` bigint(20) NOT NULL, + `value_data` varchar(255) DEFAULT NULL, + `value_type` enum('array','data','hash','text','value') NOT NULL DEFAULT 'value', + PRIMARY KEY (`id`), + UNIQUE KEY `array_2` (`array`,`pos`), +); + +CREATE TABLE `rec_hash` ( + `id` bigint(20) unsigned NOT NULL, + PRIMARY KEY (`id`) +); + +CREATE TABLE `rec_hash_item` ( + `id` bigint(20) unsigned NOT NULL AUTO_INCREMENT, + `hash` bigint(20) NOT NULL, + `key_data` varchar(255) DEFAULT NULL, + `key_hash` varchar(22) NOT NULL, + `key_type` enum('text','value') NOT NULL DEFAULT 'value', + `value_data` varchar(255) DEFAULT NULL, + `value_type` enum('array','data','hash','text','value') NOT NULL DEFAULT 'value', + PRIMARY KEY (`id`), + UNIQUE KEY `hash_2` (`hash`,`key_hash`), +); + +CREATE TABLE `rec_item` ( + `id` bigint(20) NOT NULL AUTO_INCREMENT, + `item_type` enum('array','hash') NOT NULL DEFAULT 'hash', + PRIMARY KEY (`id`) +); + +CREATE TABLE `rec_value_data` ( + `id` bigint(20) unsigned NOT NULL AUTO_INCREMENT, + `data` longblob NOT NULL, + PRIMARY KEY (`id`) +); + +CREATE TABLE `rec_value_text` ( + `id` bigint(20) unsigned NOT NULL AUTO_INCREMENT, + `data` longtext NOT NULL, + PRIMARY KEY (`id`) +); + diff --git a/etc/sql_example.pl b/etc/sql_example.pl new file mode 100755 index 0000000..1eb3c21 --- /dev/null +++ b/etc/sql_example.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use DBM::Deep; +use Data::Dumper; + +my $hash = new DBM::Deep( + 'dbi' => { + 'dsn' => 'DBI:mysql:database=perl;host=localhost', + 'user' => 'perl', + 'password' => '2A7Qcmh5CBQvLGUu', + }, + 'id' => 20, +); + +print Dumper( + $hash, + $hash->id(), +); + +my $array = new DBM::Deep( + 'dbi' => { + 'dsn' => 'DBI:mysql:database=perl;host=localhost', + 'user' => 'perl', + 'password' => '2A7Qcmh5CBQvLGUu', + }, + 'type' => DBM::Deep->TYPE_ARRAY, + 'id' => 21, +); + +print Dumper( + $array, + $array->id(), +); + diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 6a4a2c3..1d0ea6a 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -13,6 +13,10 @@ use Scalar::Util (); use DBM::Deep::Engine; use DBM::Deep::File; +use DBM::Deep::SQL::Util; +use DBM::Deep::SQL::Array; +use DBM::Deep::SQL::Hash; + use overload '""' => sub { overload::StrVal( $_[0] ) }, fallback => 1; @@ -57,11 +61,76 @@ sub new { ## my $class = shift; my $args = $class->_get_args( @_ ); + my $self; + + ## + # Check for SQL storage + ## + if (exists $args->{dbi}) { + eval { + require DBIx::Abstract; + }; if ( $@ ) { + DBM::Deep->_throw_error('DBIx::Abstract not installed. You cannot use the SQL mode.'); + } + unless (UNIVERSAL::isa($args->{dbi}, 'DBIx::Abstract')) { + $args->{dbi} = DBIx::Abstract->connect($args->{dbi}); + } + + if (defined $args->{id}) { + unless ($args->{id} =~ /^\d+$/ && $args->{id} > 0) { + DBM::Deep->_throw_error('Invalid SQL record id'); + } + my $util = {dbi => $args->{dbi}}; + bless $util, 'DBM::Deep::SQL::Util'; + my $q = $util->_select( + table => 'rec_item', + fields => 'item_type', + where => {id => $args->{id}}, + ); + if ($q->[0]->[0] eq 'array') { + $args->{type} = TYPE_ARRAY; + } + elsif ($q->[0]->[0] eq 'hash') { + $args->{type} = TYPE_HASH; + } + else { + DBM::Deep->_throw_error('Unknown SQL record id'); + } + } + else { + my $util = {dbi => $args->{dbi}}; + bless $util, 'DBM::Deep::SQL::Util'; + if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { + $args->{id} = $util->_create('array'); + } + else { + $args->{id} = $util->_create('hash'); + } + } + + if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { + $class = 'DBM::Deep::SQL::Array'; + require DBM::Deep::SQL::Array; + tie @$self, $class, %$args; + if ($args->{prefetch}) { + (tied(@$self))->_prefetch(); + } + return bless $self, $class; + } + else { + $class = 'DBM::Deep::SQL::Hash'; + require DBM::Deep::SQL::Hash; + tie %$self, $class, %$args; + if ($args->{prefetch}) { + (tied(%$self))->_prefetch(); + } + return bless $self, $class; + } + } ## # Check if we want a tied hash or array. ## - my $self; if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { $class = 'DBM::Deep::Array'; require DBM::Deep::Array; @@ -494,7 +563,7 @@ sub STORE { $value = $self->_engine->storage->{filter_store_value}->( $value ); } - my $x = $self->_engine->write_value( $self, $key, $value); + $self->_engine->write_value( $self, $key, $value); $self->unlock; diff --git a/lib/DBM/Deep/SQL/Array.pm b/lib/DBM/Deep/SQL/Array.pm new file mode 100644 index 0000000..9afd8b1 --- /dev/null +++ b/lib/DBM/Deep/SQL/Array.pm @@ -0,0 +1,598 @@ +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 new file mode 100644 index 0000000..ee3d59e --- /dev/null +++ b/lib/DBM/Deep/SQL/Hash.pm @@ -0,0 +1,572 @@ +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 new file mode 100644 index 0000000..6f7f043 --- /dev/null +++ b/lib/DBM/Deep/SQL/Util.pm @@ -0,0 +1,117 @@ +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__