File Coverage

blib/lib/Tie/File/Indexed.pm

Criterion	Covered	Total	%
statement	299	335	89.2
branch	143	284	50.3
condition	51	110	46.3
subroutine	53	63	84.1
pod	23	38	60.5
total	569	830	68.5

##-*- Mode: CPerl -*-
##
## File: Tie/File/Indexed.pm
## Author: Bryan Jurish
## Description: tied array access to indexed data files

package Tie::File::Indexed;
use 5.10.0; ##-- for // operator
use Tie::Array;
use JSON qw();
use Fcntl qw(:DEFAULT :seek :flock);
use File::Copy qw();
use IO::File;
use Carp qw(confess);
use strict;

##======================================================================
## Globals

our @ISA     = qw(Tie::Array);
our $VERSION = '0.07';

##======================================================================
## Constructors etc.

## $tied = CLASS->new(%opts)
## $tied = CLASS->new($file,%opts)
##  + %opts, object structure:
##    (
##     file   => $file,    ##-- file basename; uses files "${file}", "${file}.idx", "${file}.hdr"
##     mode   => $mode,    ##-- open mode (fcntl flags or perl-style; default='rwa')
##     perms  => $perms,   ##-- default: 0666 & ~umask
##     pack_o => $pack_o,  ##-- file offset pack template (default='J')
##     pack_l => $pack_l,  ##-- string-length pack template (default='J')
##     bsize  => $bsize,   ##-- block-size in bytes for index batch-operations (default=2**21 = 2MB)
##     temp   => $bool,    ##-- if true, call unlink() on object destruction (default=false)
##     ##
##     ##-- pack lengths (after open())
##     len_o  => $len_o,   ##-- packsize($pack_o)
##     len_l  => $len_l,   ##-- packsize($pack_l)
##     len_ix => $len_ix,  ##-- packsize($pack_ix) == $len_o + $len_l
##     pack_ix=> $pack_ix, ##-- "${pack_o}${pack_l}"
##     ##
##     ##-- guts (after open())
##     idxfh => $idxfh,    ##-- $file.idx : [$i] => pack("${pack_o}${pack_l}",  $offset_in_datfh_of_item_i, $len_in_datfh_of_item_i)
##     datfh => $datfh,    ##-- $file     : raw data (concatenated)
##     #size  => $nrecords, ##-- cached number of records for faster FETCHSIZE()  ##-- potentially UNSAFE for concurrent access: DON'T USE
##    )
sub new {
  my $that = shift;
  my $file = (@_ % 2)==0 ? undef : shift;
  my %opts = @_;
  my $tied = bless({
		   $that->defaults(),
		   file => $file,
		   @_,
		  }, ref($that)||$that);
  return $tied->open() if (defined($tied->{file}));
  return $tied;
}

## %defaults = CLASS_OR_OBJECT->defaults()
##  + default attributes for constructor
sub defaults {
  return (
	  #file  => $file,
	  perms  => (0666 & ~umask),
	  mode   => 'rwa',
	  pack_o => 'J',
	  pack_l => 'J',
	  block  => 2**21,
	 );
}

## undef = $tied->DESTROY()
##  + implicitly calls unlink() if 'temp' attribute is set to a true value
##  + implicitly calls close()
sub DESTROY {
  $_[0]->unlink() if ($_[0]{temp});
  $_[0]->close();
}

##======================================================================
## Utilities

##--------------------------------------------------------------
## Utilities: fcntl

## $flags = CLASS_OR_OBJECT->fcflags($mode)
##  + returns Fcntl flags for symbolic string $mode
sub fcflags {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $mode = shift;
  $mode //= 'r';
  return $mode if ($mode =~ /^[0-9]+$/); ##-- numeric mode is interpreted as Fcntl bitmask
  my $fread  = $mode =~ /[r<]/;
  my $fwrite = $mode =~ /[wa>\+]/;
  my $fappend = ($mode =~ /[a]/ || $mode =~ />>/);
  my $flags = ($fread
	       ? ($fwrite ? (O_RDWR|O_CREAT)   : O_RDONLY)
	       : ($fwrite ? (O_WRONLY|O_CREAT) : 0)
	      );
  $flags |= O_TRUNC  if ($fwrite && !$fappend);
  return $flags;
}

