lib/Search/Dict.pm

   1 package Search::Dict;
   2 require 5.000;
   3 require Exporter;
   4
   5 use strict;
   6
   7 our $VERSION = '1.01';
   8 our @ISA = qw(Exporter);
   9 our @EXPORT = qw(look);
  10
  11 =head1 NAME
  12
  13 Search::Dict, look - search for key in dictionary file
  14
  15 =head1 SYNOPSIS
  16
  17     use Search::Dict;
  18     look *FILEHANDLE, $key, $dict, $fold, $comp;
  19
  20 =head1 DESCRIPTION
  21
  22 Sets file position in FILEHANDLE to be first line greater than or equal
  23 (stringwise) to I<$key>.  Returns the new file position, or -1 if an error
  24 occurs.
  25
  26 The flags specify dictionary order and case folding:
  27
  28 If I<$dict> is true, search by dictionary order (ignore anything but word
  29 characters and whitespace).  The default is honour all characters.
  30
  31 If I<$fold> is true, ignore case.  The default is to honour case.
  32
  33 If I<$comp> is defined, use that as a reference to the comparison subroutine,
  34 which must return less than zero, zero, or greater than zero, if the
  35 first comparand is less than, equal, or greater than the second comparand.
  36
  37 If there are only three arguments and the third argument is a hash
  38 reference, the keys of that hash can have values C<dict>, C<fold>, and
  39 C<comp>, and their correponding values will be used as the parameters.
  40
  41 =cut
  42
  43 sub look {
  44     my($fh,$key,$dict,$fold,$comp) = @_;
  45     if (@_ == 3 && ref $dict eq 'HASH') {
  46         my $opt = $dict;
  47         $dict = 0;
  48         $dict = $opt->{dict} if exists $opt->{dict};
  49         $fold = $opt->{fold} if exists $opt->{fold};
  50         $comp = $opt->{comp} if exists $opt->{comp};
  51     }
  52     $comp = sub { $_[0] cmp $_[1] } unless defined $comp;
  53     local($_);
  54     my(@stat) = stat($fh)
  55         or return -1;
  56     my($size, $blksize) = @stat[7,11];
  57     $blksize ||= 8192;
  58     $key =~ s/[^\w\s]//g if $dict;
  59     $key = lc $key       if $fold;
  60     # find the right block
  61     my($min, $max) = (0, int($size / $blksize));
  62     my $mid;
  63     while ($max - $min > 1) {
  64         $mid = int(($max + $min) / 2);
  65         seek($fh, $mid * $blksize, 0)
  66             or return -1;
  67         <$fh> if $mid;                  # probably a partial line
  68         $_ = <$fh>;
  69         chomp;
  70         s/[^\w\s]//g if $dict;
  71         $_ = lc $_   if $fold;
  72         if (defined($_) && $comp->($_, $key) < 0) {
  73             $min = $mid;
  74         }
  75         else {
  76             $max = $mid;
  77         }
  78     }
  79     # find the right line
  80     $min *= $blksize;
  81     seek($fh,$min,0)
  82         or return -1;
  83     <$fh> if $min;
  84     for (;;) {
  85         $min = tell($fh);
  86         defined($_ = <$fh>)
  87             or last;
  88         chomp;
  89         s/[^\w\s]//g if $dict;
  90         $_ = lc $_   if $fold;
  91         last if $comp->($_, $key) >= 0;
  92     }
  93     seek($fh,$min,0);
  94     $min;
  95 }
  96
  97 1;