Simplify Perl script to extract information with regex

Question

I have to extract some information from an XML file according to a pattern. I did complete a working script, but I'm pretty sure that it could be a lot simpler and/or cleaner.

Could you tell me what could be better and why?

What my input looks like:

<modifs>
  <modif id="14661"><code c="1" /><extra id="109816" /><avant num_words="1">démissionné</avant><apres num_words="1">démissionner</apres></modif>
  <modif id="125247"><code c="1" /><avant num_words="1">demis-tons</avant><apres num_words="1">demi-tons</apres></modif>
  <modif id="90891"><code c="1" /><avant num_words="1">démit</avant><apres num_words="1">démis</apres></modif>
  <modif id="198379"><code c="1" /><avant num_words="1">demi-terain</avant><apres num_words="1">demi-terrain</apres></modif>
  <modif id="172795"><code c="1" /><avant num_words="1">demi-ton</avant><apres num_words="1">demi-tons</apres></modif>
</modifs>

What I want :+

Display, when the content of avant and apres tags ends with -é or -er, each id and extra id, followed by the content of avant and apres.

So it looks like this:

id="14661"
extra id="109816"
démissionné |||| démissionner

What my script looks like:

 use strict;
    use warnings;


    my $fichier = 'path';
    my $fichiersortie = "path";
    my @lignes ;
    my @tableau_avant ;
    my @tableau_apres ;
    my @ids ;
    my @extraids ; 
    my @radical_avant ;
    my @radical_apres ;

    open (OUTPUT, ">$fichiersortie");
    binmode(OUTPUT, ":utf8");
    open(my $fh, '<:encoding(UTF-8)', $fichier)
      or die "Can't open file";

    while (my $row = <$fh>) {
        chomp $row;

        @radical_avant = $row =~ /<avant.+?>(.+?)(?:er|é)<\/avant>/;
        @radical_apres = $row =~ /<apres.+?>(.+?)(?:er|é)<\/apres>/ ;
        @tableau_avant = $row =~ /<avant.+?>(.+?(?:er|é))<\/avant>/;
        @tableau_apres = $row =~ /<apres.+?>(.+?(?:er|é))<\/apres>/ ;
        @ids = $row =~ /<modif (id="\d+")>/ ;
        @extraids = $row =~ /<(extra id="\d+")\s\/>/g ;


        foreach my $id (@ids) {
        foreach my $match_avant (@tableau_avant) {
        foreach my $match_apres (@tableau_apres) {

        foreach my $radical_avant (@radical_avant){
        foreach my $radical_apres (@radical_apres){
        if ($radical_avant eq $radical_apres) {

        print OUTPUT "$id\n";
foreach my $extraid (@extraids) {
        print OUTPUT "$extraid\n";}
        print OUTPUT "$match_avant" . " |||| " . "$match_apres\n\n" ;}
        }
        }
                }
        }
        }
}
close (OUTPUT);

---

Tidied up, the Perl code looks like this

use strict;
use warnings;

my $fichier       = 'path';
my $fichiersortie = "path";
my @lignes;
my @tableau_avant;
my @tableau_apres;
my @ids;
my @extraids;
my @radical_avant;
my @radical_apres;

open( OUTPUT, ">$fichiersortie" );
binmode( OUTPUT, ":utf8" );

open( my $fh, '<:encoding(UTF-8)', $fichier ) or die "Can't open file";

while ( my $row = <$fh> ) {
    chomp $row;

    @radical_avant = $row =~ /<avant.+?>(.+?)(?:er|é)<\/avant>/;
    @radical_apres = $row =~ /<apres.+?>(.+?)(?:er|é)<\/apres>/;
    @tableau_avant = $row =~ /<avant.+?>(.+?(?:er|é))<\/avant>/;
    @tableau_apres = $row =~ /<apres.+?>(.+?(?:er|é))<\/apres>/;
    @ids           = $row =~ /<modif (id="\d+")>/;
    @extraids      = $row =~ /<(extra id="\d+")\s\/>/g;

    foreach my $id (@ids) {

        foreach my $match_avant (@tableau_avant) {

            foreach my $match_apres (@tableau_apres) {

                foreach my $radical_avant (@radical_avant) {

                    foreach my $radical_apres (@radical_apres) {

                        if ( $radical_avant eq $radical_apres ) {

                            print OUTPUT "$id\n";

                            foreach my $extraid (@extraids) {
                                print OUTPUT "$extraid\n";
                            }

                            print OUTPUT "$match_avant" . " |||| " . "$match_apres\n\n";
                        }
                    }
                }
            }
        }
    }
}

close(OUTPUT);

Answer 1

Don't use regular expressions to parse XML. It leads to brittle code.

perl has an XML parser, and that would look something like this:

#!/usr/bin/env perl
use strict;
use warnings;
use XML::Twig;

#load the file into the XML parser, as $twig
my $twig = XML::Twig->new->parsefile('your_file.xml'); 

#iterate elements '<modif>' - anywhere in data structure. 
#(That's what // prefix means in xpath)
foreach my $modif ( $twig->get_xpath('//modif') ) {

   #For each modif element, extract the contents of 'avant' and 'apres' and
   #compare them. 
   if (   $modif->first_child_text('avant') =~ m/(er|é)$/
      and $modif->first_child_text('apres') =~ m/(er|é)$/ )
   {
      #from this element, get the 'id' attribute. 
      #<modif id="???">
      print "ID: ", $modif->att('id'), "\n";
      #fetch all the children of <modif> called '<extra>' 
      #use map to fetch the 'id' attributes of all of these. (if more than one)
      print "extra ids", join " ",(map { $_->att('id') } $modif->children('extra')), "\n";
      #fetch content of '<avant>' and '<apres>' nodes. 
      print $modif->first_child_text('avant'), "|||", $modif ->first_child_text('apres'),"\n";
   }
}

I wasn't entirely clear on the comparison you were making, but hopefully this illustrates well enough how to do it?

e.g. perhaps you'd be comparing:

#compare both avant and apres, but only after trimming
#a couple of letters off the end. 
if ( $modif -> first_child_text('avant') =~ s/(er|é)$//r 
  eq $modif -> first_child_text('apres') =~ s/(er|é)$//r  ) {

Would compare both, after dropping those character off the end. (note - the r regex modifier needs a newish version of perl to work, it might error)