package petitParserDom;
=head1 module : petitParserDom
C'est un petit parser DOM pour XML, sommaire.
Encore en développement, créé pour intégrer un programme d'extraction/recompostion pour la gestion de traduction de document XML
La documentation sera prochainement complétée...
=head2 auteur : Raphael Schaeffer
=head1 dépendances : aucune
=head1 exemple d'utilisation
($info,$comment,$arbre)=parser(FILE);
foreach(getNoeudsParTag($arbre,"nom")){
($t)=getTexte($_);
print $$t."\n";
}
=cut
use strict;
use warnings;
use diagnostics;
use Cwd 'abs_path'; # pour reconstituer le chemin absolu d'un fichier
use utile; # pour bonneExtension
use erreur;
my %erreurLocal=( 'nonFichier' =>"erreur : l'entrée n'est pas un fichier utilisable",
'encodage' =>"erreur : l'encodage du fichier xml est inconnu",
'extension' =>"erreur : l'extension n'est pas prise en compte",
'xmlinv' =>"erreur! le fichier XLM est mal formé!",
);
erreur::maj(\%erreurLocal);
=head1 ouvre un fichier xml avec l'encodage spécifié dans l'espace de nom et renvoie un filehandle et la première ligne lue
entree : $file : string
sortie : $hdfile : référence flux
$firstLine : string
=cut
sub openXML{
my $file=shift;
$file = abs_path($file);
erreur::affiche('nonFichier',$file) unless -f $file;
erreur::affiche('extension',$file) unless utile::bonneExtension($file,"xml");
open IN,$file or erreur::affiche('ouvertureF',$file);
my $firstLine=<IN>;
#print $firstLine."\n";
$firstLine=~m/<\?xml.*encoding="(.*?)".*\?>/;
my $encoding=$1;
#print " $file encodage : $encoding;\n";
unless ($encoding=~/iso-8859-1/i){
($encoding=~/utf-8/i) ? binmode IN, ":utf8" : erreur::affiche('encodage',$encoding,$file);
}
return (\*IN,$firstLine);
}
=head1 parser
entrée : le fichier à analyser
sortie : $info, référence aux premières lignes d'informations
$comment, références aux commentaires en en-tête
$arbre, référence à l'arbre créé
=cut
sub parser{
my $entree=shift;
my $hdfich=$entree;
my $texte="";
($hdfich,$texte)=openXML($entree) unless ref($entree);
$/=""; #slurp mode
while(<$hdfich>){$texte.=$_;}
# print "texte".$texte."\n--------------------finTexte\n";
my $fin;
my @info;
my @comment;
my $arbre;
#print "INFO\n";
while($texte=~s/^\s*(<\?[^<>]+\?>)//){
#print "info : $1\n";
#print "texte".$texte."finTexte\n";
push @info, $1;
}
#print "COMMENT\n";
while($texte=~s/^\s*<!--([^<>]+)-->\s*//){
#print "comment : $1\n";
push @comment,$1;
}
#print "PARSING\n";
($fin,$arbre)=parseNoeud($texte);
return(\@info,\@comment,$arbre);
}
sub parseNoeud {
my $reste=shift;
my $balise;
my $nom; # plus pratique à utiliser dans les RI que $noeud{nom}
my %noeud;
my @champs;
$noeud{champs}=\@champs;
# cherche balise de début et la suprime du reste
erreur::affiche('xmlinv',$reste) unless ($reste=~s/^\s*<([^<>]+)>//); # s'il n'y en pas, c'est mauvais
$balise=$1;
# on en déduit le nom et les arguments
($nom,$noeud{attributs})=getArguments($balise);
$noeud{nom}=$nom;
#print "liste champs\n";
# si balise unique ex: <nom att="val"/> --> sortie
if ($balise=~m/\/$/) {
return ($reste,\%noeud);
}
# sinon on recherche tous les champs jusqu'à la balise de fin
while(1) {
# soit un commentaire
if($reste=~s/^\s*<!--([^<>]+)-->//){
my %elt=("commentaire"=>$1);
push(@champs,\%elt);
}
# soit un champs de texte
#print " reste $reste\n";
elsif ($reste=~s/^([^<>]+)//){
#print "texte $1\n";
my %elt=("texte"=>$1);
push(@champs,\%elt);
}
#(soit/puis) la balise de fin --> sortie
#print"seak : </$nom>\n";
if ($reste=~s/^\s*<\/$nom>//){
#print "fin $nom\n";
return ($reste,\%noeud);
}
# sinon c'est un noeud fils
my $fils;
($reste,$fils)=parseNoeud($reste);
my %elt=("noeud"=>$fils);
push(@champs,\%elt);
# et on recommence} } # fin newBalise
}
}
#********getArguments
# entrée : $balise : une balise de tête
# sortie : $nom : le nom de la balise
# $attributs : la référence à la table contenant les attributs
sub getArguments {
my $balise=shift;
#print "balise : $balise\n";
my $nom;
my %attributs;
my @arguments=split(/\s+/,$balise);
# première partie : nom
$nom=shift(@arguments);
#print "nom : --$nom--\n";
# autres parties : arguments (id=>val)
#print"liste attributs\n";
foreach(@arguments){
m/^([^=]+)=['"]([^"']+)["']/;
$attributs{"$1"}="$2";
#print "attribut $1\t=\t$2\n";
}
return ($nom,\%attributs);
}
sub estNoeud{
my $element=shift;
return exists($element->{noeud});
}
sub estTexte{
my $element=shift;
return exists($element->{texte});
}
sub estCommentaire{
my $element=shift;
return exists($element->{commentaire});
}
sub getChildren{
my $noeud=shift;
my @child;
my $element;
my $champs=$noeud->{champs};
foreach $element(@$champs){
if(estNoeud($element)){
push @child,$element->{noeud};
}
}
return @child;
}
sub getName{
my $noeud=shift;
return \$$noeud{nom};
}
sub getAttributs{
my $noeud=shift;
return \$$noeud{attributs};
}
sub getChamps{
my $noeud=shift;
return $noeud->{champs};
}
=head1 getTexte
entrée: un noeud
sortie: un tableau des références aux textes
=cut
sub getTexte{
my $noeud=shift;
my @texte;
my $element;
foreach $element(@{$noeud->{champs}}){
if(estTexte($element)){
push @texte,\$$element{texte};
}
}
return @texte;
}
sub getAllName{
my $noeud=shift;
my $name=getName($noeud);
my @allName;
push @allName,$name;
my @fils=getChildren($noeud);
foreach(@fils){
$name=getAllName($_);
push @allName,$name;
}
return @allName;
}
sub getAllAttributs{
my $noeud=shift;
my @att=getAttributs($noeud);
my @allAtt;
push @allAtt,@att;
my @fils=getChildren($noeud);
foreach(@fils){
@att=getAllAttributs($_);
push @allAtt,@att;
}
return @allAtt;
}
sub getAllTexte{
my $noeud=shift;
my @texte=getTexte($noeud);
my @allTexte;
push @allTexte,@texte;
my @fils=getChildren($noeud);
foreach(@fils){
@texte=getAllTexte($_);
push @allTexte,@texte;
}
return @allTexte;
}
=head1 getNoeudParTag
entrée :le noeud parent
le nom des noeuds recherchés
sortie :un tableau de noeud
=cut
sub getNoeudsParTag{
my ($noeudParent,$tag)=@_;
my @noeuds;
my $fils;
my $nom;
# pour chaque fils
foreach $fils (getChildren($noeudParent)){
$nom=getName($fils);
# s'il correpond au tag, on l'ajoute
if($$nom eq $tag){
push @noeuds,$fils;
}
# pareil pour ses déscendants
push @noeuds,getNoeudsParTag($fils,$tag);
}
# renvoie un tableau avec tous les noeuds correpondants au tag
return @noeuds;
}
1;
