File Coverage

blib/lib/Search/Tools/Snipper.pm

Criterion	Covered	Total	%
statement	241	353	68.2
branch	73	160	45.6
condition	24	47	51.0
subroutine	24	25	96.0
pod	2	2	100.0
total	364	587	62.0

package Search::Tools::Snipper;
use Moo;
extends 'Search::Tools::Object';
with 'Search::Tools::ArgNormalizer';
use Carp;
use Data::Dump qw( dump );
use Search::Tools::XML;
use Search::Tools::UTF8;
use Search::Tools::Tokenizer;
use Search::Tools::HeatMap;

use namespace::autoclean;

our $VERSION = '1.006';

# extra space here so pmvers works against $VERSION
our $ellip          = ' ... ';
our $DefaultSnipper = 'offset';

#
#   TODO allow for returning an array ref of
#   extracts instead of joining them all with $ellip
#

my @attrs = qw(
    as_sentences
    collapse_whitespace
    context
    count
    escape
    force
    ignore_length
    max_chars
    occur
    query
    show
    snipper
    strip_markup
    treat_phrases_as_singles
    type
    type_used
    use_pp
    word_len
);

my %Defaults = (
    type                     => $DefaultSnipper,
    occur                    => 5,
    max_chars                => 300,
    context                  => 8,
    word_len                 => 4,                 # TODO still used?
    show                     => 1,
    collapse_whitespace      => 1,
    escape                   => 0,
    force                    => 0,
    as_sentences             => 0,
    ignore_length            => 0,
    treat_phrases_as_singles => 1,
    strip_markup             => 0,
);

for my $attr (@attrs) {
    my $def = $Defaults{$attr} || undef;
    if ( defined $def ) {
        has( $attr => ( is => 'rw', default => sub {$def} ) );
    }
    else {
        has( $attr => ( is => 'rw' ) );
    }
}

sub BUILD {
    my $self = shift;

    #dump $self;

    $self->{_tokenizer} = Search::Tools::Tokenizer->new(
        re    => $self->query->qp->term_re,
        debug => $self->debug,
    );

    my $wc = $self->query->qp->word_characters;

    # regexp for splitting into terms in _re()
    $self->{_wc_regexp} = qr/[^$wc]+/io;

    $self->{_qre}
        = $self->query->terms_as_regex( $self->treat_phrases_as_singles );

    $self->count(0);

    return $self;
}

# I tried Text::Context but that was too slow.
# Here are several different models.
# I have found that _loop() is faster for single-word queries,
# while _re() seems to be the best compromise between speed and accuracy.
# New in version 0.24 is _token() which is mostly XS and should be best.

sub _pick_snipper {
    my ( $self, $text ) = @_;
    my $snipper_name = $self->type || $DefaultSnipper;
    if ( $self->query->qp->stemmer ) {
        $snipper_name = 'token';
    }
    my $method_name = '_' . $snipper_name;
    $self->type_used($snipper_name);
    my $func = sub { shift->$method_name(@_) };
    return $func;
}

# 2 passes, excluding ' ' in the first one,
# is 60% faster than a single pass including ' '.
# likely because there are far fewer matches
# in either of the 2 than the 1.
sub _normalize_whitespace {
    $_[0] =~ s,[\n\r\t\xa0]+,\ ,go;
    $_[0] =~ s,\ +, ,go;    # \ \ + was 16x slower on bigfile!!
}

sub snip {
    my $self = shift;
    my $text = shift;
    if ( !defined $text ) {
        croak "text required to snip";
    }

    # normalize encoding, esp for regular expressions.
    $text = to_utf8($text);

    # don't snip if we're less than the threshold
    if ( length($text) < $self->max_chars && !$self->ignore_length ) {
        if ( $self->show ) {
            if ( $self->strip_markup ) {
                return Search::Tools::XML->no_html($text);
            }
            return $text;
        }
        return '';
    }

    if ( $self->strip_markup ) {
        $text = Search::Tools::XML->no_html($text);
    }

    if ( $self->collapse_whitespace ) {
        _normalize_whitespace($text);
    }

    # we calculate the snipper each time since caller
    # may set type() or snipper() between calls to snip().
    my $func = $self->snipper || $self->_pick_snipper($text);

    my $s = $func->( $self, $text );

    $self->debug and warn "snipped: '$s'\n";

    # sanity check
    if ( length($s) > ( $self->max_chars * 4 ) && !$self->ignore_length ) {
        $s = $self->_dumb($s);
        $self->debug and warn "too long. dumb snip: '$s'\n";
    }
    elsif ( !length($s) && !$self->ignore_length ) {
        $s = $self->_dumb($text);
        $self->debug and warn "too short. dumb snip: '$s'\n";
    }

    # escape entities before collapsing whitespace.
    $s = $self->_escape($s);

    if ( $self->collapse_whitespace ) {
        _normalize_whitespace($s);
    }

    return $s;

}

