File Coverage

blib/lib/Bot/Cobalt/DB.pm
Criterion Covered Total %
statement 12 14 85.7
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 17 19 89.4


line stmt bran cond sub pod time code
1             package Bot::Cobalt::DB;
2             $Bot::Cobalt::DB::VERSION = '0.021001';
3             ## Uses proper retie-after-lock technique for locking
4              
5 5     5   59305 use v5.10;
  5         12  
6 5     5   786 use strictures 2;
  5         2120  
  5         130  
7 5     5   621 use Carp;
  5         5  
  5         214  
8              
9 5     5   1706 use List::Objects::WithUtils;
  5         2448  
  5         25  
10              
11 5     5   202749 use DB_File;
  0            
  0            
12             use Fcntl qw/:DEFAULT :flock/;
13             use IO::File;
14              
15             use Bot::Cobalt::Serializer;
16             use Bot::Cobalt::Common ':types';
17              
18             use Time::HiRes 'sleep';
19              
20              
21             use Moo;
22              
23             has file => (
24             required => 1,
25             is => 'rw',
26             isa => (Str | Object),
27             );
28             { no warnings 'once'; *File = *file; }
29              
30             has perms => (
31             is => 'rw',
32             builder => sub { 0644 },
33             );
34             { no warnings 'once'; *Perms = *perms; }
35              
36             has raw => (
37             is => 'rw',
38             isa => Bool,
39             builder => sub { 0 },
40             );
41             { no warnings 'once'; *Raw = *raw; }
42              
43             has timeout => (
44             is => 'rw',
45             isa => Num,
46             builder => sub { 5 },
47             );
48             { no warnings 'once'; *Timeout = *timeout; }
49              
50             has serializer => (
51             lazy => 1,
52             is => 'rw',
53             isa => Object,
54             builder => sub {
55             Bot::Cobalt::Serializer->new(Format => 'JSON')
56             },
57             );
58             { no warnings 'once'; *Serializer = *serializer; }
59              
60             ## _orig is the original tie().
61             has _orig => (
62             is => 'rw',
63             isa => HashRef,
64             builder => sub { {} },
65             );
66              
67             ## tied is the re-tied DB hash.
68             has tied => (
69             is => 'rw',
70             isa => HashRef,
71             builder => sub { {} },
72             );
73             { no warnings 'once'; *Tied = *tied; }
74              
75             has _lockfh => (
76             lazy => 1,
77             is => 'rw',
78             isa => FileHandle,
79             predicate => '_has_lockfh',
80             clearer => '_clear_lockfh',
81             );
82              
83             ## LOCK_EX or LOCK_SH for current open
84             has _lockmode => (
85             lazy => 1,
86             is => 'rw',
87             predicate => '_has_lockmode',
88             clearer => '_clear_lockmode',
89             );
90              
91             ## DB object.
92             has DB => (
93             lazy => 1,
94             is => 'rw',
95             isa => Object,
96             predicate => 'has_DB',
97             clearer => 'clear_DB',
98             );
99              
100             has is_open => (
101             is => 'rw',
102             isa => Bool,
103             default => sub { 0 },
104             );
105              
106             sub BUILDARGS {
107             my ($class, @args) = @_;
108             return +{ file => $args[0] } if @args == 1;
109             # Back-compat and I hate myself
110             my %opt = @args;
111             my $lower = array( qw/
112             File
113             Perms
114             Raw
115             Timeout
116             Serializer
117             Tied
118             / );
119             for my $key (%opt) {
120             if ( $lower->has_any(sub { $_ eq $key }) ) {
121             my $val = delete $opt{$key};
122             $opt{lc $key} = $val
123             }
124             }
125             \%opt
126             }
127              
128             sub DESTROY {
129             my ($self) = @_;
130             $self->dbclose if $self->is_open;
131             }
132              
133             sub dbopen {
134             my ($self, %args) = @_;
135             $args{lc $_} = delete $args{$_} for keys %args;
136              
137             ## per-open timeout was specified:
138             $self->timeout( $args{timeout} ) if $args{timeout};
139              
140             if ($self->is_open) {
141             carp "Attempted dbopen() on already-open DB";
142             return
143             }
144              
145             my ($lflags, $fflags);
146             if ($args{ro} || $args{readonly}) {
147             $lflags = LOCK_SH | LOCK_NB ;
148             $fflags = O_CREAT | O_RDONLY ;
149             $self->_lockmode(LOCK_SH);
150             } else {
151             $lflags = LOCK_EX | LOCK_NB;
152             $fflags = O_CREAT | O_RDWR ;
153             $self->_lockmode(LOCK_EX);
154             }
155              
156             my $path = $self->file;
157              
158             ## proper DB_File locking:
159             ## open and tie the DB to _orig
160             ## set up object
161             ## call a sync() to create if needed
162             my $orig_db = tie %{ $self->_orig }, "DB_File", $path,
163             $fflags, $self->perms, $DB_HASH
164             or confess "failed db open: $path: $!" ;
165             $orig_db->sync();
166              
167             ## dup a FH to $db->fd for _lockfh
168             my $fd = $orig_db->fd;
169             my $fh = IO::File->new("<&=$fd")
170             or confess "failed dup in dbopen: $!";
171              
172             my $timer = 0;
173             my $timeout = $self->timeout;
174              
175             ## flock _lockfh
176             until ( flock $fh, $lflags ) {
177             if ($timer > $timeout) {
178             warn "failed lock for db $path, timeout (${timeout}s)\n";
179             undef $orig_db; undef $fh;
180             untie %{ $self->_orig };
181             return
182             }
183              
184             sleep 0.01;
185             $timer += 0.01;
186             }
187              
188             ## reopen DB to Tied
189             my $db = tie %{ $self->tied }, "DB_File", $path,
190             $fflags, $self->perms, $DB_HASH
191             or confess "failed db reopen: $path: $!";
192              
193             ## preserve db obj and lock fh
194             $self->is_open(1);
195             $self->_lockfh($fh);
196             $self->DB($db);
197             undef $orig_db;
198              
199             ## install filters
200             ## null-terminated to be C-compat
201             $self->DB->filter_fetch_key(
202             sub { s/\0$// }
203             );
204             $self->DB->filter_store_key(
205             sub { $_ .= "\0" }
206             );
207              
208             ## JSONified values
209             $self->DB->filter_fetch_value(
210             sub {
211             s/\0$//;
212             $_ = $self->serializer->ref_from_json($_)
213             unless $self->raw;
214             }
215             );
216             $self->DB->filter_store_value(
217             sub {
218             $_ = $self->serializer->json_from_ref($_)
219             unless $self->raw;
220             $_ .= "\0";
221             }
222             );
223              
224             1
225             }
226              
227             sub dbclose {
228             my ($self) = @_;
229              
230             unless ($self->is_open) {
231             carp "attempted dbclose on unopened db";
232             return
233             }
234              
235             if ($self->_lockmode == LOCK_EX) {
236             $self->DB->sync();
237             }
238              
239             $self->clear_DB;
240             untie %{ $self->tied }
241             or carp "dbclose: untie tied: $!";
242              
243             flock( $self->_lockfh, LOCK_UN )
244             or carp "dbclose: unlock: $!";
245              
246             untie %{ $self->_orig }
247             or carp "dbclose: untie _orig: $!";
248              
249             $self->_clear_lockfh;
250             $self->_clear_lockmode;
251              
252             $self->is_open(0);
253              
254             return 1
255             }
256              
257             sub get_tied {
258             my ($self) = @_;
259             confess "attempted to get_tied on unopened db"
260             unless $self->is_open;
261              
262             $self->tied
263             }
264              
265             sub get_db {
266             my ($self) = @_;
267             confess "attempted to get_db on unopened db"
268             unless $self->is_open;
269              
270             $self->DB
271             }
272              
273             sub dbkeys {
274             my ($self) = @_;
275             confess "attempted 'dbkeys' on unopened db"
276             unless $self->is_open;
277              
278             wantarray ?
279             (keys %{ $self->tied })
280             : scalar keys %{ $self->tied }
281             }
282              
283             sub get {
284             my ($self, $key) = @_;
285             confess "attempted 'get' on unopened db"
286             unless $self->is_open;
287              
288             exists $self->Tied->{$key} ? $self->tied->{$key} : ()
289             }
290              
291             sub put {
292             my ($self, $key, $value) = @_;
293             confess "attempted 'put' on unopened db"
294             unless $self->is_open;
295              
296             $self->tied->{$key} = $value
297             }
298              
299             sub del {
300             my ($self, $key) = @_;
301             confess "attempted 'del' on unopened db"
302             unless $self->is_open;
303              
304             return unless exists $self->tied->{$key};
305              
306             delete $self->tied->{$key};
307              
308             1
309             }
310              
311             sub dbdump {
312             my ($self, $format) = @_;
313             confess "attempted dbdump on unopened db"
314             unless $self->is_open;
315             $format = 'YAMLXS' unless $format;
316              
317             ## shallow copy to drop tied()
318             my %copy = %{ $self->tied };
319             return \%copy if lc($format) eq 'hash';
320              
321             my $dumper = Bot::Cobalt::Serializer->new( Format => $format );
322              
323             $dumper->freeze(\%copy)
324             }
325              
326             1;
327             __END__