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