sub _token {
    my $self = shift;
    my $qre  = $self->{_qre};
    $self->debug and warn "\$qre: $qre";

    my $method = ( $self->{use_pp} ) ? 'tokenize_pp' : 'tokenize';

    # must split phrases into OR'd regex or else no heat is generated.
    my $qre_ORd = $qre;
    $qre_ORd =~ s/(\\ )+/\|/g;
    my $heat_seeker = qr/^$qre_ORd$/;

    # if stemmer is on, we must stem each token to look for a match
    if ( $self->query->qp->stemmer ) {
        my $stemmer = $self->query->qp->stemmer;
        my $qp      = $self->query->qp;
        my $re      = $heat_seeker;
        $heat_seeker = sub {
            my ($token) = @_;
            my $st = $stemmer->( $qp, $token->str );
            return $st =~ m/$re/;
        };
    }
    my $tokens = $self->{_tokenizer}->$method( $_[0], $heat_seeker );

    #$self->debug and $tokens->dump;

    return $self->_dumb( $_[0] ) unless scalar @{ $tokens->get_heat };

    my $heatmap = Search::Tools::HeatMap->new(
        tokens                    => $tokens,
        window_size               => $self->{context},
        as_sentences              => $self->{as_sentences},
        debug                     => $self->debug,
        _query                    => $self->query,
        _qre                      => $qre,
        _treat_phrases_as_singles => $self->{treat_phrases_as_singles},
        _stemmer                  => $self->query->qp->stemmer,
    );

    # reduce noise in debug
    delete $heatmap->{_query};

    $self->debug and warn "heatmap: " . dump $heatmap;

    my $tokens_arr = $tokens->as_array;

    #warn "snips: " . dump $heatmap->spans;
    if ( $heatmap->has_spans ) {

        # stringify positions
        my @snips;
        for my $span ( @{ $heatmap->spans } ) {

            $self->debug and warn '>>>' . $span->{str_w_pos} . '<<<';
            push( @snips, $span->{str} );
        }
        my $occur_index = $self->occur - 1;
        if ( $#snips > $occur_index ) {
            @snips = @snips[ 0 .. $occur_index ];
        }
        my $snip                   = join( $ellip, @snips );
        my $snips_start_with_query = $_[0] =~ m/^\Q$snip\E/;
        my $snips_end_with_query   = $_[0] =~ m/\Q$snip\E$/;
        if ( $self->{as_sentences} ) {
            $snips_start_with_query = 1;
            $snips_end_with_query   = $snip =~ m/[\.\?\!]\s*$/;
        }

        # if we are pulling out something less than the entire
        # text, insert ellipses...
        if ( $_[0] ne $snip ) {
            $self->debug and warn "extract is smaller than snip";
            my $extract = join( '',
                ( $snips_start_with_query ? '' : $ellip ),
                $snip, ( $snips_end_with_query ? '' : $ellip ) );
            return $extract;
        }
        else {
            return $snip;
        }
    }
    else {

        #warn "no spans. using dumb snip";
        return $self->_dumb( $_[0] );
    }

}

sub _get_offsets {
    my $self = shift;
    return $self->{_tokenizer}->get_offsets( @_, $self->{_qre} );
}

sub _offset {
    my $self    = shift;
    my $txt     = shift;
    my $offsets = $self->_get_offsets($txt);
    my $snips   = $self->_get_offset_snips( $txt, $offsets );
    return $self->_token( join( '', @$snips ) );
}

