view release on metacpan or  search on metacpan

lib/File/Locate/Iterator.pm  view on Meta::CPAN

my $header = "\0LOCATE02\0";


# Default path these days is /var/cache/locate/locatedb.
#
# Back in findutils 4.1 it was $(localstatedir)/locatedb, but there seems to
# have been no way to ask about the location.
#
sub default_database_file {
  # my ($class) = @_;
  if (defined (my $env = $ENV{'LOCATE_PATH'})) {
    return $env;
  } else {
    return '/var/cache/locate/locatedb';
  }
}

# The fields, all meant to be private, are:
#
# regexp
#     qr// regexp of all the 'regexp', 'regexps', 'suffix' and 'suffixes'
#     parameters.  If no such matches then no such field.  When the field
#     exists an entry must match the regexp or is skipped.
#
# globs
#     arrayref of strings which are globs to fnmatch().  If no globs then no
#     such field.  When the field exists an entry must match at least one of
#     the globs.
#
# mref
#     Ref to a scalar which holds the database contents, or undef if using
#     fh instead.  It's either a ref to the 'database_str' parameter passed
#     in, or a ref to a scalar created as an mmap of the file.  The mmap one
#     is shared among iterators through the File::Locate::Iterator::FileMap
#     caching.
#
# fh
#     When mref is undef, ref file handle which is to be read from,
#     otherwise no such field.  This can be either the 'database_fh'
#     parameter or an opened anonymous handle of the 'database_file'
#     parameter.
#
#     When mmap is used the 'database_fh' is not held here.  The mmap is
#     made (or rather, looked up in the FileMap cache), and the handle is
#     then no longer needed and can be closed or garbage collected in the
#     caller.
#
# fh_start
#     When fh is set, the tell($fh) position just after the $header in that
#     fh.  This is where to seek() back to for a $it->rewind.  If tell()
#     failed then this is -1 and $it->rewind is not possible.
#
#     Normally fh_start is simply length($header) for a database starting at
#     the start of the file, but a database_fh arg which is positioned at
#     some offset into a file can be read and remembering an fh_start
#     position lets $it->rewind work on it too.
#
# fm
#     When using mmap, a File::Locate::Iterator::FileMap object which is the
#     cache entry for the database file, otherwise no such field.  This is
#     hung onto to keep it alive while in use.  $self->{'mref'} is
#     $fm->mmapref in this case.
#
# pos
#     When mref is not undef, an integer offset into the $$mref string which
#     is the current read position.  The file header is checked in new() so
#     the initial value is length($header), ie. 10, the position of the
#     first entry (or possibly EOF).
#
# entry
#     String of the last database entry returned, or no such field before
#     the first is read, or undef after EOF is hit.  Might be undef instead
#     of not existing if a hypothetical seek() goes back to the start of the
#     file.
#
# sharelen
#     Integer which is the number of leading bytes of 'entry' which the next
#     entry will share with that previous entry.  Initially 0.
#
#     This is modified successively by the "adjshare" of each entry as each
#     takes more or less of the preceding entry.  An adjshare can range from
#     -sharelen to take nothing at all of the previous entry, up to
#     length($entry)-sharelen to increment up to take all of the previous
#     entry.
#
sub new {
  my ($class, %options) = @_;
  ### FLI new(): %options

  # delete 'regexp' field if it's undef, as the XS code wants no 'regexp'
  # field for no regexps, not a field set to undef
  my @regexps;
  if (defined (my $regexp = delete $options{'regexp'})) {
    push @regexps, $regexp;
  }
  if (my $regexps = delete $options{'regexps'}) {
    push @regexps, @$regexps;
  }
  foreach my $suffix (defined $options{'suffix'} ? $options{'suffix'} : (),
                      @{$options{'suffixes'}}) {
    push @regexps, quotemeta($suffix) . '$';
  }
  ### @regexps

  # as per findutils locate.c locate() function, pattern with * ? or [ is a
  # glob, anything else is a literal match
  #
  my @globs = (defined $options{'glob'} ? $options{'glob'} : (),
               @{$options{'globs'} || []});
  @globs = grep { ($_ =~ /[[*?]/
                   || do { push @regexps, quotemeta($_); 0 })
                } @globs;
  ### @globs

  my $self = bless { entry    => '',
                     sharelen => 0,
                   }, $class;

  if (@regexps) {
    my $regexp = join ('|', @regexps);
    $self->{'regexp'} = qr/$regexp/s;