perl conditional substitution according to nearest certain html tag content

user_1118630 0
Viewed 75

I have this HTML snippet which is two dictionary entries for "cat" and "choose":

cat
<h2>adjective + cat</h2>
<span>cute, pretty, small</span>
<h2>cat + verb</h2>
<span>meow, jump, play</span>
</>
choose
<h2>choose to + verb</h2>
<span>go, play, study</span>
</>

The span content needs to be replaced(appended) according to the h2 content:

cat
<h2>adjective + cat</h2>
<span>cute cat, pretty cat, small cat</span>
<h2>cat + verb</h2>
<span>cat meow, cat jump, cat play</span>
</>
choose
<h2>choose to + verb</h2>
<span>choose to go, choose to play, choose to study</span>
</>

Update: There could be multiple h2 and span in each entry and they always appear in pairs. And every html tag in the final output should be in the same order.

This is what I have tried so far:

if ($.<2 or $n){
    $line = $_;
    $line =~ s,\n,,g;
    chomp $line;
    $hw = $line;
    $to_insert = "";
    $before = 0;
}else{
    $to_insert = "";
    $before = 0;
    …
    # $all_families_all{reflection}{orig} contains all the reflections of an English word(in case its "adjective + cats" instead of "adjective + cat"), including original form.
    %all_families_all = %{$w_family{$hw}};
    $all = join "|", (keys %all_families_all);
    #hw in front of the plus sign +：
    if(/(<h2>)((?:(?!\b(?:$all)\b)[^<>])*\b(?:$all)\b[^<>]*)([+][^<>]*?)(?=<\/h2)/){
        $to_insert = $2;
        $before = 1;
    }
    # hw after the plus sign +：
    elsif(/(<h2>)((?:(?!\b(?:$all)\b)[^<>])*[+])([^<>]*?\b(?:$all)\b[^<>]*)(?=<\/h2>)/){
        $to_insert = $3;
        $before = 0;
    }elsif(/(<h2>)([^<>\+]*)(?=<\/h2>)/){
        $to_insert = "";
        $before = 0;
    }else{
        $to_insert = "";
        $before = 0;
    }

    s,(<span>)([^<>]*)(?=<\/span>), ($before ? "$1<pl>$to_insert</pl>$2" : "$1$2<pl>$to_insert</pl>"),ge if $to_insert;

}

$n=/<\/>/;

There're quite a lot of HTML snippets like the above. I was able to substitute some of them, but for others, the $to_insert appears to be from the second latest , not the latest (the nearest). Say $to_insert's value is " cat", when it should really be "choose to ".

perl regex
2 Answers

I am echoing Dave's warning. Since it's not a full HTML document, and you can assume the structure is never changing, here is a similar solution to Dave's that will work with more kinds of words than just adjectives and verbs.

use strict;
use warnings;
use feature "say";

{
    local $/ = qq{</>\n};
    while (my $record = <DATA>) {
        # each record is one set of word, <h2> and <span>, separated by newline
        my ($word, $h2, $span) = split /\n/, $record;

        # remove span tag and break into words
        (my $option_csv) = $span =~ m/>(.+)</;
        my @options = split /,\s*/, $option_csv;

        # remove tag from phrase
        (my $phrase) = $h2 =~ m/>(.+)</;

        # replace the word in the phrase with a placeholder, keep whitespace and
        # extra words like 'to'
        $phrase =~ s{
            (              # capture into $1
                [^+]*       # zero or more chars that are not a plus
                $word       # the word we're looking to replace
                [^+]*       # zero or more chars that are not a plus
            )
        }{@}x; # replace with a single @ as the placeholder
        my $word_with_whitespace = $1;

        # build all the phrases from the options by replacing everything
        # but the placeholder with the option
        my $all_phrases = join ', ', map { $phrase =~ s/[^@]+/$_/r } @options;

        # put the word back into all of them
        $all_phrases =~ s/@/$word_with_whitespace/g;

        # put the assembled list of phrases back into the span tag
        $span =~ s{
            >
            (.+)
            <
        }{>$all_phrases<}x;

        say $word;
        say $h2;
        say $span;
        say q{</>};
    }
}

__DATA__
cat
<h2>adjective + cat</h2>
<span>cute, pretty, small</span>
</>
choose
<h2>choose to + verb</h2>
<span>go, play, study</span>
</>

The idea is the same, but it's flexible on where the word goes in the h2. I've used the /x modifier on substitutions to explain what my patterns are doing. There's also a /r modifier, that returns the result of the substitution rather than change the original variable.

We can make this work for multiple sets of <h2> and <span> by using an array when splitting up the record. We can then treat them as pairs, loop over these and put them back together.