sub _get_offset_snips {
    my $self    = shift;
    my $txt     = shift;
    my $offsets = shift;

    # grab $size chars on either side of each offset
    # and tokenize each.
    # $size should be nice and wide to minimize the substr() calls.
    my $size = $self->max_chars * 10;

    #warn "window size $size";

    my @buf;
    my $len = length($txt);
    if ( $size > $len ) {

        #warn "window bigger than document";
        return [$txt];
    }

    my ( $seen_start, $seen_end );
    my $last_ending = 0;
    for my $pos (@$offsets) {

        my $tmp;

        my $start = $pos - int( $size / 2 );
        my $end   = $pos + int( $size / 2 );

        # avoid overlaps
        if ( $last_ending && $start < $last_ending ) {
            $start = $last_ending + 1;
            $end   = $start + $size;
        }

        #warn "$start .. $pos .. $end";

        if ( $pos > $end or $pos < $start ) {
            next;
        }

        $last_ending = $end;

        #warn "$start .. $end";

        # if $pos is close to the front of $txt
        if ( $start <= 0 ) {
            next if $seen_start++;

            #warn "start";
            $tmp = substr( $txt, 0, $size );
        }

        # if $pos is somewhere near the end
        elsif ( $end > $len ) {
            next if $seen_end++;

            #warn "end";
            $tmp = substr( $txt, ( $len - $size ) );
        }

        # default is somewhere in the ripe middle.
        else {

            #warn "middle";
            $tmp = substr( $txt, $start, $size );
        }

        push @buf, $tmp;
    }

    return \@buf;
}

sub _loop {
    my $self   = shift;
    my $txt    = shift;
    my $regexp = $self->{_qre};

    #carp "loop snip: $txt";

    $self->debug and carp "loop snip regexp: $regexp";

    my $debug = $self->debug || 0;

    # no matches
    return $self->_dumb($txt) unless $txt =~ m/$regexp/;

    #carp "loop snip: $txt";

    my $context = $self->context - 1;
    my $occur = $self->occur || 1;
    my @snips;

    my $notwc = $self->{_wc_regexp};

    my @words       = split( /($notwc)/, $txt );
    my $count       = -1;
    my $start_again = $count;
    my $total       = 0;
    my $first_match = 0;

WORD: for my $w (@words) {

        if ( $debug > 1 ) {
            warn ">>\n" if $count % 2;
            warn "word: '$w'\n";
        }

        $count++;
        next WORD if $count < $start_again;

        # the next WORD lets us skip past the last frag we excerpted

        my $last = $count - 1;
        my $next = $count + 1;

        #warn '-' x 30 . "\n";
        if ( $w =~ m/^$regexp$/ ) {

            if ( $debug > 1 ) {
                warn "w: '$w' match: '$1'\n";
            }

            $first_match = $count;

            my $before = $last - $context;
            $before = 0 if $before < 0;
            my $after = $next + $context;
            $after = $#words if $after > $#words;

            if ( $debug > 1 ) {
                warn "$before .. $last, $count, $next .. $after\n";
            }

            my @before = @words[ $before .. $last ];
            my @after  = @words[ $next .. $after ];

            my $this_snip_matches = grep {m/^$regexp$/i} ( @before, @after );
            if ($this_snip_matches) {
                $after += $this_snip_matches;
                @after = @words[ $next .. $after ];
            }
            $total += $this_snip_matches;
            $total++;    # for current $w

            my $t = join( '', @before, $w, @after );

            $t .= $ellip unless $count == $#words;

            if ( $debug > 1 ) {
                warn "t: $t\n";
                warn "this_snip_matches: $this_snip_matches\n";
                warn "total: $total\n";
            }

            push( @snips, [ $t, $this_snip_matches + 1 ] );    # +1 for $w
            $start_again = $after;
        }

    }

    # sort by match density.
    # consistent with HeatMap and lets us find
    # the *best* match, including phrases.
    @snips = map { $_->[0] } sort { $b->[1] <=> $a->[1] } @snips;

    if ( $debug > 1 ) {
        carp "snips: " . scalar @snips;
        carp "words: $count\n";
        carp "grandtotal: $total\n";
        carp "occur: $occur\n";
        carp '-' x 50 . "\n";

    }

    $self->count( scalar(@snips) + $self->count );
    my $last_snip = $occur - 1;
    if ( $last_snip > $#snips ) {
        $last_snip = $#snips;
    }

    #warn dump \@snips;
    my $snippet = join( '', @snips[ 0 .. $last_snip ] );
    $self->debug and warn "before no_start_partial: '$snippet'\n";

    #_no_start_partial($snippet);
    $snippet = $ellip . $snippet if $first_match;

    return $snippet;
}

