Patricia GUILPIN.

Maîtrise T.A.L.

Année 2000-2001.

 

  1. Sommaire
  2.  

    1 Sommaire *

    2 La programmation en Perl : Problèmes de segmentation *

    3 La programmation objet avec Perl *

    4 Interfaces graphiques en PERL/TK *

     

     

     

  3. La programmation en Perl : Problèmes de segmentation
  4.  

    Manipulation, constitution de dictionnaires et de nouveaux corpus.

     

    L’objectif de cette partie est de résoudre des problèmes de segmentation des textes à l’aide du langage Perl.

    - Manipulation de données.

    Il s’agit de construire d’une part un programme Perl qui lit un état quelconque du corpus Prématurés et compte le nombre de ligne du fichier lu, et d’autre part un programme qui lit un état quelconque du corpus Prématuré et en compte le nombre de mots.

    - Construction de dictionnaires.

    Nous avons souhaité lire les corpus bébés et infirmières et construire pour chacun d’eux un dictionnaire contenant les formes graphiques de ces corpus.

    - Constitution de corpus.

    Il s’agit de prendre en entrée le fichier p96.bal et d’en produire une version HTML, le nom des champs apparaissant dans la version HTML produite.

    - Constitution d’un index au format HTML.

    L’objectif de cette partie est de construire un index de fichiers. Afin de retrouver le mot en contexte, on construit l’index au format HTML. On aimerait également pouvoir naviguer entre l’index et le texte associé (lecture du mot en contexte et inversement).

    Par la suite, nous présentons un ensemble de programmes dont les premières versions sont simplifiées.

     

     

    liremot1.pl :

    N.B. : dans les quatre programmes suivants, le dictionnaire 2 (facultatif) permet d’envisager la mise en œuvre d’un dictionnaire catégorisé.

    #!/usr/bin/perl

    #--------PROGRAMME 1 :

    # Ce programme permet de lire une suite de mots segmentée entrée par

    # l'utilisateur et de les ranger dans deux dictionnaires.

    #-----------------------------------

    # N.B. : Ce programme élémentaire est composé d’un seul bloc et permet

    # de se faire une idée du langage Perl.

    print STDOUT "Entrez une suite de mots : "; #STDOUT : sortie standard,

    # permettant d'écrire sur l'écran.

    $ligne = <STDIN>; # lecture par ligne du flux d'entrée au clavier.

    print STDOUT "Ligne lue : $ligne \n";

     

    #---------Initialisation de différentes variables.

    $mot="";

    $i=0;

    $nbcar = 0;

    %dico2=(); # tableau associatif composé d’une clé et d’une valeur

    # (scalaire indexe par un scalaire)

    #--Création et ouverture des dicos 1 et 2.

    open(DIC1,">dico1.txt");

    open(DIC2,">dico2.txt");

    #-- Modification de la ligne.

    $ligne =~s/[ ]+/ /g; # recherche des suites de blancs et remplacement

    # par un blanc unique.

    $ligne =~s/^ ([^ ])/$1/g; # recherche de ce qui n'est pas un blanc en début # de ligne et renvoi du contenu de l'expression régulière.

    print STDOUT "Ligne modifiee (sans double blancs et sans blanc au depart) : $ligne \n"; # écriture de la ligne modifiée.

     

    #----Segmentation et rangement dans les tableaux :

    while (substr($ligne,$nbcar, 1)=~/(.)/)# tant que l'on rencontre

    # un groupement de chars, on reste dans la boucle.

    # N.B. : substr retourne la chaine de chars contenue dans la variable

    # ligne.

    {

    $caractere = $1; # $1 est la valeur de la dernière expression régulière

    # c'est-à-dire un groupement de caractères.

    print "caractere lu : $caractere\n";

    # 1- Si on rencontre un blanc, a) le mot est construit :

    if ($caractere =~/ /)

    {

    print "Mot construit : <mot$i = $mot>\n";

    $existmot=0;

    # 1-b : on parcourt le tableau dico1 pour vérifier si le mot

    # n'est pas déjà recensé :

    foreach $motInDico1 (@dico1)

    {

    if ($motInDico1 eq $mot)

    {

    print "Mot deja recense dans dico1 \n";

    $existmot=1;

    }

    }

    # 1-c : si le mot n'existe pas on le range dans le tableau dico1

    # et on incrémente le compteur.

    if ($existmot == 0)

    {

    $dico1[$i]=$mot;

    $i = $i + 1;

    }

    # 1-d : idem pour le dico 2 :

    if (exists ($dico2{$mot}))

    {

    print "Mot deja recense dans dico2 \n";

    }

    else

    {

    $dico2{$mot}="$mot"." <Categorie: ?>";

    }

    $mot="";

    } # fin du if ('si on rencontre un blanc').

    # 2- Sinon :on ajoute un char à la variable mot.

    else {

    $mot = "$mot"."$caractere";

    print "Mot en construction : $mot\n";

    }

    $nbcar = $nbcar + 1;

    }

    print "Mot construit : <mot$i = $mot>\n";

    $existmot="0";

    foreach $motInDico1 (@dico1)

    {

    if ($motInDico1 eq $mot)

    {

    #

    print "Mot deja recense dans dico1 \n";

    $existmot=1;

    }

    }

    if ($existmot == 0)

    {

    $dico1[$i]=$mot;

    $i = $i + 1;

    }

    if (exists ($dico2{$mot}))

    {

    print "Mot deja recense dans dico2 \n";

    }

    else

    {

    $dico2{$mot}="$mot"." <Categorie: ?>";

    }

    # Lecture et écriture dans les fichiers dicos :

    print "Lecture/Ecriture dico1 \n";

    foreach $mot (@dico1)

    {

    print "mot in dico1 : $mot\n";

    print DIC1 "$mot\n";

    }

    print "Lecture/Ecriture dico2 \n";

    foreach $item (sort keys %dico2) # tri du tableau dans l’ordre croissant.

    {

    print "(mot : $item) => Description in dico2 : $dico2{$item}\n";

    print DIC2 "(mot : $item) => $dico2{$item}\n";

    }

    close(DIC1);

    close(DIC2);

    liremot2.pl :

    #!/usr/bin/perl

    #--------------

    # Variante de liremot1 avec un sous-programme (procédure).

    #-------------

    # Sous-Programme permettant de remplir les tableaux dico1 et dico2 :

    sub rangemot {

    $existmot = 0;

    foreach $motInDico1 (@dico1) # Parcours du tableau pour voir si le mot n’est

    # déjà recensé.

    {

    if ($motInDico1 eq $mot)

    {

    print "Mot deja recense dans dico1 \n";

    $existmot=1;

    }

    }

    if ($existmot == 0) # si le mot n’existe pas, on complète le tableau.

    {

    $dico1[$i]=$mot;

    $i = $i + 1;

    }

    if (exists ($dico2{$mot}))

    {

    print "Mot deja recense dans dico2 \n";

    }

    else

    {

    $dico2{$mot}="$mot"." <Categorie: ?>";

    }

    }

    #--------------------------------------------------------------

    # Programme principal :

    print STDOUT "Entrez une suite de mots : ";

    $ligne = <STDIN>;

    print STDOUT "Ligne lue : $ligne \n";

    $mot="";

    $i=0;

    $nbcar = 0;

    %dico2=();

    open(DIC1,">dico1.txt");

    open(DIC2,">dico2.txt");

    $ligne =~s/[ ]+/ /g;

    $ligne =~s/^ ([^ ])/$1/g;

    print STDOUT "Ligne modifiee (sans double blancs et sans blanc au depart) : $ligne \n";

    # Début de la boucle while :

    while (substr($ligne,$nbcar, 1)=~/(.)/)

    {

    $caractere = $1;

    print "caractere lu : $caractere\n";

    if ($caractere =~/ /)

    {

    print "Mot construit : <mot$i = $mot>\n";

    rangemot; # appel de la procédure rangemot.

    $mot="";

    }

    else {

    $mot = "$mot"."$caractere";

    print "Mot en construction : $mot\n";

    }

    $nbcar = $nbcar + 1;

    } # fin de la boucle while.

    rangemot; # deuxième appel de la procédure rangemot.

    #---------

    print "Lecture/Ecriture dico1 \n";

    foreach $mot (@dico1)

    {

    print "mot in dico1 : $mot\n";

    print DIC1 "$mot\n";

    }

    print "Lecture/Ecriture dico2 \n";

    foreach $item (sort keys %dico2)

    {

    print "(mot : $item) => Description in dico2 : $dico2{$item}\n";

    print DIC2 "(mot : $item) => $dico2{$item}\n";

    }

    close(DIC1);

    close(DIC2);

    lirefichier1.pl :

    #!/usr/bin/perl

    #-- Programme qui permet de lire une

    # suite de mots dans un fichier. Cette suite de mots est segmentée

    # en mots, ces derniers étant enregistrés dans deux dictionnaires

    #-------------------------------------------------------------------------

    # Sous-Programme (cf. liremot2.pl).

    sub rangemot {

    $existmot = 0;

    foreach $motInDico1 (@dico1)

    {

    if ($motInDico1 eq $mot)

    {

    print "Mot deja recense dans dico1 \n";

    $existmot=1;

    }

    }

    if ($existmot == 0)

    {

    $dico1[$i]=$mot;

    $i = $i + 1;

    }

    if (exists ($dico2{$mot}))

    {

    print "Mot deja recense dans dico2 \n";

    }

    else

    {

    $dico2{$mot}="$mot"." <Categorie: ?>";

    }

    }

    #--------------------------------------------------------------

    # Programme principal

    $mot="";

    $i=0;

    $nbcar = 0;

    %dico2=();

    open(DIC1,">dico1.txt");

    open(DIC2,">dico2.txt");

    open(FILEINPUT,"$ARGV[0]"); # prend en argument le fichier tapé au clavier.

    LIGNE: while($ligne=<FILEINPUT>) # lecture ligne à ligne du fichier.

    {

    print "$ligne";

    # On saute les lignes commencant par le dièse :

    next LIGNE if ($ligne=~/^#/);

    # On saute les lignes vides :

    next LIGNE if ($ligne=~/^$/);

    print "ligne lue : $ligne\n";

    # On supprime certains caractères : tabulation, signes de ponctuation, série

    # de doublons de blancs et de blancs en début de ligne :

    $ligne =~s/[\/\t]+/ /g;

    $ligne =~s/[\$\.\:\)\(\"\/;\{\}=\@\+\,]+/ /g;

    $ligne =~s/[ ]+/ /g;

    $ligne =~s/^ ([^ ])/$1/g;

    $ligne =~s/([^ ]) $/$1/g;

    print STDOUT "Ligne modifiee (sans double blancs et sans blanc au depart...) : $ligne \n";

    while (substr($ligne,$nbcar, 1)=~/(.)/)

    {

    $caractere = $1;

    print "caractere lu : $caractere\n";

    if ($caractere =~/ /)

    {

    print "Mot construit : <mot$i = $mot>\n";

    rangemot;

    $mot="";

    }

    else {

    $mot = "$mot"."$caractere";

    print "Mot en construction : $mot\n";

    }

    $nbcar = $nbcar + 1;

    }

    rangemot; # appel de la procédure rangemot.

    }

    # Ecriture dans les dicos.

    print "Lecture/Ecriture dico1 \n";

    foreach $mot (@dico1)

    {

    print "mot in dico1 : $mot\n";

    print DIC1 "$mot\n";

    }

    print "Lecture/Ecriture dico2 \n";

    foreach $item (sort keys %dico2)

    {

    print "(mot : $item) => Description in dico2 : $dico2{$item}\n";

    print DIC2 "(mot : $item) => $dico2{$item}\n";

    }

    close(DIC1);

    close(DIC2);

    close(FILEINPUT);

    lirefichier2.pl :

    #!/usr/bin/perl

    sub rangemot { # même procédure que précédemment.

    $existmot = 0;

    foreach $motInDico1 (@dico1)

    {

    if ($motInDico1 eq $mot)

    {

    print "Mot deja recense dans dico1 \n";

    $existmot=1;

    }

    }

    if ($existmot == 0)

    {

    $dico1[$i]=$mot;

    $i = $i + 1;

    }

    if (exists ($dico2{$mot}))

    {

    print "Mot deja recense dans dico2 \n";

    }

    else

    {

    $dico2{$mot}="$mot"." <Categorie: ?>";

    }

    }

    #Programme principal

    %dico2=();

    open(DIC1,">dico1.txt");

    open(DIC2,">dico2.txt");

    $i = 0;

    $Ligne = 0;

    READ: while(<>) # fichier par défaut, tous les fichiers donnés en argument au

    # programme, où, le cas échéant, entrée standard.

    {

    #saute les lignes vides

    next READ if (/^$/);

    s/[ ]+/ /g;

    s/[\/\t]+/ /g;

    s/[\$\.\:\)\(\"\/;\{\}=\@\+\,]+/ /g;

    chop; # on enlève le dernier caractère.

    $Ligne++;

    $Lignes[$Ligne] = $_ ; # la variable $_ stocke la ligne en cours de lecture.

    @Mots = split(/\W+/); # la fonction split permet de séparer la chaîne en

    #plusieurs éléments ; ici le résultat est le tableau ‘Mots’.

    for $mot (@Mots) {

    $mot =~ /\D/ or next ;

    print "$mot \n";

    rangemot; # appel de la procédure rangemot.

    }

    }

    for $line (@Lignes) {

    print "Ligne : $line \n"; # écriture des lignes.

    }

    # Lecture et écriture dans les dicos.

    print "Lecture/Ecriture dico1 \n";

    foreach $mot (@dico1)

    {

    print "mot in dico1 : $mot\n";

    print DIC1 "$mot\n";

    }

    print "Lecture/Ecriture dico2 \n";

    foreach $item (sort keys %dico2)

    {

    print "(mot : $item) => Description in dico2 : $dico2{$item}\n";

    print DIC2 "(mot : $item) => $dico2{$item}\n";

    }

    close(DIC1);

    close(DIC2);

     

    concord.pl :

    #!/usr/bin/perl

    #--------------------------------------------------------------------

    # Programme de concordances.

    #-------------------------------------------------------------------------

    $Ligne = 0; # Initialisation de la variable ligne.

    READ: while(<>) # Début de la boucle while.

    {

    #saute les lignes vides :

    next READ if (/^$/);

    s/[ ]+/ /g; # N'accepte qu'une suite d'un seul blanc.

    chop; # Elimination du retour chariot.

    $Ligne++; # Incrémentation de la variable ligne.

    $Lignes[$Ligne] = $_ ; # On stocke la ligne en cours de lecture.

    @Mots = split(/\W+/); # segmentation des mots.

    for $Mot (@Mots) { # Concordances 

    $Mot =~ /\D/ or next ;

    push(@{$Concord{$Mot}},$Ligne); # Ajout d’une ligne au tableau.

    }

    }

    #--- Affichage des concordances :

    for $Mot (sort keys %Concord) {

    for $Ligne (@{$Concord{$Mot}})

    {

    print "<Mot:$Mot><Ligne numero:$Ligne><Ligne:$Lignes[$Ligne]>\n";

    }

    }

    Deux autres variantes pour établir des concordances :

    concord1.pl :

    #!/usr/bin/perl

    #--CONCORDANCES : PREMIERE VARIANTE.

     

    $Ligne = 0;

    READ: while(<>)

    {

    #saute les lignes vides

    next READ if (/^$/);

    s/[ ]+/ /g;

    chop;

    $Ligne++;

    $Lignes[$Ligne] = $_ ;

    @Mots = split(/\W+/);

    for $Mot (@Mots) {

    $Mot =~ /\D/ or next ;

    push(@{$Concord{$Mot}},$Ligne);

    }

    } # Changements dans les affichages :

    for $Mot (sort keys %Concord) {

    print "Mot : $Mot \n";

    for $Ligne (@{$Concord{$Mot}})

    {

    print "\t$Ligne: $Lignes[$Ligne]\n";

    }

    }

    concord2.pl :

    use strict;

    format STDOUT_TOP =

    Mot n°Ligne # Contenu Ligne

    .

    format STDOUT =

    @<<<<<<<<<<< @>>>>> @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

    $::Mot, $::Ligne, $::Lignes[$ ::Ligne]

    .

    my($Mot, %Exclude);

    for $Mot ("un", "le", "la", "une", "les") {

    $Exclude{$Mot} = 1;

    }

    my(@Mots,$Mot,%Concord);

    my($Ligne) = 0;

    READ: while(<>)

    {

    #saute les lignes vides

    next READ if (/^$/);

    s/[ ]+/ /g;

    chop;

    $Ligne++;

    $::Lignes[$Ligne] = $_ ;

    @Mots = split(/\W+/);

    for $Mot (@Mots) {

    $Mot =~ /\D/ or next ;

    $Exclude{"\L$Mot "} and next ;

    push(@{$Concord{$Mot}},$Ligne);

    }

    }

    for $::Mot (sort keys %Concord) {

    for $::Ligne (@{$Concord{$::Mot}})

    {

    write;

    $::Mot = "";

    }

    }

    balises.pl :

    #!/usr/local/bin/perl

    while(<STDIN>)

    {

    if (/^<balise>/)

    {

    $nb++;

    }

    }

    print "Il y a $nb références\n";

    extract.pl :

    #!/usr/local/bin/perl

    $rech=$ARGV[0]; # ARGV[0] fait référence au premier argument d’un tableau de

    # variables contenant l’ensemble des arguments passés en ligne de commande.

    while (<STDIN>)

    {

    if (/<$rech>(.+)<\/$rech>/) # Extraction du texte entre balises.

    {

    print "$1\n"; # Ecriture de la valeur de la dernière expression régulière : ici le

    # groupement de caractères entre balises.

    }

    }

    liste.pl :

    #!/usr/local/bin/perl

    #-- Tri des balises dans l’ordre alphabétique.

    while (<>){ # Parcours du fichier ligne par ligne.

    chop; # Suppression du dernier caractère.

    # On élimine le texte entre balise et pour chaque nouvelle balise

    # on créé un nouvel élément dans le tableau.

    s/>[^<]+</></g;

    s/></&/g;

    s/ [^&]+&/&/g;

    s/[\/<>\t]//g;

    @liste=split(/&/);

    foreach(@liste){

    $ind{$_}++;

    }

    }

    @res=sort keys %ind; # Tri du tableau par ordre alphabétique.

    print"\nliste des balises trié : \n@res\n"; # Affichage du tableau.

     

  5. La programmation objet avec Perl

Principe.

La programmation objet permet de créer des classes d’objets (ou packages) auxquelles on applique des procédures nommées ‘méthodes’. Ainsi, à un objet (une référence) sont associés des champs que l’on peut modifier à l’appel de ces méthodes préalablement définies.

Concrètement, le programme principal en Perl (ex. test.pl) utilise un programme d’extension " *.pm " qui contient les informations suivantes :

  1. La déclaration de la classe d’objet : on donne un nom à la classe d’objet (ou package) que l’on veut définir via la syntaxe [package ‘Nom’ ;].
  2. La définition de différentes méthodes : on définit les méthodes que l’on appellera dans le programme test.pl en utilisant la syntaxe Perl classique (à savoir sub ‘nom’ {...}). Parmi ces méthodes, on distingue les méthodes particulières new (constructeur de l’objet), bless (qui rend visible l’objet de l’extérieur), et destroy (destructeur de l’objet).

Au début du programme principal test.pl, il est donc indispensable d’indiquer que l’on se réfère au package et aux méthodes ainsi définies par l’intermédiaire de la commande ‘use’ suivie du nom du programme d’extension " *.pm " [use * ;].

Dans ce qui suit, nous nous proposons de rendre compte de ces différents points à partir d’un exemple, auquel nous avons apporté quelques modifications.

 

Exemples.

  1. Le programme initial.
  2. Le programme modifié.

I- Le programme initial.

Suivant la thématique du cours, nous avons travaillé sur le programme de base ‘patient0.pm’ qui consiste à définir un package ‘patient’ (ou la classe d’objet patient), et différentes méthodes :

Le programme patient0.pm est construit de la manière suivante :

(Nous avons annoté les étapes essentielles du programme en gras)

#!/usr/bin/perl

package patient; #déclaration de la classe d’objet ‘Patient’.

sub new { # méthode qui lors de son appel permettra de construire les différents champs relatifs aux

# informations sur un objet de type ‘patient’ (en l’occurrence : nom, unité, âge, sexe, adresse)

my ($class, $nom, $unite) = @_; # on remarque que la classe est toujours le premier paramètre

my $patient = {};

$patient->{'nom'}= $nom;

if ($unite) {

$patient->{'unite'} = $unite;

} else {

$patient->{'unite'} = 'Non definie';

}

return bless $patient; # c’est la référence de la variable que l’on retourne.

}

sub transfert { # méthode qui, si elle est appelée dans un programme Perl utilisant le package patient, permet

# d’indiquer le transfert d’un patient vers une nouvelle unité. On note que le nom $nvunite est arbitraire.

my ($patient, $nvunite) = @_;

$patient->{'unite'} = $nvunite;

}

sub affiche { # méthode qui permet l’affichage de la situation du patient lors de son appel.

my ($patient) = @_;

print "Le patient $patient->{'nom'} est dans l'unite $patient->{'unite'}\n"; # la syntaxe $patient->{''} donne accès au contenu du champ de l’objet ‘patient’ dont l’identifiant figure entre quotes.

}

sub DESTROY { # destructeur de l’objet.

my ($patient) = @_;

print "Le patient $patient->{'nom'} est parti !\n";

}

1;

Le programme testpatient0.pl suivant utilise la classe d’objet ‘patient’ et fait appel aux méthodes du programme précédent patient0.pm :

#!/bin/perl

use patient0; # indique que l’on utilise la classe d’objet ‘patient’ et les méthodes définies dans patient0.pm

$patient1 = new patient('Dupont Pierre'); # appel du constructeur de l’objet patient : la valeur ‘Dupont Pierre’ sera

# attribuée au champ ‘Nom’.

$patient2 = new patient('Durand Albert', 'urgences'); # nouvel appel de la méthode new qui attribue les valeurs

# ‘Durand Albert’ et ‘urgences’ repectivement aux champs ‘nom’ et ‘unité’.

$patient1->affiche; # appel de la méthode permettant l’affichage des informations concernant le patient.

$patient2->affiche;

$patient1->transfert('cardio'); # appel de la méthode permettant de modifier le contenu du champ ‘unité’.

$patient2->transfert('pneumo');

$patient1->affiche;

$patient2->affiche;

 

Ce programme a donc pour effet d’afficher à l’écran les informations suivantes :

II- Le programme modifié.

Nous avons souhaité enrichir le programme patient0.pm a) en ajoutant des informations sur le patient (âge, sexe, adresse), b) en indiquant un éventuel changement d’adresse, et le nombre de visites subi par ce dernier.

Ainsi, nous avons d’une part complété la méthode new en indiquant les nouveaux champs susceptibles d’être passés en paramètre à son appel, à savoir les champs âge, sexe, adresse et visites, en prenant soin d’initialiser le champ visite (valeur 0), puis nous avons défini deux nouvelles méthodes :

Le programme patient.pm se présente comme suit :

(nous avons annoté en gras essentiellement les nouveaux éléments du programme)

#!/usr/bin/perl

package patient;

sub new { # lors de son appel, la méthode new pourra prendre en argument le nom, l’unité, l’âge, le sexe,

# l’adresse, et le nombre de visites du patient.

my ($class, $nom, $unite, $age, $sexe, $adresse, $visites) = @_;

my $patient = {};

$patient->{'nom'}= $nom;

$patient->{'age'}= $age;

$patient->{'sexe'}= $sexe;

$patient->{'adresse'}= $adresse;

$patient->{'visites'}= 0; # initialisation du champ visite.

if ($unite) {

$patient->{'unite'} = $unite;

} else {

$patient->{'unite'} = 'Non definie';

}

return bless $patient;

}

sub transfert {

my ($patient, $nvunite) = @_;

$patient->{'unite'} = $nvunite;

}

sub nadress { # méthode qui lors de son appel permet de modifier le champ adresse de l’objet patient. On

# rappelle que le nom de la variable $nadress est arbitraire, et aide principalement à la lecture du programme.

my ($patient, $nadress) = @_;

$patient->{'adresse'} = $nadress;

}

sub nvisites { # méthode qui permet de permet de passer en paramètre le nombre de visites subi par le patient

# à son appel. Nous avons volontairement choisi d’appeler la variable $nadress afin de montrer qu’il s’agit d’une

# variable locale et que son nom n’influe pas sur le fonctionnement du programme.

my ($patient, $nadress) = @_;

$patient->{'visites'} = $nadress;

}

sub affiche {

my ($patient) = @_;

print "Le patient $patient->{'nom'}, age de $patient->{'age'} ans, de sexe $patient->{'sexe'}, habitant $patient->{'adresse'}, se trouve dans l'unite $patient->{'unite'}, et a recu $patient->{'visites'} visites.\n";

}

sub DESTROY {

my ($patient) = @_;

print "Le patient $patient->{'nom'} est parti !\n";

}

1;

Le programme testpatient.pl qui suit nous permet, selon le principe décrit en I, de faire appel aux méthodes définies précédemment :

#!/bin/perl

use patient;

$patient1 = new patient('Simon Kotsidis', 'cardio','34','m','28 rue de Belgique'); # passage en argument

# d’ informations sur le patient à la méthode new définie dans le programme patient.pm.

$patient2 = new patient('Eleni Kouyoublachi','urgences','23','f','54 rue Alitis');

$patient1->affiche;

$patient2->affiche;

$patient2->transfert('pneumo'); # utilisation des nouvelles méthodes nadress et nvisites définies

$patient1->nadress("23 rue du Brouillard"); # dans patient.pm

$patient2->nadress('43 passage Josset');

$patient2->nvisites(7);

$patient1->affiche;

$patient2->affiche;

 

En lançant le programme, le résultat obtenu est le suivant :

 

 

Conclusion :

Ces manipulations à partir d’exemples simples nous permettent d’illustrer une autre possibilité offerte par le langage Perl la programmation objet. Nous verrons également que le langage Perl est particulièrement adapté à la création d’interfaces graphique.

 

 

  1. Interfaces graphiques en PERL/TK

Le projet menuSearchRegexp.pl.

Introduction.

Le langage Perl permet de créer des interfaces graphiques grâce à l’extension Tk introduite par Nick Ing-Simmons. Ainsi, tous les programmes utilisant cette extension via la commande ‘use Tk ;’ nécessitent l’installation préalable de Perl/Tk.

Les unités ou ‘briques’ manipulées par l’interface graphique s’appellent des widgets, dont on distingue deux types essentiels :

On construit un widget selon la méthode générale suivante : à chaque widget, on associe un parent qui garde la trace du nouveau widget, le temps de son existence.

Ex. : $fils=$parent->widgetType(| -option=>valeur,…|) ;

Généralement, la construction d’un programme en Perl /Tk se divise en deux grandes étapes :

1) La définition d’une fenêtre principale ($mw= MainWindow->new;) contenant la définition de tous les widgets. Cette étape se termine toujours par un " Mainloop ; ", qui met en marche le gestionnaire d’événements.

