File Coverage

blib/lib/Search/Tokenizer.pm

Criterion	Covered	Total	%
statement	71	77	92.2
branch	23	32	71.8
condition	5	8	62.5
subroutine	10	13	76.9
pod	5	6	83.3
total	114	136	83.8

package Search::Tokenizer;
use warnings;
use strict;
use Carp              qw(croak);
use Unicode::CaseFold qw(fc);    # because CORE::fc only came with Perl 5.16

our $VERSION = '1.03';

#======================================================================
# MAIN FUNCTIONALITY
#======================================================================

sub new {
  my $class = shift;

  # defaults
  my $regex           = qr/\p{Word}+/;
  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, $val) = splice(@_, 0, 2)) {
    $arg .= "=>" . (ref($val) || "SCALAR");
  CHECK:
    for ($arg) {
      /^regex=>Regexp$/         and do { $regex = $val;           last CHECK};
      /^lower=>SCALAR$/         and do { $lower = !!$val;         last CHECK};
      /^filter=>CODE$/          and do { $filter = $val;          last CHECK};
      /^filter_in_place=>CODE$/ and do { $filter_in_place = $val; last CHECK};
      /^stopwords=>HASH$/       and do { $stopwords = $val;       last CHECK};
      croak "Invalid option or invalid operand: $arg";
    }
  }

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

  # return tokenizer factory: closure
  return sub {
    my ($string, @other_args) = @_;
    not @other_args
      or croak "too many args -- just a single string is expected";

    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, that's the end of the input string, return undef or empty list
      return;
    };
  };
}

#======================================================================
# BUILTIN TOKENIZERS
#======================================================================


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);
}


#======================================================================
# UTILITY FUNCTION
#======================================================================

sub unroll {
  my $iterator   = shift;
  my $no_details = shift;
  my @results;

  while (my @r = $iterator->() ) {
    push @results, $no_details ? $r[0] : \@r;
  }
  return @results;
}


1; # End of Search::Tokenizer


__END__