File Coverage

blib/lib/DiaColloDB/EnumFile/FixedLen.pm
Criterion Covered Total %
statement 15 135 11.1
branch 0 74 0.0
condition 0 46 0.0
subroutine 5 15 33.3
pod 9 10 90.0
total 29 280 10.3


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ## File: DiaColloDB::EnumFile::FixedLen.pm
3             ## Author: Bryan Jurish <moocow@cpan.org>
4             ## Description: collocation db, symbol<->integer enum, fixed-length symbols
5              
6             package DiaColloDB::EnumFile::FixedLen;
7 1     1   8 use DiaColloDB::EnumFile;
  1         5  
  1         31  
8 1     1   6 use DiaColloDB::Logger;
  1         3  
  1         28  
9 1     1   6 use DiaColloDB::Utils qw(:fcntl :file :json :regex :pack);
  1         2  
  1         83  
10 1     1   473 use Fcntl qw(:DEFAULT :seek);
  1         3  
  1         34  
11 1     1   500 use strict;
  1         3  
  1         2179  
12              
13             ##==============================================================================
14             ## Globals & Constants
15              
16             our @ISA = qw(DiaColloDB::EnumFile);
17              
18             ##==============================================================================
19             ## Constructors etc.
20              
21             ## $enum = CLASS_OR_OBJECT->new(%args)
22             ## + %args, object structure:
23             ## (
24             ## ##-- EnumFile: basic options
25             ## base => $base, ##-- database basename; use files "${base}.fsx", "${base}.fix", "${base}.hdr"
26             ## perms => $perms, ##-- default: 0666 & ~umask
27             ## flags => $flags, ##-- default: 'r'
28             ## pack_i => $pack_i, ##-- integer pack template (default='N')
29             ## #pack_o => $pack_o, ##-- file offset pack template (default='N') ; OVERRIDE:unused
30             ## #pack_l => $pack_l, ##-- string-length pack template (default='n'); OVERRIDE:unused
31             ## pack_s => $pack_s, ##-- string pack template for text i/o; OVERRIDE:REQUIRED (default='Nn')
32             ## size => $size, ##-- number of mapped symbols, like scalar(@i2s)
33             ## utf8 => $bool, ##-- true iff strings are stored as utf8 (used by re2i()) OVERRIDE: unused
34             ## ##
35             ## ##-- EnumFile: in-memory construction
36             ## s2i => \%s2i, ##-- maps symbols to integers
37             ## i2s => \@i2s, ##-- maps integers to symbols
38             ## dirty => $bool, ##-- true if in-memory structures are not in-sync with file data
39             ## loaded => $bool, ##-- true if file data has been loaded to memory
40             ## shared => $bool, ##-- true to avoid closing filehandles on close() or DESTROY() (default=false)
41             ## ##
42             ## ##-- EnumFile: pack lengths (after open())
43             ## len_i => $len_i, ##-- packsize($pack_i)
44             ## #len_o => $len_o, ##-- packsize($pack_o) ; OVERRIDE: unused
45             ## #len_l => $len_l, ##-- packsize($pack_l) ; OVERRIDE: unused
46             ## len_s => $len_s, ##-- packsize($pack_s); OVERRIDE: new
47             ## len_sx => $len_sx, ##-- $len_s + $len_i ; OVERRIDE: new value
48             ## ##
49             ## ##-- EnumFile: filehandles (after open())
50             ## #sfh => $sfh, ##-- $base.es : OVERRIDE: unused
51             ## ixfh => $ixfh, ##-- $base.fix : [$i] => pack("${pack_s}", $s_with_id_i) : OVERRIDE: new extension, new format
52             ## sxfh => $sxfh, ##-- $base.fsx : [$j] => pack("${pack_s}${pack_i}", $s_with_sortorder_j_and_id_i, $i) : OVERRIDE: new extension, new format
53             ## )
54             sub new {
55 0     0 1   my $that = shift;
56 0           return $that->SUPER::new(
57             utf8 => 0,
58             pack_s => 'Nn',
59             @_, ##-- user arguments
60             );
61             }
62              
63             ##==============================================================================
64             ## I/O
65              
66             ##--------------------------------------------------------------
67             ## I/O: open/close (file)
68              
69             ## $enum_or_undef = $enum->open($base,$flags)
70             ## $enum_or_undef = $enum->open($base)
71             ## $enum_or_undef = $enum->open()
72             ## + opens file(s), clears {loaded} flag
73             sub open {
74 0     0 1   my ($enum,$base,$flags) = @_;
75 0   0       $base //= $enum->{base};
76 0   0       $flags //= $enum->{flags};
77 0 0         $enum->close() if ($enum->opened);
78 0           $enum->{base} = $base;
79 0           $enum->{flags} = $flags = fcflags($flags);
80 0 0 0       if (fcread($flags) && !fctrunc($flags)) {
81 0 0         $enum->loadHeader()
82             or $enum->logconess("failed to load header from '$enum->{base}.hdr': $!");
83             return $enum->promote($enum->{hclass})->open($base,$flags)
84 0 0 0       if ($enum->{hclass} && !$enum->isa($enum->{hclass})); ##-- auto-promote based on header data
85             }
86              
87             $enum->{sxfh} = fcopen("$base.fsx", $flags, $enum->{perms})
88 0 0         or $enum->logconfess("open failed for $base.fsx: $!");
89             $enum->{ixfh} = fcopen("$base.fix", $flags, $enum->{perms})
90 0 0         or $enum->logconfess("open failed for $base.fix: $!");
91              
92             ##-- pack lengths
93 0           $enum->{len_i} = packsize($enum->{pack_i});
94 0           $enum->{len_s} = packsize($enum->{pack_s});
95 0           $enum->{len_sx} = $enum->{len_s} + $enum->{len_i};
96              
97             ##-- flags
98 0           $enum->{loaded} = 0;
99              
100             ##-- cleanup
101 0           delete(@$enum{qw(pack_o len_o pack_l len_l sfh)});
102              
103 0           return $enum;
104             }
105              
106             ## $enum_or_undef = $enum->close()
107             ## + INHERITED
108              
109             ## $bool = $enum->opened()
110             sub opened {
111 0     0 1   my $enum = shift;
112             return
113             (
114             #defined($enum->{base}) &&
115             #defined($enum->{sfh}) &&
116             defined($enum->{ixfh})
117             && defined($enum->{sxfh})
118 0   0       );
119             }
120              
121             ## $bool = $enum->reopen()
122             ## + re-opens datafiles
123             sub reopen {
124 0     0 0   my $enum = shift;
125 0   0       my $base = $enum->{base} || "$enum";
126             return (
127             $enum->opened
128             #&& fh_reopen($enum->{sfh}, "$base.fs")
129             && fh_reopen($enum->{ixfh}, "$base.fix")
130 0   0       && fh_reopen($enum->{sxfh}, "$base.fsx")
131             );
132             }
133              
134             ## $bool = $enum->dirty()
135             ## + returns true iff some in-memory structures haven't been flushed to disk
136             ## + INHERITED
137              
138             ## $bool = $enum->loaded()
139             ## + returns true iff in-memory structures have been populated from disk
140             ## + INHERITED
141              
142             ## $bool = $enum->flush()
143             ## $bool = $enum->flush($force)
144             ## + flush in-memory structures to disk
145             ## + no-op unless $force or $enum->dirty() is true
146             ## + clobbers any old disk-file contents with in-memory maps
147             ## + enum must be opened in write-mode
148             ## + invalidates any old references to {s2i}, {i2s} (but doesn't empty them if you need to keep a reference)
149             ## + clears {dirty} flag
150             sub flush {
151 0     0 1   my ($enum,$force) = @_;
152 0 0 0       return undef if (!$enum->opened || !fcwrite($enum->{flags}));
153 0 0 0       return $enum if (!$force && !$enum->dirty);
154              
155             ##-- save header
156 0 0         $enum->saveHeader()
157             or $enum->logconfess("flush(): failed to store header $enum->{base}.hdr: $!");
158              
159 0           my ($ixfh,$sxfh) = @$enum{qw(ixfh sxfh)};
160 0           $ixfh->seek(0,SEEK_SET);
161 0           $sxfh->seek(0,SEEK_SET);
162              
163             ##-- dump $base.fix
164 0           my $i2s = $enum->{i2s};
165 0           my ($len_s,$pack_i,$pack_s) = @$enum{qw(len_s pack_i pack_s)};
166 0           my $i = 0;
167 0           my $null = "\0" x $len_s;
168 0           foreach (@$i2s) {
169 0   0       $_ //= $null;
170 0 0         $ixfh->print($_)
171             or $enum->logconfess("flush(): failed to write ix-record for id=$i to $enum->{base}.fix");
172 0           ++$i;
173             }
174 0           CORE::truncate($ixfh, $ixfh->tell());
175              
176             ##-- dump $base.fsx
177 0           foreach $i (sort {$i2s->[$a] cmp $i2s->[$b]} (0..$#$i2s)) {
  0            
178 0 0         $sxfh->print($i2s->[$i], pack($pack_i, $i))
179             or $enum->logconfess("flush(): failed to dump sx-record for id $i to $enum->{base}.fsx");
180             }
181 0           CORE::truncate($sxfh, $sxfh->tell());
182              
183             ##-- clear in-memory structures (but don't clobber existing references; used for xenum by DiaColloDB::create())
184 0           $enum->{i2s} = [];
185 0           $enum->{s2i} = {};
186 0           $enum->{dirty} = 0;
187              
188 0 0 0       $enum->reopen() or return undef if ((caller(1))[3] !~ /::close$/);
189 0           return $enum;
190             }
191              
192              
193             ##--------------------------------------------------------------
194             ## I/O: memory <-> file
195              
196             ## \@i2s = $enum->toArray()
197             sub toArray {
198 0     0 1   my $enum = shift;
199 0 0 0       return $enum->{i2s} if ($enum->loaded || !$enum->opened);
200              
201             #use bytes; ##-- deprecated in perl v5.18.2
202 0           my $ixfh = $enum->{ixfh};
203 0           my $ixlen = (-s $ixfh);
204 0           my ($ixbuf,@i2s);
205 0 0         CORE::seek($ixfh,0,SEEK_SET)
206             or $enum->logconfess("toArray(): seek(0) failed on $enum->{base}.fix: $!");
207 0 0         CORE::read($ixfh, $ixbuf, $ixlen)==$ixlen
208             or $enum->logconfess("toArray(): read() failed for $ixlen bytes from $enum->{base}.fix: $!");
209 0           @i2s = unpack("(A[$enum->{len_s}])*", $ixbuf);
210 0           undef $ixbuf;
211 0 0         push(@i2s, @{$enum->{i2s}}[scalar(@i2s)..$#{$enum->{i2s}}]) if ($enum->dirty);
  0            
  0            
212 0           return \@i2s;
213             }
214              
215             ## $enum = $enum->fromArray(\@i2s)
216             ## + clobbers $enum contents, steals \@i2s
217             ## + INHERITED
218              
219             ## $enum = $enum->fromHash(\%s2i)
220             ## + clobbers $enum contents, steals \%s2i
221             ## + INERHITED
222              
223             ## $enum = $enum->fromEnum($enum2)
224             ## + clobbers $enum contents, does NOT steal $enum2->{i2s}
225             ## + INHERITED
226              
227             ## $bool = $enum->load()
228             ## + loads files to memory; must be opened
229             ## + INHERITED
230              
231             ## $enum = $enum->save()
232             ## $enum = $enum->save($base)
233             ## + saves enum to $base; really just a wrapper for open() and flush()
234             ## + INHERITED
235              
236             ##--------------------------------------------------------------
237             ## I/O: header
238              
239             ## @keys = $coldb->headerKeys()
240             ## + keys to save as header
241             sub headerKeys {
242 0     0 1   my $enum = shift;
243 0           return grep {!m{(?:(?:pack|len)_[lo])$}} $enum->SUPER::headerKeys();
  0            
244             }
245              
246             ## $bool = $enum->loadHeader()
247             ## + INHERITED
248              
249             ## $bool = $enum->saveHeader()
250             ## + INHERITED
251              
252             ##--------------------------------------------------------------
253             ## I/O: text
254             ## + INHERITED
255              
256             ##==============================================================================
257             ## Methods: population (in-memory only)
258             ## + INHERITED
259              
260             ##==============================================================================
261             ## Methods: lookup
262              
263             ## $s_or_undef = $enum->i2s($i)
264             ## + in-memory cache overrides file contents
265             sub i2s {
266 0     0 1   my ($enum,$i) = @_;
267 0 0         return undef if ($i >= $enum->{size});
268              
269 0           my ($buf,$soff,$slen);
270 0 0         return $buf if (defined($buf=$enum->{i2s}[$i]));
271              
272 0 0         CORE::seek($enum->{ixfh}, $i*$enum->{len_s}, SEEK_SET)
273             or $enum->logconfess("i2s(): seek() failed on $enum->{base}.fix for i=$i");
274             CORE::read($enum->{ixfh},$buf,$enum->{len_s})==$enum->{len_s}
275 0 0         or $enum->logconfess("i2s(): read() failed on $enum->{base}.fix for i=$i");
276              
277 0           return $buf;
278             }
279              
280             ## $i_or_undef = $enum->s2i($s)
281             ## $i_or_undef = $enum->s2i($s, $ilo,$ihi)
282             ## + binary search; in-memory cache overrides file contents
283             sub s2i {
284 0     0 1   my ($enum,$key,$ilo,$ihi) = @_;
285              
286 0           my ($sxfh,$len_s,$len_sx) = @$enum{qw(sxfh len_s len_sx)};
287 0   0       $ilo //= 0;
288 0 0 0       $ihi //= $enum->{dirty} ? ((-s $sxfh)/$len_sx) : $enum->{size};
289              
290 0           my ($imid,$buf,$s,$si);
291 0 0         return $buf if (defined($buf=$enum->{s2i}{$key}));
292              
293 0           while ($ilo < $ihi) {
294 0           $imid = ($ihi+$ilo) >> 1;
295              
296             ##-- get sx-record @ $imid
297 0 0         CORE::seek($sxfh, $imid*$len_sx, SEEK_SET)
298             or $enum->logconfess("s2i(): seek() failed on $enum->{base}.fsx for item $imid");
299 0 0         CORE::read($sxfh, $buf, $len_s)==$len_s
300             or $enum->logconfess("s2i(): read() failed on $enum->{base}.fsx for item $imid");
301              
302 0 0         if ($buf lt $key) {
303 0           $ilo = $imid + 1;
304             } else {
305 0           $ihi = $imid;
306             }
307             }
308              
309             ##-- output
310 0 0         if ($ilo==$ihi) {
311             ##-- get sx-record @ $ilo
312 0 0         CORE::seek($sxfh, $ilo*$len_sx, SEEK_SET)
313             or $enum->logconfess("s2i(): seek() failed on $enum->{base}.fsx for item $imid");
314 0 0         CORE::read($sxfh, $buf, $len_sx)==$len_sx
315             or $enum->logconfess("s2i(): read() failed on $enum->{base}.fsx for item $imid");
316 0           ($s,$si) = unpack($enum->{pack_s}.$enum->{pack_i}, $buf);
317              
318 0 0         return $si if ($buf eq $key);
319             }
320              
321 0           return undef;
322             }
323              
324              
325             ## \@is = $enum->re2i($regex, $pack_s)
326             ## + gets indices for all (packed) strings matching $regex
327             ## + if $pack_s is specified, is will be used to unpack strings (default=$enum->{pack_s}), only the first unpacked element will be tested
328             sub re2i {
329             #use bytes; ##-- deprecated in perl v5.18.2
330 0     0 1   my ($enum,$re,$pack_s) = @_;
331 0 0         $re = regex($re) if (!ref($re));
332              
333 0   0       $pack_s //= $enum->{pack_s};
334 0           my $i2s = $enum->{i2s};
335              
336 0 0 0       if ($enum->loaded || !$enum->opened) {
337             ##-- easy answer: loaded
338 0 0         if ($pack_s) {
339 0           my ($s);
340 0           return [grep {($s)=unpack($pack_s,$i2s->[$_]); $s =~ $re} [0..$#$i2s]];
  0            
  0            
341             } else {
342 0           return [grep {$i2s->[$_] =~ $re} [0..$#$i2s]];
  0            
343             }
344             }
345              
346             ##-- iteration a la toArray
347 0           my $ixfh = $enum->{ixfh};
348 0           my $len_s = $enum->{len_s};
349 0           my @is = qw();
350 0           my ($i,$buf);
351 0           for ($i=0,CORE::seek($ixfh,0,SEEK_SET); !eof($ixfh); ++$i) {
352 0 0         CORE::read($ixfh, $buf, $len_s)==$len_s
353             or $enum->logconfess("re2i(): read() failed for $len_s bytes from $enum->{base}.fix: $!");
354 0 0         ($buf) = unpack($pack_s, $buf) if ($pack_s);
355 0 0         push(@is, $i) if ($buf =~ $re);
356             }
357              
358             ##-- append expansions from in-memory cache
359 0 0         if ($enum->dirty) {
360 0 0         if ($pack_s) {
361 0           my ($s);
362 0           push(@is, grep {($s)=unpack($pack_s,$i2s->[$_]); $s =~ $re} (((-s $ixfh)/$len_s)..$#$i2s));
  0            
  0            
363             } else {
364 0           push(@is, grep {$i2s->[$_] =~ $re} (((-s $ixfh)/$len_s)..$#$i2s));
  0            
365             }
366             }
367              
368 0           return \@is;
369             }
370              
371              
372              
373             ##==============================================================================
374             ## Footer
375             1;
376              
377             __END__
378              
379              
380              
381