Sack/Digest/BerkeleyDB.pm

package Sack::Digest::BerkeleyDB;

=head1 NAME

Sack::Digest::BerkeleyDB - turn long fields into integers and back

=cut

use warnings;
use strict;

use BerkeleyDB;
use Digest::MD5 qw(md5);
use Data::Dump qw/dump/;


our $debug = 0;
our $port = '?';

sub new {
        my $class = shift;
        my $self  = bless {@_}, $class;
        die "no port" unless defined $self->{port};
        $port = $self->{port};

        $self->clean if $self->{clean};

        $self->open;

        return $self;
}


sub open {
        my $self = shift;

        my $path = "/dev/shm/sack.$self->{port}";

        $self->{db_md5_nr} ||= tie my %md5_nr, 'BerkeleyDB::Btree', 
                -Filename  => "$path.md5_nr",
#               -Cachesize => 700_000_000,
                -Flags     => DB_CREATE
        || die "$path.md5_nr $!";

        $self->{md5_nr} = \%md5_nr;


        $self->{db_nr_md5} ||= tie my @nr_md5, 'BerkeleyDB::Recno',
                -Filename  => "$path.nr_md5",
#               -Cachesize => 700_000_000,
                -Flags     => DB_CREATE,
        || die "$path.nr_md5 $!";

        $self->{nr_md5} = \@nr_md5;


        $self->{db_md5}  ||= tie my %md5, 'BerkeleyDB::Btree',
                -Filename  => "$path.md5",
                -Flags     => DB_CREATE,
        || die "$path.md5 $!";

        $self->{md5} = \%md5;

        warn "[$port] BDB open $path\n";

}


sub close {
        my $self = shift;
        my $error = 0;
        foreach ( qw( md5 md5_nr nr_md5 ) ) {
                my $db = delete $self->{"db_$_"} || next;
                warn "[$port] close $_\n";
                $error += $db->db_close;
        }
        return not $error;
}


sub clean {
        my $self = shift;
        $self->close;
        foreach ( glob "/dev/shm/sack.$port.*" ) {
                warn "[$port] clean $_ ", -s $_, " bytes\n";
                unlink $_ || warn "[$port] ERROR can't remove $_:$!";
        }
        1;
}


our $seq = 0;

sub to_int {
        my ( $self, $full ) = @_;
        my $nr;

        my $md5 = md5 $full;

        if ( my $nr = $self->{md5_nr}->{ $md5 } ) {
                return $nr;
        } else {
                $seq++;
                $self->{md5}   ->{ $md5 } = $full;
                $self->{md5_nr}->{ $md5 } = $seq;
                $self->{nr_md5}->[ $seq ] = $md5;
                return $seq;
        }
}


sub from_int {
        my ( $self, $d ) = @_;
        my $v = $self->{nr_md5}->[ $d ];
        $v = $self->{md5}->{ $v } if defined $v;
#       warn "## from_int $d = $v\n";
        defined $v ? $v : $d;
}

