example/modules/SimpleHighlight.pm

#=======================================================================
#  Simple Highlighting Code
#    $Id: SimpleHighlight.pm,v 1.1 2001/12/06 07:32:11 whmoseley Exp $
#=======================================================================
package SimpleHighlight;
use strict;

sub new {
    my ( $class, $results, $metaname ) = @_;


    my $self = bless {
        results => $results,  # just in case we need a method
        settings=> $results->config('highlight'),
        metaname=> $metaname,
    }, $class;

    # parse out the query into words
    my $query = $results->extract_query_match;


    # Do words exist for this layer (all text at this time) and metaname?
    # This is a reference to an array of phrases and words


    if ( $query && exists $query->{text}{$metaname} ) {
        $self->{query} = $query->{text}{$metaname};

        $self->set_match_regexp;
    }


    return $self;
}

sub highlight {
    my ( $self, $properties ) = @_;


    return unless $self->{query};

    my $phrase_array = $self->{query};

    my $settings = $self->{settings};
    my $metaname = $self->{metaname};

    # Do we care about this meta?
    return unless exists $settings->{meta_to_prop_map}{$metaname};

    # Get the related properties
    my @props = @{ $settings->{meta_to_prop_map}{$metaname} };

    for ( @props ) {
        if ( $properties->{$_} ) {
            $self->highlight_text( \$properties->{$_}, $phrase_array );
        }
    }

}


#==========================================================================
#

sub highlight_text {

    my ( $self, $text_ref, $phrase_array ) = @_;
    

    my $settings = $self->{settings};

    my $Show_Words = $settings->{show_words} || 10;
    my $Occurrences = $settings->{occurrences} || 5;
    my $Max_Words = $settings->{max_words} || 100;
    my $On = $settings->{highlight_on} || '<b>';
    my $Off = $settings->{highlight_off} || '</b>';

    my @words = split /\s+/, $$text_ref;
    if ( @words > $Max_Words ) {
        $$text_ref = join ' ', @words[0..$Max_Words], '<b>...</b>';
    }


    for ( @{ $self->{matches} } ) {
        $$text_ref =~ s/($_)/$On$1$Off/g;
    }

    
}

#============================================
# Returns compiled regular expressions for matching
#
# This builds a list of expressions to match against the text.

sub set_match_regexp {
    my $self = shift;

    my $results = $self->{results};


    my $wc = $results->header('wordcharacters');
    $wc = quotemeta $wc;

    my @matches;

    # loop through all the phrase 
    for ( @{$self->{query}} ) {

        # Fix up wildcards
        my $exp = join '[^$wc]+',
            map { '\b' . $_ . '\b' }
            map { substr( $_, -1, 1 ) eq '*'
                ? quotemeta( substr( $_, 0, -1) ) . "[$wc]*?"
                : quotemeta
            } @$_;

        push @matches, qr/$exp/i;
    }


    $self->{matches} = \@matches;

}    
1;

1	#=======================================================================
2	# Simple Highlighting Code
3	# $Id: SimpleHighlight.pm,v 1.1 2001/12/06 07:32:11 whmoseley Exp $
4	#=======================================================================
5	package SimpleHighlight;
6	use strict;
7
8	sub new {
9	my ( $class, $results, $metaname ) = @_;
10
11
12	my $self = bless {
13	results => $results, # just in case we need a method
14	settings=> $results->config('highlight'),
15	metaname=> $metaname,
16	}, $class;
17
18	# parse out the query into words
19	my $query = $results->extract_query_match;
20
21
22	# Do words exist for this layer (all text at this time) and metaname?
23	# This is a reference to an array of phrases and words
24
25
26
27	if ( $query && exists $query->{text}{$metaname} ) {
28	$self->{query} = $query->{text}{$metaname};
29
30	$self->set_match_regexp;
31	}
32
33
34	return $self;
35	}
36
37	sub highlight {
38	my ( $self, $properties ) = @_;
39
40
41	return unless $self->{query};
42
43	my $phrase_array = $self->{query};
44
45	my $settings = $self->{settings};
46	my $metaname = $self->{metaname};
47
48	# Do we care about this meta?
49	return unless exists $settings->{meta_to_prop_map}{$metaname};
50
51	# Get the related properties
52	my @props = @{ $settings->{meta_to_prop_map}{$metaname} };
53
54	for ( @props ) {
55	if ( $properties->{$_} ) {
56	$self->highlight_text( \$properties->{$_}, $phrase_array );
57	}
58	}
59
60	}
61
62
63
64	#==========================================================================
65	#
66
67	sub highlight_text {
68
69	my ( $self, $text_ref, $phrase_array ) = @_;
70
71
72	my $settings = $self->{settings};
73
74	my $Show_Words = $settings->{show_words} \|\| 10;
75	my $Occurrences = $settings->{occurrences} \|\| 5;
76	my $Max_Words = $settings->{max_words} \|\| 100;
77	my $On = $settings->{highlight_on} \|\| '<b>';
78	my $Off = $settings->{highlight_off} \|\| '</b>';
79
80	my @words = split /\s+/, $$text_ref;
81	if ( @words > $Max_Words ) {
82	$$text_ref = join ' ', @words[0..$Max_Words], '<b>...</b>';
83	}
84
85
86	for ( @{ $self->{matches} } ) {
87	$$text_ref =~ s/($_)/$On$1$Off/g;
88	}
89
90
91
92	}
93
94	#============================================
95	# Returns compiled regular expressions for matching
96	#
97	# This builds a list of expressions to match against the text.
98
99	sub set_match_regexp {
100	my $self = shift;
101
102	my $results = $self->{results};
103
104
105	my $wc = $results->header('wordcharacters');
106	$wc = quotemeta $wc;
107
108	my @matches;
109
110	# loop through all the phrase
111	for ( @{$self->{query}} ) {
112
113	# Fix up wildcards
114	my $exp = join '[^$wc]+',
115	map { '\b' . $_ . '\b' }
116	map { substr( $_, -1, 1 ) eq '*'
117	? quotemeta( substr( $_, 0, -1) ) . "[$wc]*?"
118	: quotemeta
119	} @$_;
120
121	push @matches, qr/$exp/i;
122	}
123
124
125	$self->{matches} = \@matches;
126
127	}
128	1;
129