2) La définition d’éventuelles procédures appelées par les widgets.

 

Dans ce qui suit, nous présentons différentes étapes de construction aboutissant à l’interface graphique " menuSearchRegexp.pl ".

  1. Le programme widtest.pl.
  2. Le programme menuSearchregexp.pl.

 

  1. Le programme widtest.pl.

Etat initial.

Cette étape permet de décrire toutes les fonctions de base du menu ‘widtest.pl’, et permet de présenter différents types de widgets.

A]

B]

A] Lors de cette étape, nous avons créé une fenêtre principale ($mw= MainWindow->new;) nommée ‘Recherche avec Expressions régulières’, amenée à contenir la définition de tous les widgets.

Par la suite, nous avons créé un cadre ($cadre = $mw->Frame), dont l’affichage est réalisé par le gestionnaire d’espace ‘pack’.

B] Puis, nous avons créé différents widgets :

 

Etape 2.

Des widgets plus complexes : menus déroulants, barres de défilement et texte.

a) Un menu déroulant : $b_menucadre->Menubutton.

Le principe de fonctionnement du menu déroulant est d’apparaître à la pression d’un bouton et de disparaître après la sélection d’une option. A la suite de la création du widget ($b_menucadre->Menubutton), l’option menuitems indique dans l’ordre la liste de commande qui sera affichée. Chaque sous-liste respecte la syntaxe ‘type de commande’ => chaîne de caractères’. Dans l’exemple qui suit, ‘command’ associe au menu ‘load’ la fonction lire_fic :