sub _re {

   # get first N matches for each q, then take one of each till we have $occur

    my $self  = shift;
    my $text  = shift;
    my @q     = @{ $self->query->terms };
    my $occur = $self->occur;
    my $Nchar = $self->context * $self->word_len;
    my $total = 0;
    my $notwc = $self->{_wc_regexp};

    # get minimum number of snips necessary to meet $occur
    my $snip_per_q = int( $occur / scalar(@q) );
    $snip_per_q ||= 1;

    my ( %snips, @snips, %ranges, $snip_starts_with_query );
    $snip_starts_with_query = 0;

Q: for my $q (@q) {
        $snips{$q} = { t => [], offset => [] };

        $self->debug and warn "$q : $snip_starts_with_query";

        # try simple regexp first, then more complex if we don't match
        next Q
            if $self->_re_match( \$text, $self->query->regex_for($q)->plain,
            \$total, $snips{$q}, \%ranges, $Nchar, $snip_per_q,
            \$snip_starts_with_query );

        $self->debug and warn "failed match on plain regexp";

        pos $text = 0;    # do we really need to reset this?

        unless (
            $self->_re_match(
                \$text,      $self->query->regex_for($q)->html,
                \$total,     $snips{$q},
                \%ranges,    $Nchar,
                $snip_per_q, \$snip_starts_with_query
            )
            )
        {
            $self->debug and warn "failed match on html regexp";
        }

    }

    return $self->_dumb($text) unless $total;

    # get all snips into one array in order they appeared in $text
    # should be a max of $snip_per_q in any one $q snip array
    # so we should have at least $occur in total,
    # which we'll splice() if need be.

    my %offsets;
    for my $q ( keys %snips ) {
        my @s = @{ $snips{$q}->{t} };
        my @o = @{ $snips{$q}->{offset} };

        my $i = 0;
        for (@s) {
            $offsets{$_} = $o[$i];
        }
    }
    @snips = sort { $offsets{$a} <=> $offsets{$b} } keys %offsets;

    # max = $occur
    @snips = splice @snips, 0, $occur;

    $self->debug and warn dump( \@snips );

    my $snip = join( $ellip, @snips );
    _no_start_partial($snip) unless $snip_starts_with_query;
    $snip = $ellip . $snip unless $text =~ m/^\Q$snips[0]/i;
    $snip .= $ellip unless $text =~ m/\Q$snips[-1]$/i;

    $self->count( scalar(@snips) + $self->count );

    return $snip;

}

