diff -r 6d08f4a05d93 -r 3145852acc89 releasing/cbrtools/perl/MLDBM/Sync/SDBM_File.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/releasing/cbrtools/perl/MLDBM/Sync/SDBM_File.pm	Fri Jun 25 18:37:20 2010 +0800
@@ -0,0 +1,163 @@
+# Copyright (c) 2001-2002 Joshua Chamas, Chamas Enterprises Inc.  All rights reserved.
+# Sponsored by development on NodeWorks http://www.nodeworks.com and Apache::ASP
+# http://www.apache-asp.org
+#
+# This program is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+
+package MLDBM::Sync::SDBM_File;
+$VERSION = .17;
+
+use SDBM_File;
+use strict;
+use vars qw(@ISA  $MaxSegments $MaxSegmentLength %KEYS $Zlib $VERSION);
+
+@ISA = qw(SDBM_File);
+$MaxSegments   = 8192; # to a 1M limit
+# leave room for key index pad
+$MaxSegmentLength = 128;
+eval "use Compress::Zlib";
+$Zlib = $@ ? 0 : 1;
+
+sub FETCH {
+    my($self, $key) = @_;
+    my $segment_length = $MaxSegmentLength;
+
+    my $total_rv;
+    for(my $index = 0; $index < $MaxSegments; $index++) {
+	my $rv = $self->SUPER::FETCH(_index_key($key, $index));
+	if(defined $rv) {
+	    $total_rv ||= '';
+	    $total_rv .= $rv;
+	    last if length($rv) < $segment_length;
+	} else {
+	    last;
+	}
+    }
+
+    if(defined $total_rv) {
+	$total_rv =~ s/^(..)//s;
+	my $type = $1;
+	if($type eq 'G}') {
+	    $total_rv = uncompress($total_rv);
+	} elsif ($type eq 'N}') {
+	    # nothing
+	} else {
+	    # old SDBM_File ?
+	    $total_rv = $type . $total_rv;
+	}
+    }
+
+    $total_rv;
+}
+
+sub STORE {
+    my($self, $key, $value) = @_;
+    my $segment_length = $MaxSegmentLength;
+
+    # DELETE KEYS FIRST
+    for(my $index = 0; $index < $MaxSegments; $index++) {
+	my $index_key = _index_key($key, $index);
+	my $rv = $self->SUPER::FETCH($index_key);
+	if(defined $rv) {
+	    $self->SUPER::DELETE($index_key);
+	} else {
+	    last;
+	}
+	last if length($rv) < $segment_length;
+    }
+
+    # G - Gzip compression
+    # N - No compression
+    #
+    my $old_value = $value;
+    $value = ($Zlib && (length($value) >= $segment_length/2)) ? "G}".compress($value) : "N}".$value;
+
+    my($total_rv, $last_index);
+    for(my $index = 0; $index < $MaxSegments; $index++) {
+	if($index == $MaxSegments) {
+	    die("can't store more than $MaxSegments segments of $MaxSegmentLength bytes per key in ".__PACKAGE__);
+	}
+	$value =~ s/^(.{0,$segment_length})//so;
+	my $segment = $1;
+	
+	last if length($segment) == 0;
+#	print "STORING "._index_key($key, $index)." $segment\n";
+	my $rv = $self->SUPER::STORE(_index_key($key, $index), $segment);
+	$total_rv .= $segment;
+	$last_index = $index;
+    }
+
+#    use Time::HiRes;
+#    print "[".&Time::HiRes::time()."] STORED ".($last_index+1)." segments for length ".
+#      length($total_rv)." bytes for value ".length($old_value)."\n";
+
+    $old_value;
+}
+
+sub DELETE {
+    my($self, $key) = @_;
+    my $segment_length = $MaxSegmentLength;
+
+    my $total_rv;
+    for(my $index = 0; $index < $MaxSegments; $index++) {
+	my $index_key = _index_key($key, $index);
+	my $rv = $self->SUPER::FETCH($index_key) || '';
+	$self->SUPER::DELETE($index_key);
+	$total_rv ||= '';
+	$total_rv .= $rv;
+	last if length($rv) < $segment_length;
+    }
+
+    $total_rv =~ s/^(..)//s;
+    my $type = $1;
+    if($type eq 'G}') {
+	$total_rv = uncompress($total_rv);
+    } elsif ($type eq 'N}') {
+	# normal
+    } else {
+	# old SDBM_File
+	$total_rv = $type.$total_rv;
+    }
+
+    $total_rv;
+}
+
+sub FIRSTKEY {
+    my $self = shift;
+
+    my $key = $self->SUPER::FIRSTKEY();
+    my @keys = ();
+    if (defined $key) {
+	do {
+	    if($key !~ /\*\*\d+$/s) {
+		if(my $new_key = _decode_key($key)) {
+		    push(@keys, $new_key);
+		}
+	    }
+	} while($key = $self->SUPER::NEXTKEY($key));
+    }
+    $KEYS{$self} = \@keys;
+
+    $self->NEXTKEY;
+}
+
+sub NEXTKEY {
+    my $self = shift;
+    shift(@{$KEYS{$self}});
+}
+
+sub _index_key {
+    my($key, $index) = @_;
+    $key =~ s/([\%\*])/uc sprintf("%%%02x",ord($1))/esg;
+    $index ? $key.'**'.$index : $key;
+}
+
+sub _decode_key {
+    my $key = shift;
+    $key =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
+    $key;
+}
+
+1;
+