I've converted it to a function and removed the </> delimiter so I can use Test::More on it.

use strict;
use warnings;
use Test::More;

my ($input, $expected);

$input = <<EOT;
cat
<h2>adjective + cat</h2>
<span>cute, pretty, small</span>
EOT

$expected = <<EOT;
cat
<h2>adjective + cat</h2>
<span>cute cat, pretty cat, small cat</span>
</>
EOT

is foo($input), $expected, 'one set of adjectives';

$input = <<EOT;
choose
<h2>choose to + verb</h2>
<span>go, play, study</span>
EOT

$expected = <<EOT;
choose
<h2>choose to + verb</h2>
<span>choose to go, choose to play, choose to study</span>
</>
EOT

is foo($input), $expected, 'one set of verbs';

$input = <<EOT;
cat
<h2>adjective + cat</h2>
<span>round, fluffy</span>
<h2>adjective + cat</h2>
<span>small, soft, little ball of fur</span>
EOT

$expected = <<EOT;
cat
<h2>adjective + cat</h2>
<span>round cat, fluffy cat</span>
<h2>adjective + cat</h2>
<span>small cat, soft cat, little ball of fur cat</span>
</>
EOT

is foo($input), $expected, 'two sets of adjectives';

$input = <<EOT;
decide
<h2>decide to + verb</h2>
<span>answer</span>
<h2>decide to + verb</h2>
<span>help, figure out</span>
<h2>decide to + verb</h2>
<span>arrive, stay, wait, leave</span>
EOT

$expected = <<EOT;
decide
<h2>decide to + verb</h2>
<span>decide to answer</span>
<h2>decide to + verb</h2>
<span>decide to help, decide to figure out</span>
<h2>decide to + verb</h2>
<span>decide to arrive, decide to stay, decide to wait, decide to leave</span>
</>
EOT

is foo($input), $expected, 'three sets of verbs';

done_testing;

sub foo {
    my $record = shift;

    # each record is one set of word, <h2> and <span>, separated by newline
    my ($word, @rest) = split /\n/, $record;
    die 'wrong number of arguments' if scalar @rest % 2;

    my @output = $word;
    while ( @rest ) {
        my $h2   = shift @rest;
        my $span = shift @rest;

        # remove span tag and break into words
        (my $option_csv) = $span =~ m/>(.+)</;
        my @options = split /,\s*/, $option_csv;

        # remove tag from phrase
        (my $phrase) = $h2 =~ m/>(.+)</;

        # replace the word in the phrase with a placeholder, keep whitespace and
        # extra words like 'to'
        $phrase =~ s{
            (              # capture into $1
                [^+]*       # zero or more chars that are not a plus
                $word       # the word we're looking to replace
                [^+]*       # zero or more chars that are not a plus
            )
        }{@}x; # replace with a single @ as the placeholder
        my $word_with_whitespace = $1;

        # build all the phrases from the options by replacing everything
        # but the placeholder with the option
        my $all_phrases = join ', ', map { $phrase =~ s/[^@]+/$_/r } @options;

        # put the word back into all of them
        $all_phrases =~ s/@/$word_with_whitespace/g;

        # put the assembled list of phrases back into the span tag
        $span =~ s{
            >
            (.+)
            <
        }{>$all_phrases<}x;

        push @output, $h2, $span;
    }
    return join "\n", @output, qq{</>\n};
}
user_13314510

You shouldn't parse HTML with regexes.

But, that said, this data seems regular enough that you might just get away with it.

The secret is to use $/ to change the input record separator so that you can process one of your chunks at a time.

A simple approach might look like this:

#!/usr/bin/perl

use strict;
use warnings;

# Set the input record separator
local $/ = "</>\n";

# This now reads a "chunk" at a time
while (<DATA>) {
  # Extract the contents of the <span>
  my ($span) = m|<span>(.+)</span>|;

  # If we have an adjective chunk, then extract the adjective
  if (m|<h2>adjective \+ (.+)</h2>|) {
    my $noun = $1;
    # Add the adjective to the words in the span
    $span =~ s/(\w+)(\W|$)/$1 $noun$2/g;
  }

  # If we have a verb chunk, then extract the verb
  if (m|<h2>(.+) \+ verb</h2>|) {
    my $verb = $1;
    # Add the verb to the words in the span
    $span =~ s/(^|\W)(\w)/$1$verb $2/g;
  }

  # Replace the span text with our new version
  s|<span>.+</span>|<span>$span</span>|;

  print;
}

__DATA__
cat
<h2>adjective + cat</h2>
<span>cute, pretty, small</span>
</>
choose
<h2>choose to + verb</h2>
<span>go, play, study</span>
</>
user_72310
Related