File Coverage

lib/MKDoc/XML/Tagger.pm

Criterion	Covered	Total	%
statement	106	109	97.2
branch	4	4	100.0
condition	2	4	50.0
subroutine	12	13	92.3
pod	2	2	100.0
total	126	132	95.4

# -------------------------------------------------------------------------------------
# MKDoc::XML::Tagger
# -------------------------------------------------------------------------------------
# Author : Jean-Michel Hiver.
# Copyright : (c) MKDoc Holdings Ltd, 2003
#
# This module adds markup to an existing XML file / variable by matching expression.
# You could see it as an XML-compatible search and substitute module.
#
# The main reason it exists is to automagically hyperlink HTML in MKDoc, and also to
# mark up properly abbreviations based on glossaries.
#
# This module is distributed under the same license as Perl itself.
# -------------------------------------------------------------------------------------
package MKDoc::XML::Tagger;
use MKDoc::XML::Tokenizer;
use strict;
use warnings;
use utf8;

our $tags = [];
our $Ignorable_RE = qr /(?:\r|\n|\s|(?:\&\(\d+\)))*/;

our @DONT_TAG = qw/a/;

##
# $class->process_data ($xml, @expressions);
# ------------------------------------------
# Tags $xml with @expressions, where expression is a list of hashes.
#
# For example:
#
# MKDoc::XML::Tagger->process (
#     'I like oranges and bananas',
#     { _expr => 'oranges', _tag => 'a', href => 'http://www.google.com?q=oranges' },
#     { _expr => 'bananas', _tag => 'a', href => 'http://www.google.com?q=bananas' },
#
# Will return
#
# 'I like oranges and \
# bananas.
##
sub process_data
{
    my $class  = shift;
    my $tokens = MKDoc::XML::Tokenizer->process_data (shift);
    return _replace ($tokens, @_);
}


##
# $class->process_file ($file, @expressions);
# -------------------------------------------
# Same as $class->process_data ($data, @expressions), except that $data is read
# from $file.
##
sub process_file
{
    my $class  = shift;
    my $tokens = MKDoc::XML::Tokenizer->process_file (shift);
    return _replace ($tokens, @_);
}


##
# _replace ($tokens, @expressions);
# ---------------------------------
# This function constructs the newly marked up text from a list
# of XML $tokens and a list of @expressions and returns it.
#
# Longest expressions are applied first.
##
sub _replace
{
    my $tokens = shift;
    my @expr   = sort { length ($b->{_expr}) <=> length ($a->{_expr}) } @_;

    @expr = map {
	my $hash = \%{$_};
	for (keys %{$hash}) {
	    $hash->{$_} =~ s/\&/\&/g;
	    $hash->{$_} =~ s/\
	    $hash->{$_} =~ s/\>/\>/g;
	    $hash->{$_} =~ s/\"/\"/g;
	};
	$hash;
    } @expr;

    my $text; local $tags;
    ($text, $tags) = _segregate_markup_from_text ($tokens);

    # once we have segregated markup from the text, we can safely
    # encode < and > and "...
    # $text =~ s/\&/\&/g; # seems to be already encoded... where do we encode this stuff !?!
    $text =~ s/\
    $text =~ s/\>/\>/g;
    $text =~ s/\"/\"/g;

    # but we don't want any '
    $text =~ s/\'/\'/g;

    # @expr = _filter_out ($text, @expr);
    while (my $attr = shift (@expr))
    {
	my %attr = %{$attr};
        my $tag  = delete $attr{_tag}  || next;
        my $expr = delete $attr{_expr} || next;
        $text = _text_replace ($text, $expr, $tag, \%attr);
    }

    while ($text =~ /\&\(\d+\)/)
    {
    for (my $i = 0; $i < @{$tags}; $i++)
    {
        my $c   = $i + 1;
        my $tag = $tags->[$i];
        $text =~ s/\&\($c\)/$tag/g;
    }
    }

    return $text;
}


##
# _text_replace ($text, $expr, $tag, $attr);
# ------------------------------------------
# Replaces all $text, $expr, $tag, $attr.
##
sub _text_replace
{
    my $text  = shift;
    my $expr  = shift;
    my $tag   = shift;
    my $attr  = shift;

    my $re    = _expression_to_regex ($expr);
    my $tag1  = _tag_open ($tag, $attr);
    my $tag2  = _tag_close ($tag, $attr);

    # let's treat beginning and end of string as spaces,
    # it makes the regular expressions much easier.
    $text = " $text ";

    my %expr  = map { $_ => 1 } $text =~
    /(?<=\p{IsSpace}|\p{IsPunct}|\&)($re)(?=\p{IsSpace}|\p{IsPunct}|\&)/gi;

    foreach (keys %expr)
    {
        my $to_replace  = quotemeta ($_);
        my $replacement = $_;
        $replacement =~ s/(\&\(\d+\))/$tag2$1$tag1/g;
        $replacement = "$tag1$replacement$tag2";

	# Double hyperlinking fix
	# JM - 2004-01-23
	push @{$tags}, $replacement;
	my $rep = '&(' . @{$tags} . ')';
        $text =~ s/(?<=\p{IsSpace}|\p{IsPunct}|\&)$to_replace(?=\p{IsSpace}|\p{IsPunct}|\&)/$rep/g;
        # matching placeholders fix Bruno 2005-03-10
        my $rep_quoted = quotemeta ($rep);
        $text =~ s/&\($rep_quoted\)/&($to_replace)/g;
    }

    # remove the first and last space which we previously inserted for
    # ease-of-regex purposes.
    $text =~ s/^ //;
    $text =~ s/ $//;
    return $text;
}


##
# _segregate_markup_from_text ($tokens);
# --------------------------------------
# From an array reference of tokens, returns text with
# placeholders for markup, followed by an array reference
# of markup tokens.
#
# Example:
#
#   [ '', 'Hello ', '', 'World', '' ]
#
# becomes
#
#   ( '&(1)Hello &(2)World&(3)', [ '', '', '' ] )
##
sub _segregate_markup_from_text
{
    my $tokens = shift;
    my @tags   = ();
    my $res    = '';

    for (@{$tokens})
    {
	$_ = $$_; # replace the token object by its value
        /^
            push @tags, $_;
            $res .= '&(' . @tags . ')';
            next;
        };
        $res .= $_;
    }

    return $res, \@tags;
}


##
# _expression_to_regex ($expr);
# -----------------------------
# Turns $expr into a regular expression that will match
# all segregated text which should match this expression.
##
sub _expression_to_regex
{
    my $text  = shift;
    $text     = lc ($text);
    $text     =~ s/^(?:\s|\r|\n)+//;
    $text     =~ s/(?:\s|\r|\n)+$//;

    my @split = split /(?:\s|\r|\n)+/, $text;
    $text     = join $Ignorable_RE, map { quotemeta ($_) } @split;

    return $text;
}


##
# _tag_open ($tag_name, $tag_attributes);
# ---------------------------------------
# Turns a structure representing an opening tag into
# a string representing an opening tag.
##
sub _tag_open
{
    my $tag  = shift;
    my $attr = shift;

    my $attr_str = join ' ', map { $_ . '=' . do {
        my $val = $attr->{$_};
        "\"$val\"";
    } } keys %{$attr};

    return $attr_str ? "<$tag $attr_str>" : "<$tag>";
}


##
# _tag_close ($tag_name);
# -----------------------
# Turns a structure representing an closing tag into
# a string representing a closing tag.
##
sub _tag_close
{
    my $tag  = shift;
    return "";
}


1;


__END__