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         {
 399                 my $done = 0;
 400                 unless ($obj->{'serialize'})
 401                 {
 402                         if ($val =~ /HASH/)
 403                         {
 404                                 my $id = $obj->_create('hash');
 405                                 my $ta = $obj->_tiehash($id);
 406                                 $dval = $ta;
 407                                 foreach my $k (keys %$val)
 408                                 {
 409                                         $ta->{$k} = $val->{$k};
 410                                 }
 411                                 $vt = 'hash';
 412                                 $val = $id;
 413                                 $done = 1;
 414                         }
 415                         elsif ($val =~ /ARRAY/)
 416                         {
 417                                 my $id = $obj->_create('array');
 418                                 my $ta = $obj->_tiearray($id);
 419                                 $dval = $ta;
 420                                 foreach my $i (0..$#{$val})
 421                                 {
 422                                         $ta->[$i] = $val->[$i];
 423                                 }
 424                                 $vt = 'array';
 425                                 $val = $id;
 426                                 $done = 1;
 427                         }
 428                 }
 429                 unless ($done)
 430                 {
 431                         my $data = nfreeze($val);
 432                         $val = $obj->_create('value_data', {
 433                                 'data' => $data,
 434                         });
 435                         $vt = 'data';
 436                 }
 437         }
 438         elsif (length($val) > 255)
 439         {
 440                 $val = $obj->_create('value_data', {
 441                         'data' => $val,
 442                 });
 443                 $vt = 'text';
 444         }
 445         else
 446         {
 447                 $vt = 'value';
 448         }
 449         my $hcode = md5_base64($k);
 450         my $c = $obj->_select(
 451                 'table' => 'rec_hash_item',
 452                 'fields' => ['value_type', 'id'],
 453                 'where' => {
 454                         'hash' => $obj->{'id'},
 455                         'key_hash' => $hcode,
 456                 },
 457         );
 458         my $create = 1;
 459         if (scalar @$c)
 460         {
 461                 if ($c->[0]->[0] eq 'value')
 462                 {
 463                         $create = 0;
 464                         $obj->_update(
 465                                 'table' => 'rec_hash_item',
 466                                 'fields' => {
 467                                         'value_type' => $vt,
 468                                         'value_data' => $val,
 469                                 },
 470                                 'where' => {
 471                                         'id' => $c->[0]->[1],
 472                                 },
 473                         );
 474                 }
 475                 else
 476                 {
 477                         $obj->_delete($k);
 478                 }
 479         }
 480         if ($create)
 481         {
 482                 my $kt;
 483                 if (length($k) > 255)
 484                 {
 485                         $k = $obj->_create('value_text', {
 486                                 'data' => $k,
 487                         });
 488                         $kt = 'text';
 489                 }
 490                 else
 491                 {
 492                         $kt = 'value';
 493                 }
 494                 $obj->_create('hash_item', {
 495                         'hash' => $obj->{'id'},
 496                         'key_hash' => $hcode,
 497                         'key_data' => $k,
 498                         'key_type' => $kt,
 499                         'value_data' => $val,
 500                         'value_type' => $vt,
 501                 });
 502         }
 503         $obj->_set_cache($k, $dval);
 504         return $dval;
 505 }
 506
 507 sub EXISTS
 508 {
 509         my ($tobj, $k) = @_;
 510         my $obj = $tobj->_get_self();
 511         $k = '' unless defined ($k);
 512         return $obj->_exists($k);
 513 }
 514
 515 sub DELETE
 516 {
 517         my ($tobj, $i) = @_;
 518         my $obj = $tobj->_get_self();
 519         $obj->_delete($i);
 520 }
 521
 522 sub CLEAR
 523 {
 524         my ($tobj) = @_;
 525         my $obj = $tobj->_get_self();
 526         $obj->_clear();
 527 }
 528
 529 sub FIRSTKEY
 530 {
 531         my ($tobj) = @_;
 532         my $obj = $tobj->_get_self();
 533         if ($obj->{'sort'})
 534         {
 535                 $obj->{'keys_sorted'} = [sort $obj->_get_keys()];
 536                 return shift @{$obj->{'keys_sorted'}};
 537         }
 538         else
 539         {
 540                 $obj->_get_keys();
 541                 return each %{$obj->{'keys'}};
 542         }
 543 }
 544
 545 sub NEXTKEY
 546 {
 547         my ($tobj) = @_;
 548         my $obj = $tobj->_get_self();
 549         if ($obj->{'sort'} && exists $obj->{'keys_sorted'})
 550         {
 551                 return shift @{$obj->{'keys_sorted'}};
 552         }
 553         else
 554         {
 555                 return each %{$obj->{'keys'}};
 556         }
 557 }
 558
 559 sub SCALAR
 560 {
 561         # TODO
 562 }
 563
 564 sub id
 565 {
 566         my ($tobj) = @_;
 567         my $obj = $tobj->_get_self();
 568         return $obj->{'id'};
 569 }
 570
 571 1;
 572