sub undigest_out {
        my ( $self, $out ) = @_;

        foreach my $k1 ( grep { m/#/ } keys %$out ) {
                my @k2 = keys %{ $out->{$k1} };
                foreach my $k2 ( @k2 ) {
                        my $v = delete $out->{$k1}->{$k2};
#                       warn "## k2 $k2 = $v";
                        $out->{$k1}->{ $self->from_int($k2) } = $v;
                }
        }

        return $out;
}


sub undigest_node_k_v {
        my ( $self, $node, $k, $v ) = @_;
        $self->from_int( $v );
}


sub sync {
        my $self = shift;
        warn "[$port] sync";

        return
                not $self->{db_md5_nr}->db_sync
                 +  $self->{db_nr_md5}->db_sync
                 +  $self->{db_md5}->db_sync
        ;
}


sub info {
        my $self = shift;
        my $info;
        $info->{$_} = $self->{"db_$_"}->db_stat foreach qw( md5_nr nr_md5 md5 );
        warn "[$port] BDB info [$seq] ", dump( map { $info->{$_}->{bt_nkeys} } keys %$info );
        return $info;
}

sub lookup {
        my ( $self, $name, $key ) = @_;
        die "no lookup $name" unless $self->{$name};
        die "no key" unless $key;
#warn "XXXX $self->{$name}";
        my $v = $name eq 'nr_md5' ? $self->{ $name }->[$key] : $self->{ $name }->{$key} ;
        warn "### lookup $name $key = $v\n";
        return $v;
}

1;
1	package Sack::Digest::BerkeleyDB;
2
3	=head1 NAME
4
5	Sack::Digest::BerkeleyDB - turn long fields into integers and back
6
7	=cut
8
9	use warnings;
10	use strict;
11
12	use BerkeleyDB;
13	use Digest::MD5 qw(md5);
14	use Data::Dump qw/dump/;
15
16
17	our $debug = 0;
18	our $port = '?';
19
20	sub new {
21	my $class = shift;
22	my $self = bless {@_}, $class;
23	die "no port" unless defined $self->{port};
24	$port = $self->{port};
25
26	$self->clean if $self->{clean};
27
28	$self->open;
29
30	return $self;
31	}
32
33
34	sub open {
35	my $self = shift;
36
37	my $path = "/dev/shm/sack.$self->{port}";
38
39	$self->{db_md5_nr} \|\|= tie my %md5_nr, 'BerkeleyDB::Btree',
40	-Filename => "$path.md5_nr",
41	# -Cachesize => 700_000_000,
42	-Flags => DB_CREATE
43	\|\| die "$path.md5_nr $!";
44
45	$self->{md5_nr} = \%md5_nr;
46
47
48	$self->{db_nr_md5} \|\|= tie my @nr_md5, 'BerkeleyDB::Recno',
49	-Filename => "$path.nr_md5",
50	# -Cachesize => 700_000_000,
51	-Flags => DB_CREATE,
52	\|\| die "$path.nr_md5 $!";
53
54	$self->{nr_md5} = \@nr_md5;
55
56
57	$self->{db_md5} \|\|= tie my %md5, 'BerkeleyDB::Btree',
58	-Filename => "$path.md5",
59	-Flags => DB_CREATE,
60	\|\| die "$path.md5 $!";
61
62	$self->{md5} = \%md5;
63
64	warn "[$port] BDB open $path\n";
65
66	}
67
68
69	sub close {
70	my $self = shift;
71	my $error = 0;
72	foreach ( qw( md5 md5_nr nr_md5 ) ) {
73	my $db = delete $self->{"db_$_"} \|\| next;
74	warn "[$port] close $_\n";
75	$error += $db->db_close;
76	}
77	return not $error;
78	}
79
80
81	sub clean {
82	my $self = shift;
83	$self->close;
84	foreach ( glob "/dev/shm/sack.$port.*" ) {
85	warn "[$port] clean $_ ", -s $_, " bytes\n";
86	unlink $_ \|\| warn "[$port] ERROR can't remove $_:$!";
87	}
88	1;
89	}
90
91
92	our $seq = 0;
93
94	sub to_int {
95	my ( $self, $full ) = @_;
96	my $nr;
97
98	my $md5 = md5 $full;
99
100	if ( my $nr = $self->{md5_nr}->{ $md5 } ) {
101	return $nr;
102	} else {
103	$seq++;
104	$self->{md5} ->{ $md5 } = $full;
105	$self->{md5_nr}->{ $md5 } = $seq;
106	$self->{nr_md5}->[ $seq ] = $md5;
107	return $seq;
108	}
109	}
110
111
112	sub from_int {
113	my ( $self, $d ) = @_;
114	my $v = $self->{nr_md5}->[ $d ];
115	$v = $self->{md5}->{ $v } if defined $v;
116	# warn "## from_int $d = $v\n";
117	defined $v ? $v : $d;
118	}
119
120	sub undigest_out {
121	my ( $self, $out ) = @_;
122
123	foreach my $k1 ( grep { m/#/ } keys %$out ) {
124	my @k2 = keys %{ $out->{$k1} };
125	foreach my $k2 ( @k2 ) {
126	my $v = delete $out->{$k1}->{$k2};
127	# warn "## k2 $k2 = $v";
128	$out->{$k1}->{ $self->from_int($k2) } = $v;
129	}
130	}
131
132	return $out;
133	}
134
135
136	sub undigest_node_k_v {
137	my ( $self, $node, $k, $v ) = @_;
138	$self->from_int( $v );
139	}
140
141
142	sub sync {
143	my $self = shift;
144	warn "[$port] sync";
145
146	return
147	not $self->{db_md5_nr}->db_sync
148	+ $self->{db_nr_md5}->db_sync
149	+ $self->{db_md5}->db_sync
150	;
151	}
152
153
154	sub info {
155	my $self = shift;
156	my $info;
157	$info->{$_} = $self->{"db_$_"}->db_stat foreach qw( md5_nr nr_md5 md5 );
158	warn "[$port] BDB info [$seq] ", dump( map { $info->{$_}->{bt_nkeys} } keys %$info );
159	return $info;
160	}
161
162	sub lookup {
163	my ( $self, $name, $key ) = @_;
164	die "no lookup $name" unless $self->{$name};
165	die "no key" unless $key;
166	#warn "XXXX $self->{$name}";
167	my $v = $name eq 'nr_md5' ? $self->{ $name }->[$key] : $self->{ $name }->{$key} ;
168	warn "### lookup $name $key = $v\n";
169	return $v;
170	}
171
172	1;