How can I modify a complex XML document in Perl to add additional markup to text nodes?

Question

I have an XML document like this:

<article>
  <author>Smith</author>
  <date>2011-10-10</date>
  <description>Article about <b>frobnitz</b>, crulps and furtikurty's. Mainly frobnitz</description>
</article>

I need to parse this in Perl and then add new tags around some words or phrases (eg to link to definitions). I want to tag only the first instance of a target word and narrow my search to just what's in a given tag (eg description tag only).

I can parse with XML::Twig and set a "twig_handler" for the description tag. But when I call $node->text I get the text with intervening tags removed. Really what I want to do is traverse down the (very small) tree so that existing tags are preserved and not broken. The final XML output should therefore look like this:

<article>
  <author>Smith</author>
  <date>2011-10-10</date>
  <description>Article about <b><a href="dictionary.html#frobnitz">frobnitz</a></b>, <a href="dictionary.html#crulps">crulps</a> and <a href="dictionary.html#furtikurty">furtikurty</a>'s. Mainly frobnitz</description>
</article>

I also have XML::LibXML available on the target environment but I'm not sure how to start there...

Here's my minimal test case so far. Appreciate any help!

#!/usr/bin/perl
use strict;
use warnings;

use XML::Twig;

my %dictionary = (
    frobnitz    => 'dictionary.html#frobnitz',
    crulps      => 'dictionary.html#crulps',
    furtykurty  => 'dictionary.html#furtykurty',
    );

sub markup_plain_text { 
    my ( $text ) = @_;

    foreach my $k ( keys %dictionary ) {
        $text =~ s/(^|\W)($k)(\W|$)}/$1<a href="$dictionary{$k}">$2<\/a>$3/si;
    }

    return $text;
}

sub convert {
    my( $t, $node ) = @_;
    warn "convert: TEXT=[" . $node->text . "]\n";
    $node->set_text( markup_plain_text($node->text) );
    return 1;
}

sub markup {
    my ( $text ) = @_;

    my $t = XML::Twig->new(
        twig_handlers => { description => \&convert },
        pretty_print  => 'indented',
        );
    $t->parse( $text );

    return $t->flush;
}


my $orig = <<END_XML;
<article>
    <author>Smith</author>
    <date>2011-10-10</date>
    <description>Article about <b>frobnitz</b>, crulps and furtikurty's. Mainly frobnitz's</description>
</article>
END_XML
;

markup($orig);

i have no experience with web-programming, but doesn't it seem a little odd to put html inside xml? — flies
– flies, Commented May 12, 2011 at 14:41
Yes, it is. This particular CMS has a DTD allowing a sub-set of HTML. In production the XML is transformed a second time and the HTML wrapped inside a CDATA tag -- which is a bit more normal. — Hissohathair
– Hissohathair, Commented May 13, 2011 at 1:20

mirod · Accepted Answer · 2011-05-12 10:13:37Z

3

It's a slightly tricky one, but XML::Twig is designed (and I use it heavily) to this kind of processing. So there is a specific method, called mark, that takes a regexp and tags the matches.

In this case the regexp will likely be quite big. I used Regexp::Assempble to build it, so it gets optimized. Then an other problem is that mark doesn't let you use the text of the match to set an attribute (I might work on this in the next version of the module, that would be useful), so I has to mark first, then go back and set the href attribute in a second pass (in any case the second pass is needed to "un-link" words that have already been linked).

One last word: I nearly gave up on writing the solution, because your example data has a few typos. There is nothing worse than getting the code right, just to see the test still fail because you use 'dictionary' in the code and 'definitions' in the data, or 'furtykurtle', 'furtikurty' and 'furtijurty' where it should all be the same word. So please, before posting, make sure your data is right. Thankfully I was writing the code as a test.

#!/usr/bin/perl 

use strict;
use warnings;

use XML::Twig;
use Regexp::Assemble;

use Test::More tests => 1; 
use autodie qw(open);

my %dictionary = (
    frobnitz    => 'definitions.html#frobnitz',
    crulps      => 'definitions.html#crulps',
    furtikurty  => 'definitions.html#furtikurty',
    );

my $match_defs= Regexp::Assemble->new()
                                ->add( keys %dictionary)
                                ->anchor_word
                                ->as_string;
# I am not familiar enough with Regexp::Assemble to know a cleaner
# way to get get the capturing braces in the regexp
$match_defs= qr/($match_defs)/; 

my $in       = data_para(); 
my $expected = data_para();
my $out;
open( my $out_fh, '>', \$out);


XML::Twig->new( twig_roots => { 'description' => sub { tag_defs( @_, $out_fh, $match_defs, \%dictionary); } },
                twig_print_outside_roots => $out_fh, 
              )
         ->parse( $in);

is( $out, $expected, 'base test');
exit;

sub tag_defs
  { my( $t, $description, $out_fh, $match_defs, $dictionary)= @_;

    my @a= $description->mark( $match_defs, 'a' );

    # word => 1 when already used in this description
    # this might need to have a different scope if you need to tag
    # only the first time the word appears in a section or whatever
    my $tagged_in_description; 

    foreach my $a (@a) 
      { my $word= $a->text;
        warn "checking a: ", $a->sprint, "\n";

        if( $tagged_in_description->{$word})
          { $a->erase; } # we did not need to tag it after all
        else
          { $a->set_att( href => $dictionary->{$word}); }
        $tagged_in_description->{$word}++;
      }

    $t->flush( $out_fh); }


sub def_href
  { my( $word)= @_;
    return $dictionary{word};
  }

sub data_para
  { local $/="\n\n";
    my $para= <DATA>;
    return $para;
  }

__DATA__
<article>
  <author>Smith</author>
  <date>2011-10-10</date>
  <description>Article about <b>frobnitz</b>, crulps and furtikurty's. Mainly frobnitz</description>
</article>

<article>
  <author>Smith</author>
  <date>2011-10-10</date>
  <description>Article about <b><a href="definitions.html#frobnitz">frobnitz</a></b>, <a href="definitions.html#crulps">crulps</a> and <a href="definitions.html#furtikurty">furtikurty</a>'s. Mainly frobnitz</description>
</article>

edited May 12, 2011 at 10:13

answered May 12, 2011 at 8:19

mirod

16.2k3 gold badges49 silver badges65 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Hissohathair Over a year ago

For the author of the actual module to answer is pretty awesome. I feel like I asked a golf question and Tiger Woods answered it. Thanks. Sorry about the test data -- my own efforts were going nowhere (was trying to use insert to add new Elt's) so I hadn't noticed the typo yet. Quick question -- I had to add a "chomp $in;" to get the test to actually pass -- the $in version had an extra trailing newline. Difference in Perl versions? (I'm using 5.10.1)

mirod Over a year ago

Thanks, I try to answer questions about XML::Twig, good customer service is key for the success of a module ;--) The trailing newline is actually missing at the end of the DATA section, due to my not copying it properlly (so you know you're not the only one to make typos, of course!).

Don Over a year ago

In the current revision (0.35) of Regexp::Assemble you can use ->re to get the compiled regular expression rather than ->as_string and then manually applying the qr//

Collectives™ on Stack Overflow

How can I modify a complex XML document in Perl to add additional markup to text nodes?

1 Answer 1

3 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

3 Comments

Your Answer

Sign up or log in

Post as a guest

Related