lib/DBM/Deep/SQL/Hash.pm

   1 package DBM::Deep::SQL::Hash;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 BEGIN {
   7         use base 'DBM::Deep::SQL::Util';
   8
   9         use Digest::MD5 'md5_base64';
  10         use Storable 'nfreeze', 'thaw';
  11 }
  12
  13 sub _get_self
  14 {
  15         eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0];
  16 }
  17
  18 sub _clear
  19 {
  20         my ($obj) = @_;
  21         my $ks = $obj->_get_keys();
  22         foreach my $k (@$ks)
  23         {
  24                 $obj->_delete($k);
  25         }
  26         $obj->{'cache'} = {};
  27 }
  28
  29 sub _get_keys
  30 {
  31         my ($obj) = @_;
  32         if (exists $obj->{'keys'})
  33         {
  34                 my @ks = keys %{$obj->{'keys'}};
  35                 return (wantarray()) ? @ks : \@ks;
  36         }
  37         my $q = $obj->_select(
  38                 'table' => 'rec_hash_item',
  39                 'fields' => ['key_type', 'key_data'],
  40                 'where' => {
  41                         'hash' => $obj->{'id'},
  42                 },
  43         );
  44         my @textkey = ();
  45         my @textkeypos = ();
  46         my $kcache = $obj->{'keys'} = {};
  47         my @ks = ();
  48         foreach my $i (0..$#{$q})
  49         {
  50                 my $row = $q->[$i];
  51                 my $kt = $row->[0];
  52                 my $k = $row->[1];
  53                 if ($kt eq 'text')
  54                 {
  55                         push @ks, undef;
  56                         push @textkey, $k;
  57                         push @textkeypos, $i;
  58                 }
  59                 else
  60                 {
  61                         push @ks, $k;
  62                         $kcache->{$k} = undef;
  63                 }
  64         }
  65         if (scalar @textkey)
  66         {
  67                 my $ids = join(',', @textkey);
  68                 my $tq = $obj->_select(
  69                         'table' => 'rec_value_text',
  70                         'fields' => ['id', 'data'],
  71                         'where' => "id in ($ids)",
  72                 );
  73                 my %data = map {$_->[0] => $_->[1]} @$tq;
  74                 foreach my $x (0..$#textkey)
  75                 {
  76                         my $id = $textkey[$x];
  77                         my $i = $textkeypos[$x];
  78                         my $nk = $data{$id};
  79                         $ks[$i] = $nk;
  80                         $kcache->{$nk} = undef;
  81                 }
  82         }
  83         return (wantarray()) ? @ks : \@ks;
  84 }
  85
  86 sub _delete
  87 {
  88         my ($obj, $k) = @_;
  89         my $hcode = md5_base64($k);
  90         my $q = $obj->_select(
  91                 'table' => 'rec_hash_item',
  92                 'fields' => ['value_type', 'value_data', 'id', 'key_type', 'key_data'],
  93                 'where' => {
  94                         'hash' => $obj->{'id'},
  95                         'key_hash' => $hcode,
  96                 },
  97         );
  98         if (scalar @$q)
  99         {
 100                 my $kt = $q->[0]->[3];
 101                 if ($kt eq 'text')
 102                 {
 103                         $obj->_delete_sql('rec_value_text', {'id' => $q->[0]->[4]});
 104                 }
 105                 my $dt = $q->[0]->[0];
 106                 if ($dt eq 'text' || $dt eq 'data')
 107                 {
 108                         $obj->_delete_sql('rec_value_'. $dt, {'id' => $q->[0]->[1]});
 109                 }
 110                 elsif ($dt eq 'hash')
 111                 {
 112                         my $rec = $obj->_tiehash($q->[0]->[1]);
 113                         %$rec = ();
 114                         $obj->_delete_sql('rec_hash', {'id' => $q->[0]->[1]});
 115                         $obj->_delete_sql('rec_item', {'id' => $q->[0]->[1]});
 116                 }
 117                 elsif ($dt eq 'array')
 118                 {
 119                         my $rec = $obj->_tiearray($q->[0]->[1]);
 120                         @$rec = ();
 121                         $obj->_delete_sql('rec_array', {'id' => $q->[0]->[1]});
 122                         $obj->_delete_sql('rec_item', {'id' => $q->[0]->[1]});
 123                 }
 124                 $obj->_delete_sql('rec_hash_item', {'id' => $q->[0]->[2]});
 125         }
 126         delete $obj->{'cache'}->{$k};
 127         if (exists $obj->{'keys'})
 128         {
 129                 delete $obj->{'keys'}->{$k};
 130         }
 131 }
 132
 133 sub _set_cache
 134 {
 135         my ($obj, $k, $val) = @_;
 136         $obj->{'cache'}->{$k} = $val;
 137         if (exists $obj->{'keys'})
 138         {
 139                 $obj->{'keys'}->{$k} = undef;
 140         }
 141 }
 142
 143 sub _get_cache
 144 {
 145         my ($obj, $k, $vref) = @_;
 146         if (exists $obj->{'cache'}->{$k})
 147         {
 148                 $$vref = $obj->{'cache'}->{$k};
 149                 return 1;
 150         }
 151         return undef;
 152 }
 153
 154 sub _exists
 155 {
 156         my ($obj, $k) = @_;
 157         if (exists $obj->{'cache'}->{$k})
 158         {
 159                 return 1;
 160         }
 161         my $hcode = md5_base64($k);
 162         my $c = $obj->_select(
 163                 'table' => 'rec_hash_item',
 164                 'fields' => 'count(id)',
 165                 'where' => {
 166                         'hash' => $obj->{'id'},
 167                         'key_hash' => $hcode,
 168                 },
 169         )->[0]->[0];
 170         return $c;
 171 }
 172
 173 sub _data
 174 {
 175         my ($obj, $k) = @_;
 176         my $hcode = md5_base64($k);
 177         my $q = $obj->_select(
 178                 'table' => 'rec_hash_item',
 179                 'fields' => ['value_type', 'value_data'],
 180                 'where' => {
 181                         'hash' => $obj->{'id'},
 182                         'key_hash' => $hcode,
 183                 },
 184         );
 185         if (scalar @$q)
 186         {
 187                 my $dt = $q->[0]->[0];
 188                 my $val = $q->[0]->[1];
 189                 if ($dt eq 'value')
 190                 {
 191                         return $val;
 192                 }
 193                 elsif ($dt eq 'text')
 194                 {
 195                         my $dq = $obj->_select(
 196                                 'table' => 'rec_value_text',
 197                                 'fields' => 'data',
 198                                 'where' => {
 199                                         'id' => $val,
 200                                 },
 201                         );
 202                         return $dq->[0]->[0];
 203                 }
 204                 elsif ($dt eq 'data')
 205                 {
 206                         my $dq = $obj->_select(
 207                                 'table' => 'rec_value_data',
 208                                 'fields' => 'data',
 209                                 'where' => {
 210                                         'id' => $val,
 211                                 },
 212                         );
 213                         if (scalar @$dq)
 214                         {
 215                                 my $rec = thaw($dq->[0]->[0]);
 216                                 return $rec;
 217                         }
 218                         return undef;
 219                 }
 220                 elsif ($dt eq 'array')
 221                 {
 222                         my $rec = $obj->_tiearray($val);
 223                         if ($obj->{'prefetch'})
 224                         {
 225                                 (tied(@$rec))->_prefetch();
 226                         }
 227                         return $rec;
 228                 }
 229                 elsif ($dt eq 'hash')
 230                 {
 231                         my $rec = $obj->_tiehash($val);
 232                         if ($obj->{'prefetch'})
 233                         {
 234                                 (tied(%$rec))->_prefetch();
 235                         }
 236                         return $rec;
 237                 }
 238         }
 239         return undef;
 240 }
 241
 242 sub _prefetch
 243 {
 244         my ($obj) = @_;
 245         my $pd = $obj->_select(
 246                 'table' => 'rec_hash_item',
 247                 'fields' => ['key_type', 'key_data', 'value_type', 'value_data'],
 248                 'where' => {
 249                         'hash' => $obj->{'id'},
 250                 },
 251         );
 252         my @data = ();
 253         my @datapos = ();
 254         my @text = ();
 255         my @textpos = ();
 256         my %hash = ();
 257         my @textkey = ();
 258         my @textkeypos = ();
 259         foreach my $i (0..$#{$pd})
 260         {
 261                 my $row = $pd->[$i];
 262                 my $kt = $row->[0];
 263                 my $k = $row->[1];
 264                 if ($kt eq 'text')
 265                 {
 266                         push @textkey, $k;
 267                         push @textkeypos, $i;
 268                 }
 269         }
 270         if (scalar @textkey)
 271         {
 272                 my $ids = join(',', @textkey);
 273                 my $tq = $obj->_select(
 274                         'table' => 'rec_value_text',
 275                         'fields' => ['id', 'data'],
 276                         'where' => "id in ($ids)",
 277                 );
 278                 my %data = map {$_->[0] => $_->[1]} @$tq;
 279                 foreach my $x (0..$#textkey)
 280                 {
 281                         my $id = $textkey[$x];
 282                         my $i = $textkeypos[$x];
 283                         $pd->[$i]->[1] = $data{$id};
 284                 }
 285         }
 286         foreach my $r (@$pd)
 287         {
 288                 my $k = $r->[1];
 289                 my $vt = $r->[2];
 290                 my $val = $r->[3];
 291                 if ($vt eq 'value')
 292                 {
 293                         $hash{$k} = $val;
 294                 }
 295                 elsif ($vt eq 'text')
 296                 {
 297                         push @textpos, $k;
 298                         push @text, $val;
 299                 }
 300                 elsif ($vt eq 'value')
 301                 {
 302                         push @datapos, $k;
 303                         push @data, $val;
 304                 }
 305                 elsif ($vt eq 'array')
 306                 {
 307                         my $rec = $obj->_tiearray($val);
 308                         if ($obj->{'prefetch'})
 309                         {
 310                                 (tied(@$rec))->_prefetch();
 311                         }
 312                         $hash{$k} = $rec;
 313                 }
 314                 elsif ($vt eq 'hash')
 315                 {
 316                         my $rec = $obj->_tiehash($val);
 317                         if ($obj->{'prefetch'})
 318                         {
 319                                 (tied(@$rec))->_prefetch();
 320                         }
 321                         $hash{$k} = $rec;
 322                 }
 323         }
 324         if (scalar @text)
 325         {
 326                 my $ids = join(',', @text);
 327                 my $tq = $obj->_select(
 328                         'table' => 'rec_value_text',
 329                         'fields' => ['id', 'data'],
 330                         'where' => "id in ($ids)",
 331                 );
 332                 my %data = map {$_->[0] => $_->[1]} @$tq;
 333                 foreach my $x (0..$#text)
 334                 {
 335                         my $id = $text[$x];
 336                         my $k = $textpos[$x];
 337                         $hash{$k} = $data{$id};
 338                 }
 339         }
 340         if (scalar @data)
 341         {
 342                 my $ids = join(',', @data);
 343                 my $tq = $obj->_select(
 344                         'table' => 'rec_value_data',
 345                         'fields' => ['id', 'data'],
 346                         'where' => "id in ($ids)",
 347                 );
 348                 my %d = map {$_->[0] => $_->[1]} @$tq;
 349                 foreach my $x (0..$#data)
 350                 {
 351                         my $id = $data[$x];
 352                         my $k = $datapos[$x];
 353                         if (defined $d{$id})
 354                         {
 355                                 $hash{$k} = thaw($d{$id});
 356                         }
 357                 }
 358         }
 359         return $obj->{'cache'} = \%hash;
 360 }
 361
 362 sub TIEHASH
 363 {
 364         my $class = shift;
 365         my %prm = @_;
 366         my $obj = \%prm;
 367         $obj->{'sort'} = 1;
 368         $obj->{'cache'} = {};
 369         bless $obj, $class;
 370         return $obj;
 371 }
 372
 373 sub FETCH
 374 {
 375         my ($tobj, $k) = @_;
 376         my $obj = $tobj->_get_self();
 377         my $val = undef;
 378         if ($obj->_get_cache($k, \$val))
 379         {
 380                 return $val;
 381         }
 382         $val = $obj->_data($k);
 383         if (defined $val)
 384         {
 385                 $obj->_set_cache($k, $val);
 386         }
 387         return $val;
 388 }
 389
 390 sub STORE
 391 {
 392         my ($tobj, $k, $val) = @_;
 393         my $dval = $val;
 394         my $obj = $tobj->_get_self();
 395         my $vt;
 396         $val = '' unless (defined $val);
 397         if (ref $val) {
 398                 my $done = 0;
 399                 unless ($obj->{'serialize'}) {
 400                         if ($val =~ /HASH/) {
 401                                 my $id = $obj->_create('hash');
 402                                 my $ta = $obj->_tiehash($id);
 403                                 $dval = $ta;
 404                                 foreach my $k (keys %$val) {
 405                                         $ta->{$k} = $val->{$k};
 406                                 }
 407                                 $vt = 'hash';
 408                                 $val = $id;
 409                                 $done = 1;
 410                         }
 411                         elsif ($val =~ /ARRAY/) {
 412                                 my $id = $obj->_create('array');
 413                                 my $ta = $obj->_tiearray($id);
 414                                 $dval = $ta;
 415                                 foreach my $i (0..$#{$val}) {
 416                                         $ta->[$i] = $val->[$i];
 417                                 }
 418                                 $vt = 'array';
 419                                 $val = $id;
 420                                 $done = 1;
 421                         }
 422                 }
 423                 unless ($done) {
 424                         my $data = nfreeze($val);
 425                         $val = $obj->_create('value_data', {
 426                                 'data' => $data,
 427                         });
 428                         $vt = 'data';
 429                 }
 430         }
 431         elsif (length($val) > 255) {
 432                 $val = $obj->_create('value_data', {
 433                         'data' => $val,
 434                 });
 435                 $vt = 'text';
 436         }
 437         else {
 438                 $vt = 'value';
 439         }
 440         my $hcode = md5_base64($k);
 441         my $c = $obj->_select(
 442                 'table' => 'rec_hash_item',
 443                 'fields' => ['value_type', 'id'],
 444                 'where' => {
 445                         'hash' => $obj->{'id'},
 446                         'key_hash' => $hcode,
 447                 },
 448         );
 449         my $create = 1;
 450         if (scalar @$c) {
 451                 if ($c->[0]->[0] eq 'value') {
 452                         $create = 0;
 453                         $obj->_update(
 454                                 'table' => 'rec_hash_item',
 455                                 'fields' => {
 456                                         'value_type' => $vt,
 457                                         'value_data' => $val,
 458                                 },
 459                                 'where' => {
 460                                         'id' => $c->[0]->[1],
 461                                 },
 462                         );
 463                 }
 464                 else {
 465                         $obj->_delete($k);
 466                 }
 467         }
 468         if ($create) {
 469                 my $kt;
 470                 if (length($k) > 255) {
 471                         $k = $obj->_create('value_text', {
 472                                 'data' => $k,
 473                         });
 474                         $kt = 'text';
 475                 }
 476                 else {
 477                         $kt = 'value';
 478                 }
 479                 $obj->_create('hash_item', {
 480                         'hash' => $obj->{'id'},
 481                         'key_hash' => $hcode,
 482                         'key_data' => $k,
 483                         'key_type' => $kt,
 484                         'value_data' => $val,
 485                         'value_type' => $vt,
 486                 });
 487         }
 488         $obj->_set_cache($k, $dval);
 489         return $dval;
 490 }
 491
 492 sub EXISTS
 493 {
 494         my ($tobj, $k) = @_;
 495         my $obj = $tobj->_get_self();
 496         $k = '' unless defined ($k);
 497         return $obj->_exists($k);
 498 }
 499
 500 sub DELETE
 501 {
 502         my ($tobj, $i) = @_;
 503         my $obj = $tobj->_get_self();
 504         $obj->_delete($i);
 505 }
 506
 507 sub CLEAR
 508 {
 509         my ($tobj) = @_;
 510         my $obj = $tobj->_get_self();
 511         $obj->_clear();
 512 }
 513
 514 sub FIRSTKEY
 515 {
 516         my ($tobj) = @_;
 517         my $obj = $tobj->_get_self();
 518         if ($obj->{'sort'})
 519         {
 520                 $obj->{'keys_sorted'} = [sort $obj->_get_keys()];
 521                 return shift @{$obj->{'keys_sorted'}};
 522         }
 523         else
 524         {
 525                 $obj->_get_keys();
 526                 return each %{$obj->{'keys'}};
 527         }
 528 }
 529
 530 sub NEXTKEY
 531 {
 532         my ($tobj) = @_;
 533         my $obj = $tobj->_get_self();
 534         if ($obj->{'sort'} && exists $obj->{'keys_sorted'})
 535         {
 536                 return shift @{$obj->{'keys_sorted'}};
 537         }
 538         else
 539         {
 540                 return each %{$obj->{'keys'}};
 541         }
 542 }
 543
 544 sub SCALAR
 545 {
 546         # TODO
 547 }
 548
 549 sub id
 550 {
 551         my ($tobj) = @_;
 552         my $obj = $tobj->_get_self();
 553         return $obj->{'id'};
 554 }
 555
 556 1;
 557