File Coverage

blib/lib/DiaColloDB/Compat/v0_08/MultiMapFile.pm
Criterion Covered Total %
statement 21 95 22.1
branch 0 44 0.0
condition 0 25 0.0
subroutine 7 13 53.8
pod 5 5 100.0
total 33 182 18.1


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ## File: DiaColloDB::Compat::v0_08::MultiMapFile
3             ## Author: Bryan Jurish <moocow@cpan.org>
4             ## Description: collocation db, integer->integer* multimap file, e.g. for expansion indices (v0.08.x format)
5              
6             package DiaColloDB::Compat::v0_08::MultiMapFile;
7 1     1   6 use DiaColloDB::MultiMapFile;
  1         3  
  1         26  
8 1     1   5 use DiaColloDB::Compat;
  1         1  
  1         14  
9 1     1   4 use DiaColloDB::Logger;
  1         2  
  1         12  
10 1     1   4 use DiaColloDB::Persistent;
  1         2  
  1         16  
11 1     1   5 use DiaColloDB::Utils qw(:fcntl :json :pack);
  1         2  
  1         29  
12 1     1   282 use Fcntl qw(:DEFAULT :seek);
  1         2  
  1         27  
13 1     1   394 use strict;
  1         2  
  1         1125  
14              
15             ##==============================================================================
16             ## Globals & Constants
17              
18             our @ISA = qw(DiaColloDB::MultiMapFile DiaColloDB::Compat);
19              
20             ##==============================================================================
21             ## Constructors etc.
22              
23             ## $cldb = CLASS_OR_OBJECT->new(%args)
24             ## + %args, object structure:
25             ## (
26             ## base => $base, ##-- database basename; use files "${base}.ma", "${base}.mb", "${base}.hdr"
27             ## perms => $perms, ##-- default: 0666 & ~umask
28             ## flags => $flags, ##-- default: 'r'
29             ## pack_i => $pack_i, ##-- integer pack template (default='N')
30             ## pack_o => $pack_o, ##-- file offset pack template (default='N')
31             ## pack_l => $pack_l, ##-- set-length pack template (default='N')
32             ## size => $size, ##-- number of mapped , like scalar(@data)
33             ## ##
34             ## ##-- in-memory construction
35             ## a2b => \@a2b, ##-- maps source integers to (packed) target integer-sets: [$a] => pack("${pack_i}*", @bs)
36             ## ##
37             ## ##-- computed pack-templates and -lengths (after open())
38             ## pack_a => $pack_a, ##-- "${pack_i}"
39             ## pack_b => $pack_a, ##-- "${pack_i}*"
40             ## len_i => $len_i, ##-- bytes::length(pack($pack_i,0))
41             ## len_o => $len_o, ##-- bytes::length(pack($pack_o,0))
42             ## len_l => $len_l, ##-- bytes::length(pack($pack_l,0))
43             ## ##
44             ## ##-- filehandles (after open())
45             ## afh => $afh, ##-- $base.ma : [$a] => pack(${pack_o}, $boff_a)
46             ## bfh => $bfh, ##-- $base.mb : $boff_a : pack("${pack_l}/(${pack_i}*)", @targets_for_a)
47             ## )
48             sub new {
49 0     0 1   my $that = shift;
50 0   0       my $mmf = bless({
51             base => undef,
52             perms => (0666 & ~umask),
53             flags => 'r',
54             size => 0,
55             pack_i => 'N',
56             pack_o => 'N',
57             pack_l => 'N',
58              
59             a2b=>[],
60              
61             #len_i => undef,
62             #len_o => undef,
63             #len_l => undef,
64             #len_a => undef,
65             #pack_a => undef,
66             #pack_b => undef,
67              
68             #afh =>undef,
69             #bfh =>undef,
70              
71             @_, ##-- user arguments
72             },
73             ref($that)||$that);
74 0           $mmf->{class} = ref($mmf);
75 0   0       $mmf->{a2b} //= [];
76 0 0         return defined($mmf->{base}) ? $mmf->open($mmf->{base}) : $mmf;
77             }
78              
79             sub DESTROY {
80 0 0   0     $_[0]->close() if ($_[0]->opened);
81             }
82              
83             ##==============================================================================
84             ## I/O
85              
86             ##--------------------------------------------------------------
87             ## I/O: open/close (file)
88              
89             ## $mmf_or_undef = $mmf->open($base,$flags)
90             ## $mmf_or_undef = $mmf->open($base)
91             ## $mmf_or_undef = $mmf->open()
92             sub open {
93 0     0 1   my ($mmf,$base,$flags) = @_;
94 0   0       $base //= $mmf->{base};
95 0   0       $flags //= $mmf->{flags};
96 0 0         $mmf->close() if ($mmf->opened);
97 0           $mmf->{base} = $base;
98 0           $mmf->{flags} = $flags = fcflags($flags);
99 0 0 0       if (fcread($flags) && !fctrunc($flags)) {
100 0 0         $mmf->loadHeader()
101             or $mmf->logconess("failed to load header from '$mmf->{base}.hdr': $!");
102             }
103              
104             $mmf->{afh} = fcopen("$base.ma", $flags, $mmf->{perms})
105 0 0         or $mmf->logconfess("open failed for $base.ma: $!");
106             $mmf->{bfh} = fcopen("$base.mb", $flags, $mmf->{perms})
107 0 0         or $mmf->logconfess("open failed for $base.mb: $!");
108 0           binmode($_,':raw') foreach (@$mmf{qw(afh bfh)});
109              
110             ##-- computed pack lengths & templates
111 0   0       $mmf->{pack_o} //= $mmf->{pack_i};
112 0   0       $mmf->{pack_l} //= $mmf->{pack_i};
113 0           $mmf->{pack_a} = $mmf->{pack_i};
114 0           $mmf->{pack_b} = $mmf->{pack_i}."*";
115 0           $mmf->{len_i} = packsize($mmf->{pack_i});
116 0           $mmf->{len_o} = packsize($mmf->{pack_o});
117 0           $mmf->{len_l} = packsize($mmf->{pack_l});
118 0           $mmf->{len_a} = $mmf->{len_o} + $mmf->{len_l};
119              
120 0           return $mmf;
121             }
122              
123             ## $mmf_or_undef = $mmf->close()
124             ## + INHERITED from MultiMapFile
125              
126             ## $bool = $mmf->opened()
127             ## + INHERITED from MultiMapFile
128              
129             ## $bool = $mmf->dirty()
130             ## + returns true iff some in-memory structures haven't been flushed to disk
131             ## + INHERITED from MultiMapFile
132              
133             ## $bool = $mmf->flush()
134             ## + flush in-memory structures to disk
135             ## + clobbers any old disk-file contents with in-memory maps
136             ## + file must be opened in write-mode
137             ## + invalidates any old references to {a2b} (but doesn't empty them if you need to keep a reference)
138             sub flush {
139 0     0 1   my $mmf = shift;
140 0 0 0       return undef if (!$mmf->opened || !fcwrite($mmf->{flags}));
141 0 0         return $mmf if (!$mmf->dirty);
142              
143             ##-- save header
144 0 0         $mmf->saveHeader()
145             or $mmf->logconfess("flush(): failed to store header $mmf->{base}.hdr: $!");
146              
147             #use bytes; ##-- deprecated in perl v5.18.2
148 0           my ($afh,$bfh) = @$mmf{qw(afh bfh)};
149 0           $afh->seek(0,SEEK_SET);
150 0           $bfh->seek(0,SEEK_SET);
151              
152             ##-- dump datafiles $base.ma, $base.mb
153 0           my ($a2b,$pack_o,$pack_l,$len_l,$pack_i,$len_i) = @$mmf{qw(a2b pack_o pack_l len_l pack_i len_i)};
154 0           my $off = 0;
155 0           my $ai = 0;
156 0           my $bsz;
157 0           foreach (@$a2b) {
158 0   0       $_ //= '';
159 0           $bsz = length($_);
160 0 0         $afh->print(pack($pack_o, $off))
161             or $mmf->logconfess("flush(): failed to write source record for a=$ai to $mmf->{base}.ma");
162 0 0         $bfh->print(pack($pack_l, $bsz/$len_i), $_)
163             or $mmf->logconfess("flush(): failed to write targets for a=$ai to $mmf->{base}.mb");
164 0           $off += $len_l + $bsz;
165 0           ++$ai;
166             }
167              
168             ##-- truncate datafiles at current position
169 0           CORE::truncate($afh, $afh->tell());
170 0           CORE::truncate($bfh, $bfh->tell());
171              
172             ##-- clear in-memory structures (but don't clobber existing references)
173 0           $mmf->{a2b} = [];
174              
175 0           return $mmf;
176             }
177              
178              
179             ##--------------------------------------------------------------
180             ## I/O: memory <-> file
181              
182             ## \@a2b = $mmf->toArray()
183             sub toArray {
184 0     0 1   my $mmf = shift;
185 0 0         return $mmf->{a2b} if (!$mmf->opened);
186              
187             #use bytes; ##-- deprecated in perl v5.18.2
188 0           my ($pack_l,$len_l,$pack_i,$len_i) = @$mmf{qw(pack_l len_l pack_i len_i)};
189 0           my $bfh = $mmf->{bfh};
190 0           my @a2b = qw();
191 0           my ($buf,$bsz);
192 0           for (CORE::seek($bfh,0,SEEK_SET); !eof($bfh); ) {
193 0 0         CORE::read($bfh, $buf, $len_l)==$len_l
194             or $mmf->logconfess("toArray(): read() failed on $mmf->{base}.mb for target-set size at offset ", tell($bfh), ", item ", scalar(@a2b));
195 0           $bsz = $len_i * unpack($pack_l, $buf);
196              
197 0 0         CORE::read($bfh, $buf, $bsz)==$bsz
198             or $mmf->logconfess("toArray(): read() failed on $mmf->{base}.mb for target-set of $bsz bytes at offset ", tell($bfh), ", item ", scalar(@a2b));
199 0           push(@a2b, $buf);
200             }
201 0 0         push(@a2b, @{$mmf->{a2b}}[scalar(@a2b)..$#{$mmf->{a2b}}]) if ($mmf->dirty);
  0            
  0            
202 0           return \@a2b;
203             }
204              
205             ## $mmf = $mmf->fromArray(\@a2b)
206             ## + clobbers $mmf contents, steals \@a2b
207             ## + INHERITED from MultiMapFile
208              
209             ## $bool = $mmf->load()
210             ## + loads files to memory; must be opened
211             ## + INHERITED from MultiMapFile
212              
213             ## $mmf = $mmf->save()
214             ## $mmf = $mmf->save($base)
215             ## + saves multimap to $base; really just a wrapper for open() and flush()
216             ## + INHERITED from MultiMapFile
217              
218             ##--------------------------------------------------------------
219             ## I/O: header
220             ## + see also DiaColloDB::Persistent
221              
222             ## @keys = $coldb->headerKeys()
223             ## + keys to save as header
224             ## + INHERITED from MultiMapFile
225              
226             ## $bool = $CLASS_OR_OBJECT->loadHeader()
227             ## + wraps $CLASS_OR_OBJECT->loadHeaderFile($CLASS_OR_OBJ->headerFile())
228             ## + INHERITED from DiaColloDB::Persistent
229              
230             ## $bool = $mmf->loadHeaderData($hdr)
231             ## + INHERITED from MultiMapFile
232              
233             ## $bool = $enum->saveHeader()
234             ## + inherited from DiaColloDB::Persistent
235              
236             ##--------------------------------------------------------------
237             ## I/O: text
238              
239             ## $bool = $obj->loadTextFile($filename_or_handle, %opts)
240             ## + wraps loadTextFh()
241             ## + INHERITED from DiaColloDB::Persistent
242              
243             ## $mmf = $CLASS_OR_OBJECT->loadTextFh($fh)
244             ## + loads from text file with lines of the form "A B1 B2..."
245             ## + clobbers multimap contents
246             ## + INHERITED from MultiMapFile
247              
248             ## $bool = $obj->saveTextFile($filename_or_handle, %opts)
249             ## + wraps saveTextFh()
250             ## + INHERITED from DiaColloDB::Persistent
251              
252             ## $bool = $mmf->saveTextFh($filename_or_fh,%opts)
253             ## + save from text file with lines of the form "A B1 B2..."
254             ## + %opts:
255             ## a2s=>\&a2s ##-- stringification code for A items, called as $s=$a2s->($bi)
256             ## b2s=>\&b2s ##-- stringification code for B items, called as $s=$b2s->($bi)
257             ## + INHERITED from MultiMapFile
258              
259             ##==============================================================================
260             ## Methods: population (in-memory only)
261              
262             ## $newsize = $mmf->addPairs($a,@bs)
263             ## $newsize = $mmf->addPairs($a,\@bs)
264             ## + adds mappings $a=>$b foreach $b in @bs
265             ## + multimap must be loaded to memory
266             ## + INHERITED from MultiMapFile
267              
268             ##==============================================================================
269             ## Methods: lookup
270              
271             ## $bs_packed = $mmf->fetchraw($a)
272             sub fetchraw {
273 0     0 1   my ($mmf,$a) = @_;
274 0 0         return '' if (!defined($a));
275              
276 0           my ($boff,$bsz,$buf);
277 0 0         CORE::seek($mmf->{afh}, $a*$mmf->{len_o}, SEEK_SET)
278             or $mmf->logconfess("fetch(): seek() failed on $mmf->{base}.ma for a=$a");
279             CORE::read($mmf->{afh},$buf,$mmf->{len_o})==$mmf->{len_o}
280 0 0         or $mmf->logconfess("fetch(): read() failed on $mmf->{base}.ma for a=$a");
281 0           $boff = unpack($mmf->{pack_o},$buf);
282              
283 0 0         CORE::seek($mmf->{bfh}, $boff, SEEK_SET)
284             or $mmf->logconfess("fetch(): seek() failed on $mmf->{base}.mb to offset $boff for a=$a");
285             CORE::read($mmf->{bfh}, $buf,$mmf->{len_l})==$mmf->{len_l}
286 0 0         or $mmf->logconfess("fetch(): read() failed on $mmf->{base}.mb for target-set length at offset $boff for a=$a");
287 0           $bsz = $mmf->{len_i} * unpack($mmf->{pack_l},$buf);
288              
289 0 0         CORE::read($mmf->{bfh}, $buf, $bsz)==$bsz
290             or $mmf->logconfess("fetch(): read() failed on $mmf->{base}.mb for target-set of size $bsz bytes at offset $boff for a=$a");
291              
292 0           return $buf;
293             }
294              
295             ## \@bs_or_undef = $mmf->fetch($a)
296             ## + returns array \@bs of targets for $a, or undef if not found
297             ## + multimap must be opened
298             ## + INHERITED from MultiMapFile
299              
300             ##==============================================================================
301             ## Footer
302             1;
303              
304             __END__
305              
306              
307              
308