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	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	44	our ( %btree, @array, %full );
21	dpavlin	33
22	dpavlin	45	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	dpavlin	33
28	dpavlin	45	warn "## self ",dump $self;
29
30			$self->clean if $self->{clean};
31
32	dpavlin	33	my $path = "/dev/shm/sack.$port";
33
34	dpavlin	45	$self->{btree} \|\|= tie %btree, 'BerkeleyDB::Btree',
35	dpavlin	33	-Filename => "$path.btree",
36			# -Cachesize => 700_000_000,
37	dpavlin	34	-Flags => DB_CREATE
38			\|\| die "$path.btree $!";
39	dpavlin	33
40	dpavlin	45	$self->{array} \|\|= tie @array, 'BerkeleyDB::Recno',
41	dpavlin	33	-Filename => "$path.array",
42			# -Cachesize => 700_000_000,
43			-Flags => DB_CREATE,
44	dpavlin	34	\|\| die "$path.array $!";
45	dpavlin	44
46	dpavlin	45	$self->{full} \|\|= tie %full, 'BerkeleyDB::Btree',
47	dpavlin	44	-Filename => "$path.full",
48			-Flags => DB_CREATE,
49			\|\| die "$path.full $!";
50
51	dpavlin	34	warn "[$port] BDB open $path\n";
52	dpavlin	33
53	dpavlin	45	return $self;
54	dpavlin	33	}
55
56	dpavlin	45
57	dpavlin	34	sub close {
58	dpavlin	45	my $self = shift;
59	dpavlin	34	my $error = 0;
60	dpavlin	45	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	dpavlin	34	}
67
68	dpavlin	45
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	dpavlin	34	our $seq = 0;
81
82			sub to_int {
83			my ( $self, $full ) = @_;
84	dpavlin	33	my $nr;
85
86	dpavlin	44	my $md5 = md5 $full;
87	dpavlin	33
88	dpavlin	44	if ( my $nr = $btree{ $md5 } ) {
89	dpavlin	34	return $nr;
90			} else {
91			$seq++;
92	dpavlin	44	$full{ $md5 } = $full;
93			$btree{ $md5 } = $seq;
94			$array[ $seq ] = $md5;
95	dpavlin	34	return $seq;
96			}
97	dpavlin	33	}
98
99	dpavlin	34
100			sub from_int {
101	dpavlin	36	# my ( $self, $d ) = @_;
102			my $d = pop @_;
103	dpavlin	34	my $v = $array[ $d ];
104	dpavlin	44	$v = $full{ $v } if defined $v;
105	dpavlin	37	# warn "## from_int $d = $v\n";
106	dpavlin	34	defined $v ? $v : $d;
107			}
108
109	dpavlin	36	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	dpavlin	37	# warn "## k2 $k2 = $v";
117	dpavlin	36	$out->{$k1}->{ from_int $k2 } = $v;
118			}
119			}
120
121			return $out;
122			}
123
124	dpavlin	44
125			sub undigest_node_k_v {
126			my ( $self, $node, $k, $v ) = @_;
127			$self->from_int( $v );
128			}
129
130
131	dpavlin	37	sub sync {
132	dpavlin	45	my $self = shift;
133	dpavlin	37	warn "[$port] sync";
134	dpavlin	45
135			return
136			not $self->{btree}->db_sync
137			+ $self->{array}->db_sync
138			+ $self->{full}->db_sync
139			;
140	dpavlin	37	}
141
142	dpavlin	44
143			sub info {
144	dpavlin	45	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	dpavlin	44	return $info;
149			}
150
151	dpavlin	33	1;