Ex. : 'command' => "load",

-command => \&lire_fic

b) Scrolled et les barres de défilement.

Dans la ligne " $texte=$mw->Scrolled("Text")" , la méthode Scrolled permet de créer un widget avec ses barres de défilement.

c) Le widget texte.

On peut se repérer dans un texte à partir de la valeur de l’indice ‘l,k’ (ligne, colonne, la colonne commençant à 0). Les marqueurs de texte permettre également d’associer des informations à une partie du texte (tag), d’insérer (insert), supprimer (delete), capturer (get), afficher (see), ou encore rechercher des informations dans un texte (search).

Le programme ‘widtest.pl’ qui utilise toutes les fonctions décrites précédemment se présente donc de la façon suivante :

(Différentes possibilités offertes par les options sont décrites en note de bas de page, au fur et à mesure du commentaire du programme).

#/usr/local/bin

use Tk; ; # Commande qui signale que le programme utilise l’extension Tk,

# installée au préalable.

$mw= MainWindow->new; #Création de la fenêtre principale qui contient

# les widgets fils.

$mw->title("Recherche avec Expressions regulieres"); # Modification du titre de la

# fenêtre principale : ‘title’ prend pour argument la chaîne de caractères

# indiquée.

$cadre = $mw->Frame->pack(-side => 'top', # Création d’un cadre et affichage de

-fill => 'x'); # ce cadre via la méthode pack.

