File Coverage

blib/lib/Search/Tokenizer.pm

Criterion	Covered	Total	%
statement	62	68	91.1
branch	20	28	71.4
condition	5	8	62.5
subroutine	8	11	72.7
pod	4	5	80.0
total	99	120	82.5

package Search::Tokenizer;
use warnings;
use strict;
use Unicode::CaseFold ();

our $VERSION = '1.02';

sub new {
  my $class = shift;

  # defaults
  my $regex           = qr/\w+/;
  my $lower           = 1;
  my $filter          = undef;
  my $filter_in_place = undef;
  my $stopwords       = undef;

  # parse arguments
  unshift @_, "regex" if @_ == 1; # positional API
  while (my $arg = shift) {
    my $val = shift;
    $arg .= "=>" . (ref($val) || "NOREF");
    for ($arg) {
      /^regex=>Regexp$/         and do { $regex = $val;           last};
      /^lower=>NOREF$/          and do { $lower = !!$val;         last};
      /^filter=>CODE$/          and do { $filter = $val;          last};
      /^filter_in_place=>CODE$/ and do { $filter_in_place = $val; last};
      /^stopwords=>HASH$/       and do { $stopwords = $val;       last};
      die "Invalid option or invalid operand: $arg";
    }
  }

  # check that regex doest not match the empty string
  not "" =~ $regex
    or die "regex $regex matches the empty string: cannot tokenize";

  # return tokenizer factory: closure
  return sub {
    my $string = shift;
    my $term_index = -1;

    # return tokenizer : additional closure on $string and $term_index
    return sub {

      # get next occurrence of $regex in $string (thanks to the /g flag)
      while ($string =~ /$regex/g) {

        # index of this term within the input string
        $term_index += 1;

        # boundaries for the match
        my $end   = pos($string);
        my $term  = $&; # used to be slow in older perls, but now OK
        my $start = $end - length($term);

        # the old way used to be as follows, but it is ridiculously slow on utf8 strings
        # .. see https://github.com/Perl/perl5/issues/18786
        #
        # my ($start, $end) = ($-[0], $+[0]);
        # my $term = substr($string, $start, $end-$start);

        # apply filtering and stopwords, if any
        $term = Unicode::CaseFold::fc($term) if $lower;
        $term = $filter->($term)             if $filter;
        $filter_in_place->($term)            if $filter_in_place;
        undef $term            if $stopwords and $stopwords->{$term};

        # if $term was not cancelled by filters above, return it
        if ($term) {
          return wantarray ? ($term, length($term), $start, $end, $term_index)
                           : $term;
        }
      } # otherwise, loop again to extract next term

      # otherwise, no more term in input string, return undef or empty list
      return;
    };
  };
}

sub word {
  __PACKAGE__->new(regex => qr/\w+/, @_);
}

sub word_locale {
  use locale;
  __PACKAGE__->new(regex => qr/\w+/, @_);
}

sub word_unicode {
  __PACKAGE__->new(regex => qr/\p{Word}+/, @_);
}

sub unaccent {
  require Text::Transliterator::Unaccent;
  my %args = @_;
  my $want_lower      = !exists $args{lower} || $args{lower};
  my %unaccenter_args = $want_lower ? () : (upper => 0);
  my $unaccenter = Text::Transliterator::Unaccent->new(%unaccenter_args);
  __PACKAGE__->new(regex           => qr/\p{Word}+/,
                   filter_in_place => $unaccenter,
                   %args);
}


1; # End of Search::Tokenizer


__END__