sub _re_match {

    # the .{0,$Nchar} regexp slows things WAY down. so just match,
    # then use pos() to get chars before and after.

    # if escape = 0 and if prefix or suffix contains a < or >,
    # try to include entire tagset.

    my ( $self, $text, $re, $total, $snips, $ranges, $Nchar, $max_snips,
        $snip_starts_with_query )
        = @_;

    my $t_len = length $$text;

    my $cnt = 0;

    if ( $self->debug ) {
        warn "re_match regexp: >$re<\n";
        warn "max_snips: $max_snips\n";
    }

RE: while ( $$text =~ m/$re/g ) {

        my $pos          = pos $$text;
        my $before_match = $1;
        my $match        = $2;
        my $after_match  = $3;
        $cnt++;
        my $len  = length $match;
        my $blen = length $before_match;
        if ( $self->debug ) {
            warn "re: '$re'\n";
            warn "\$1 = '$before_match' = ", ord($before_match), "\n";
            warn "\$2 = '$match'\n";
            warn "\$3 = '$after_match' = ", ord($after_match), "\n";
            warn "pos = $pos\n";
            warn "len = $len\n";
            warn "blen= $blen\n";
        }

        if ( $self->debug && exists $ranges->{$pos} ) {
            warn "already found $pos\n";
        }

        next RE if exists $ranges->{$pos};

        my $start_match = $pos - $len - ( $blen || 1 );
        $start_match = 0 if $start_match < 0;

        $$snip_starts_with_query = 1 if $start_match == 0;

        # sanity
        $self->debug
            and warn "match should be [$start_match $len]: '",
            substr( $$text, $start_match, $len ), "'\n";

        my $prefix_start
            = $start_match < $Nchar
            ? 0
            : $start_match - $Nchar;

        my $prefix_len = $start_match - $prefix_start;

        #$prefix_len++; $prefix_len++;

        my $suffix_start = $pos - length($after_match);
        my $suffix_len   = $Nchar;
        my $end          = $suffix_start + $suffix_len;

        # if $end extends beyond, that's ok, substr compensates

        $ranges->{$_}++ for ( $prefix_start .. $end );
        my $prefix = substr( $$text, $prefix_start, $prefix_len );
        my $suffix = substr( $$text, $suffix_start, $suffix_len );

        if ( $self->debug ) {
            warn "prefix_start = $prefix_start\n";
            warn "prefix_len = $prefix_len\n";
            warn "start_match = $start_match\n";
            warn "len = $len\n";
            warn "pos = $pos\n";
            warn "char = $Nchar\n";
            warn "suffix_start = $suffix_start\n";
            warn "suffix_len = $suffix_len\n";
            warn "end = $end\n";
            warn "prefix: '$prefix'\n";
            warn "match:  '$match'\n";
            warn "suffix: '$suffix'\n";
        }

        # try and get whole words if we split one up
        # _no_*_partial does this more rudely

        # might be faster to do m/(\S)*$prefix/i
        # but we couldn't guarantee position accuracy
        # e.g. if $prefix matched more than once in $$text,
        # we might pull the wrong \S*

        unless ( $prefix =~ m/^\s/
            or substr( $$text, $prefix_start - 1, 1 ) =~ m/(\s)/ )
        {
            while ( --$prefix_start >= 0
                and substr( $$text, $prefix_start, 1 ) =~ m/(\S)/ )
            {
                my $onemorechar = $1;

                #warn "adding $onemorechar to prefix\n";
                $prefix = $onemorechar . $prefix;

                #last if $prefix_start <= 0 or $onemorechar !~ /\S/;
            }
        }

        # do same for suffix

        # We get error here under -w
        # about substr outside of string -- is $end undefined sometimes??

        unless ( $suffix =~ m/\s$/ or substr( $$text, $end, 1 ) =~ m/(\s)/ ) {
            while ( $end <= $t_len
                and substr( $$text, $end++, 1 ) =~ m/(\S)/ )
            {

                my $onemore = $1;

                #warn "adding $onemore to suffix\n";
                #warn "before '$suffix'\n";
                $suffix .= $onemore;

                #warn "after  '$suffix'\n";
            }
        }

        # will likely fail to include one half of tagset if other is complete
        unless ( $self->escape ) {
            my $sanity = 0;
            my @l      = ( $prefix =~ /(<)/g );
            my @r      = ( $prefix =~ /(>)/g );
            while ( scalar @l != scalar @r ) {

                @l = ( $prefix =~ /(<)/g );
                @r = ( $prefix =~ /(>)/g );
                last
                    if scalar @l
                    == scalar @r;    # don't take any more than we need to

                my $onemorechar = substr( $$text, $prefix_start--, 1 );

                #warn "tagfix: adding $onemorechar to prefix\n";
                $prefix = $onemorechar . $prefix;
                last if $prefix_start <= 0;
                last if $sanity++ > 100;

            }

            $sanity = 0;
            while ( $suffix =~ /<(\w+)/ && $suffix !~ /<\/$1>/ ) {

                my $onemorechar = substr( $$text, $end, 1 );

                #warn "tagfix: adding $onemorechar to suffix\n";
                $suffix .= $onemorechar;
                last if ++$end > $t_len;
                last if $sanity++ > 100;

            }
        }

        #		warn "prefix: '$prefix'\n";
        #		warn "match:  '$match'\n";
        #		warn "suffix: '$suffix'\n";

        my $context = join( '', $prefix, $match, $suffix );

        #warn "context is '$context'\n";

        push( @{ $snips->{t} },      $context );
        push( @{ $snips->{offset} }, $prefix_start );

        $$total++;

        #		warn '-' x 40, "\n";

        last if $cnt >= $max_snips;
    }

    return $cnt;
}

sub _dumb {

    # just grap the first X chars and return

    my $self = shift;
    return '' unless $self->show;

    my $txt = shift;
    my $max = $self->max_chars;
    $self->type_used('dumb');

    my $show = substr( $txt, 0, $max );
    _no_end_partial($show);
    $show .= $ellip;

    $self->count( 1 + $self->count );

    return $show;

}

sub _no_start_partial {
    $_[0] =~ s/^\S+\s+//gs;
}

sub _no_end_partial {
    $_[0] =~ s/\s+\S+$//gs;
}

sub _escape {
    if ( $_[0]->escape ) {
        return Search::Tools::XML->escape( $_[1] );
    }
    else {
        return $_[1];
    }
}

1;
__END__