Boite à Outils 1 : l'extraction avec XML:RSS
Le code commenté
#!/usr/bin/perl
use utf8;
use strict;
use XML::RSS;
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/[\/]$//;
my $rubrique="$ARGV[1]";
my %redondant;
my $rss=new XML::RSS; #crée un objet qui porte le savoir lié à la bonne formation d'un fichier RSS
open (FILEOUT, ">:encoding(utf8)", "XML_RSS-sortie-$rubrique.txt");
open (ficOUT, ">:encoding(utf8)", "XML_RSS-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
eval {$rss->parsefile($file); }; #j'analyser le fichier RSS et remplace le contenu de $rss
if( $@ ) {
$@ =~ s/at \/.*?$//s; # remove module line number
print STDERR "\nERROR in '$file':\n$@\n";
}
else {
foreach my $item (@{$rss->{'items'}}) { #pour chaque balise item
my $description=$item->{'description'}; #on récupère le contenu de son fils "description"
my $title=$item->{'title'}; #et celui de son fils 'title'
$title=~s/<[^>]+>//g; #on en retire les balises
$description=~s/<[^>]+>//g;
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";
}
}
}
}
}
}
}
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/<.+?>//g; #élimine ce qui sert à rien
$var1=~s/<.+?>//g;
$var2=~s/&#39;/'/g; #remplace l'entité HTML de l'apostrophe
$var1=~s/&#39;/'/g;
$var2=~s/&#34;/"/g; #remplace l'entité HTML des guillemets
$var1=~s/&#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 ;
}