$b_menu=$cadre->Menubutton(-text => "File", # Création d’un menu déroulant

# qui affiche la commande ‘load’.

-tearoff => 0,

-relief => 'ridge',

-menuitems => [['command' => "load",

-command => \&lire_fic]

])->pack(-side => 'left');

$cadre->Label(-text => "File : ", # Création d’un widget étiquette nommé ‘File :’.

-relief => 'raised')->pack(-side => 'left',

-anchor => 'w');

$cadre->Entry(-textvariable => \$nom_fic)->pack(-side => 'left', # Création d’un

# widget de zone de saisie.

-anchor => 'w',

-fill => 'x',

-expand=> 1);

$cadre->Button(-text => "load", # Création d’un bouton ‘load’.

-command => sub {&lire_fic})->pack(-side => 'left',

-anchor => 'e');

$texte = $mw->Scrolled("Text")->pack(-side => 'bottom', # création d’une barre de

# défilement.

-fill => 'both',

-expand => 1);

 

MainLoop; # fin de la création des widgets, début de définition des

# procédures.

#----------------- Procédure permettant de charger un fichier, elle est

associée à ‘load’ via l’option ‘command’.

sub lire_fic {

$info="Chargement du fichier '$nom_fic'...";

$texte->delete("1.0","end");

if (!open(FIC,"$nom_fic")) {

$texte->insert("end","ERREUR : Impossible d\'ouvrir '$nom_fic'\n");

return;

}

while (<FIC>) {

$texte->insert("end",$_);

}

close(FIC);

$info = "Fichier '$nom_fic' chargé.";

}

# ------ Fin du programme widtest.pl.

 

Conclusion :

Le programme ‘widtest.pl’ a donc pour effet de créer une fenêtre (frame) nommée " Recherche avec expressions régulières ", un menu déroulant ‘File’ avec l’option ‘load’, ainsi qu’un bouton Load.. Dans cet exemple, nous avons chargé le fichier Boeing.txt.

 

 

 

II- Le menuSearchRegexp.txt.

 

Etape 3 :

Dans cette phase, nous avons d’abord complété le menu ‘Fichier’ gérant l’ouverture, la sauvegarde des fichiers (et la sortie du programme), puis, nous avons ajouté un menu ‘Edition’, afin que notre éditeur, comme son nom l’indique, effectue des ‘Recherches avec expressions régulières’. Enfin, nous avons intégré un menu ‘Balises’ permet de lister, supprimer et modifier des balises de textes aux formats html ou xml.

A/ Le menu déroulant ‘Fichier’.

Il contient les commandes suivantes :

N.B. :

Certaines de ces tâches peuvent être effectuées à l’aide de boutons, notamment pour les fonctions ‘Load’, ‘Save’ et ‘Exit’.

B/ Le menu Edition.

Les commandes disponibles dans ce menu déroulant sont les suivantes :

Ce menu permet donc d’effectuer des recherches incrémentale et globale (motif intégré dans le champ ‘Search string’), ainsi que des remplacements (motif à remplacer intégré dans la zone ‘Replace string’).

Dans la zone texte, on repère le résultat de ces recherches qui clignote en vert.

Remarques :

C/ Le menu Balises<[^>]+>.

(Rappel : l’expression régulière correspondant aux balises est la suivante : " <[^>]+> ").

Ce menu est composé des commandes suivantes :

Voici le programme ‘menuSearchregexp.pl’ :

 

 

#/usr/local/bin

use Tk; #programme utilisant l'extension Tk de Perl.

#--Creations de la fenetre principale et d'un cadre (cf.prg precedent).

$mw= MainWindow->new;

$mw->title("Recherche avec Expressions regulieres");

$cadre = $mw->Frame->pack(-side => 'top',

-fill => 'x');

#------- Menu 'File' (ouverture, fermeture, sauvergarde de fichiers).

