home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / SDBM_File.pm < prev    next >
Encoding:
Perl POD Document  |  2001-10-11  |  3.4 KB  |  158 lines
  1.  
  2. package MLDBM::Sync::SDBM_File;
  3. $VERSION = .17;
  4.  
  5. use SDBM_File;
  6. use strict;
  7. use vars qw(@ISA  $MaxSegments $MaxSegmentLength %KEYS $Zlib $VERSION);
  8.  
  9. @ISA = qw(SDBM_File);
  10. $MaxSegments   = 8192; # to a 1M limit
  11. # leave room for key index pad
  12. $MaxSegmentLength = 128;
  13. eval "use Compress::Zlib";
  14. $Zlib = $@ ? 0 : 1;
  15.  
  16. sub FETCH {
  17.     my($self, $key) = @_;
  18.     my $segment_length = $MaxSegmentLength;
  19.  
  20.     my $total_rv;
  21.     for(my $index = 0; $index < $MaxSegments; $index++) {
  22.     my $rv = $self->SUPER::FETCH(_index_key($key, $index));
  23.     if(defined $rv) {
  24.         $total_rv ||= '';
  25.         $total_rv .= $rv;
  26.         last if length($rv) < $segment_length;
  27.     } else {
  28.         last;
  29.     }
  30.     }
  31.  
  32.     if(defined $total_rv) {
  33.     $total_rv =~ s/^(..)//s;
  34.     my $type = $1;
  35.     if($type eq 'G}') {
  36.         $total_rv = uncompress($total_rv);
  37.     } elsif ($type eq 'N}') {
  38.         # nothing
  39.     } else {
  40.         # old SDBM_File ?
  41.         $total_rv = $type . $total_rv;
  42.     }
  43.     }
  44.  
  45.     $total_rv;
  46. }
  47.  
  48. sub STORE {
  49.     my($self, $key, $value) = @_;
  50.     my $segment_length = $MaxSegmentLength;
  51.  
  52.     # DELETE KEYS FIRST
  53.     for(my $index = 0; $index < $MaxSegments; $index++) {
  54.     my $index_key = _index_key($key, $index);
  55.     my $rv = $self->SUPER::FETCH($index_key);
  56.     if(defined $rv) {
  57.         $self->SUPER::DELETE($index_key);
  58.     } else {
  59.         last;
  60.     }
  61.     last if length($rv) < $segment_length;
  62.     }
  63.  
  64.     # G - Gzip compression
  65.     # N - No compression
  66.     #
  67.     my $old_value = $value;
  68.     $value = ($Zlib && (length($value) >= $segment_length/2)) ? "G}".compress($value) : "N}".$value;
  69.  
  70.     my($total_rv, $last_index);
  71.     for(my $index = 0; $index < $MaxSegments; $index++) {
  72.     if($index == $MaxSegments) {
  73.         die("can't store more than $MaxSegments segments of $MaxSegmentLength bytes per key in ".__PACKAGE__);
  74.     }
  75.     $value =~ s/^(.{0,$segment_length})//so;
  76.     my $segment = $1;
  77.     
  78.     last if length($segment) == 0;
  79. #    print "STORING "._index_key($key, $index)." $segment\n";
  80.     my $rv = $self->SUPER::STORE(_index_key($key, $index), $segment);
  81.     $total_rv .= $segment;
  82.     $last_index = $index;
  83.     }
  84.  
  85. #    use Time::HiRes;
  86. #    print "[".&Time::HiRes::time()."] STORED ".($last_index+1)." segments for length ".
  87. #      length($total_rv)." bytes for value ".length($old_value)."\n";
  88.  
  89.     $old_value;
  90. }
  91.  
  92. sub DELETE {
  93.     my($self, $key) = @_;
  94.     my $segment_length = $MaxSegmentLength;
  95.  
  96.     my $total_rv;
  97.     for(my $index = 0; $index < $MaxSegments; $index++) {
  98.     my $index_key = _index_key($key, $index);
  99.     my $rv = $self->SUPER::FETCH($index_key) || '';
  100.     $self->SUPER::DELETE($index_key);
  101.     $total_rv ||= '';
  102.     $total_rv .= $rv;
  103.     last if length($rv) < $segment_length;
  104.     }
  105.  
  106.     $total_rv =~ s/^(..)//s;
  107.     my $type = $1;
  108.     if($type eq 'G}') {
  109.     $total_rv = uncompress($total_rv);
  110.     } elsif ($type eq 'N}') {
  111.     # normal
  112.     } else {
  113.     # old SDBM_File
  114.     $total_rv = $type.$total_rv;
  115.     }
  116.  
  117.     $total_rv;
  118. }
  119.  
  120. sub FIRSTKEY {
  121.     my $self = shift;
  122.  
  123.     my $key = $self->SUPER::FIRSTKEY();
  124.     my @keys = ();
  125.     if (defined $key) {
  126.     do {
  127.         if($key !~ /\*\*\d+$/s) {
  128.         if(my $new_key = _decode_key($key)) {
  129.             push(@keys, $new_key);
  130.         }
  131.         }
  132.     } while($key = $self->SUPER::NEXTKEY($key));
  133.     }
  134.     $KEYS{$self} = \@keys;
  135.  
  136.     $self->NEXTKEY;
  137. }
  138.  
  139. sub NEXTKEY {
  140.     my $self = shift;
  141.     shift(@{$KEYS{$self}});
  142. }
  143.  
  144. sub _index_key {
  145.     my($key, $index) = @_;
  146.     $key =~ s/([\%\*])/uc sprintf("%%%02x",ord($1))/esg;
  147.     $index ? $key.'**'.$index : $key;
  148. }
  149.  
  150. sub _decode_key {
  151.     my $key = shift;
  152.     $key =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
  153.     $key;
  154. }
  155.  
  156. 1;
  157.  
  158.