1 |
package Sack::Digest; |
2 |
|
3 |
=head1 NAME |
4 |
|
5 |
Sack::Digest - 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; |