$b_menu=$cadre->Menubutton(-text => "Fichier",

-tearoff => 0,

-relief => 'ridge',

-menuitems => [['command' => "load",

-command => \&lire_fic],

['command' => "~Select File & open",

-command => \&query_file_dialog],

['command' => "Enregistrer",

-command => \&sauve_fic],

['command' => "Exit",

-command => sub {exit;}]])->pack(-side => 'left');

#------ Menu 'Edition' (recherches incrementales/globales avec ou sans

# regexp).

$c_menu=$cadre->Menubutton(-text => "Edition",

-tearoff => 0,

-relief => 'ridge',

-menuitems => [['command' => "I-Search",

-command => \&i_search],

['command' => "Repeat I-Search",

-command => \&i_search2],

['command' => "Global Search",

-command => \&search_in_fic],

['command' => "I-Replace",

-command => \&i_replace],

['command' => "Repeat I-Replace",

-command => \&i_replace2],

['command' => "Global Replace",

-command => \&replace]])->pack(-side => 'left');

$mw->bind(Tk::Text,"<Button-3>",sub{ $c_menu->Popup(-popover => 'cursor',

_popanchor => "nw")});

#-------------Menu 'Balises'.

$d0_menu=$cadre->Menubutton(-text => "Balises <[^>]+>",

-tearoff => 0,

-relief => 'ridge',

-menuitems => [['command' => "Voir",

-command => \&list_balise],

['command' => "Effacer",

-command => \&del_balise],

['command' => "Rechercher",

-command => \&search_balise],

['command' => "I-Search",

-command => \&i_search],

['command' => "Repeat I-Search",

-command => \&i_search2],

['command' => "Extract Text in Markups",

-command => \&query_search_text_in_balise]

])->pack(-side => 'left');

#---------------- Creation d'une etiquette et d'une zone de saisie.

$cadre->Label(-text => "File : ",

-relief => 'raised')->pack(-side => 'left',

-anchor => 'w');

$cadre->Entry(-textvariable => \$nom_fic)->pack(-side => 'left',

-anchor => 'w',

-fill => 'x',

-expand => 1);

#---Bouton 'Load'.

$cadre->Button(-text => "load",

-command => sub {&lire_fic})->pack(-side => 'left',

-anchor => 'e');

#---Creation d'une barre de defilement.

$texte = $mw->Scrolled("Text")->pack(-side => 'bottom',

-fill => 'both',

-expand => 1);

#--- Widgets textes.

$texte->Text(-setgrid => 'true');

$search_string = '';

$w_string = $mw->Frame()->pack(-side => 'top', -fill => 'x');

$w_string_label = $w_string->Label(-text => 'Search string:', -width => 13, -anchor => 'w');

$saisie2= $w_string_entry = $w_string->Entry(-textvariable => \$search_string);

$w_string_label2 = $w_string->Label(-text => 'Delete string:', -width => 13, -anchor => 'w');

$w_string_entry2 = $w_string->Entry( -textvariable => \$search_string);

$w_string_button = $w_string->Button(-text => 'Highlight');

$w_string_button1 = $w_string->Button(-text => 'No Highlight');

$w_string_button2 = $w_string->Button(-text => 'Delete');

#Affichages des etiquettes, zones de saisie et boutons :

$w_string_label->pack(-side => 'left');

$w_string_entry->pack(-side => 'left');

$w_string_label2->pack(-side => 'left');

$w_string_entry2->pack(-side => 'left');

$w_string_button->pack(-side => 'left', -pady => 5, -padx => 10);

$w_string_button1->pack(-side => 'left', -pady => 5, -padx => 10);

$w_string_button2->pack(-side => 'left', -pady => 5, -padx => 10);

$w_string->pack(-side => 'top', -fill => 'x');

$w_string_button->configure(-command => [sub {&text_search($texte, $search_string, 'search')}, $texte]);

$w_string_button1->configure(-command => [sub {&remove_mark_search}]);

$w_string_button2->configure(-command => [sub {&text_delete($texte, $search_string, 'search')}, $texte]);

$w_string_entry->bind('<Return>' => [sub {shift; &text_search($texte, $search_string, 'search')}, $texte]);

$w_string_entry2->bind('<Return>' => [sub {shift; &text_delete($texte, $search_string, 'search')}, $texte]);

$w_string->pack(-side => 'top', -fill => 'x');

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$saisie2->delete(0,'end');

#---Les remplacements :

$w_string2 = $mw->Frame()->pack(-side => 'top', -fill => 'x');

$w_string2_label = $w_string2->Label(-text => 'Replace with string:', -width => 20, -anchor => 'w');

$saisie3= $w_string2_entry = $w_string2->Entry(-textvariable => \$replace_string);

$w_string2_button = $w_string2->Button(-text => 'Replace');

$w_string2_label->pack(-side => 'left');

$w_string2_entry->pack(-side => 'left');

$w_string2_button->pack(-side => 'left', -pady => 5, -padx => 10);

#$w_string2->pack(-side => 'top', -fill => 'x');

$w_string2_button->configure(-command => [sub {&text_replace($texte, $search_string, $replace_string, 'search')}, $texte]);

$w_string2_entry->bind('<Return>' => [sub {shift; &text_replace($texte, $search_string, $replace_string, 'search')}, $texte]);

$w_string2->pack(-side => 'top', -fill => 'x');

$saisie3->delete(0,'end');

#------Creations des boutons 'Exit'et 'Save'.

$cadre->Button(-text => "Exit",

-command => sub {exit;})->pack(-side => 'right');

$cadre->Button(-text => "Save",

-command => sub {&sauve_fic})->pack(-side => 'right',

-anchor => 'e');

$mw->Label(-textvariable => \$info,

-relief => 'ridge')->pack(-side => 'bottom',

-fill => 'x');

MainLoop;

#---------------- DEFINITIONS DES PROCEDURES APPELEES.

#---On indiquera la fonction essentielle de chaque procedure,

# N.B. : certaines procedures sont apellees par d'autres programmes.

#---1) MENU FICHIER.

#-----a) Charger le fichier, commande 'load'.

sub lire_fic {

$info="Chargement du fichier '$nom_fic'...";

$texte->delete("1.0","end");

if (!open(FIC,"$nom_fic")) {

$texte->insert("end","ERREUR : Impossible d\'ouvrir '$nom_fic'\n");

return;

}

while (<FIC>) {

$texte->insert("end",$_);

}

close(FIC);

$info = "Fichier '$nom_fic' chargé.";

}

 

#----b) "Select File and open" du menu 'Fichier'.

sub query_file_dialog {

if (! Exists ($pn9)) {

 

$pn9 = $mw ->Toplevel();

foreach my $i (qw(open)) {

my $f = $pn9->Frame;

my $lab = $f->Label(-text => "Select a file to $i: ",

-anchor => 'e');

my $ent = $f->Entry(-width => 20);

my $but = $f->Button(-text => "Browse ...",

-command => sub { fileDialog($pn9, $ent, $i)});

$lab->pack(-side => 'left');

$ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');

$but->pack(-side => 'left');

$f->pack(-fill => 'x', -padx => '1c', -pady => 3);

}

my $cbf = $pn9->Frame->pack(-fill => 'x', -padx => '1c', -pady => 3);

my $fd;

$cbf->Radiobutton

(-text => 'FileSelect',

-variable => \$fd,

-value => 'FileSelect',

-command => sub { local($^W) = 0;

require Tk::FileSelect;

Tk::FileSelect->import('as_default');

# XXX remove cached dialogs

my $pn9 = $pn9->MainWindow;

delete $pn9->{'tk_getOpenFile'};

# delete $pn9->{'tk_getSaveFile'};

})->pack(-side => 'left');

my $fdb = $cbf->Radiobutton

(-text => 'FBox',

-variable => \$fd,

-value => 'FBox',

-command => sub { local($^W) = 0;

require Tk::FBox;

Tk::FBox->import('as_default');

# XXX remove cached dialogs

my $pn9 = $pn9->MainWindow;

delete $pn9->{'tk_getOpenFile'};

# delete $pn9->{'tk_getSaveFile'};

})->pack(-side => 'left');

$fdb->invoke;

}

}

# autres sous-programmes :

#-------a)