## $bool = CLASS_OR_OBJECT->fcread($mode)
##  + returns true if any read-bits are set for $mode
sub fcread {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $flags = fcflags(shift);
  return ($flags&O_RDONLY)==O_RDONLY || ($flags&O_RDWR)==O_RDWR;
}

## $bool = CLASS_OR_OBJECT->fcwrite($mode)
##  + returns true if any write-bits are set for $mode
sub fcwrite {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $flags = fcflags(shift);
  return ($flags&O_WRONLY)==O_WRONLY || ($flags&O_RDWR)==O_RDWR;
}

## $bool = CLASS_OR_OBJECT->fctrunc($mode)
##  + returns true if truncate-bits are set for $mode
sub fctrunc {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $flags = fcflags(shift);
  return ($flags&O_TRUNC)==O_TRUNC;
}

## $bool = CLASS_OR_OBJECT->fccreat($mode)
sub fccreat {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $flags = fcflags(shift);
  return ($flags&O_CREAT)==O_CREAT;
}

## $str = CLASS_OR_OBJECT->fcperl($mode)
##  + return perl mode-string for $mode
sub fcperl {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my $flags = fcflags(shift);
  return (fcread($flags)
	  ? (fcwrite($flags)    ##-- +read
	     ? (fctrunc($flags) ##-- +read,+write
		? '+>' : '+<')  ##-- +read,+write,+/-trunc
	     : '<')
	  : (fcwrite($flags)    ##-- -read
	     ? (fctrunc($flags) ##-- -read,+write
		? '>' : '>>')   ##-- -read,+write,+/-trunc
	     : '<')             ##-- -read,-write : default
	 );
}

## $fh_or_undef = CLASS_OR_OBJECT->fcopen($file,$mode)
## $fh_or_undef = CLASS_OR_OBJECT->fcopen($file,$mode,$perms)
##  + opens $file with fcntl- or perl-style mode $mode
sub fcopen {
  shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
  my ($file,$flags,$perms) = @_;
  $flags    = fcflags($flags);
  $perms  //= (0666 & ~umask);
  my $mode = fcperl($flags);

  my ($sysfh);
  if (ref($file)) {
    ##-- dup an existing filehandle
    $sysfh = $file;
  }
  else {
    ##-- use sysopen() to honor O_CREAT and O_TRUNC
    sysopen($sysfh, $file, $flags, $perms) or return undef;
  }

  ##-- now open perl-fh from system fh
  open(my $fh, "${mode}&=", fileno($sysfh)) or return undef;
  if (fcwrite($flags) && !fctrunc($flags)) {
    ##-- append mode: seek to end of file
    seek($fh, 0, SEEK_END) or return undef;
  }
  return $fh;
}

##--------------------------------------------------------------
## Utilities: pack sizes

