File Coverage

blib/lib/Cache/File/Heap.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Cache::File::Heap - A file based heap for use by Cache::File
4              
5             =head1 SYNOPSIS
6              
7             use Cache::File::Heap;
8              
9             $heap = Cache::File::Heap->new('/path/to/some/heap/file');
10             $heap->add($key, $val);
11             ($key, $val) = $heap->minimum;
12             ($key, $val) = $heap->extract_minimum;
13             $heap->delete($key, $val);
14              
15             =head1 DESCRIPTION
16              
17             This module is a wrapper around a Berkeley DB using a btree structure to
18             implement a heap. It is specifically for use by Cache::File for storing
19             expiry times (although with a bit of work it could be made more general).
20              
21             See LIMITATIONS below.
22              
23             =cut
24             package Cache::File::Heap;
25              
26             require 5.006;
27 6     6   1475 use strict;
  6         12  
  6         250  
28 6     6   32 use warnings;
  6         11  
  6         162  
29 6     6   3177 use DB_File;
  0            
  0            
30             use Carp;
31              
32             use fields qw(db dbhash);
33              
34             our $VERSION = '2.10';
35              
36             # common info object
37             my $BTREEINFO = new DB_File::BTREEINFO;
38             $BTREEINFO->{compare} = \&_Num_Compare;
39             $BTREEINFO->{flags} = R_DUP;
40              
41              
42             =head1 CONSTRUCTOR
43              
44             my $heap = Cache::File::Heap->new( [$dbfile] );
45              
46             The heap constructor takes an optional argument which is the name of the
47             database file to open. If specified, it will attempt to open the database
48             during construction. A new Cache::File::Heap blessed reference will be
49             returned, or undef if the open failed.
50              
51             =cut
52              
53             sub new {
54             my Cache::File::Heap $self = shift;
55              
56             $self = fields::new($self) unless ref $self;
57              
58             if (@_) {
59             $self->open(@_) or return undef;
60             }
61              
62             return $self;
63             }
64              
65              
66             =head1 METHODS
67              
68             =over
69              
70             =item $h->open($dbfile)
71              
72             Opens the specified database file.
73              
74             =cut
75              
76             sub open {
77             my Cache::File::Heap $self = shift;
78             my ($dbfile) = @_;
79              
80             $self->close();
81              
82             my %dbhash;
83             my $db = tie %dbhash, 'DB_File', $dbfile, O_CREAT|O_RDWR, 0666, $BTREEINFO
84             or return undef;
85              
86             $self->{db} = $db;
87             $self->{dbhash} = \%dbhash;
88              
89             return 1;
90             }
91              
92             =item $h->close()
93              
94             Closes a previously opened heap database. Note that the database will be
95             automatically closed when the heap reference is destroyed.
96              
97             =cut
98              
99             sub close {
100             my Cache::File::Heap $self = shift;
101             $self->{db} = undef;
102             untie %{$self->{dbhash}};
103             $self->{dbhash} = undef;
104             }
105              
106             =item $h->add($key, $val)
107              
108             Adds a key and value pair to the heap. Currently the key should be a number,
109             whilst the value may be any scalar. Invokes 'die' on failure (use eval to
110             catch it).
111              
112             =cut
113              
114             sub add {
115             my Cache::File::Heap $self = shift;
116             my ($key, $val) = @_;
117             defined $key or croak "key undefined";
118             defined $val or croak "value undefined";
119             # return code from DB_File is 0 on success.....
120             $self->_db->put($key, $val) and die "Heap add failed: $@";
121             }
122              
123             =item $h->delete($key, $val)
124              
125             Removes a key and value pair from the heap. Returns 1 if the pair was found
126             and removed, or 0 otherwise.
127              
128             =cut
129              
130             sub delete {
131             my Cache::File::Heap $self = shift;
132             my ($key, $val) = @_;
133             defined $key or croak "key undefined";
134             defined $val or croak "value undefined";
135             # return code from DB_File is 0 on success.....
136             $self->_db->del_dup($key, $val) and return 0;
137             return 1;
138             }
139              
140             =item ($key, $val) = $h->minimum()
141              
142             In list context, returns the smallest key and value pair from the heap. In
143             scalar context only the key is returned. Note smallest is defined via a
144             numerical comparison (hence keys should always be numbers).
145              
146             =cut
147              
148             sub minimum {
149             my Cache::File::Heap $self = shift;
150             my ($key, $val) = (0,0);
151             $self->_db->seq($key, $val, R_FIRST)
152             and return undef;
153             return wantarray? ($key, $val) : $key;
154             }
155              
156             =item ($key, $vals) = $h->minimum_dup()
157              
158             In list context, returns the smallest key and an array reference containing
159             all the values for that key from the heap. In scalar context only the key is
160             returned.
161              
162             =cut
163              
164             sub minimum_dup {
165             my Cache::File::Heap $self = shift;
166             my $db = $self->_db;
167             my ($key, $val) = (0,0);
168             $db->seq($key, $val, R_FIRST)
169             and return undef;
170             return wantarray? ($key, [ $db->get_dup($key) ]) : $key;
171             }
172              
173             =item ($key, $val) = $h->extract_minimum()
174              
175             As for $h->minimum(), but the key and value pair is removed from the heap.
176              
177             =cut
178              
179             sub extract_minimum {
180             my Cache::File::Heap $self = shift;
181             my $db = $self->_db;
182             my ($key, $val) = (0,0);
183             $db->seq($key, $val, R_FIRST)
184             and return undef;
185             $db->del_dup($key, $val);
186             return wantarray? ($key, $val) : $key;
187             }
188              
189             =item ($key, $vals) = $h->extract_minimum_dup()
190              
191             As for $h->minimum_dup(), but all the values are removed from the heap.
192              
193             =cut
194              
195             sub extract_minimum_dup {
196             my Cache::File::Heap $self = shift;
197             my $db = $self->_db;
198             my ($key, $val) = (0,0);
199             $db->seq($key, $val, R_FIRST)
200             and return undef;
201             my @values = $db->get_dup($key) if wantarray;
202             $db->del($key);
203             # bugfix for broken db1 - not all values are removed the first time
204             $db->del($key);
205             return wantarray? ($key, \@values) : $key;
206             }
207              
208             =back
209              
210             =cut
211              
212              
213             sub _db {
214             my Cache::File::Heap $self = shift;
215             my $db = $self->{db};
216             croak "Heap not opened" unless $db;
217             }
218              
219             sub _Num_Compare {
220             my ($key1, $key2) = @_;
221              
222             # somehow we can get undefined keys here? Probably a db bug.
223              
224             if (not defined $key1 and not defined $key2) {
225             return 0
226             }
227             elsif (defined $key1 and not defined $key2) {
228             return 1;
229             }
230             elsif (not defined $key1 and defined $key2) {
231             return -1;
232             }
233             else {
234             return $key1 <=> $key2;
235             }
236             }
237              
238              
239             1;
240             __END__