sub fileDialog {

my $w = shift;

my $ent = shift;

my $operation = shift;

my $types;

my $file;

# Type names Extension(s) Mac File Type(s)

#

#---------------------------------------------------------

@types =

(

["(HT/X/SG)ML files", [qw/.xml .html .sgml .htm .dtd/]],

["Text files", [qw/.txt .doc/]],

["Text files", '', 'TEXT'],

["Perl Scripts", '.pl', 'TEXT'],

["C Source Files", ['.c', '.h']],

["All Source Files", [qw/.tcl .c .h/]],

["Image Files", '.gif'],

["Image Files", ['.jpeg', '.jpg']],

["Image Files", '', [qw/GIFF JPEG/]],

["All files", '*']

);

if ($operation eq 'open') {

$file = $w->getOpenFile(-filetypes => \@types);

if (defined $file and $file ne '') {&load_selected_fic($file);}

if (Exists ($pn9)) {$pn9->destroy();}

} else {

$file = $w->getSaveFile(-filetypes => \@types,

-initialfile => 'Untitled',

-defaultextension => '.txt');

if (Exists ($pn9)) {$pn9->destroy();}

}

}

#---b)

sub load_selected_fic {

($nom_fic) = @_;

if (&ConfirmNewDocument($texte)) {

my $nom = "$nom_fic";

if (!exists ($Courant{$nom})){

$Courant{$nom}++;

$num_doc++;

push (@courant, $nom);

$b_menu->command(-label => "$nom",

-command => [ \&load_selected_fic, "$nom"]);

}

$info="Chargement du fichier '$nom_fic'...";

$texte->Load($nom_fic);

$info = "Fichier '$nom_fic' chargé.";

}

}

#--c)

sub ConfirmNewDocument {

my ($w)=@_;

if (ConfirmDiscard2($w)) {

return 1;

}

else {

return 0;

}

}

#---c)Les sauvegardes de fichiers.

sub sauve_fic {

$info="Sauvegarde du fichier '$nom_fic'...";

open(FIC,">$nom_fic");

print FIC $texte->get("1.0","end");

$info= "Fichier '$nom_fic' sauvegardé.";

}

 

#-----2)MENU EDITION : recherche de motifs.

#----a) RECHERCHE GLOBALE.

sub search_in_fic {

$info="Recherche dans le fichier '$nom_fic'...";

&text_search($texte, $search_string, 'search');

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche dans Fichier '$nom_fic' terminée.";

}

#-------b) RECHERCHE INCREMENTALE SIMPLE.

sub i_search {

if ($search_string eq "") {

&mkPrintErreur("ERREUR : Aucune sélection de chaîne de recherche donnée\n");

return;

}

$info="Recherche dans le fichier '$nom_fic'...";

$texte->tag('remove', 'search', '0.0', 'end');

my $resultat=$texte->search(-regexp, "$search_string",'1.0','end');

if ($resultat eq "") {

&mkPrintMsgInfo("Aucune chaîne correspondante pour le motif de recherche donné\n");

return;

}

my $lenght = length $search_string;

$resultat=~/([0-9]+)\.([0-9]+)/;

$i=$1;

$offset=$2;

$texte->tag('add', 'search', sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$lenght));

$texte->see($resultat);

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche dans Fichier '$nom_fic' terminée.";

$position_search= sprintf("%d.%d", $i, $offset+$lenght);

}

#---N.B. : LES PROCEDURES MKPRINT SE TROUVENT A LA FIN.

#------c) REPEAT I-SEARCH : nouvelle recherche du motif donne.

sub i_search2 {

if ($search_string eq "") {

&mkPrintErreur("ERREUR : Aucune slection de chaîne de recherche donnée\n");

return;

}

$texte->tag('remove', 'search', '0.0', 'end');

if ($position_search !~/[0-9]+\.[0-9]+/) {

&mkPrintMsgInfo("On vous a déjà dit qu'il n\'existe aucune chaîne correspondante pour le motif de recherche donné\n...");

return;

}

$info="Recherche dans le fichier '$nom_fic'...";

$resultat=$texte->search(-regexp, "$search_string",$position_search,'end');

print $resultat,"<<<<<<<\n";

if ($resultat eq "") {

&mkPrintMsgInfo("Aucune chaîne correspondante pour le motif de recherche donné\n");

return;

}

my $lenght = length $search_string;

$resultat=~/([0-9]+)\.([0-9]+)/;

$i=$1;

$offset=$2;

$texte->tag('add', 'search', sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$lenght));

$texte->see($resultat);

if ($pnDraw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche dans Fichier '$nom_fic' terminée.";

$position_search= sprintf("%d.%d", $i, $offset+$lenght);

}

#--------d) REMPLACEMENT INCREMENTAL D'UN MOTIF PAR UN AUTRE.

sub i_replace {

if ($search_string eq "") {

&mkPrintErreur("ERREUR : Aucune sélection de chaîne de recherche donnée\n");

return;

}

$info="Recherche dans le fichier '$nom_fic'...";

$texte->tag('remove', 'search', '0.0', 'end');

$resultat=$texte->search(-regexp, "$search_string",'1.0','end');

if ($resultat eq "") {

&mkPrintMsgInfo("Aucune chaîne correspondante pour le motif de recherche donné\n");

return;

}

my $lenght = length $search_string;

$resultat=~/([0-9]+)\.([0-9]+)/;

$i=$1;

$offset=$2;

$texte->tag('add', 'search', sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$lenght));

$texte->delete(sprintf("%d.%d",$i,$offset),sprintf("%d.%d",$i,$offset + $lenght));

$texte->insert(sprintf("%d.%d", $i, $offset),$replace_string);

$lenght = length $replace_string;

$texte->tag('add', 'search', sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$lenght));

$texte->see($resultat);

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche dans Fichier '$nom_fic' terminée.";

$position_search= sprintf("%d.%d", $i, $offset+$lenght);

}

#-----------e) Repeat I-Replace.

sub i_replace2 {

if ($search_string eq "") {

&mkPrintErreur("ERREUR : Aucune sélection de chaîne de recherche donnée\n");

return;

}

if ($position_search !~/[0-9]+\.[0-9]+/) {

&mkPrintMsgInfo("On vous a déjà dit qu'il n\'existe aucune chaîne correspondante pour le motif de recherche donné\n...");

return;

}

$info="Recherche dans le fichier '$nom_fic'...";

$texte->tag('remove', 'search', '0.0', 'end');

$resultat=$texte->search(-regexp, "$search_string",$position_search,'end');

if ($resultat eq "") {

&mkPrintMsgInfo("Aucune chaîne correspondante pour le motif de recherche donné\n");

return;

}

my $lenght = length $search_string;

$resultat=~/([0-9]+)\.([0-9]+)/;

$i=$1;

$offset=$2;

$texte->tag('add', 'search', sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$lenght));

$texte->delete(sprintf("%d.%d",$i,$offset),sprintf("%d.%d",$i,$offset + $lenght));

$texte->insert(sprintf("%d.%d", $i, $offset),$replace_string);

$lenght = length $replace_string;

$texte->tag('add', 'search', sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$lenght));

$texte->see($resultat);

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche dans Fichier '$nom_fic' terminée.";

$position_search= sprintf("%d.%d", $i, $offset+$lenght);

}

#---------f) Remplacement global.

sub replace {

$info="Recherche et remplacement dans le fichier '$nom_fic'...";

&text_replace($texte, $search_string, $replace_string, 'search');

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche et remplacement dans Fichier '$nom_fic' terminée.";

$saisie2->delete(0,'end');

$saisie3->delete(0,'end');

}

#------------3) MENU BALISES.

#-----a) Effacer des balises.

sub del_balise {

$search_string="<[^>]+>";

$info="Recherche et suppression dans le fichier '$nom_fic'...";

&text_delete($texte, $search_string, 'search');

$info= "Suppression dans Fichier '$nom_fic' terminée.";

$saisie2->delete(0,'end');

}

#--b) Voir les balises.

sub list_balise {

$search_string="<[^>]+>";

$info="Recherche dans le fichier '$nom_fic'...";

&text_balise($texte, $search_string, 'search');

$info= "Affichage balises dans Fichier '$nom_fic' terminée.";

$saisie2->delete(0,'end');

}

#--- c) Rechercher les balises.

