1 2package MLDBM::Sync::SDBM_File; 3$VERSION = .17; 4 5use SDBM_File; 6use strict; 7use 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; 13eval "use Compress::Zlib"; 14$Zlib = $@ ? 0 : 1; 15 16sub 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 48sub 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 92sub 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 120sub 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 139sub NEXTKEY { 140 my $self = shift; 141 shift(@{$KEYS{$self}}); 142} 143 144sub _index_key { 145 my($key, $index) = @_; 146 $key =~ s/([\%\*])/uc sprintf("%%%02x",ord($1))/esg; 147 $index ? $key.'**'.$index : $key; 148} 149 150sub _decode_key { 151 my $key = shift; 152 $key =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; 153 $key; 154} 155 1561; 157 158