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 = '?';

our ( %btree, @array, %full );

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

warn "## self ",dump $self;

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

        my $path = "/dev/shm/sack.$port";

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

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

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

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

        return $self;
}


sub close {
        my $self = shift;
        my $error = 0;
        foreach ( qw( tree array full ) ) {
                my $db = delete $self->{$_} || 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 = $btree{ $md5 } ) {
                return $nr;
        } else {
                $seq++;
                $full{ $md5 }   = $full;
                $btree{ $md5 } = $seq;
                $array[ $seq ]  = $md5;
                return $seq;
        }
}


sub from_int {
#       my ( $self, $d ) = @_;
        my $d = pop @_;
        my $v = $array[ $d ];
        $v = $full{ $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}->{ 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->{btree}->db_sync
                 +  $self->{array}->db_sync
                 +  $self->{full}->db_sync
        ;
}


sub info {
        my $self = shift;
        my $info;
        $info->{$_} = $self->{$_}->db_stat foreach qw( btree array full );
        warn "[$port] BDB info [$seq] ", dump $info;
        return $info;
}

1;
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	our ( %btree, @array, %full );
21
22	sub new {
23	my $class = shift;
24	my $self = bless {@_}, ref $class ? ref $class : $class;
25	die "no port" unless defined $self->{port};
26	$port = $self->{port};
27
28	warn "## self ",dump $self;
29
30	$self->clean if $self->{clean};
31
32	my $path = "/dev/shm/sack.$port";
33
34	$self->{btree} \|\|= tie %btree, 'BerkeleyDB::Btree',
35	-Filename => "$path.btree",
36	# -Cachesize => 700_000_000,
37	-Flags => DB_CREATE
38	\|\| die "$path.btree $!";
39
40	$self->{array} \|\|= tie @array, 'BerkeleyDB::Recno',
41	-Filename => "$path.array",
42	# -Cachesize => 700_000_000,
43	-Flags => DB_CREATE,
44	\|\| die "$path.array $!";
45
46	$self->{full} \|\|= tie %full, 'BerkeleyDB::Btree',
47	-Filename => "$path.full",
48	-Flags => DB_CREATE,
49	\|\| die "$path.full $!";
50
51	warn "[$port] BDB open $path\n";
52
53	return $self;
54	}
55
56
57	sub close {
58	my $self = shift;
59	my $error = 0;
60	foreach ( qw( tree array full ) ) {
61	my $db = delete $self->{$_} \|\| next;
62	warn "[$port] close $_\n";
63	$error += $db->db_close;
64	}
65	return not $error;
66	}
67
68
69	sub clean {
70	my $self = shift;
71	$self->close;
72	foreach ( glob "/dev/shm/sack.$port.*" ) {
73	warn "[$port] clean $_ ", -s $_, " bytes\n";
74	unlink $_ \|\| warn "[$port] ERROR can't remove $_:$!";
75	}
76	1;
77	}
78
79
80	our $seq = 0;
81
82	sub to_int {
83	my ( $self, $full ) = @_;
84	my $nr;
85
86	my $md5 = md5 $full;
87
88	if ( my $nr = $btree{ $md5 } ) {
89	return $nr;
90	} else {
91	$seq++;
92	$full{ $md5 } = $full;
93	$btree{ $md5 } = $seq;
94	$array[ $seq ] = $md5;
95	return $seq;
96	}
97	}
98
99
100	sub from_int {
101	# my ( $self, $d ) = @_;
102	my $d = pop @_;
103	my $v = $array[ $d ];
104	$v = $full{ $v } if defined $v;
105	# warn "## from_int $d = $v\n";
106	defined $v ? $v : $d;
107	}
108
109	sub undigest_out {
110	my ( $self, $out ) = @_;
111
112	foreach my $k1 ( grep { m/#/ } keys %$out ) {
113	my @k2 = keys %{ $out->{$k1} };
114	foreach my $k2 ( @k2 ) {
115	my $v = delete $out->{$k1}->{$k2};
116	# warn "## k2 $k2 = $v";
117	$out->{$k1}->{ from_int $k2 } = $v;
118	}
119	}
120
121	return $out;
122	}
123
124
125	sub undigest_node_k_v {
126	my ( $self, $node, $k, $v ) = @_;
127	$self->from_int( $v );
128	}
129
130
131	sub sync {
132	my $self = shift;
133	warn "[$port] sync";
134
135	return
136	not $self->{btree}->db_sync
137	+ $self->{array}->db_sync
138	+ $self->{full}->db_sync
139	;
140	}
141
142
143	sub info {
144	my $self = shift;
145	my $info;
146	$info->{$_} = $self->{$_}->db_stat foreach qw( btree array full );
147	warn "[$port] BDB info [$seq] ", dump $info;
148	return $info;
149	}
150
151	1;