sub search_balise {

$search_string="<[^>]+>";

$info="Recherche balises le fichier '$nom_fic'...";

&text_search($texte, $search_string, 'search');

if ($mw->depth > 1) {

text_toggle($texte, ['configure', 'search', -background => 'SeaGreen4', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

} else {

text_toggle($texte, ['configure', 'search', -background => 'black', -foreground => 'white'], 800,

['configure', 'search', -background => undef, -foreground => undef], 200);

}

$info= "Recherche dans Fichier '$nom_fic' terminée.";

$saisie2->delete(0,'end');

}

#--d) Extraire le texte entre les balises.

sub query_search_text_in_balise {

if (! Exists ($pn7)) {

$pn7 = $mw ->Toplevel();

$pn7->title("Text-Extractor");

my $cadre = $pn7->Frame->pack(-side => 'top',

-fill => 'x');

$cadre->Label(-text => "Search : ",

-relief => 'raised')->pack(-side => 'left',

-anchor => 'w');

my $search="";

my $saisie_1=$cadre->Entry(-textvariable => \$search)->pack(-side => 'left',

-anchor => 'w',

-fill => 'x',

-expand => 1);

$cadre->Button(-text => "Extract Text",

-command => sub {&extract_balise_i($search)})->pack(-side => 'right',

-anchor => 'e');

$pn7->Button(-text => "Fermer",

-command => sub {$pn7->destroy()})->pack;

}

else {

$pn7->deiconify();

$pn7->raise();

}

}

#--------------------------------------------- Autres programmes :

sub extract_balise_i {

my ($balise_d) = @_;

$balise_d=~/<([^>]+)>/;

my $tmp=$1;

my $ind=0;

if ($balise_d=~/<([^ ]+) [^>]*>/) {$tmp=$1}

my $balise_f="<\/$tmp>";

my $balise_name = $tmp;

my @chars = unpack("A1" x length($balise_name), $balise_name);

my $tmp_string="[^<]*[^\/]*";

foreach $ch (@chars) {

$tmp_string .= "[^".$ch."]*";

}

$tmp_string .= "[^>]*";

my $resultat=$texte->search(-regexp, "$balise_f",'1.0','end');

if ($resultat eq "") {

&mkPrintErreur("ERREUR : Pas de balise fermante '$balise_f' pour cette balise\n");

return;

}

$nom_fic2="tmp-ExtractText_".$balise_name.".txt";

$info="Lecture du fichier '$nom_fic'...";

if (!open(TMPFILE,("$nom_fic"))) {

&mkPrintErreur("ERREUR : Impossible d\'ouvrir le fichier '$nom_fic'\n");

return;

}

if (!open(TMPFILE2,(">$nom_fic2"))) {

&mkPrintErreur("ERREUR : Impossible d\'ouvrir le fichier '$nom_fic2'\n");

return;

}

$info="Création du fichier '$nom_fic2'...";

while ($ligne = <TMPFILE>) {

if ($ligne =~ /$balise_d(.*)$balise_f/i)

{

$ind++;

print TMPFILE2 "<$balise_name=NUM$ind>\n";

print TMPFILE2 "$1\n";

}

if (($ligne=~/$balise_d(.*)/i) && ($ligne!~/$balise_f/i)){

my $tmp="$1";

$ind++;

print TMPFILE2 "<$balise_name=NUM$ind>\n";

print TMPFILE2 "$tmp";

$ligne=<TMPFILE>;

until ($ligne=~/$balise_f/i){

print TMPFILE2 "$ligne";

$ligne=<TMPFILE>;

break if $ligne == EOF;

}

$ligne=~/(.*)$balise_f/;

print TMPFILE2 "$1";

}

}

print TMPFILE2 "\n";

close(TMPFILE);

close(TMPFILE2);

my $tmpfile="tmp-ExtractText_".$balise_name.".txt";

$mkExtractTextInMarkup->destroy if Exists($mkExtractTextInMarkup);

$mkExtractTextInMarkup = $mw->Toplevel();

my $w = $mkExtractTextInMarkup;

$w->title('Extract Text');

$w->iconname('Extract');

my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);

my $w_t = $w->TextUndo(-setgrid => 'true', -width => '60', -height => '28',

-font => '-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*');

my $w_save = $w->Button(-text => "Save",

-command => sub {$w_t->FileSaveAsPopup()})->pack(-side => 'top', -pady => 5, -padx => 10);

my $w_s = $w->Scrollbar(-command => ['yview', $w_t]);

$w_t->configure(-yscrollcommand => ['set', $w_s]);

$w_ok->pack(-side => 'top', -pady => 5, -padx => 10);

$w_s->pack(-side => 'right', -fill => 'y');

$w_t->pack(-expand => 'yes', -fill => 'both');

# Set up display styles

my(@bold, @normal, $tags);

if ($mkExtractTextInMarkup->depth > 1) {

@bold = (-foreground => 'red');

@normal = (-foreground => undef);

} else {

@bold = (-foreground => 'white', -background => 'black');

@normal = (-foreground => undef, -background => undef);

}

$w_t->insert('0.0', 'Extract Results...');

$w_t->insert("end","\n\n");

$w_t->IncludeFile($tmpfile);

$info = "Recherche Markups sur '$nom_fic' terminée.";

}

#---------------------------------------------

#----II- Les procedures asociees aux widgets textes.

sub text_balise {

# The utility procedure below searches and destroy for all instances of a given string in a text widget and applies a given tag

# to each instance found.

# Arguments:

#

# w - The window in which to search. Must be a text widget.

# string - The string to search for.

# tag - Tag to apply to each instance of a matching string.

my($w, $string, $tag) = @_;

my $id = 0;

my @seenElt=();

$w->tag('remove', $tag, '0.0', 'end');

(my $num_lines) = $w->index('end') =~ /(\d*)\.\d*/;

for($i = 1; $i <=$num_lines; $i++) {

my $line = $w->get("${i}.0", "${i}.1000");

next if not defined $line or $line !~ /($string)/;

my $l = length $1;

my $stringRegexp=$1;

my $offset = 0;

while (1) {

my $tmpoffset=0;

my $index = index $line, $stringRegexp, $tmpoffset;

last if $index == -1;

$offset += $index;

$seenElt[$id] =[$i, $offset, $i, $offset+$l];

$id++;

$offset += $l;

$line = substr $line, $index+$l;

if ($line=~/($string)/) { $stringRegexp=$1;

$l = length $1;}

} # whilend

} # forend

$cpt_file_balises++;

if (!open(TMPFILE,(">tmp-Mkbalises.txt"))) {

&mkPrintErreur("ERREUR : Impossible d\'ouvrir le fichier tmp-Mkbalises.txt\n");

return;

}

$info="Création du fichier tmp-Mkbalises.txt...";

for ($i =0 ; $i <= $#seenElt; $i++) {

$tmpTexte=$w->get(sprintf("%d.%d",$seenElt[$i][0],$seenElt[$i][1]),sprintf("%d.%d",$seenElt[$i][2],$seenElt[$i][3]));

print TMPFILE "$tmpTexte\n";

}

close(TMPFILE);

 

$info="Chargement du fichier tmp-Mkbalises.txt...";

my $tmpFile="tmp-Mkbalises.txt";

&print_list_balise($tmpFile);

}

#-----

sub print_list_balise {

my ($tmpfile) = @_;

$mkTextMarkup->destroy if Exists($mkTextMarkup);

$mkTextMarkup = $mw->Toplevel();

my $w = $mkTextMarkup;

$w->title('Markup List');

$w->iconname('Markup');

my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);

my $w_t = $w->TextUndo(-setgrid => 'true', -width => '60', -height => '28',

-font => '-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*');

my $w_save = $w->Button(-text => "Save",

-command => sub {$w_t->FileSaveAsPopup()})->pack(-side => 'top', -pady => 5, -padx => 10);

 

my $w_s = $w->Scrollbar(-command => ['yview', $w_t]);

$w_t->configure(-yscrollcommand => ['set', $w_s]);

$w_ok->pack(-side => 'top', -pady => 5, -padx => 10);

$w_s->pack(-side => 'right', -fill => 'y');

$w_t->pack(-expand => 'yes', -fill => 'both');

# Set up display styles

my(@bold, @normal, $tags);

if ($mkTextMarkup->depth > 1) {

@bold = (-foreground => 'red');

@normal = (-foreground => undef);

} else {

@bold = (-foreground => 'white', -background => 'black');

@normal = (-foreground => undef, -background => undef);

}

$w_t->insert('0.0', 'Markup Results...');

$w_t->insert("end","\n\n");

$w_t->IncludeFile($tmpfile);

$info = "Recherche Markups sur '$nom_fic' terminée.";

}

#----- Recherche d'une chaine de caracteres :

