[couverture de Linux Magazine 62]

Perl/Tk ou pTk, une Fenêtre sur Perl

Article publié dans Linux Magazine 62, juin 2004.

Copyright © 2004 - Charles Minc.

[+ del.icio.us] [+ Developers Zone] [+ Bookmarks.fr] [Digg this] [+ My Yahoo!]

Chapeau de l'article

La relation Homme-Machine a été améliorée par deux moyens relativement récents : le graphisme et la souris. Perl/Tk, alliance du toolkit Tk et du langage Perl, assure une gestion aisée et efficace de cette communication par l'étendue de sa palette, constituée de ses très nombreux « widgets ».

L'utilisation directe de ces widgets, grâce à leurs options prédéfinies, ouvre la possibilité d'un « prototypage rapide », en laissant toute latitude pour des retouches ultérieures.

Introduction

Désormais, il convient d'indiquer que l'ouvrage Mastering Perl/Tk[1] apparaît à ce jour comme la bible (766 pages) sur ce sujet. Il succède à Learning Perl/Tk[2] dont la version française s'intitule Introduction à Perl/Tk. N'oublions pas non plus dans cette base bibliographique le Précis et Concis de Perl/Tk[3].

Présenter tous les modules du package de Tk (il en existe au moins une centaine) avec toutes les options possibles, n'est donc pas notre but. Notre objectif est de décrire les fonctionnalités qui nous paraissent avoir une utilisation majeure et signaler quelques petits pièges.

Pour alléger le texte, nous utiliserons Tk lorsque nous faisons référence à Perl/Tk.

Tk trouve son origine dans Tcl/Tk. La dernière version Tk-804.027 correspond l'adaptation de Tcl/Tk8.4.5 pour Perl. Elle supporte Unicode. Un des gros avantages du couple Perl-Perl/Tk sur Tcl/Tk, tient dans une portabilité supérieure, puisqu'elle s'appuie sur celle de Perl.

Pour être précis et parfaitement honnête, le rendu graphique de Tk dépend tout de même du système, mais n'entache pas la fonctionnalité. Il est également important de souligner que Perl/Tk est un logiciel libre et gratuit.

Enfin,les versions de Perl depuis 5.8.0 se marient avec la version stable Tk804.027.

Widget ?

Le terme widget, il proviendrait de la contraction anglaise de window gadget selon le « Grand dictionnaire terminologique de l'office québécois de la langue française ». Cela se traduit tout simplement par « gadget logiciel » et donc naturellement, ceci n'est jamais utilisé.

Les widgets de Tk, au sens de Perl, sont des méthodes. En revanche, en Perl/Tk, « widget » désigne la classe et « widgets » les classes prédéfinies (Button, Label, Frame, etc.). Les widgets, de par leur construction, ont des options communes et d'autres, bien sûr, qui leur sont propres.

Installation

De prime abord, nous ne pensions pas parler de l'installation, mais toutes les versions perl n'incluent pas forcément Tk. Pour la famille Mac, il semble que les renseignements nécessaires se trouvent sur la page ci-dessous :

http://www.lehigh.edu/~sol0/Macintosh/X/ptk/

Pour Unix, il n'y a en général pas de difficultés à se procurer Tk. Par contre, pour Linux nous avons rencontré des problèmes à l'exécution de certaines versions.

Rappelons que la méthode conseillée par la documentation pour charger Tk consiste à taper la commande :

    $ perl -MCPAN -e'install Tk'

