Boite à Outils 1 : l'extraction avec les RegEx

Le code commenté

#!/usr/bin/perl -w
use utf8;
use strict;
binmode STDOUT, "utf8";
# perl RegEx.pl corpus rubrique
#extrait titre + description
#en sortie : 2 fichier
	# 1 fichier.txt avec les titres et les descriptions
	# 1 fichier XML : mêmes infos structurées en XML

my $rep="$ARGV[0]";
$rep=~ s/[\/]$//;
print $rep;
my $rubrique="$ARGV[1]";
my %redondant;

open (FILEOUT, ">:encoding(utf8)", "RegEx_sortie-$rubrique.txt");
open (ficOUT, ">:encoding(utf8)", "RegEx_sortie-$rubrique.xml");

print ficOUT "<?xml version='1.0' encoding=\"UTF-8\" ?>\n";
print ficOUT "<racine>"; #on créer une racine pour notre fichier XML


&parcoursarborescencefichiers($rep);


print ficOUT "</racine>";

close (FILEOUT);
close (ficOUT);

exit;

#________________________________________________
sub parcoursarborescencefichiers {
	my $path = shift(@_); #on récupère le nom du repertoire
	opendir(DIR, $path) or die "can't open $path: $!\n"; #je l'ouvre
	my @files = readdir(DIR); #je fais l'inventaire du contenu de ce repertoire
	closedir(DIR);
#je traite tout ce que contient mon répertoire
	foreach my $file (@files) {
		next if $file =~ /^\.\.?$/; #j'ignore le répertoire père, et le dossier lui-même
		$file = $path."/".$file; #je recréer leur chemin relatif complet par rapport au dossier d'où le prgm a été lancé}
# si l'élément est un répertoire
		if (-d $file) { 
			print "<NOUVEAU REPERTOIRE> ==> ",$file,"\n";
			&parcoursarborescencefichiers($file);	#recurse!
			print "<FIN REPERTOIRE> ==> ",$file,"\n";
		}
# si l'élément est un fichier
		if (-f $file) {
			if ($file=~m/$rubrique.+\.xml$/) { #je ne traite que les fichiers XML
				#print "<", $i++, "> ==> ", $file, "\n";
				my $ensemble="";
				
	#on parcours le fichier ligne à ligne
				open (ficIN, "<:encoding(utf8)", $file);
				while (my $ligne=<ficIN>) { #là, "my" limite la portée de $ligne à la boucle.

					chomp $ligne; #fonction qui supprime les caractères de retours à la ligne.
					#on supprime les blancs des lignes qui commencent ou finissent par une balise, pour ne pas avoir de blanc inter-balise
					$ligne=~s/^ +</</;
					$ligne=~s/> +$/>/;
					#on ajoute la ligne au reste du texte
					$ensemble = $ensemble . $ligne ; 
				}

	#on extrait le titre et la description
				while ($ensemble=~/<item>.*?<title>([^<]*?)<\/title>.*?<description>([^<]*?)<\/description>.*?<\/item>/g) {
					my $title=$1 ;
					my $description=$2 ;
					if (!exists $redondant{$title}){
						$redondant{title}=1;
						my ($title_new, $description_new)= &nettoyage ($title,$description) ; #on appelle la fonction nettoyage, définie plus bas
						print FILEOUT "$title_new\n";
						print FILEOUT "$description_new\n";
						print ficOUT "<article><titre>$title_new</titre>\n";
						print ficOUT "<description> $description_new</description></article>\n";
					}
				}
				close(ficIN)
			}
		}
	}
}

sub nettoyage {
	# @_[1]		liste créee automatiquement qui regroupe les arguments utilisés pour lancer un sous-prgm
	my $var1 = shift @_ ;
	my $var2 = shift @_ ;
	$var2=~s/&lt;.+?&gt;//g; #vire ce qui sert à rien
	$var1=~s/&lt;.+?&gt;//g;
	$var2=~s/&#38;#39;/'/g;	#remplace l'entité HTML de l'apostrophe
	$var1=~s/&#38;#39;/'/g;
	$var2=~s/&#38;#34;/"/g; #remplace l'entité HTML des guillemets
	$var1=~s/&#38;#34;/"/g; 
	if ($var1!~/[\.?!]$/){ #si la phrase ne fini pas déjà par une ponctuation forte
		$var1=$var1.'.'} #on y ajoute un point
	if ($var2!~/[\.?!]$/){
		$var2=$var2.'.'} 
	return $var1, $var2 ;
}