File Coverage

blib/lib/HTML/Highlight.pm

Criterion	Covered	Total	%
statement	92	99	92.9
branch	28	40	70.0
condition	3	9	33.3
subroutine	10	11	90.9
pod	2	3	66.6
total	135	162	83.3

package HTML::Highlight;

use locale;

use strict;
use Carp;

BEGIN {
	use vars qw ($VERSION @ISA);
	$VERSION     = 0.20;
	@ISA         = ();
}

END { }

my $MIN_SECTION_LENGTH = 60;
my $DEFAULT_SECTION_LENGTH = 80;

sub new {
	$_ = shift;
	my $class = ref($_) || $_;

	croak ('HTML::Highlight - even number of parameters expected.')
		if (@_ % 2);

	# set the defaults
	my $self = {
		words => [],
		wildcards => [],
		colors => [
		'#ffff66',
        '#A0FFFF',
        '#99ff99',
		'#ff9999',
		'#ff66ff'
		],
		czech_language => 0,
		debug => 0
	};

	bless ($self, $class);

	# get parameters, overiding the defaults
	for (my $i = 0; $i <= $#_; $i += 2)	{
		exists ( $self->{lc($_[$i])} ) or
			croak ('HTML::Highlight - invalid parameter ' . $_[$i] . '.');
    	$self->{lc($_[$i])} = $_[($i + 1)];
	}

	croak ('HTML::Highlight - "words" and "wildcards" parameters must be references to arrays')
		if (ref($self->{words}) ne 'ARRAY' or ref($self->{wildcards}) ne 'ARRAY');

	require CzFast if ($self->{czech_language});

	return $self;
}


sub highlight {
	my $self = shift;
	my $document = shift;

	croak ('HTML::Highlight - no document defined')
		if (not defined($document));
	return '' if (length($document) == 0);

	my $doc = $document;

    for (my $i = 0, my $cindex = 0; $i < @{$self->{words}}; $i++, $cindex++) {
    	my $color;
        my $out;
		if ($self->{colors}->[$cindex]) {
			$color = $self->{colors}->[$cindex];
        }
        else {
			$cindex = 0;
			$color = $self->{colors}->[$cindex];
		}
        while($doc) {
            if ($doc !~ /(.*?)(<.*?>)(.*)/s) {
                $out .= $self->_highlight($doc, $i, $color);
                last;
            }
            else {
                my $str = $1;
                my $html = $2;
                my $rest = $3;
                $out .= $self->_highlight($str, $i, $color);
                $out .= $html;
                $doc = $rest;
            }
        }
        $doc = $out;
    }

return $doc;
}

sub preview_context {
	my $self = shift;
	my $document = shift;
	my $sectlen = shift;

	$self->{context} = {};
	$self->{sectlen} = $sectlen >= $MIN_SECTION_LENGTH ?
					   $sectlen : $DEFAULT_SECTION_LENGTH;
	$self->{sections} = [];

	$document =~ s/<.*?>//g;

	for (my $i = 0; $i < @{$self->{words}}; $i++) {
		my $pattern = $self->{czech_language} ?
					  &CzFast::czregexp($self->{words}->[$i]) :
					  $self->{words}->[$i];

        my $wildcard = $self->{wildcards}->[$i];
		my $regexp;

        if ($wildcard eq '%') {
			$regexp = "${pattern}\\w*";
		}
		elsif ($wildcard eq '*') {
			$regexp = "${pattern}s?";
		}
		else {
			$regexp = $pattern;
		}

		if (not $self->{context}->{$pattern}
        	and not grep (/$regexp/i, values %{$self->{context}})) {
			my $chars = int(($self->{sectlen} - length($pattern)) / 2);
			print "Chars: $chars\n" if ($self->{debug});
			if ($document =~ /(?:^|\W)(.{0,$chars})(\W+|^)($regexp)(\W+|$)(.{0,$chars})(?:\W|$)/six) {
				my $section = $1.$2.$3.$4.$5;
				$self->{context}->{$pattern} = $section;
				push(@{$self->{sections}}, $section);
			}
		}
	}

	return $self->{sections};
}

#########################
#### private methods ####
#########################

sub _highlight {
	my $self = shift;
	my $str = shift;
    my $word = shift;
	my $color = shift;

    my $pattern = $self->{words}->[$word];
	$pattern = &CzFast::czregexp($pattern) if ($self->{czech_language});

	my $wildcard = $self->{wildcards}->[$word];
	my $regexp;

    if ($wildcard eq '%') {
		my $pat = $self->{czech_language} ? &_cz_pattern : '\w*';
		$regexp = "${pattern}$pat";
	}
	elsif ($wildcard eq '*') {
		$regexp = "${pattern}s?";
	}
	else {
		$regexp = $pattern;
	}

	print "$str: $pattern | $wildcard | $regexp | $color\n" if ($self->{debug});
	$str =~ s!(\W+|^)($regexp)!$1$2!sig;
	return $str;
}

sub _cz_pattern {
	my @chars;
    my $pat = '(';
	foreach my $char ('a'..'z') {
		push(@chars, &CzFast::czregexp($char));
	}
	$pat .= join('|',@chars);
	$pat .= ')*';
	return $pat;
}


1;

__END__