File Coverage

blib/lib/Text/Context.pm

Criterion	Covered	Total	%
statement	95	95	100.0
branch	16	16	100.0
condition	1	2	50.0
subroutine	15	15	100.0
pod	10	10	100.0
total	137	138	99.2

package Text::Context;

use strict;
use warnings;

use UNIVERSAL::require;

our $VERSION = "3.7";

=head1 NAME

Text::Context - Handle highlighting search result context snippets

=head1 SYNOPSIS

  use Text::Context;

  my $snippet = Text::Context->new($text, @keywords);

  $snippet->keywords("foo", "bar"); # In case you change your mind

  print $snippet->as_html;
  print $snippet->as_text;

=head1 DESCRIPTION

Given a piece of text and some search terms, produces an object
which locates the search terms in the message, extracts a reasonable-length
string containing all the search terms, and optionally dumps the string out
as HTML text with the search terms highlighted in bold.

=head2 new

Creates a new snippet object for holding and formatting context for
search terms.

=cut

sub new {
	my ($class, $text, @keywords) = @_;
	my $self = bless { text => $text, keywords => [] }, $class;
	$self->keywords(@keywords);
	return $self;
}

=head2 keywords

Accessor method to get/set keywords. As the context search is done
case-insensitively, the keywords will be lower-cased.

=cut

sub keywords {
	my ($self, @keywords) = @_;
	$self->{keywords} = [ map { s/\s+/ /g; lc $_ } @keywords ] if @keywords;
	return @{ $self->{keywords} };
}

=begin maintenance

=head2 prepare_text

Turns the text into a set of Paragraph objects, collapsing multiple
spaces in the text and feeding the paragraphs, in order, onto the
C member.

=head2 para_class

The Paragraph class to use. This defaults to 'Text::Context::Para'

=end maintenance

=cut

sub para_class { "Text::Context::Para" }

sub prepare_text {
	my $self = shift;
	my @paras = split /\n\n/, $self->{text};
	for (0 .. $#paras) {
		my $x = $paras[$_];
		$x =~ s/\s+/ /g;
		$self->para_class->require;
		push @{ $self->{text_a} }, $self->para_class->new($x, $_);
	}
}

=begin maintenance

=head2 permute_keywords

This is very clever. To determine which keywords "apply" to a given
paragraph, we first produce a set of all possible keyword sets. For
instance, given "a", "b" and "c", we want to produce

    a b c
    a b
    a   c
    a
      b c
      b
        c

We do this by counting in binary, and then mapping the counts onto
keywords.

=end maintenance

=cut

sub permute_keywords {
	my $self = shift;
	my @permutation;
	for my $bitstring (1 .. (2**@{ $self->{keywords} }) - 1) {
		my @thisperm;
		for my $bitmask (0 .. @{ $self->{keywords} } - 1) {
			push @thisperm, $self->{keywords}[$bitmask]
				if $bitstring & 2**$bitmask;
		}
		push @permutation, \@thisperm;
	}
	return reverse @permutation;
}

=begin maintenance

=head2 score_para / get_appropriate_paras

Now we want to find a "score" for this paragraph, finding the best set
of keywords which "apply" to it. We favour keyword sets which have a
large number of matches (obviously a paragraph is better if it matches
"a" and "c" than if it just matches "a") and with multi-word keywords.
(A paragraph which matches "fresh cheese sandwiches" en bloc is worth
picking out, even if it has no other matches.)

=end maintenance

=cut

sub score_para {
	my ($self, $para) = @_;
	my $content = $para->{content};
	my %matches;

	# Do all the matching of keywords in advance of the boring
	# permutation bit
	for my $word (@{ $self->{keywords} }) {
		my $word_score = 0;
		$word_score += 1 + ($content =~ tr/ / /) if $content =~ /\b\Q$word\E\b/i;
		$matches{$word} = $word_score;
	}

	#XXX : Possible optimization: Give up if there are no matches

	for my $wordset ($self->permute_keywords) {
		my $this_score = 0;
		$this_score += $matches{$_} for @$wordset;
		$para->{scoretable}[$this_score] = $wordset if $this_score > @$wordset;
	}
	$para->{final_score} = $#{ $para->{scoretable} };
}

sub _set_intersection {
	my %union;
	my %isect;
	for (@_) { $union{$_}++ && ($isect{$_} = $_) }
	return values %isect;
}

sub _set_difference {
	my ($a, $b) = @_;
	my %seen;
	@seen{@$b} = ();
	return grep { !exists $seen{$_} } @$a;
}

sub get_appropriate_paras {
	my $self = shift;
	my @app_paras;
	my @keywords = @{ $self->{keywords} };
	my @paras    =
		sort { $b->{final_score} <=> $a->{final_score} } @{ $self->{text_a} };
	for my $para (@paras) {
		my @words = _set_intersection($para->best_keywords, @keywords);
		if (@words) {
			@keywords = _set_difference(\@keywords, \@words);
			$para->{marked_words} = \@words;
			push @app_paras, $para;
			last if !@keywords;
		}
	}
	$self->{app_paras} = [ sort { $a->{order} <=> $b->{order} } @app_paras ];
	return @{ $self->{app_paras} };
}

=head2 paras

    @paras = $self->paras($maxlen)

Return shortened paragraphs to fit together into a snippet of at most
C<$maxlen> characters.

=cut

sub paras {
	my $self = shift;
	my $max_len = shift || 80;
	$self->prepare_text;
	$self->score_para($_) for @{ $self->{text_a} };
	my @paras = $self->get_appropriate_paras;
	return unless @paras;

	# XXX: Algorithm may get better here by considering number of marked
	# up words as weight
	return map { $_->slim($max_len / @paras) } $self->get_appropriate_paras;
}

=head2 as_text

Calculates a "representative" string which contains
the given search terms. If there's lots and lots of context between the
terms, it's replaced with an ellipsis.

=cut

sub as_text {
	return join " ... ", map { $_->as_text } $_[0]->paras;
}

=head2 as_html([ start => "", end => "" ])

Markup the snippet as a HTML string using the specified delimiters or
with a default set of delimiters (Cspan class="quoted"E>).

=cut

sub as_html {
	my $self = shift;
	my %args = @_;

	my ($start, $end) = @args{qw(start end)};
	return join " ... ", map { $_->marked_up($start, $end) } $self->paras;
}

=head1 AUTHOR

Original author: Simon Cozens

Current maintainer: Tony Bowden

=head1 BUGS and QUERIES

Please direct all correspondence regarding this module to:
  [e-mail]

=head1 COPYRIGHT AND LICENSE

  Copyright (C) 2002-2005 Kasei

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License; either version
  2 of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut

1;