Si cela ne fonctionne pas, alors le plus simple est d'aller sur le site d'Active State pour télécharger une version complète compilée ou non, de Perl avec Tk. (http://www.activestate.com/Products/Download/Download.plex?id=ActivePerl).

Si vous ajoutez juste Tk, il convient tout de même de vous assurer que votre perl fonctionne avec des liens dynamiques (dynamic linking) en testant la variable dlsrc avec la commande : perl -V:dlsrc. Le résultat doit apparaître sous la forme 'dl_xxxx.xs'xxx est le nom du système ou 'none'.

Structure de Tk

On peut schématiser une application de la façon suivante :

    use strict;
    use Tk;
    my $ref_0 = MainWindow->new(%option_0);
    my $ref_M = $ref_0->UnCertainWidget(%option_M);
    my $ref_N = $ref_M->UnAutreWidget(%option_N) -> pack;
    # ... le reste du code ...
    my $ref_X = $ref_P->AnOtherWidget(%option_X) -> pack;
    # ou $ref_X->AnOtherWidget(%option_X) -> pack; si $ref_X
    # n'est pas utilisée

    MainLoop;

On remarque déjà que le style de programmation est du type objet (voir LM 47 ou Dossiers N°2, La programmation objet en Perl).

La première instruction crée une fenêtre principale. La référence $ref_0 de cet élément permet d'y inclure d'autres objets . Chaque élément se construit de proche en proche, avec l'élément précédent (ou supérieur). L'utilisation des références permet de déterminer l'objet sur lequel s'appuie la construction.

Cependant dans certains cas, la formulation suivante en cascade permet de s'en dispenser :

    $ref->widget_M->...->widget_N(%option);

ou

    MainWindow->new->widget_M->...->widget_N(%option);

par exemple :

    MainWindow->new->Label(-text => "Salut")->pack;
    MainLoop;

qui donne la figure suivante :

[Figure fig1]

Parmi les mots-clés, on remarque le terme pack, qui est le nom de la méthode d'un des gestionnaires de géométrie : le packer. Actuellement, ceux-ci sont au nombre de quatre : form, grid, place, pack.

Si le packer semble le plus utilisé, form est le plus récent et il inclut de nombreuses fonctionnalités au nombre desquels se trouvent toutes celles du packer.

Soulignons qu'en principe le widget n'est pas affiché tant que le packer n'est pas appelé. Quant à l'aspect du résultat final, il dépend de l'ordre dans lequel les éléments sont « packés ».

La fonction MainLoop() correspond à l'appel du gestionnaire d'évènements. Par conséquent, cette ligne apparaît, généralement, une fois dans tout programme, puisque son absence empêche également toute visualisation. De plus, il marque la fin d'une zone de programme Tk et c'est donc nécessairement la dernière ligne de cette zone.

Quelques Widgets simples

Nous classons dans les widgets élémentaires :

Note : La liste des widgets standards est la suivante : Button, Radiobutton, Checkbutton, Listbox, Scrollbar, Entry, Text, Canvas, Frame, Toplevel, Scale, Menu, Menubutton.

Avec le programme ci-dessous nous obtenons le résultat présenté sur les fig2a et fig2b.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : fig2.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.1 2003-12-28
    ####-----------------------------------

    use strict;
    use Tk;
    #  Création du TopLevel
    my $top = MainWindow->new(-title => 'fig2');

    #  Création du widget Button
    $top -> Button(-background => 'yellow', -text => 'bouton') -> pack;

    #  Création d'un cadre (Widget Frame)
    my $frame1 = $top->Frame()->pack(-fill => 'x');

    #  Création de deux boutons Radio dans le Cadre
    #  Création de la variable commune aux Boutons Radio
    my $var_rb;
    #  Création du premier bouton Radio
    my $rbutton1 = $frame1 -> Radiobutton(
                           -text => 'bouton',
                           -value => 'bouton',
                           -variable => \$var_rb
        ) -> pack(-side => 'left');
    # positionnement de l'état du bouton rbutton1 en mode sélectionné

    $rbutton1->select;
    #  Création du second bouton Radio
    my $rbutton2 = $frame1 -> Radiobutton(
                           -state => 'active',
                           -text => 'radio',
                           -value => 'radio',
                           -variable => \$var_rb
        ) -> pack(-side => 'left');
    # positionnement de l'état du bouton rbutton1 en mode désélectionné

    $rbutton2->deselect;

    # Création d'un bouton à cocher
    $top -> Checkbutton(
                    -background => 'green',
                    -text => 'Checkbutton'
            ) -> pack;

    # Création d'une liste
    my $lb = $top -> Listbox() -> pack;
    $lb->insert('end', "itemFin");
    $lb->insert(2, "item1", "item2");
    $lb->insert(0, "itemA", "itemB");
    $lb->insert(4, "item3", "item4");

    # Création d'une barre de défilement
    $top -> Scrollbar() -> pack;

    # Création de deux lignes de "dialogue"
    $top -> Entry(-text => 'Login') -> pack;
    $top -> Entry(-text => 'passwd', -show => '*') -> pack;

    # Sous-Programme de création d'un bouton image


    icon_mini();

    # et enfin l'incontournable :

    MainLoop;

    # Ce sous-programme est la reproduction d'un
    # exemple sur le Web dû à Peter Prymmer
    # Cornell University, Ithaca NY

    sub icon_mini {

        # $Tk::library est le chemin ou se trouve ../lib/Tk/demos
        my $window = $top;

        # les bitmaps flagup et flagdown sont en standard
        # dans la distribution Tk

        $window->Bitmap('flagup',
              -file => "$Tk::library/demos/images/flagup",
              -maskfile => "$Tk::library/demos/images/flagup",
        );
        $window->Bitmap('flagdown',
              -file => "$Tk::library/demos/images/flagdown",
              -maskfile => "$Tk::library/demos/images/flagdown",
        );

        my $w_frame_b1 = $window->Checkbutton(
              -image            => 'flagdown',
              -selectimage      => 'flagup',
              -indicatoron      => 0,
        );
        $w_frame_b1->pack();

    } # end icon

[Figure fig2a] [Figure fig2b]

Ces figures ont pour but de montrer les réactions graphiques pour les widgets énumérés.

On remarque ainsi que :

Cet exemple amène les questions suivantes :

Le Packer

Le gestionnaire de géométrie est certainement un élément essentiel qui simplifie considérablement la vie du programmeur. En effet, il prend en charge les widgets composant de l'application, adapte automatiquement les dimensions et gère le tout de façon dynamique.

Le principe de fonctionnement est simple, vous partez d'un côté (option -side=>[ 'left' | 'right' | 'top' | 'bottom' ]) qui, par défaut a la valeur top. Les objets sont rangés selon l'ordre de leur déclaration, en fonction de l'espace disponible, en réservant toute la surface perpendiculaire à la direction choisie d'empilage. Si, de plus, l'option -fill est précisée alors le widget va remplir l'espace selon la valeur choisie : x|y|none|both.

L'option -anchor réglera l'ancrage du widget selon la valeur suivante n|s|e|w|center (pour north, south, east, west ). Les combinaisons sw, se, ne, nw sont autorisées.

Ainsi, pour bien mettre en relief la différence entre les options '-side' et '-anchor', la première correspond au sens d'empilage tandis que l'autre se réfère au placement du widget dans la surface réservée à cet effet. Cette zone est différente de celle occupée par le widget, mais peut offrir un recouvrement identique avec les options '-expand' et '-fill'.

Enfin, l'option -expand=>y permet de répartir l'espace restant entre tous les widgets qui partage une donnée de même « nature » (bottom et top) d'une part et (left, right) d'autre part. En effet, par défaut, c'est le dernier widget qui récupère toute la surface disponible pour son propre compte.

On comprendra facilement que cette simplicité rend parfois impossible le rangement de widgets dans un ordre donné. C'est là où le widget Frame vient à notre secours, en introduisant des cadres intermédiaires pour y placer les éléments. Par exemple, ranger trois « boutons à gauche », l'un en dessous de l'autre, se résout simplement en utilisant un « frame » (cadre en français) avec l'option -side=>'left' et les boutons avec l'option -side=>'top' ou 'bottom'.

Les Rétroactions (Callbacks)

Les rétroactions sont des commandes associées aux widgets. Les widgets qui les acceptent contiennent une des options suivantes : -command, -validatecommand, -browsecommand.

La syntaxe est simple :

  Format sans argument          Format avec Arguments
  -command => sub {....}        -command => [sub {....},arg1, arg2,...]
  -command => \&routine         -command => [\&routine, arg1, arg2,...]
  -command => 'methode'         -command => ['methode', arg1, arg2,...]

Par contre, c'est une bévue d'écrire :

-command => \&routine(paramètres).

Cela entraîne l'exécution immédiate de la routine et vous obtenez la référence de la valeur de retour, ce qui ne donne probablement pas le résultat escompté.

Les Associations (Binding)

Binding est quelquefois traduit par « liaison », mais le terme « association » paraît plus précis et liaison est mieux traduit par link. Une solution consisterait peut-être, à utiliser le terme de « ligature » moins galvaudé. Cette fonctionnalité, en apparence simple, offre de multiples ressources.

Formellement, cela s'écrit :

    $widget->bind(tag, descripteur => callback)

ou

    $widget->bind(descripteur => callback)

bind() est la méthode qui permet d'associer un événement X, défini par le champ descripteur. L'association se trouve faite soit avec :

Si la fonction callback est la chaîne vide, alors l'association est détruite.

Par contre, lorsque l'on n'a spécifié que le descripteur, alors bind() renvoie le callback correspondant. Enfin, quand le descripteur ou le callback ne sont pas présents, c'est la liste des éléments associés qui est retournée, filtrée par le tag ou $widget (si le tag est aussi absent).

Maintenant nous allons examiner de plus près le descripteur. Il se compose de trois champs : le modificateur, le type, la touche (en anglais : detail).

On peut résumer la syntaxe par : descripteur=<modificateur-modificateur-...-modificateur-type-touche>. Les signes <>- font partie de la syntaxe.

La table ci-dessous résume les combinaisons possibles entre les champs :

    Modificateur                 Type                     Touche

    Control                      KeyPress                 Keysym
    Meta                         KeyRelease               Enter
    Alt                          ButtonPress ou Button    Right
    Shift                        ButtonRelease            Pickup
    Button 1 (ou B1)             Enter                    Delete
    Button 2 (ou B2)             Leave                    Backspace
    Double                       Motion                   Escape
    Any                                                   Help
    Triple                                                F1 .. F12
    Mod1, ..., Mod5 (ou M1, ..., M5)                          a-zA-Z0-9 etc.

Par exemple, on pourra écrire :

     $mainwindow->bind('Tk::Button','<Control-Alt-a>',\&some_callback) ;

Une association supplémentaire s'ajoutera à tous les boutons présents dans le widget principal $mainwindow. En effet, par défaut, les widgets Button possède déjà un certain nombre d'associations. Quand les touches Control, Alt et a seront pressées alors some_callback sera exécuté.

Pour illustrer cette partie, nous vous proposons le petit programme suivant qui affiche les coordonnées relatives et absolues du curseur. Pour ce faire, nous avons eu recours au widget Balloon qui permet de réaliser des infobulles.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : bind.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.0 2003-12-10
    ####-----------------------------------

    use Tk;
    use Tk::Balloon;

    my $window = MainWindow->new;
    my $frame = $window -> Frame(-height => 50, -width => 150);
    $frame -> pack;
    my $ball = $window->Balloon(-statusbar => $window);
    $ball->attach($frame, -balloonposition => 'mouse', -msg => \$msg );
    $window->bind('<Motion>', [\&affich, Ev('x'), Ev('y'),  Ev('X'), Ev('Y')]);

    sub affich {
        my ($z, $x, $y, $X, $Y) = @_;
        $msg = $x . ":" .  $y . " at " . $X . ":" .  $Y;
    }
    MainLoop;

Lorsque la rétroaction est déclenchée, la construction Ev(code) est remplacée par la valeur du code du champ d'évènement X11. Ces codes sont nombreux, citons x et y pour les coordonnées relatives dans le widget, X et Y pour les coordonnées absolues dans l'écran, t pour avoir la date de l'évènement, k pour le code touche (keycode), K pour le nom de la touche (keysym) etc...

Citons pour être exhaustif, les « événements virtuels » au principe de construction similaire à celui que nous venons de décrire. Ils sont gérés par les quatre fonctions eventAdd, eventDelete, eventGenerate, eventInfo. eventAdd est utilisée pour associer le descripteur à l'événement virtuel.

Les << et >> font partie de la syntaxe et virtual_event représente une chaîne de caractères

    $widget->bind(tag,'<<virtual_event>>', callback);
    $widget->eventAdd('<<virtual_event>>', descripteur, ..., descripteur);

Par opposition, on appelle quelquefois les associations des événements physiques. Ces derniers, en cas de descripteur identique, sont prioritaires sur les événement virtuels. Ces derniers peuvent être associés (méthode bind), sans avoir été définis au préalable. Les événements virtuels offrent la possibilités de créer des associations dynamiques, c'est-à-dire qu'elles sont prises en compte immédiatement dans le déroulement du programme.

L'exemple, ci dessous, ouvre juste une fenêtre. Le fait de cliquer, de frapper contol-a, control-q, ou control-A provoque l'impression de messages. En particulier, on peut comparer le formalisme entre les deux types d'associations. De plus, la modification de l'évènement virtuel <<virtual_click2>> va provoquer l'alternance de réaction à control-a et control-A.

	#!/usr/local/bin/perl -w
	####-----------------------------------
	### File	: virtuel.pl
	### Author	: C.Minc
	### Purpose	:
	### Version	: 1.1 2004/5/3
	####-----------------------------------

	use Tk;
	use strict;
	my $mw = MainWindow->new;

	# association physique
	$mw->bind('<ButtonRelease-1>' => \&callback);

	# association virtuelle identique formellement à la précédente
	$mw->bind('<<virtual_click1>>'=>\&callback) ;

	# définition après coup de l'association virtuelle
	# avec changement de boutons pour pouvoir distinguer
	# les actions à l'exécution
	$mw->eventAdd('<<virtual_click1>>'=>'<ButtonRelease-2>','<ButtonRelease-3>') ;

	# illustration de l'effet dynamique des associations virtuelles

	$mw->eventAdd('<<virtual_click2>>'=>'<Control-q>','<Control-a>') ;
	$mw->bind('<<virtual_click2>>'=>[\&virtual,Ev('K')]) ;

	MainLoop;

	sub virtual {

 	 my ($objet,$touche)=@_ ;

  	if ( $touche eq 'A' ) {
    	$objet->eventDelete('<<virtual_click2>>') ;
    	$objet->eventAdd('<<virtual_click2>>'=>'<Control-a>','<Control-q>') ;
  	} elsif ($touche eq 'a') {
    	$objet->eventDelete('<<virtual_click2>>') ;
    	$objet->eventAdd('<<virtual_click2>>'=>'<Control-A>','<Control-q>') ;
  	}

  	print "virtual event  touche:$touche \n";
	}

	sub callback {
 	 print "callback args  = @_\n";
	}

Configuration

Nous avons dit qu'un programme avec Tk présentait l'avantage de pouvoir se modifier facilement à partir d'un premier jet et de s'affiner au fur et à mesure des besoins.

Pour ce faire la manière la plus répandue consiste à utiliser la méthode configure(). Dans l'exemple ci-dessous, nous présentons trois façons d'exprimer la même chose avec des syntaxes différentes (première, deuxième et troisième forme). On pourra comparer avec l'exemple des fig2a-fig2b. Cette manière de faire correspond à une configuration individuelle de chaque widget, même si les paramètres communs peuvent être facilement répétés en réutilisant le hash %option.

Tk::CmdLine sert quant à lui pour définir un style sur l'ensemble de l'application. Placé obligatoirement avant la création du MainWindow, il peut permettre de charger un fichier de configuration (pour de plus amples précisions sur ce point, vous pouvez vous référer à la documentation). Dans le cas présent, nous avons explicité les options de SetResources qui définissent dans notre exemple, la configuration par défaut. Seul le bouton ($bb) affiché '< bout on >' correspond à ce profil dans les figures Cfg local-Cfg Global. Les autres configurations viennent alors, en surcharge de ce profil initial en partie ou en totalité, suivant les cas.

Enfin, le module Tk::Preferences permet aussi une modification globale des widgets en applicant la méthode SetPrefs() au parent, tous les enfants héritant de la configuration définie par le hash %preferences.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : cfg.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.0 2003-12-10
    ####-----------------------------------

    use strict;
    use Tk;
    require Tk::Preferences;

    # Configuration générale (doit se trouver avant la création de MainWindow)
    Tk::CmdLine::SetResources(  # set multiple resources
        [ '*Button*background: green',
          '*Button*width: 20',
          '*Button*height: 1 ',
          '*Button*text: < bout on >' 
        ],
        'widgetDefault'
    );


    my $top = MainWindow->new(-title => 'Cfg local');

    # première forme de configuration locale

    my %option1 = (-background, 'yellow', -text, 'bouton1');
    $top -> Button(%option1) -> pack;

    # seconde forme de configuration locale

    my %option2 = qw/-background yellow -text bouton2/;
    $top -> Button(%option2) -> pack;

    # troisième forme de configuration locale

    my $b = $top -> Button()-> pack;
    my %option3 = qw/-bg yellow -fg red -text bouton3/;
    $b->configure(%option3);

    # quatrième forme de configuration globale sur les
    # enfants de $top1

    my %preferences = (
            'Toplevel' => {
                -width => '10c',
                -height => '20c',
                -background => 'blue'
            },
            'Button' => {'bg' => 'red'}
    );

    my $top1 = $top->Toplevel (-title => "Cfg Global");

    $top1->Button(-text => 'bouton4')->pack;
    $top1->Button(-text => 'bouton5')->pack;

    # application de la configuration (placée après les créations)

    $top1->SetPrefs(-prefs => \%preferences);

    # bouton configuré de manière globale par CmdLine

    my $bb = $top1 -> Button()-> pack;

    MainLoop;

[Figure cfglocal] [Figure cfgglobal]

MainLoop

Cette méthode assure la gestion des évènements au fur et à mesure qu'ils apparaissent. Mais parfois, il faut attendre que se produise une action à un endroit précis du programme.

Trois commandes sont conçues pour cela :

La première de ces trois commandes est certainement la plus intéressante, puisque très souvent utilisée dans les processus de communication. L'exemple le plus banal est représenté par la saisie d'un texte dans une boîte de dialogue. La seconde permet d'attendre que les fenêtres soient devenues visible à l'écran. La troisième provoquera une attente jusqu'à la disparition du $widget.

A l'inverse, dans d'autres cas il faut forcer le rafraîchissement des informations, ceci est obtenu par la commande :

L'exemple suivant est constitué d'une boucle d'attente, dans laquelle la variable $status_bar, gérant la barre de progression, est mise à jour. L'affichage du widget ProgressBar est lui mis en concordance avec la variable par l'instruction $mw->update. Sans elle, on ne percevrait pas les états intermédiaires,mais seulement celui du début et de la fin.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : update.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.0 2004-04-12
    ####-----------------------------------
    use strict ;
    use Tk ;
    use Tk::ProgressBar;

    my $status_var =0;
    my $mw = MainWindow->new;

    $mw->ProgressBar(
                 -borderwidth => 2,
                 -relief => 'sunken',
                 -width => 20,
                 -padx => 2,
                 -pady => 2,
                 -variable => \$status_var,
                 -colors => [ 0 => 'green',
                             10 => 'yellow',
                             20 => 'blue',
                             30 => 'green',
                             40 => 'yellow',
                             50 => 'blue',
                             60 => 'green',
                             70 => 'yellow' ,
                             80 => 'blue',
                             90 => 'red' ],
                 -resolution => 0,
                 -blocks => 50,
                 -anchor => 'w',
                 -from =>'0',
                 -to => '100'
                )->pack(
                        -padx => 10,
                        -pady => 10,
                        -fill => 'both',
                        -expand => 1
                       );

    # La boucle dans laquelle la variable de ProgressBar change

    for (my $lostime = 0 ; $lostime < 101 ; $lostime += 5) {
        sleep 5 ;
        $status_var=$lostime ;
        print "comptage en cours: $lostime \n" ;

        # l'instruction suivante permet la prise en compte
        # des changements de valeurs de $status_var dans Perl/Tk,
        # ici  le widget Progressbar

        $mw->update;
    }

    sleep 5;
    print "Fin de l'exemple update \n";
    $mw->destroy;
    MainLoop;

La figure ci-dessous, montre le résultat pour une valeur de boucle à 90.

[Figure ProgressBar]

Cette situation est typique d'une lecture de fichier, d'un formatage, de l'établissement d'une communication, etc.

Widgets Scrollbar et Scrolled/Pane

Le widget Scrollbar n'est pas des plus faciles à utiliser. Heureusement les widgets Scrolled et Pane sont là pour vous simplifier la vie.

Mais avant examinons le programme suivant :

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : skolbar.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.2 2004-01-17
    ####-----------------------------------

    use strict;
    use Tk;

    my @array;
    my @list;

    my $mw = MainWindow->new(-title => 'Scrollbar/Skolbar');

    my $lst = $mw->Listbox();

    # liaison entre les widgets
    my $scroll = $mw->Scrollbar(-command => ['yview', $lst]);
    $lst->configure(-yscrollcommand => ['set', $scroll]);

    # disposition des widgets
    $lst->pack(-side => 'left', -fill => 'both', -expand => 1);
    $scroll->pack(-side => 'right', -fill => 'y');

    @list = (
        "ADELSCOTT",
        "DESPERADOS",
        "KARLSBRAU",
        "Hoegarden Blanche",
        "Kronembourg",
        "CARLSBERG",
        "BEAMICH STOUT",
        "BEAMICH RED",
        "Abbaye de Leffe",
        "MAREDSOUS",
        "GRIMBERGEN",
        "FOSTER",
        "PECHERESSE",
        "KRIEK foudroyante"
    );

    # Insertion de la liste:

    # première solution
    $lst->insert('end', @list);

    # deuxième solution
    tie @array, "Tk::Listbox", $lst;
    # chargement de la liste
    push(@array, @list);
    # modification de la liste
    @array = sort @array;

    MainLoop;

On constate qu'il faut lier d'une part la barre de défilement ($scroll) à la listbox ($lst) par la rétroaction ['yview', $lst] et réciproquement, par la commande -yscrollcommand.

Mais cela ne suffit pas, il faut ajouter les deux instructions incluant le packer où toutes les options sont nécessaires pour obtenir le résultat escompté et fonctionnel !

Enfin, nous avons indiqué deux modes de chargement de la liste. Le second facilite grandement la manipulation puisque @array permet l'accès direct aux données affichées, à l'inverse du premier. Ceci est illustré par un tri (voir figures Scrollbar/Skolbar).

[Figure scrollbar] [Figure scrollbar1] [Figure scrollbar2]

On notera que la barre de défilement est « active » suivant le dimensionnement de la fenêtre et on vérifiera que l'on ne peut sélectionner qu'un seul élément à la fois dans la liste, avec les options choisies par défaut.

Maintenant nous allons essayer de faire quelque chose de plus compliqué dans le paragraphe suivant.

Le Widget Scrolled

Le widget Scrolled a pour synopsis :

    $un_widget = $parent->Scrolled(
                            Type_du_widget,
                            -scrollbars => 'n|e|w|s|on|oe|ow|os');

$un_widget désigne une référence et Type_du_widget un certain type de widget qui accepte les barres de défilement (le widget Button par exemple, ne fait pas évidemment partie du lot mais Scrolled n'émettra pas d'erreur). Les données de -scrollbars peuvent être une combinaison des éléments de bases. Le préfixe 'o' permet d'afficher les barres que lorsque c'est nécessaire et non en permanence.

Maintenant réfléchissons au problème suivant : la réalisation d'un échiquier de boutons avec deux barres de défilement. Il faut pour cela utiliser 8 cadres dans lesquels nous allons ranger huit boutons. On peut choisir de packer les cadres avec -side => 'top' et les boutons avec -side => 'left'. Jusque-là, pour les barres de défilement dans le sens horizontal, une solution consisterait à attacher la barre de défilement à l'un des cadres. Ensuite il faudra cerner la partie de la zone affichée et transmettre cette information aux autres cadres pour qu'ils se translatent... Et pour le sens vertical ? Bon, eh bien, Si vous avez des insomnies, vous pouvez continuer ! Nous, dans ce cas, nous utilisons le widget Pane avec le widget Scrolled. Cela donne le programme ci-dessous, avec le résultat représenté sur la figure chessbar.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : chessbar.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.1 2003-12-15
    ####-----------------------------------

    use strict;
    use English;
    use Tk;
    # use Tk::Scrolled;

    my @frame;
    my @case;

    my ($col, $row) = (7, 7);
    my $chessbd = MainWindow->new();
    $chessbd->maxsize(qw(700 700));
    $chessbd->minsize(qw(150 150));

    # La ligne qui simplifie tout !!
    my $wchessbd = $chessbd->Scrolled('Pane',
            -height => 1,
            -width => 1,
            -scrollbars => 'ne'
    );

    $wchessbd->pack(-expand => 1, -fill => 'both' );

    # génération des cases :
    # 8 cadres contenant chacun 8 boutons
    # alternativement vert ou jaune
    foreach my $r (0 .. $row) {
        $frame[$r] = $wchessbd->Frame()->pack;
        foreach (0 .. $col) {
            $case[$r][$_] = $frame[$r]->Button(-text => "R.$r.C.$_");
            $case[$r][$_]->configure(-width => 6, -heigh => 2);
            ($r+$_)%2 ? $case[$r][$_]->configure(-bg => 'yellow') 
                      : $case[$r][$_]->configure(-bg => 'green');
            $case[$r][$_]->pack(-side => 'left');
        }
    }

    MainLoop;

[Figure chessbar]

Widgets Menu, Menubutton

Un problème récurrent est la création des menus. En général, on y trouve des boutons radios, des boutons à cliquer, des menus déroulants, en cascade ou des popups, des barres de menus.

Les widgets Menu et Menubutton sont complémentaires. Menubutton permet de créer le bouton auquel sera associé un menu et les sous-menus. Donc, pour créer une barre de menus, il suffit de générer un cadre qui contiendra les boutons de menu nécessaires.

Les trois exemples ci-dessous vont nous servir à analyser différentes approches. Afin de montrer le degré de souplesse existant, nous avons placé toutes les données dans le package suivant :

    ####-----------------------------------
    ### File    : taverne.pm
    ### Author  : C.Minc
    ### Purpose : Données communes aux prg tavernexx.pl
    ### Version : 1.0 2003-12-10
    ####-----------------------------------

    package taverne;
    require Exporter;
    use strict;

    # déclaration des variables externes
    use vars qw(
            @ISA
            @EXPORT
            @EXPORT_OK
            @menu
            %sous_menu
            %var
            &send_command
    );
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(
            @menu 
            %sous_menu
            %var
            &send_command
            @Soupes 
            @Pates 
            @Plat_Garnis 
            @Hamburgers
    );

    # données du menu principal
    @menu = ("Soupes", "Pates", "Plats Garnis", "Hamburgers");

    # données des sous-menus
    my @Soupes = ("soupe de légumes", "gratinée à l'oignon"); 
    my @Pates = ("Pâtes au saumon frais, crème à l'Aneth", "Bolognèse", "Carbonara");
    my @Plat_Garnis = (
            "Poulet Rôti", "Escalope milanaise Spaghetti",
            "Magret de Canard Rôti dans sa peau au Miel",
            "Pavé de Saumon grillé"
    );
    my @Hamburgers = ("Hamburger pommes frites", "Cheeseburger", "Bacon cheeseburger");

    # Définition des références aux sous-menus
    %sous_menu = (
            Soupes         => \@Soupes,
            Pates          => \@Pates,
            "Plats Garnis" => \@Plat_Garnis,
            Hamburgers     => \@Hamburgers
    );

    sub send_command {

        use Mail::Sendmail qw(%mailcfg sendmail);

        $mailcfg{smtp} = [qw(smtp.wanadoo.fr localhost)];
        my ($customer, $taverne) = @_;
        my $monchoix = "\nVeuillez trouver ci-dessous mon choix :\n";

        foreach (keys %var) { 
            $monchoix .= "\t\t" . $_ . "\n"  if( defined($var{$_}) );
        }

        my %mail = (  To      =>  $taverne,
                      From    =>  $customer,
                      Message =>  $monchoix,
                      Subject =>  'commande'
        );

        sendmail(%mail) or die $Mail::Sendmail::error;
        print "OK. Log says:\n", $Mail::Sendmail::log;
        print "$monchoix";

    }

    1;

Nous avons donc quatre tableaux et un hash. Le tableau @menu contient les noms des sous-menus, chaque sous-menu contient des données qui pourront être utilisées de manières diverses. Le hash %sous_menu contient les références des tableaux des sous-menus (Soupes, Pates, Plat_Garnis, Hamburgers).

Le premier exemple ci-dessous part de la création d'un « bouton menu » (Menubutton). Après, l'opération se fait en quatre temps : création des références aux sous-menus (méthode menu->Menu()), mise en cascade des sous-menus (méthode add()), puis des données du bouton menu (méthode cascade()) et enfin, liaison entre les données et les références des sous-menus (méthode entryconfigure()) comme une sorte de « feedback ».

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : taverne1b.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.0 2003-12-10
    ####-----------------------------------
    use strict;
    use Tk;
    use taverne qw(@menu %sous_menu);

    my %sous_menuref;

    my $mw = MainWindow->new(-title => 'taverne1');
    my $fr = $mw->Frame-> pack;

    # création du bouton menu
    my $b_menu = $mw->Menubutton(-text => '   Menu de la Taverne   ',
                                 -relief => 'raised',
                                 -underline => 3,
                                )->pack(-fill => 'x');

    foreach my $m (@menu) {
        # création des sous-menus en cascade
        $sous_menuref{$m} = $b_menu->menu->Menu;
        # entrées des données des sous-menus
        map( $sous_menuref{$m}->add('command', -label => $_), @{$sous_menu{$m}} );
        # entrées des données du menu
        $b_menu->cascade(-label => $m);
        # associations entre le nom ($m) du sous-menu et sa référence $sous_menuref
        $b_menu->entryconfigure($m, -menu => $sous_menuref{$m});
    }

    MainLoop;

[Figure taverne1] [Figure taverne2]

La figure « taverne1 » illustre la structure en cascade obtenue à partir d'un bouton menu. Les sous-menus sont par défaut, détachables (option tearoff => 1, 0 pour le contraire).

On passe de la figure « taverne1 » à la figure « taverne2 » en changeant juste la ligne :

    map( $sous_menuref{$m}->add('command', -label => $_), @{$sous_menu{$m}} );

par celle-ci

    map( $sous_menuref{$m}->checkbutton(-label => $_), @{$sous_menu{$m}} );

Ce deuxième exemple ressemble beaucoup au premier, mais la différence principale réside dans la disposition en ligne de la racine des menus.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : taverne3b.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.0 2003-12-10
    ####-----------------------------------
    use strict;
    use Tk;
    use English;
    use taverne qw(@menu %sous_menu);

    my %b_menu;
    my %var;
    my $v;
    my %sous_menux;

    my $mw = MainWindow->new(-title => 'taverne3');
    my $fr = $mw->Frame-> pack;
    my $b = $mw->Button(
                -text => 'Quit',
                -command => sub{
                    foreach (keys (%var)) {
                        print "<$_>\n" if defined $var{$_};
                    } 
                    exit;
                }
    ) -> pack(-side => 'top', -expand => '0', -fill => 'x');

    map($b_menu{$_} = $mw->Menubutton(
                        -text => $_,
                        -relief => 'raised',
                        -underline => 0,
        ) -> pack(-anchor => 'n', -side => 'left', -fill => 'x', -expand => '1'), 
        @menu
    );

    foreach my $m (@menu) {
        $sous_menux{$m} = $b_menu{$m}->menu->Menu;
        map( $b_menu{$m}->checkbutton(-label => $_, -variable => \$var{$_}), 
             @{$sous_menu{$m}}
        );
    }

    MainLoop;

Et nous obtenons la figure « taverne3 ». Le procédé est le même que pour la figure « taverne1 » si ce n'est que nous avons en quelque sorte multiplié le nombre des Menubutton.

[Figure taverne3]

Le programme suivant, sans doute, encore très simpliste, affiche une barre de menu en utilisant cette fois, le widget Menu avec l'option menubar. Le bouton "Envoyer" permet à la fin, d'envoyer la sélection par email grâce au callback sendcommand. (Cela autoriserait, par exemple de passer une commande via un terminal WAP ou UMTS dans le futur, quand Perl sera disponible sur ces dispositifs.) Cet exemple montre particulièrement la puissance de Perl et de Perl/Tk pour réaliser une programmation ultra compacte.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : taverne4b.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.0 2003-12-10
    ####-----------------------------------
    use strict;
    use Tk;
    use taverne qw(@menu %sous_menu %var &send_command);

    my %sous_menuref;

    my $mw = MainWindow->new(-title => 'taverne4');
    $mw->geometry("300x6");
    my $top = $mw->toplevel;

    my $menubar = $top->Menu(-type => 'menubar');
    $top->configure(-menu => $menubar);

    foreach my $m (@menu) {

        # création des sous-menus en cascade
        $sous_menuref{$m} = $menubar->cascade(-label => $m);

        # entrées des données des sous-menus
        map( $sous_menuref{$m}->checkbutton(-label => $_, -variable => \$var{$_}), 
             @{$sous_menu{$m}}
        );
    }

    # un petit repentir : On rajoute le bouton 'Envoyer' dans le menu
    # avec un callback qui mail la commande From $customer To $taverne 

    # adresses humoristiques
    my $customer = 'table5.fauteuil2.taverne.republic@liberte.fr';
    my $taverne = 'lecuisinier.taverne.republic@liberte.fr';

    my $smref = $menubar->command(
                    -label => 'Envoyer',
                    -command => [\&send_command, $customer, $taverne]
    );

    MainLoop;

L'exécution du programme donne la figure « taverne4 ». La comparaison avec la figure « taverne2 » montre un résultat similaire et ce, comme nous l'avons déjà souligné, avec une programmation beaucoup plus limpide.

[Figure taverne4]

Nous espérons, par ces exemples, avoir pu vous montrer toute la souplesse des solutions, puisque toutes ces présentations ont été établies à partir des mêmes données.

Un Widget très utile : FileSelect

FileSelect est un widget composé de deux widgets LabEntry et de deux ScrListbox2.

Ce widget permet de sélectionner simplement un fichier. Le squelette est le suivant :

Comme le programme filesel.pl le confirme, ce widget nécessite vraiment qu'à peine trois lignes de code pour être lancé.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : filesel.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.1 17/1/2004
    ####-----------------------------------

    use strict ;
    use Tk::FileSelect;

    my $start_dir = ".";
    my $Fsref = MainWindow->new->FileSelect(-directory => $start_dir);
    my $file = $Fsref->Show;
    $Fsref->configure(
                    -command=>\&sous($file),
                    -width => 25
    );

    sub sous {
        my $file = $_[0] || '';
        print "myfile = $file";
    }

[Figure filesel]

Dans le programme, la partie configure() comporte l'option -command et pour donnée le sous-programme sous(). Il est exécuté dès qu'un fichier est validé dans le widget. Ici, on ne fait qu'imprimer le nom du fichier sélectionné, mais cela ouvre évidemment bien d'autres possibilités.

D'autre widgets utiles

MessageBox

Le programme ci-dessous illustre le fait qu'il suffit de peu de choses pour introduire de l'interactivité avec un utilisateur. Les six boîtes de dialogue qui suivent en fournissent la preuve et sont générées en quelques lignes.

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : dialog.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.2 1/17/2004
    ####-----------------------------------

    use strict;
    use Tk;
    use Tk::Dialog;

    # messageBox

    # Affiche 6 combinaisons différentes de messageBox
    # successivement en cliquant sur un bouton.
    # Le nom du bouton cliqué est retourné par la
    # méthode appelée ($reponse dans cet exemple).

    my @listtype = qw(AbortRetryIgnore OK OKCancel RetryCancel YesNo YesNoCancel);
    my @iconlist = qw(error info question error info question);

    my $mw = MainWindow->new;

    foreach (0 .. $#listtype) {

        my $reponse = $mw->messageBox(-icon => $iconlist[$_],
                -message => "ceci est un message du type : $listtype[$_]\n".
                            " avec une icone : $iconlist[$_]",
                -title => "messageBox $listtype[$_]",
                -type => $listtype[$_] 
                -default => 'OK'
        );
        print "$reponse \n"
    }

    MainLoop();

[Figure messageBox1] [Figure messageBox2] [Figure messageBox3] [Figure messageBox4] [Figure messageBox5] [Figure messageBox6]

Trucs et Astuces : De la sélection multiple

En général, il n'est pas possible de sélectionner plusieurs éléments à la fois avec les options standard de Tk. Cependant, en modifiant judicieusement l'option selectmode, cette opération devient réalisable. C'est ce qu'illustre le programme suivant:

    #!/usr/bin/perl -w
    ####-----------------------------------
    ### File    : multisel.pl
    ### Author  : C.Minc
    ### Purpose :
    ### Version : 1.1 1/17/2004
    ####-----------------------------------

    use strict;
    use Tk;
    use Tk::Listbox;

    my $mw = MainWindow->new(-title => 'MultiSel');

    # Pour pouvoir sélectionner plusieurs éléments dans une même liste
    # l'option selectmode extended doit être ajoutée car
    # par défaut, il ne peut y en avoir qu'un seul à la fois.
    my $lsb1 = $mw->Listbox(-selectmode => 'extended') -> pack(-side => 'left', -fill => 'y');

    # Pour pouvoir faire des sélections dans plusieurs listbox
    # les options selectmode et exportselection sont nécessaires.
    $lsb1->configure(-selectmode => 'multiple', -exportselection => 0);

    $lsb1->insert(0, 'a', 'b', 'c', 'd');
    $lsb1->insert('end', 'e', 'f');

    # Pour placer les boutons l'un au-dessus de l'autre, entre les listes
    # l'adjonction d'un cadre est nécessaire dans le placement.
    my $f = $mw->Frame()->pack(-side => 'left');

    my $lsb2 = $mw->Listbox(-selectmode => 'extended') -> pack(-side => 'left', -fill => 'y');

    # Association des tableaux aux ListBox
    tie my @array1, "Tk::Listbox", $lsb1;
    tie my @array2, "Tk::Listbox", $lsb2;

    # Création du bouton envoi de la liste gauche vers la liste droite
    # Remarquer l'utilisation du première forme du callback
    my $b = $f->Button(
                -text => '>>',
                -command => [ \&trans, \@array2, $lsb1, \@array1 ]
    ) -> pack(fill => 'x', -side => 'top', -anchor => 'center');

    # Création du bouton échange entre les listes
    # Remarquer une autre forme du callback avec subroutine anonyme
    my $b1 = $f->Button(
                    -text => '<->',
                    -command => sub {
                        trans(\@array2, $lsb1, \@array1);
                        trans(\@array1, $lsb2, \@array2)
                    }
    ) -> pack(fill => 'x', -side => 'top', -anchor => 'center');

    MainLoop();


    sub trans {
        # envoi les éléments sélectionnés de la listbox $lsb, de @ar2 à vers @ar1
        my $ar1 = shift;
        my $lsb = shift;
        my $ar2 = shift;
        my @sel = $lsb->curselection;
        my @remove = reverse sort @sel;
        push @{$ar1}, @{$ar2}[@sel];
        delete @{$ar2}[@remove];
    }

[Figure multisel1] Départ

[Figure multisel4] Transfert de a,c,e (bouton >>) après sélection multiple à gauche

[Figure multisel5] Visualisation de la sélection multiple et simultanée dans les deux Listbox

[Figure multisel6] Échange simultané des éléments sélectionnés dans les fenêtres par le bouton (<->) en creux

Conclusion

Nous terminerons en citant deux applications de Perl/Tk souvent méconnues :

tkpod assure la visualisation la documentation Perl en « langage » pod comme si vous aviez un navigateur HTML avec une présentation des plus élégantes. ptkdb est un débogueur avec un GUI, essayez-le vous serez, sans aucun doute, très agréablement surpris.

Perl/Tk comporte beaucoup d'exemples, ils sont tous très instructifs et on ne saurait trop vous conseiller de vous y reporter, il vous suffit pour cela de consulter les références ci-après.

Un grand absent ici, est le widget que l'on nomme canevas en français et canvas en anglais, mais vu son importance et ses possibilités, il est suffisant à lui tout seul pour faire l'objet d'un article et n'aurait pas mérité d'être traité de façon simpliste.

Malgré tout, nous espérons que vous aurez déjà trouvé suffisamment de grain à moudre pour satisfaire votre curiosité.

Auteurs

Catherine Trubert.

Charles Minc (membre de Paris.pm et de l'association "les Mongueurs de Perl").

Nous remercions chaudement l'ensemble des relecteurs du groupe articles des Mongueurs pour leurs contributions actives à cette introduction.

Références bibliographiques

Documentation

Références ouvrages

Références sites web

Divers

[IE7, par Dean Edwards] [Validation du HTML] [Validation du CSS]