lib/Sack/Digest.pm

package Sack::Digest;

=head1 NAME

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