## $len = CLASS->packsize($packfmt)
## $len = CLASS->packsize($packfmt,@args)
##  + get pack-size for $packfmt with args @args
sub packsize {
  use bytes; ##-- deprecated in perl v5.18.2
  no warnings;
  return bytes::length(pack($_[0],@_[1..$#_]));
}


##--------------------------------------------------------------
## Utilities: JSON

## $data = CLASS->loadJsonString( $string,%opts)
## $data = CLASS->loadJsonString(\$string,%opts)
##  + %opts passed to JSON::from_json(), e.g. (relaxed=>0)
##  + supports $opts{json} = $json_obj
sub loadJsonString {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my $bufr = ref($_[0]) ? $_[0] : \$_[0];
  my %opts = @_[1..$#_];
  return $opts{json}->decode($$bufr) if ($opts{json});
  return JSON::from_json($$bufr, {utf8=>!utf8::is_utf8($$bufr), relaxed=>1, allow_nonref=>1, %opts});
}

## $data = CLASS->loadJsonFile($filename_or_handle,%opts)
sub loadJsonFile {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my $file = shift;
  my $fh = ref($file) ? $file : IO::File->new("<$file");
  return undef if (!$fh);
  binmode($fh,':raw');
  local $/=undef;
  my $buf = <$fh>;
  close($fh) if (!ref($file));
  return $that->loadJsonString(\$buf,@_);
}

## $str = CLASS->saveJsonString($data)
## $str = CLASS->saveJsonString($data,%opts)
##  + %opts passed to JSON::to_json(), e.g. (pretty=>0, canonical=>0)'
##  + supports $opts{json} = $json_obj
sub saveJsonString {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my $data = shift;
  my %opts = @_;
  return $opts{json}->encode($data)  if ($opts{json});
  return JSON::to_json($data, {utf8=>1, allow_nonref=>1, allow_unknown=>1, allow_blessed=>1, convert_blessed=>1, pretty=>1, canonical=>1, %opts});
}

## $bool = CLASS->saveJsonFile($data,$filename_or_handle,%opts)
sub saveJsonFile {
  my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
  my $data = shift;
  my $file = shift;
  my $fh = ref($file) ? $file : IO::File->new(">$file");
  logconfess((ref($that)||$that)."::saveJsonFile() failed to open file '$file': $!") if (!$fh);
  binmode($fh,':raw');
  $fh->print($that->saveJsonString($data,@_)) or return undef;
  if (!ref($file)) { close($fh) || return undef; }
  return 1;
}

##--------------------------------------------------------------
## Utilities: debugging

## $idxbuf = $tied->slurpIndex()
##  + slurps whole raw index-file into a string-buffer (for debugging)
sub slurpIndex {
  my $tied = shift;
  return undef if (!$tied->opened);
  my $fh = $tied->{idxfh};
  CORE::seek($fh, 0, SEEK_SET) or return undef;
  local $/ = undef;
  return <$fh>;
}

## $idxtxt = $tied->indexText()
## @idxtxt = $tied->indexText()
##  + slurps whole index file and returns it as a text-buffer (for debugging)
sub indexText {
  my $tied = shift;
  my @idx = map {join(' ',unpack($tied->{pack_ix},$_))} unpack("(A[$tied->{len_ix}])*", $tied->slurpIndex//'');
  return wantarray ? @idx : join("\n",@idx)."\n";
}

## $datbuf = $tied->slurpData()
##  + slurps whole raw data-file into a string-buffer (for debugging)
sub slurpData {
  my $tied = shift;
  return undef if (!$tied->opened);
  my $fh = $tied->{datfh};
  CORE::seek($fh, 0, SEEK_SET) or return undef;
  local $/ = undef;
  return <$fh>;
}


##======================================================================
## Subclass API: Data I/O

## $bool = $tied->writeData($data)
##  + write item $data to $tied->{datfh} at its current position
##  + after writing, $tied->{datfh} should be positioned to the first byte following the written item
##  + $tied is assumed to be opened in write-mode
##  + default implementation just writes $data as a byte-string (undef is written as the empty string)
##  + can be overridden by subclasses to perform transparent encoding of complex data
sub writeData {
  return $_[0]{datfh}->print($_[1]//'');
}

## $data_or_undef = $tied->readData($length)
##  + read item data record of length $length from $tied->{datfh} at its current position
##  + default implementation just reads a byte-string of length $length
sub readData {
  CORE::read($_[0]{datfh}, my $buf, $_[1])==$_[1] or return undef;
  return $buf;
}

##======================================================================
## Subclass API: Index I/O

## ($off,$len) = $tied->readIndex($index)
## ($off,$len) = $tied->readIndex(undef)
##  + gets index-record for item at logical index $index from $tied->{idxfh}
##  + if $index is undef, read from the current position of $tied->{idxfh}
##  + $index is assumed to exist in the array
##  + returns the empty list on error
sub readIndex {
  !defined($_[1]) or CORE::seek($_[0]{idxfh}, $_[1]*$_[0]{len_ix}, SEEK_SET) or return qw();
  CORE::read($_[0]{idxfh}, my $buf, $_[0]{len_ix})==$_[0]{len_ix} or return qw();
  return unpack($_[0]{pack_ix}, $buf);
}

## $tied_or_undef = $tied->writeIndex($index,$off,$len)
## $tied_or_undef = $tied->writeIndex(undef,$off,$len)
##  + writes index-record for item at logical index $index to $tied->{idxfh}
##  + if $index is undef, write at the current position of $tied->{idxfh}
##  + returns undef list on error
sub writeIndex {
  !defined($_[1]) or CORE::seek($_[0]{idxfh}, $_[1]*$_[0]{len_ix}, SEEK_SET) or return undef;
  $_[0]{idxfh}->print(pack($_[0]{pack_ix}, $_[2], $_[3])) or return undef;
  return $_[0];
}

## $tied_or_undef = $tied->shiftIndex($start,$n,$shift)
##  + moves $n index records starting from $start by $shift positions (may be negative)
##  + operates directly on $tied->{idxfh}
##  + doesn't change old values unless they are overwritten
sub shiftIndex {
  my ($tied,$start,$n,$shift) = @_;

  ##-- common variables
  my $idxfh  = $tied->{idxfh};
  my $len_ix = $tied->{len_ix};
  my $bsize  = $tied->{bsize} // 2**21;
  my $bstart = $len_ix * $start;
  my $bn     = $len_ix * $n;
  my $bshift = $len_ix * $shift;
  my ($buf,$boff,$blen);

  ##-- dispatch by shift direction
  if ($shift > 0) {
    ##-- shift right (copy right-to-left)
    CORE::seek($tied->{idxfh}, $bstart+$bn, SEEK_SET) or return undef;
    while ($bn > 0) {
      $blen = $bn > $bsize ? $bsize : $bn;
      CORE::seek($idxfh, -$blen, SEEK_CUR) or return undef;
      CORE::read($idxfh, $buf, $blen)==$blen or return undef;
      CORE::seek($idxfh, $bshift-$blen, SEEK_CUR) or return undef;
      $idxfh->print($buf) or return undef;
      CORE::seek($idxfh, -$bshift, SEEK_CUR) or return undef;
      $bn -= $blen;
    }
  } else {
    ##-- shift left (copy left-to-right)
    CORE::seek($tied->{idxfh}, $bstart, SEEK_SET) or return undef;
    while ($bn > 0) {
      $blen = $bn > $bsize ? $bsize : $bn;
      CORE::read($idxfh, $buf, $blen)==$blen or return undef;
      CORE::seek($idxfh, $bshift-$blen, SEEK_CUR) or return undef;
      $idxfh->print($buf) or return undef;
      CORE::seek($idxfh, -$bshift, SEEK_CUR) or return undef;
      $bn -= $blen;
    }
  }

  return $tied;
}



##======================================================================
## Object API

##--------------------------------------------------------------
## Object API: header

## @keys = $tied->headerKeys()
##  + keys to save as header
sub headerKeys {
  return grep {!ref($_[0]{$_}) && $_ !~ m{^(?:file|mode|perms)$}} keys %{$_[0]};
}

## \%header = $tied->headerData()
##  + data to save as header
sub headerData {
  my $tied = shift;
  return {(map {($_=>$tied->{$_})} $tied->headerKeys), class=>ref($tied)};
}

## $tied_or_undef = $tied->loadHeader()
## $tied_or_undef = $tied->loadHeader($headerFile,%opts)
##  + loads header from "$tied->{file}.hdr"
##  + %opts are passed to loadJsonFile()
sub loadHeader {
  my ($tied,$hfile,%opts) = @_;
  $hfile //= $tied->{file}.".hdr" if (defined($tied->{file}));
  confess(ref($tied)."::loadHeader(): no header-file specified and no 'file' attribute defined") if (!defined($hfile));
  my $hdata = $tied->loadJsonFile($hfile,%opts)
    or confess(ref($tied)."::loadHeader(): failed to load header data from '$hfile'");
  @$tied{keys %$hdata} = values %$hdata;
  return $tied;
}

## $tied_or_undef = $tied->saveHeader()
## $tied_or_undef = $tied->saveHeader($headerFile)
##  + saves header data to $headerFile
##  + %opts are passed to saveJsonFile()
sub saveHeader {
  my ($tied,$hfile,%opts) = @_;
  $hfile //= $tied->{file}.".hdr" if (defined($tied->{file}));
  confess(ref($tied)."::saveHeader(): no header-file specified and no 'file' attribute defined") if (!defined($hfile));
  return $tied->saveJsonFile($tied->headerData(), $hfile, %opts);
}

##--------------------------------------------------------------
## Object API: open/close

## $tied_or_undef = $tied->open($file,$mode)
## $tied_or_undef = $tied->open($file)
## $tied_or_undef = $tied->open()
##  + opens file(s)
sub open {
  my ($tied,$file,$mode) = @_;
  $file //= $tied->{file};
  $mode //= $tied->{mode};
  $tied->close() if ($tied->opened);
  $tied->{file} = $file;
  $tied->{mode} = $mode = fcflags($mode);

  if (fcread($mode) && !fctrunc($mode)) {
    (!-e "$file.hdr" && fccreat($mode))
      or $tied->loadHeader()
      or confess(ref($tied)."::failed to load header from '$tied->{file}.hdr': $!");
  }

  $tied->{idxfh} = fcopen("$file.idx", $mode, $tied->{perms})
    or confess(ref($tied)."::open failed for index-file $file.idx: $!");
  $tied->{datfh} = fcopen("$file", $mode, $tied->{perms})
    or confess(ref($tied)."::open failed for data-file $file: $!");
  binmode($_) foreach (@$tied{qw(idxfh datfh)});

  ##-- pack lengths
  #use bytes; ##-- deprecated in perl v5.18.2
  $tied->{len_o}   = packsize($tied->{pack_o});
  $tied->{len_l}   = packsize($tied->{pack_l});
  $tied->{len_ix}  = $tied->{len_o} + $tied->{len_l};
  $tied->{pack_ix} = $tied->{pack_o}.$tied->{pack_l};

  return $tied;
}

## $tied_or_undef = $tied->close()
##   + close any opened file, writes header if opened in write mode
sub close {
  my $tied = shift;
  return $tied if (!$tied->opened);
  if ($tied->opened && fcwrite($tied->{mode})) {
    $tied->saveHeader() or
      confess(ref($tied)."::close(): failed to save header file");
  }
  delete @$tied{qw(idxfh datfh)}; ##-- should auto-close if not shared
  undef $tied->{file};
  return $tied;
}

## $bool = $tied->reopen()
##  + closes and re-opens underlying filehandles
##  + should cause a "real" flush even on systems without a working IO::Handle::flush
sub reopen {
  my $tied = shift;
  my ($file,$mode) = @$tied{qw(file mode)};
  return $tied->opened() && $tied->close() && $tied->open($file,$mode);
}

## $bool = $tied->opened()
##  + returns true iff object is opened
sub opened {
  my $tied = shift;
  return (ref($tied)
	  && defined($tied->{idxfh})
	  && defined($tied->{datfh})
	 );
}

## $tied_or_undef = $tied->flush()
## $tied_or_undef = $tied->flush($flushHeader)
##  + attempts to flush underlying filehandles using underlying filehandles' flush() method
##    (ususally IO::Handle::flush)
##  + also writes header file
##  + calls reopen() if underlying filehandles don't support a flush() method
sub flush {
  my ($tied,$flushHeader) = @_;
  my $rc = $tied->opened;
  if ($rc && UNIVERSAL::can($tied->{idxfh},'flush') && UNIVERSAL::can($tied,'flush')) {
    ##-- use fh flush() method
    $rc = $tied->{idxfh}->flush() && $tied->{datfh}->flush() && (!$flushHeader || $tied->saveHeaderFile());
  }
  else {
    ##-- use reopen()
    $rc = $tied->reopen();
  }
  return $rc ? $tied : undef;
}

##--------------------------------------------------------------
## Object API: file operations

## $tied_or_undef = $tied->unlink()
## $tied_or_undef = $tied->unlink($file)
##  + attempts to unlink underlying files
##  + implicitly calls close()
sub unlink {
  my ($tied,$file) = @_;
  $file //= $tied->{file};
  $tied->close();
  return undef if (!defined($file));
  foreach ('','.idx','.hdr') {
    CORE::unlink("${file}$_") or return undef;
  }
  return $tied;
}

## $tied_or_undef = $tied->rename($newname)
##  + renames underlying file(s) using CORE::rename()
##  + implicitly close()s and re-open()s $tied
##  + object must be opened in write-mode
sub rename {
  my ($tied,$newfile) = @_;
  my $flags   = fcflags($tied->{mode});
  my $oldfile = $tied->{file};
  return undef if (!$tied->opened() || !fcwrite($flags) || !$tied->close);
  foreach ('','.idx','.hdr') {
    CORE::rename("${oldfile}$_","${newfile}$_") or return undef;
  }
  return $tied->open($newfile, ($flags & ~O_TRUNC));
}

## $dst_object_or_undef = $tied_src->copy($dst_filename, %dst_opts)
## $dst_object_or_undef = $tied_src->copy($dst_object)
##  + copies underlying file(s) using File::Copy::copy()
##  + source object must be opened
##  + implicitly calls flush() on both source and destination objects
##  + if a destination object is specified, it must be opened in write-mode
sub copy {
  my ($src,$dst,%opts) = @_;
  return undef if (!$src->opened || !$src->flush);
  $dst = $src->new($dst, %opts, mode=>'rw') if (!ref($dst));
  return undef if (!$dst->opened && !$dst->open($opts{file}, 'rw'));

  foreach (qw(idxfh datfh)) {
    CORE::seek($src->{$_}, 0, SEEK_SET) or return undef;
    CORE::seek($dst->{$_}, 0, SEEK_SET) or return undef;
    File::Copy::copy($src->{$_}, $dst->{$_}) or return undef;
  }
  return $dst->flush();
}

## $tied_or_undef = $tied->move($newname)
##  + renames underlying file(s) using File::Copy::move()
##  + implicitly close()s and re-open()s $tied
##  + object must be opened in write-mode
sub move {
  my ($tied,$newfile) = @_;
  my $flags   = fcflags($tied->{mode});
  my $oldfile = $tied->{file};
  return undef if (!$tied->opened() || !fcwrite($flags) || !$tied->close);
  foreach ('','.idx','.hdr') {
    File::Copy::move("${oldfile}$_","${newfile}$_") or return undef;
  }
  return $tied->open($newfile, ($flags & ~O_TRUNC));
}



##--------------------------------------------------------------
## Object API: consolidate

## $tied_or_undef = $tied->consolidate()
## $tied_or_undef = $tied->consolidate($tmpfile)
##  + consolidates file data: ensures data in $tied->{datfh} are in index-order and contain no gaps or unused blocks
##  + object must be opened in write-mode
##  + uses $tmpfile as a temporary file for consolidation (default="$tied->{file}.tmp")
sub consolidate {
  my ($tied,$tmpfile) = @_;

  ##-- open tempfile
  $tmpfile //= "$tied->{file}.tmp";
  my $tmpfh = fcopen($tmpfile, $tied->{mode}, $tied->{perms})
    or confess(ref($tied)."::open failed for temporary data-file $tmpfile: $!");
  binmode($tmpfh);

  ##-- copy data
  my ($file,$idxfh,$datfh,$len_ix,$pack_ix) = @$tied{qw(file idxfh datfh len_ix pack_ix)};
  my ($buf,$off,$len);
  my $size = $tied->size;
  CORE::seek($idxfh, 0, SEEK_SET) or return undef;
  CORE::seek($tmpfh, 0, SEEK_SET) or return undef;
  for (my $i=0; $i < $size; ++$i) {
    CORE::read($idxfh, $buf, $len_ix)==$len_ix or return undef;
    ($off,$len) = unpack($pack_ix, $buf);

    ##-- update index record (in-place)
    CORE::seek($idxfh, $i*$len_ix, SEEK_SET) or return undef;
    $idxfh->print(pack($pack_ix, CORE::tell($tmpfh),$len)) or return undef;

    ##-- copy data record
    next if ($len == 0);
    CORE::seek($datfh, $off, SEEK_SET) or return undef;
    CORE::read($datfh, $buf, $len)==$len or return undef;
    $tmpfh->print($buf) or return undef;
  }

  ##-- close data-filehandles
  CORE::close($tmpfh)
      or confess(ref($tied)."::consolidate(): failed to close temp-file '$tmpfile': $!");
  CORE::close($datfh)
    or confess(ref($tied)."::consolidate(): failed to close old data-file '$file': $!");

  ##-- replace old datafile
  undef $tmpfh;
  undef $datfh;
  delete $tied->{datfh};
  CORE::unlink($file)
      or confess(ref($tied)."::consolidate(): failed to unlink old data-file '$tied->{file}': $!");
  #CORE::rename($tmpfile, $file) ##-- win32 chokes here with "Permission denied"
  File::Copy::move($tmpfile, $file)
      or confess(ref($tied)."::consolidate(): failed to move temp-file '$tmpfile' to '$file': $!");

  ##-- re-open
  $tied->{datfh} = fcopen("$file", (fcflags($tied->{mode}) & ~O_TRUNC), $tied->{perms})
    or confess(ref($tied)."::consolidate(): failed to re-open data-file $file: $!");

  return $tied;
}

##--------------------------------------------------------------
## Object API: advisory locking

## $bool = $tied->flock()
## $bool = $tied->flock($lock)
##  + get an advisory lock of type $lock (default=LOCK_EX) on $tied->{datfh}, using perl's flock() function
##  + implicitly calls flush() prior to locking
sub flock {
  my ($tied,$op) = @_;
  return undef if (!$tied->opened);
  $tied->flush();
  return CORE::flock($tied->{datfh}, ($op // LOCK_EX));
}

## $bool = $tied->funlock()
## $bool = $tied->funlock($lock)
##  + unlock $tied->{datfh} using perl's flock() function; $lock defaults to LOCK_UN
sub funlock {
  return $_[0]->flock( LOCK_UN | ($_[1]//0) );
}


##======================================================================
## API: Tied Array

##--------------------------------------------------------------
## API: Tied Array: mandatory methods

## $tied = tie(@array, $tieClass, $file,%opts)
## $tied = TIEARRAY($tieClass, $file,%opts)
BEGIN { *TIEARRAY = \&new; }

## $count = $tied->FETCHSIZE()
##  + like scalar(@array)
##  + re-positions $tied->{idxfh} to eof
BEGIN { *size = \&FETCHSIZE; }
sub FETCHSIZE {
  return undef if (!$_[0]{idxfh});
  #return ((-s $_[0]{idxfh}) / $_[0]{len_ix}); ##-- doesn't handle recent writes correctly (probably due to perl i/o buffering)
  ##
  CORE::seek($_[0]{idxfh},0,SEEK_END) or return undef;
  return CORE::tell($_[0]{idxfh}) / $_[0]{len_ix};
}

## $val = $tied->FETCH($index)
## $val = $tied->FETCH($index)
sub FETCH {
  ##-- sanity check
  return undef if ($_[1] >= $_[0]->size);

  ##-- get index record from $idxfh
  my ($off,$len) = $_[0]->readIndex($_[1]) or return undef;

  ##-- get data record from $datfh
  CORE::seek($_[0]{datfh}, $off, SEEK_SET) or return undef;
  return $_[0]->readData($len);
}

## $val = $tied->STORE($index,$val)
##  + no consistency checking or optimization; just appends a new record to the end of $datfh and updates $idxfh
sub STORE {
  ##-- append encoded record to $datfh
  CORE::seek($_[0]{datfh}, 0, SEEK_END) or return undef;
  my $off0 = CORE::tell($_[0]{datfh});
  $_[0]->writeData($_[2]) or return undef;
  my $off1 = CORE::tell($_[0]{datfh});

  ##-- update index record in $idxfh
  $_[0]->writeIndex($_[1], $off0, ($off1-$off0)) or return undef;

  ##-- return
  return $_[2];
}

## $count = $tied->STORESIZE($count)
## $count = $tied->STORESIZE($count) ##-- local extension
##  + modifies only $idxfh
sub STORESIZE {
  my $oldsize = $_[0]->size;
  if ($_[1] < $oldsize) {
    ##-- shrink
    CORE::truncate($_[0]{idxfh}, $_[1]*$_[0]{len_ix}) or return undef;
  } elsif ($_[1] > $oldsize) {
    ##-- grow (idxfh only)
    CORE::seek($_[0]{idxfh}, $_[1]*$_[0]{len_ix}-1, SEEK_SET) or return undef;
    $_[0]{idxfh}->print("\0");
  }
  return $_[1];
}

## $bool = $tied->EXISTS($index)
sub EXISTS {
  return $_[1] < $_[0]->size;
}

## undef = $tied->DELETE($index)
##  + really just wraps $tied->STORE($index,undef)
sub DELETE {
  return $_[0]->STORE($_[1],undef);
}

##--------------------------------------------------------------
## API: Tied Array: optional methods

## undef = $tied->CLEAR()
sub CLEAR {
  CORE::truncate($_[0]{idxfh}, 0) or return undef;
  CORE::truncate($_[0]{datfh}, 0) or return undef;
  return $_[0];
}

## $newsize = $tied->PUSH(@vals)
sub PUSH {
  my $tied = shift;

  CORE::seek($tied->{datfh}, 0, SEEK_END) or return undef;
  CORE::seek($tied->{idxfh}, 0, SEEK_END) or return undef;
  my ($off0,$off1);
  foreach (@_) {
    my $off0 = CORE::tell($tied->{datfh});
    $tied->writeData($_) or return undef;
    my $off1 = CORE::tell($tied->{datfh});

    ##-- update index record in $idxfh
    $tied->writeIndex(undef, $off0, ($off1-$off0)) or return undef;
  }

  return $tied->size if (defined(wantarray));
}

## $val = $tied->POP()
##  + truncates data-file if we're popping the final data-record
sub POP {
  return undef if (!(my $size=$_[0]->size));

  ##-- get final index record (& truncate it)
  my ($off,$len) = $_[0]->readIndex($size-1) or return undef;
  CORE::truncate($_[0]{idxfh}, ($size-1)*$_[0]{len_ix}) or return undef;

  ##-- get corresponding data-record
  CORE::seek($_[0]{datfh}, $off, SEEK_SET) or return undef;
  my $val = $_[0]->readData($len);

  ##-- maybe trim data-file
  CORE::truncate($_[0]{datfh}, $off) if (($off+$len) == (-s $_[0]{datfh}));
  return $val;
}

## $val = $tied->SHIFT()
##  + truncates data-file if we're shifting the final data-record
sub SHIFT {
  ##-- get first index record
  my ($off,$len) = $_[0]->readIndex(0) or return undef;

  ##-- defer to SPLICE
  my $val = $_[0]->SPLICE(0,1);

  ##-- maybe trim data-file
  CORE::truncate($_[0]{datfh}, $off) if (($off+$len) == (-s $_[0]{datfh}));
  return $val;
}

## @removed      = $tied->SPLICE($offset, $length, @newvals)
## $last_removed = $tied->SPLICE($offset, $length, @newvals)
sub SPLICE {
  my $tied = shift;
  my $size = $tied->size();
  my $off  = (@_) ? shift : 0;
  $off    += $size if ($off < 0);
  my $len  = (@_) ? shift : ($size-$off);
  $len    += $size-$off if ($len < 0);

  ##-- get result-list
  my ($i,@result);
  if (wantarray) {
    for ($i=$off; $i <= $len; ++$i) {
      push(@result, $tied->FETCH($i));
    }
  } elsif ($len > 0) {
    @result = ($tied->FETCH($off+$len-1));
  }

  ##-- shift post-splice index records (expensive, but generally not so bad as default Tie::Array iterated FETCH()+STORE())
  my $shift = scalar(@_) - $len;
  $tied->shiftIndex($off+$len, $size-($off+$len), $shift) if ($shift != 0);

  ##-- store new values
  for ($i=0; $i < @_; ++$i) {
    $tied->STORE($off+$i, $_[$i]);
  }

  ##-- maybe shrink array
  CORE::truncate($tied->{idxfh}, ($size+$shift)*$tied->{len_ix}) or return undef if ($shift < 0);

  ##-- return
  return wantarray ? @result : $result[0];
}

## @vals = $tied->UNSHIFT(@vals)
##  + just defers to SPLICE
sub UNSHIFT {
  return scalar shift->SPLICE(0,0,@_);
}

## ? = $tied->EXTEND($newcount)

1; ##-- be happpy