'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',
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)
--- /dev/null
+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`)
+);
+
--- /dev/null
+#!/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(),
+);
+
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;
##
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;
$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;
--- /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__
projects / dbsrgits/DBM-Deep.git / commitdiff