File Coverage

blib/lib/DiaColloDB/PackedFile.pm
Criterion Covered Total %
statement 32 248 12.9
branch 0 142 0.0
condition 0 72 0.0
subroutine 10 48 20.8
pod 32 33 96.9
total 74 543 13.6


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ## File: DiaColloDB::PackedFile.pm
3             ## Author: Bryan Jurish <moocow@cpan.org>
4             ## Description: collocation db: flat fixed-length record-oriented files
5              
6             package DiaColloDB::PackedFile;
7 1     1   9 use DiaColloDB::Logger;
  1         3  
  1         38  
8 1     1   7 use DiaColloDB::Persistent;
  1         2  
  1         27  
9 1     1   7 use DiaColloDB::Utils qw(:fcntl :file :pack);
  1         3  
  1         50  
10 1     1   389 use Tie::Array;
  1         2  
  1         28  
11 1     1   6 use Fcntl;
  1         2  
  1         59  
12 1     1   417 use IO::File;
  1         2  
  1         53  
13 1     1   266 use Carp;
  1         2  
  1         27  
14 1     1   115 use strict;
  1         2  
  1         1023  
15              
16             ##==============================================================================
17             ## Globals & Constants
18              
19             our @ISA = qw(DiaColloDB::Persistent Tie::Array);
20              
21             ##==============================================================================
22             ## Constructors etc.
23              
24             ## $pf = CLASS_OR_OBJECT->new(%opts)
25             ## + %opts, %$pf:
26             ## ##-- user options
27             ## file => $filename, ##-- default: undef (none)
28             ## flags => $flags, ##-- fcntl flags or open-mode (default='r')
29             ## perms => $perms, ##-- creation permissions (default=(0666 &~umask))
30             ## reclen => $reclen, ##-- record-length in bytes: (default: guess from pack format if available)
31             ## packas => $packas, ##-- pack-format or array; see DiaColloDB::Utils::packFilterStore();
32             ## temp => $bool, ##-- if true, data file(s) will be unlinked on DESTROY
33             ## ##
34             ## ##-- filters
35             ## filter_fetch => $filter, ##-- DB_File-style filter for fetch
36             ## filter_store => $filter, ##-- DB_File-style filter for store
37             ## ##
38             ## ##-- low-level data
39             ## fh => $fh, ##-- underlying filehandle
40             sub new {
41 0     0 1   my $that = shift;
42 0   0       my $pf = bless({
43             file => undef,
44             flags => 'r',
45             perms => (0666 & ~umask),
46             reclen => undef,
47             temp => 0,
48             #packas => undef,
49              
50             ##-- filters
51             #filter_fetch => undef,
52             #filter_store => undef,
53              
54             ##-- low level data
55             #fh => undef,
56              
57             ##-- user args
58             @_
59             }, ref($that)||$that);
60 0           $pf->{class} = ref($pf);
61 0 0         return $pf->open() if (defined($pf->{file}));
62 0           return $pf;
63             }
64              
65             sub DESTROY {
66 0     0     my $obj = $_[0];
67 0 0         $obj->unlink() if ($obj->{temp});
68             }
69              
70             ##==============================================================================
71             ## API: open/close
72              
73             ## $pf = $pf->open()
74             ## $pf = $pf->open($file)
75             ## $pf = $pf->open($file,$flags,%opts)
76             ## + %opts are as for new()
77             ## + $file defaults to $pf->{file}
78             sub open {
79 0     0 1   my ($pf,$file,$flags,%opts) = @_;
80 0 0         $pf->close() if ($pf->opened);
81 0           @$pf{keys %opts} = values(%opts);
82 0   0       $flags = $pf->{flags} = fcflags($flags // $pf->{flags});
83 0 0 0       return undef if (!defined($pf->{file} = $file = ($file // $pf->{file})));
84 0 0 0       return undef if (-f "$pf->{file}.hdr" && !$pf->loadHeader()); ##-- allow missing header files for old v0.01 PackedFile objects
85             $pf->{fh} = fcopen($file, $flags, $pf->{perms})
86 0 0         or return undef;
87 0           binmode($pf->{fh},':raw');
88 0           $pf->setFilters();
89 0           return $pf;
90             }
91              
92             ## $bool = $pf->opened()
93             sub opened {
94 0     0 1   return defined($_[0]{fh});
95             }
96              
97             ## $bool = $pf->reopen()
98             ## + re-opens datafile
99             sub reopen {
100 0     0 0   my $pf = shift;
101 0   0       my $file = $pf->{file} || "$pf";
102 0   0       return $pf->opened && fh_reopen($pf->{fh}, $file);
103             }
104              
105             ## $bool = $pf->close()
106             sub close {
107 0     0 1   my $pf = shift;
108             my $rc = (($pf->opened && fcwrite($pf->{flags}) ? $pf->flush : 1)
109             &&
110 0   0       (defined($pf->{fh}) ? CORE::close($pf->{fh}) : 1));
111 0           delete $pf->{fh};
112 0           $pf->{size} = 0;
113 0           return $rc;
114             }
115              
116             ## $bool = $pf->setsize($nrecords)
117             sub setsize {
118 0 0   0 1   if ($_[1] > $_[0]->size) {
119             ##-- grow
120 0 0         CORE::seek($_[0]{fh}, $_[1]*$_[0]{reclen}-1, SEEK_SET)
121             or $_[0]->logconfess(__PACKAGE__, "::setsize() failed to grow file to $_[1] elements: $!");
122 0           $_[0]{fh}->print("\0");
123             }
124             else {
125             ##-- shrink
126             CORE::truncate($_[0]{fh}, $_[1]*$_[0]{reclen})
127 0 0         or $_[0]->logconfess(__PACKAGE__, "::setsize() failed to shrink file to $_[1] elements: $!");
128             }
129 0           return 1;
130             }
131              
132             ## $bool = $pf->truncate()
133             ## + truncates $pf->{fh} or $pf->{file}; otherwise a no-nop
134             sub truncate {
135 0     0 1   my $pf = shift;
136 0 0         if (defined($pf->{fh})) {
    0          
137 0           return CORE::truncate($pf->{fh},0) ;
138             }
139             elsif (defined($pf->{file})) {
140 0 0         my $fh = fcopen($pf->{file}, (O_WRONLY|O_CREAT|O_TRUNC)) or return undef;
141 0           return CORE::close($fh);
142             }
143 0           return undef;
144             }
145              
146             ## $bool = $pf->flush()
147             ## + attempt to flush underlying filehandle, may not work
148             sub flush {
149 0     0 1   my $pf = shift;
150 0 0 0       return undef if (!$pf->opened || !fcwrite($pf->{flags}));
151 0 0         $pf->saveHeader()
152             or $pf->logconfess("flush(): failed to store header file ", $pf->headerFile, ": $!");
153              
154             ##-- BUGHUNT/Birmingham: strangeness: tied @$docoff buffers seem not to get flushed
155             #return $pf->{fh}->flush() if (UNIVERSAL::can($pf->{fh},'flush'));
156             #return binmode($pf->{fh},':raw'); ##-- see perlfaq5(1) re: flushing filehandles
157              
158 0 0 0       $pf->reopen() or return undef if ((caller(1))[3] !~ /::close$/);
159 0           return $pf;
160             }
161              
162             ##==============================================================================
163             ## API: filters
164              
165             ## $pf = $pf->setFilters($packfmt)
166             ## $pf = $pf->setFilters([$packfmt, $unpackfmt])
167             ## $pf = $pf->setFilters([\&packsub,\&unpacksub])
168             ## + %opts : override (but don't clobber) $pf->{packfmt}
169             sub setFilters {
170 0     0 1   my ($pf,$packfmt) = @_;
171 0   0       $packfmt //= $pf->{packas};
172 0           $pf->{filter_fetch} = packFilterFetch($packfmt);
173 0           $pf->{filter_store} = packFilterStore($packfmt);
174 0 0 0       if (!defined($pf->{reclen}) && defined($pf->{filter_store})) {
175             ##-- guess record length from pack filter output
176             ##use bytes; ##-- deprecated in perl v5.18.2
177 1     1   12 no warnings;
  1         2  
  1         3062  
178 0           local $_ = 0;
179 0           $pf->{filter_store}->();
180 0 0         utf8::encode($_) if (utf8::is_utf8($_));
181 0           $pf->{reclen} = length($_);
182             }
183 0           return $pf;
184             }
185              
186             ##==============================================================================
187             ## API: positioning
188              
189             ## $nrecords = $pf->size()
190             ## + returns number of records
191             ## + doesn't handle recent writes correctly (probably due to perl i/o buffering)
192             sub size {
193 0 0   0 1   return undef if (!$_[0]{fh});
194 0           return (-s $_[0]{fh}) / $_[0]{reclen};
195             }
196              
197             ## $bool = $pf->seek($recno)
198             ## + seek to record-number $recno
199             sub seek {
200 0     0 1   CORE::seek($_[0]{fh}, $_[1]*$_[0]{reclen}, SEEK_SET);
201             }
202              
203             ## $recno = $pf->tell()
204             ## + report current record-number
205             sub tell {
206 0     0 1   return CORE::tell($_[0]{fh}) / $_[0]{reclen};
207             }
208              
209             ## $bool = $pf->reset();
210             ## + reset position to beginning of file
211             sub reset {
212 0     0 1   return $_[0]->seek(0);
213             }
214              
215             ## $bool = $pf->seekend()
216             ## + seek to end-of file
217             sub seekend {
218 0     0 1   CORE::seek($_[0]{fh}, 0, SEEK_END);
219             }
220              
221             ## $bool = $pf->eof()
222             ## + returns true iff current position is end-of-file
223             sub eof {
224 0     0 1   return CORE::eof($_[0]{fh});
225             }
226              
227             ##==============================================================================
228             ## API: record access
229              
230             ##--------------------------------------------------------------
231             ## API: record access: read
232              
233             ## $bool = $pf->read(\$buf)
234             ## + read a raw record into \$buf
235             sub read {
236 0     0 1   return CORE::read($_[0]{fh}, ${$_[1]}, $_[0]{reclen})==$_[0]{reclen};
  0            
237             }
238              
239             ## $bool = $pf->readraw(\$buf, $nrecords)
240             ## + batch-reads $nrecords into \$buf
241             sub readraw {
242 0     0 1   return CORE::read($_[0]{fh}, ${$_[1]}, $_[2]*$_[0]{reclen})==$_[2]*$_[0]{reclen};
  0            
243             }
244              
245             ## $value_or_undef = $pf->get()
246             ## + get (unpacked) value of current record, increments filehandle position to next record
247             sub get {
248 0     0 1   local $_=undef;
249 0 0         CORE::read($_[0]{fh}, $_, $_[0]{reclen})==$_[0]{reclen} or return undef;
250 0 0         $_[0]{filter_fetch}->() if ($_[0]{filter_fetch});
251 0           return $_;
252             }
253              
254             ## \$buf_or_undef = $pf->getraw(\$buf)
255             ## + get (packed) value of current record, increments filehandle position to next record
256             sub getraw {
257 0 0   0 1   CORE::read($_[0]{fh}, ${$_[1]}, $_[0]{reclen})==$_[0]{reclen} or return undef;
  0            
258 0           return $_[1];
259             }
260              
261             ## $value_or_undef = $pf->fetch($index)
262             ## + get (unpacked) value of record $index
263             sub fetch {
264 0     0 1   local $_=undef;
265 0 0         CORE::seek($_[0]{fh}, $_[1]*$_[0]{reclen}, SEEK_SET) or return undef;
266 0 0         CORE::read($_[0]{fh}, $_, $_[0]{reclen})==$_[0]{reclen} or return undef;
267 0 0         $_[0]{filter_fetch}->() if ($_[0]{filter_fetch});
268 0           return $_;
269             }
270              
271             ## $buf_or_undef = $pf->fetchraw($index,\$buf)
272             ## + get (packed) value of record $index
273             sub fetchraw {
274 0 0   0 1   CORE::seek($_[0]{fh}, $_[1]*$_[0]{reclen}, SEEK_SET) or return undef;
275 0 0         CORE::read($_[0]{fh}, ${$_[2]}, $_[0]{reclen})==$_[0]{reclen} or return undef;
  0            
276 0           return ${$_[2]};
  0            
277             }
278              
279             ##--------------------------------------------------------------
280             ## API: record access: write
281              
282             ## $bool = $pf->write($buf)
283             ## + write a raw record $buf to current position; increments position
284             sub write {
285 0     0 1   $_[0]{fh}->print($_[1]);
286             }
287              
288             ## $value_or_undef = $pf->set($value)
289             ## + set (packed) value of current record, increments filehandle position to next record
290             sub set {
291 0     0 1   local $_=$_[1];
292 0 0         $_[0]{filter_store}->() if ($_[0]{filter_store});
293 0 0         $_[0]{fh}->print($_) or return undef;
294 0           return $_[1];
295             }
296              
297             ## $value_or_undef = $pf->store($index,$value)
298             ## + store (packed) $value as record-number $index
299             sub store {
300 0 0   0 1   CORE::seek($_[0]{fh}, $_[1]*$_[0]{reclen}, SEEK_SET) or return undef;
301 0           local $_=$_[2];
302 0 0         $_[0]{filter_store}->() if ($_[0]{filter_store});
303 0 0         $_[0]{fh}->print($_) or return undef;
304 0           return $_[2];
305             }
306              
307             ## $value_or_undef = $pf->push($value)
308             ## + store (packed) $value at end of record
309             sub push {
310 0 0   0 1   CORE::seek($_[0]{fh}, 0, SEEK_END) or return undef;
311 0           local $_ = $_[1];
312 0 0         $_[0]{filter_store}->() if ($_[0]{filter_store});
313 0 0         $_[0]{fh}->print($_) or return undef;
314 0           return $_[1];
315             }
316              
317             ##==============================================================================
318             ## API: batch I/O
319              
320             ## \@data = $pf->toArray(%opts)
321             ## + read entire contents to an array
322             ## + %opts : override %$pf:
323             ## packas => $packas
324             sub toArray {
325 0     0 1   my ($pf,%opts) = @_;
326 0 0         $pf->setFilters($opts{packas}) if (exists($opts{packas}));
327 0           my ($fh,$filter_fetch,$reclen) = @$pf{qw(fh filter_fetch reclen)};
328 0           my @data = qw();
329 0           local $_;
330 0           $fh->seek(0,SEEK_SET);
331 0           while (!CORE::eof($fh)) {
332 0 0         CORE::read($fh, $_, $reclen)==$reclen
333             or $pf->logconfess("toArray(): failed to read $reclen bytes for record number ", scalar(@data), ": $!");
334 0 0         $filter_fetch->() if ($filter_fetch);
335 0           CORE::push(@data,$_);
336             }
337 0           $pf->setFilters();
338 0           return \@data;
339             }
340              
341             ## $pf = $pf->fromArray(\@data,%opts)
342             ## + write file contents from an array
343             ## + %opts : override %$pf:
344             ## packas => $packas
345             sub fromArray {
346 0     0 1   my ($pf,$data,%opts) = @_;
347 0 0         $pf->setFilters($opts{packas}) if (exists($opts{packas}));
348 0           my ($fh,$filter_store) = @$pf{qw(fh filter_store)};
349 0           local $_;
350 0 0         $pf->setsize(scalar @$data)
351             or $pf->logconfess("fromArray(): failed to set file size = ", scalar(@$data), ": $!");
352 0           $fh->seek(0,SEEK_SET);
353 0           my $i = 0;
354 0           foreach (@$data) {
355 0 0         $filter_store->() if ($filter_store);
356 0 0         $fh->print($_)
357             or $pf->logconfess("fromArray(): failed to write record number $i: $!");
358 0           ++$i;
359             }
360 0           $pf->setFilters();
361 0           return $pf;
362             }
363              
364             ## $pdl = $pf->toPdl(%options)
365             ## + returns a piddle for $pf
366             ## + %options:
367             ## type => $pdl_type, ##-- pdl type (default:'auto':guess)
368             ## swap => $bool_or_sub, ##-- byte-swap? (default:'auto':guess)
369             ## mmap => $bool, ##-- mmap data? (default: 0)
370             ## ... ##-- other options passed to DiaColloDB::Utils::readPdlFile()
371             sub toPdl {
372 0     0 1   my ($pf,%opts) = @_;
373             #require 'PDL.pm';
374             #require 'PDL/IO/FastRaw.pm';
375              
376             ##-- type
377 0 0 0       if (($opts{type}//'auto') eq 'auto') {
378 0           $opts{type} = (map {$_->{ioname}}
379 0           grep {length(pack($PDL::Types::pack[$_->{numval}],0))==$pf->{reclen}}
380 0           @PDL::Types::typehash{@PDL::Types::names}
381             )[0];
382             }
383 0 0         $opts{type} = PDL->can($opts{type})->() if (PDL->can($opts{type}));
384             $pf->logconfess("toPdl(): could not guess PDL type for pack template '$pf->{packas}'")
385 0 0         if (!UNIVERSAL::isa($opts{type},'PDL::Type'));
386              
387             ##-- swap?
388 0           my $packsize = $pf->{reclen};
389 0 0 0       if (($opts{swap}//'auto') eq 'auto') {
    0          
390 0           my $buf = pack("C*", (1..$packsize));
391 0           my $val = unpack($pf->{packas}, $buf);
392 0           my $pdl = PDL->zeroes($opts{type}, 1);
393 0           ${$pdl->get_dataref} = $buf;
  0            
394 0           $pdl->upd_data;
395 0 0         if ($pdl->sclr == $val) {
    0          
396 0           $opts{swap} = 0;
397             }
398             elsif (defined(my $swapsub = $pdl->can("bswap${packsize}"))) {
399 0           $swapsub->($pdl);
400 0 0         if ($pdl->sclr==$val) {
401 0           $opts{swap} = $swapsub;
402             }
403             }
404             }
405             elsif ($opts{swap}) {
406 0           $opts{swap} = PDL->can("bswap${packsize}");
407             }
408             $pf->logconfess("toPdl(): could not guess swap function for pack template '$pf->{packas}' and PDL type $opts{type}")
409 0 0 0       if (($opts{swap}//'auto') eq 'auto');
410              
411             ##-- create header
412 0           $pf->flush();
413 0           my $hfile = "$pf->{file}.phdr";
414 0 0         DiaColloDB::Utils::writePdlHeader($hfile, $opts{type}, 1, $pf->size)
415             or $pf->logconfess("toPdl(): failed to write PDL::IO::FastRaw header $hfile: $!");
416              
417             ##-- read or mmap piddle file
418 0           my %io = (Creat=>0,Header=>$hfile);
419 0           my ($pdl);
420 0 0         if ($opts{mmap}) {
421 0   0       $pdl = PDL->mapfraw($pf->{file},{%io,ReadOnly=>($opts{ReadOnly}//1)});
422             } else {
423 0           $pdl = PDL->readfraw($pf->{file}, \%io);
424             }
425 0 0         defined($pdl) or $pf->logconfess("toPdl(): failed to ".($opts{mmap} ? "mmap" : "read")." file $pf->{file} as PDL data of type $opts{type}: $!");
    0          
426 0 0         $opts{swap}->($pdl) if (UNIVERSAL::isa($opts{swap},'CODE'));
427 0 0 0       !-e $hfile
428             or CORE::unlink($hfile)
429             or $pf->logconfess("toPdl(): failed to unlink temporary PDL header '$hfile': $!");
430 0           return $pdl;
431             }
432              
433             ##==============================================================================
434             ## API: binary search
435              
436             ## $index_or_undef = $pf->bsearch($key, %opts)
437             ## + %opts:
438             ## lo => $ilo, ##-- index lower-bound for search (default=0)
439             ## hi => $ihi, ##-- index upper-bound for search (default=size)
440             ## packas => $packas, ##-- key-pack template (default=$pf->{packas})
441             ## + returns the minimum index $i such that unpack($packas,$pf->[$i]) == $key and $ilo <= $j < $i,
442             ## or undef if no such $i exists.
443             ## + $key must be a numeric value, and records must be stored in ascending order
444             ## by numeric value of key (as unpacked by $packas) between $ilo and $ihi
445             sub bsearch {
446 0     0 1   my ($pf,$key,%opts) = @_;
447 0   0       my $ilo = $opts{lo} // 0;
448 0   0       my $ihi = $opts{hi} // $pf->size;
449 0   0       my $packas = $opts{packas} // $pf->{packas};
450              
451             ##-- binary search guts
452 0           my ($imid,$buf,$keymid);
453 0           while ($ilo < $ihi) {
454 0           $imid = ($ihi+$ilo) >> 1;
455              
456             ##-- get item[$imid]
457 0           $pf->fetchraw($imid,\$buf);
458 0           ($keymid) = unpack($packas,$buf);
459              
460 0 0         if ($keymid < $key) {
461 0           $ilo = $imid + 1;
462             } else {
463 0           $ihi = $imid;
464             }
465             }
466              
467 0 0         if ($ilo==$ihi) {
468             ##-- get item[$ilo]
469 0           $pf->fetchraw($ilo,\$buf);
470 0           ($keymid) = unpack($packas,$buf);
471 0 0         return $ilo if ($keymid == $key);
472             }
473              
474 0           return undef;
475             }
476              
477             ##==============================================================================
478             ## disk usage, timestamp, etc
479             ## + see DiaColloDB::Persistent
480              
481             ## @files = $obj->diskFiles()
482             ## + returns disk storage files, used by du() and timestamp()
483             ## + default implementation returns $obj->{file} or glob("$obj->{base}*")
484             sub diskFiles {
485 0     0 1   my $obj = shift;
486 0 0 0       return ($obj->{file}, $obj->{file}.".hdr") if (ref($obj) && defined($obj->{file}));
487 0           return qw();
488             }
489              
490              
491             ##==============================================================================
492             ## I/O
493             ## + largely INHERITED from DiaColloDB::Persistent
494              
495             ##--------------------------------------------------------------
496             ## I/O: header
497             ## + largely INHERITED from DiaColloDB::Persistent
498              
499             ## @keys = $coldb->headerKeys()
500             ## + keys to save as header
501             sub headerKeys {
502 0   0 0 1   return grep {!ref($_[0]{$_}) && $_ !~ m{^(?:flags|perms|file|loaded|dirty)$}} keys %{$_[0]};
  0            
  0            
503             }
504              
505             ##--------------------------------------------------------------
506             ## I/O: text
507              
508             ## $bool = $obj->saveTextFile($filename_or_handle, %opts)
509             ## + wraps saveTextFh()
510             ## + INHERITED from DiaColloDB::Persistent
511              
512             ## $bool = $pf->saveTextFh($fh, %opts)
513             ## + save from text file with lines of the form "KEY? VALUE(s)..."
514             ## + %opts:
515             ## keys=>$bool, ##-- do/don't save keys (default=true)
516             ## key2s=>$key2s, ##-- code-ref for key formatting, called as $s=$key2s->($key)
517             sub saveTextFh {
518 0     0 1   my ($pf,$outfh,%opts) = @_;
519 0 0         $pf->logconfess("saveTextFh(): no packed-file opened!") if (!$pf->opened);
520              
521 0           my $key2s = $opts{key2s};
522 0   0       my $keys = $opts{keys} // 1;
523 0           my $fh = $pf->{fh};
524 0           my ($i,$key,$val);
525 0           for ($i=0, $pf->reset(); !CORE::eof($fh); ++$i) {
526 0           $val = $pf->get();
527 0 0         $outfh->print(($keys
    0          
    0          
528             ? (($key2s ? $key2s->($i) : $i),"\t")
529             : qw()),
530             (UNIVERSAL::isa($val,'ARRAY') ? join(' ',@$val) : $val),
531             "\n");
532             }
533              
534 0           return $pf;
535             }
536              
537             ## $bool = $obj->loadTextFile($filename_or_handle, %opts)
538             ## + wraps loadTextFh()
539             ## + INHERITED from DiaColloDB::Persistent
540              
541             ## $bool = $pf->loadTextFh($fh, %opts)
542             ## + load from text file with lines of the form "KEY? VALUE(s)..."
543             ## + %opts:
544             ## keys=>$bool, ##-- expect keys in input? (default=true)
545             ## gaps=>$bool, ##-- expect gaps or out-of-order elements in input? (default=false; implies keys=>1)
546             sub loadTextFh {
547 0     0 1   my ($pf,$infh,%opts) = @_;
548 0 0         $pf->logconfess("loadTextFile(): no packed-file opened!") if (!$pf->opened);
549              
550 0           $pf->truncate();
551 0   0       my $gaps = $opts{gaps} // 0;
552 0   0       my $keys = $gaps || ($opts{keys} // 1);
553 0           my $fh = $pf->{fh};
554 0           my ($key,$val);
555 0 0         if ($gaps) {
556             ##-- load with keys, possibly out-of-order
557 0           while (defined($_=<$infh>)) {
558 0           chomp;
559 0 0 0       next if (/^$/ || /^%%/);
560 0           ($key,$val) = split(' ',$_,2);
561 0           $pf->store($key,$val);
562             }
563             }
564             else {
565             ##-- load in serial order, with or without keys (ignored)
566 0           $pf->reset;
567 0           while (defined($_=<$infh>)) {
568 0           chomp;
569 0 0 0       next if (/^$/ || /^%%/);
570 0 0         ($key,$val) = ($keys ? split(' ',$_,2) : (undef,$_));
571 0           $pf->set($val);
572             }
573             }
574 0           $pf->flush();
575              
576 0           return $pf;
577             }
578              
579             ##==============================================================================
580             ## API: tie interface
581              
582             ## $tied = tie(@array, $class, $file, $flags, %opts)
583             ## $tied = TIEARRAY($class, $file, $flags, %opts)
584             sub TIEARRAY {
585 0     0     my ($that,$file,$flags,%opts) = @_;
586 0   0       $flags //= 'r';
587 0           return $that->new(%opts,file=>$file,flags=>$flags);
588             }
589              
590             BEGIN {
591 1     1   11 *FETCH = \&fetch;
592 1         3 *STORE = \&store;
593 1         2 *STORESIZE = \&setsize;
594 1         3 *EXTEND = \&setsize;
595 1         201 *CLEAR = \&truncate;
596             }
597              
598             ## $count = $tied->FETCHSIZE()
599             ## + like scalar(@array)
600             ## + re-positions $tied->{fh} to eof
601             sub FETCHSIZE {
602 0 0   0     return undef if (!$_[0]{fh});
603             #return ((-s $_[0]{fh}) / $_[0]{reclen}); ##-- doesn't handle recent writes correctly (probably due to perl i/o buffering)
604             ##
605 0 0         CORE::seek($_[0]{fh},0,SEEK_END) or return undef;
606 0           return CORE::tell($_[0]{fh}) / $_[0]{reclen};
607             }
608              
609             ## $bool = $tied->EXISTS($index)
610             sub EXISTS {
611 0     0     return ($_[1] < $_[0]->size);
612             }
613              
614             ## undef = $tied->DELETE($index)
615             sub DELETE {
616 0     0     $_[0]->STORE($_[1], pack("C$_[0]{reclen}"));
617             }
618              
619              
620             ##==============================================================================
621             ## Footer
622             1;
623              
624             __END__