sub text_search {

# The utility procedure below searches for all instances of a given string in a text widget and applies a given tag

# to each instance found.

# Arguments:

#

# w - The window in which to search. Must be a text widget.

# string - The string to search for. (regexp and so on...)

# tag - Tag to apply to each instance of a matching string.

my($w, $string, $tag) = @_;

$w->tag('remove', $tag, '0.0', 'end');

(my $num_lines) = $w->index('end') =~ /(\d*)\.\d*/;

for($i = 1; $i <=$num_lines; $i++) {

my $line = $w->get("${i}.0", "${i}.1000");

next if not defined $line or $line !~ /($string)/;

my $l = length $1;

$stringRegexp=$1;

my $offset = 0;

while (1) {

my $tmpoffset=0;

my $index = index $line, $stringRegexp, $tmpoffset;

last if $index == -1;

$offset += $index;

$w->tag('add', $tag, sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$l));

$offset += $l;

$line = substr $line, $index+$l;

if ($line=~/($string)/) { $stringRegexp=$1;

$l = length $1;}

} # whilend

} # forend

} # end text_search

#-------

sub text_replace {

# The utility procedure below searches for all instances of a given string in a text widget and applies a given tag

# to each instance found.

# Arguments:

#

# w - The window in which to search. Must be a text widget.

# string - The string to search for. (regexp and so on...)

# tag - Tag to apply to each instance of a matching string.

my($w, $string, $replace, $tag) = @_;

my @seenElt=();

if ($string eq "") {

&mkPrintErreur("ERREUR : Aucune sélection de chaîne de recherche donnée\n");

return;

}

my $resultat=$w->search(-regexp, "$string",'1.0','end');

if ($resultat eq "") {

&mkPrintMsgInfo("Aucune chaîne correspondante pour le motif de recherche donné\n");

return;

}

$w->tag('remove', $tag, '0.0', 'end');

(my $num_lines) = $w->index('end') =~ /(\d*)\.\d*/;

my $id = 0;

for($i = 1; $i <=$num_lines; $i++) {

my $line = $w->get("${i}.0", "${i}.1000");

next if not defined $line or $line !~ /($string)/;

my $l = length $1;

my $stringRegexp=$1;

my $offset = 0;

while (1) {

my $tmpoffset=0;

my $index = index $line, $stringRegexp, $tmpoffset;

last if $index == -1;

$offset += $index;

$w->tag('add', $tag, sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$l));

$seenElt[$id] =[$i, $offset, $i, $offset+$l,$l];

$id++;

$offset += $l;

$line = substr $line, $index+$l;

if ($line=~/($string)/) { $stringRegexp=$1;

$l = length $1;}

} # whilend

} # forend

 

for ($i = $#seenElt; $i >= 0; $i--) {

$w->delete(sprintf("%d.%d",$seenElt[$i][0],$seenElt[$i][1]),sprintf("%d.%d",$seenElt[$i][2],$seenElt[$i][3]));

$w->insert(sprintf("%d.%d",$seenElt[$i][0],$seenElt[$i][1]),$replace);

my $lenght = length $replace;

$w->tag('add', 'search', sprintf("%d.%d", $seenElt[$i][0],$seenElt[$i][1]), sprintf("%d.%d", $seenElt[$i][2],$seenElt[$i][3] + $lenght - $seenElt[$i][4]));

}

} # end text_replace

sub text_delete {

# The utility procedure below searches and destroy for all instances of a given string in a text widget and applies a given tag

# to each instance found.

# Arguments:

#

# w - The window in which to search. Must be a text widget.

# string - The string to search for.

# tag - Tag to apply to each instance of a matching string.

my($w, $string, $tag) = @_;

my @seenElt=();

if ($string eq "") {

&mkPrintErreur("ERREUR : Aucune sélection de chaîne de recherche donnée\n");

return;

}

my $resultat=$w->search(-regexp, "$string",'1.0','end');

if ($resultat eq "") {

&mkPrintMsgInfo("Aucune chaîne correspondante pour le motif de recherche donné\n");

return;

}

$w->tag('remove', $tag, '0.0', 'end');

(my $num_lines) = $w->index('end') =~ /(\d*)\.\d*/;

my $id = 0;

for($i = 1; $i <=$num_lines; $i++) {

my $line = $w->get("${i}.0", "${i}.1000");

next if not defined $line or $line !~ /($string)/;

my $l = length $1;

my $stringRegexp=$1;

my $offset = 0;

while (1) {

my $tmpoffset=0;

my $index = index $line, $stringRegexp, $tmpoffset;

last if $index == -1;

$offset += $index;

$w->tag('add', $tag, sprintf("%d.%d", $i, $offset), sprintf("%d.%d", $i, $offset+$l));

$seenElt[$id] =[$i, $offset, $i, $offset+$l];

$id++;

$offset += $l;

$line = substr $line, $index+$l;

if ($line=~/($string)/) { $stringRegexp=$1;

$l = length $1;}

} # whilend

} # forend

 

for ($i = $#seenElt; $i >= 0; $i--) {

$w->delete(sprintf("%d.%d",$seenElt[$i][0],$seenElt[$i][1]),sprintf("%d.%d",$seenElt[$i][2],$seenElt[$i][3]));

}

@seenElt=();

}

#----

sub remove_mark_search {

$texte->tagDelete('search','1.0','end');

}

#-----------------------------------------------

#--------- -III- DIFFERENTS MKPRINT :

sub mkPrintErreur {

my ($erreur) = @_;

$mkErreur->destroy if Exists($mkErreur);

$mkErreur = $mw->Toplevel();

my $w = $mkErreur;

$w->title('Erreur');

$w->iconname('Erreur');

my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);

my $w_t = $w->TextUndo(-setgrid => 'true', -width => '60', -height => '28',

-font => '-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*');

my $w_s = $w->Scrollbar(-command => ['yview', $w_t]);

$w_t->configure(-yscrollcommand => ['set', $w_s]);

$w_ok->pack(-side => 'top', -pady => 5, -padx => 10);

$w_s->pack(-side => 'right', -fill => 'y');

$w_t->pack(-expand => 'yes', -fill => 'both');

# Set up display styles

my(@bold, @normal, $tags);

if ($mkErreur->depth > 1) {

@bold = (-foreground => 'red');

@normal = (-foreground => undef);

} else {

@bold = (-foreground => 'white', -background => 'black');

@normal = (-foreground => undef, -background => undef);

}

$w_t->insert('0.0', "$erreur...");

$w_t->insert("end","............................\n");

$w_t->insert("end","\n\n");

}

#-----------------------------------

sub mkPrintMsgInfo {

my ($info) = @_;

$mkMsgInfoDisplay->destroy if Exists($mkMsgInfoDisplay);

$mkMsgInfoDisplay = $mw->Toplevel();

my $w = $mkMsgInfoDisplay;

$w->title('Info');

$w->iconname('Info');

my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);

my $w_t = $w->TextUndo(-setgrid => 'true', -width => '60', -height => '28',

-font => '-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*');

my $w_s = $w->Scrollbar(-command => ['yview', $w_t]);

$w_t->configure(-yscrollcommand => ['set', $w_s]);

$w_ok->pack(-side => 'top', -pady => 5, -padx => 10);

$w_s->pack(-side => 'right', -fill => 'y');

$w_t->pack(-expand => 'yes', -fill => 'both');

# Set up display styles

my(@bold, @normal, $tags);

if ($mkMsgInfoDisplay->depth > 1) {

@bold = (-foreground => 'red');

@normal = (-foreground => undef);

} else {

@bold = (-foreground => 'white', -background => 'black');

@normal = (-foreground => undef, -background => undef);

}

$w_t->insert('0.0', "$info...");

$w_t->insert("end","............................\n");

$w_t->insert("end","\n\n");

}

#--

sub text_toggle {

# The procedure below is invoked repeatedly to invoke two commands at periodic intervals. It normally reschedules itself

# after each execution but if an error occurs (e.g. because the window was deleted) then it doesn't reschedule itself.

# Arguments:

#

# w - Text widget reference.

# cmd1 - Reference to a list of tag options.

# sleep1 - Ms to sleep after executing cmd1 before executing cmd2.

# cmd2 - Reference to a list of tag options.

# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again.

my($w, $cmd1, $sleep1, $cmd2, $sleep2) = @_;

$w->tag(@{$cmd1});

$w->after($sleep1, [sub {text_toggle(@_)}, $w, $cmd2, $sleep2, $cmd1, $sleep1]);

} # end text_toggle

#---

sub ConfirmDiscard2 {

my ($w)=@_;

if ($w->numberChanges)

{

my $ans = $w->messageBox(-icon => 'warning',

-type => 'YesNoCancel',

-message =>

"The text has been modified without being saved.

Save edits?");

return 0 if ($ans=~/Cancel/i);

return 1 if (($ans!~/Yes/i) && ($ans!~/Cancel/i));

return 0 if (($ans=~/Yes/i) && (!$w->FileSaveAsPopup));

}

else {

return 1;

}

}

#---