Écriture d'un petit logiciel WYSIWYG en Perl


Principales sources d'information

Quelques widgets

  #! perl -w
  use Tk;

  my $w_top = new MainWindow;

  MainLoop;

Rajoutons un bouton. La commande pack demande à Perl de mettre le widget un peu où il veut. On peut lui donner des arguments pour contrôler un peu son comportement.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Essayons maintenant de mettre plusieurs boutons : on constate que Perl a tendance à les mettre en colonne.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;
  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;
  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Il est possible de demander à Perl de les mettre en ligne en donnant les arguments -side => 'left' à la commande pack.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack(-side => 'left');
  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack(-side => 'left');
  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack(-side => 'left');

  MainLoop;

La plupart du temps, cela suffit pour positionner les widgets où on veut. (Je conseille d'ailleurs au lecteur de sauter les exemples suivants.) Il existe néanmoins d'autres moyens, plus complexes, mais plus précis : évoquons-les maintenant. Le plus simple est d'utiliser la commande Frame, qui agit à la manière des \hbox ou des \vbox de TeX.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  my $w_frame1 = $w_top->Frame;

  $w_frame1->Button(-text => "1a",
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame1->Button(-text => "1b",
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame1->Button(-text => "1c",
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');

  $w_frame1->pack;

  my $w_frame2 = $w_top->Frame;

  $w_frame2->Button(-text => "2a",
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame2->Button(-text => "2b",
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame2->Button(-text => "2c",
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');

  $w_frame2->pack;

  MainLoop;

Voici un autre exemple, dans l'autre sens.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  my $w_frame1 = $w_top->Frame;

  $w_frame1->Button(-text => "1a",
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');
  $w_frame1->Button(-text => "1b",
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');
  $w_frame1->Button(-text => "1c",
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');

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

  my $w_frame2 = $w_top->Frame;

  $w_frame2->Button(-text => "2a",
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');
  $w_frame2->Button(-text => "2b",
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');
  $w_frame2->Button(-text => "2c",
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');

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

  MainLoop;

Les exemples précédents étaient très symétriques ; le suivant l'est moins.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  my $w_frame1 = $w_top->Frame;

  $w_frame1->Button(-text => "1a",
		    -width => 3,
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame1->Button(-text => "1b",
		    -width => 3,
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame1->Button(-text => "1c",
		    -width => 3,
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');

  $w_frame1->pack;

  my $w_frame2 = $w_top->Frame;

  $w_frame2->Button(-text => "2a",
		    -width => 3,
		    -command => sub { exit 0; },
		   )->pack(-side => 'left');
  $w_frame2->Button(-text => "2c",
		    -width => 3,
		    -command => sub { exit 0; },
		   )->pack(-side => 'right');

  $w_frame2->pack;

  my $w_frame3 = $w_top->Frame;

  $w_frame3->Button(-text => "3a",
		    -width => 3,
		    -command => sub { exit 0; },
		   )->pack(-side => 'top');

  $w_frame3->pack;

  MainLoop;

La commade pack admet divers arguments. Les options -padx et -pady donnent la distance entre le bord du widget et ce qu'il y a autour. Les options -ipadx et -ipady donnent la distance entre le bord du widget et son contenu. L'option fill, qui peut valoir x, y ou both indique que le widget doit grandir dans la direction indiquée pour prendre toute la place disponible. Voici l'un des exemples ci-dessous, avec certaines de ces options.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my @p = qw(-pady 5 -padx 10 -ipadx 20 -fill x);

  $w_top->Label(-text => "sunken",
		-relief => 'sunken',
	       )->pack(@p);
  $w_top->Label(-text => "raised",
		-relief => 'raised',
	       )->pack(@p);
  $w_top->Label(-text => "flat",
		-relief => 'flat',
	       )->pack(@p);
  $w_top->Label(-text => "groove",
		-relief => 'groove',
	       )->pack(@p);
  $w_top->Label(-text => "ridge",
		-relief => 'ridge',
	       )->pack(@p);
  $w_top->Label(-text => "solid",
		-relief => 'solid',
	       )->pack(@p);

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack(@p);

  MainLoop;

Autre exemple, avec expand.









  ...

Il est aussi possible de positionner les Widgets dans une grille.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  my $w_frame = $w_top->Frame->grid;

  $w_frame->Button(-text => "1a",
		    -command => sub { exit 0; },
		   )->grid(-column => 0, -row => 0);
  $w_frame->Button(-text => "1b",
		    -command => sub { exit 0; },
		   )->grid(-column => 0, -row => 1);
  $w_frame->Button(-text => "1c",
		    -command => sub { exit 0; },
		   )->grid(-column => 0, -row => 2);
  $w_frame->Button(-text => "2a",
		    -command => sub { exit 0; },
		   )->grid(-column => 1, -row => 0);
  $w_frame->Button(-text => "2b",
		    -command => sub { exit 0; },
		   )->grid(-column => 1, -row => 1);
  $w_frame->Button(-text => "2c",
		    -command => sub { exit 0; },
		   )->grid(-column => 1, -row => 2);

  $w_frame->pack;

  MainLoop;

Après cet apperçu des méthodes permettant de positionner les widgets, examinons quelques autres widgets. Il est tout d'abord possible d'afficher une chaine de caractères.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  $w_top->Label(-text => "Coucou !")->pack;

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Il est possible de donner du « relief » au texte.

#! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Enchevetrements");

  $w_top->Label(-text => "Coucou !",
		-width => 10,
	       )->pack;
  $w_top->Label(-text => "sunken",
		-relief => 'sunken',
	       )->pack;
  $w_top->Label(-text => "raised",
		-relief => 'raised',
	       )->pack;
  $w_top->Label(-text => "flat",
		-relief => 'flat',
	       )->pack;
  $w_top->Label(-text => "groove",
		-relief => 'groove',
	       )->pack;
  $w_top->Label(-text => "ridge",
		-relief => 'ridge',
	       )->pack;
  $w_top->Label(-text => "solid",
		-relief => 'solid',
	       )->pack;

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Pour des textes plus longs, on autorise Perl à utiliser plusieures lignes.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $text = "Ceci est un très long texte. ";
  $text = $text x 8;

  $w_top->Label(-text => $text,
		-wraplength => '5c', # 5 centimètres
		-justify => 'left',
	       )->pack;

  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Il y a encore d'autres choses à dire sur ce genre de Widget.
  ...

L'exemple suivant montre comment définir un menu.

 #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_menu = $w_top->Menubutton(-text => 'File', 
				  -underline => 0, 
				  -tearoff => 0,
				 );
  $w_menu->command(-label => 'Charger',
		   -command => \&file_load,
		  );
  $w_menu->command(-label => 'Nouveau',
		   -command => \&file_new,
		  );
  $w_menu->command(-label => 'Sauvegarder',
		   -command => \&file_save,
		  );
  $w_menu->command(-label => 'Sauvegarder comme',
		   -command => \&file_save_as,
		  );
  $w_menu->command(-label => 'Quitter',
		   -command => \&file_quit,
		   -accelerator => 'C-q',
		  );
  $w_top->bind( '<Control-q>', \&file_quit );
  $w_menu->pack;

  sub error { 
    my ($message) = @_;
    print STDERR "$message\n";
  }
  sub file_load    { error "Not implemented"; }
  sub file_new     { error "Not implemented"; }
  sub file_save    { error "Not implemented"; }
  sub file_save_as { error "Not implemented"; }
  sub file_quit    { exit; }

  MainLoop;

Et voici une barre de menus.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_menubar = $w_top->Frame(-relief => 'raised', -borderwidth => 2);

  my $w_menu_file = $w_menubar->Menubutton(-text => 'File', 
					   -underline => 0, 
					   -tearoff => 0,
					  );
  $w_menu_file->command(-label => 'Charger',
			-command => \&file_load,
		       );
  $w_menu_file->command(-label => 'Nouveau',
			-command => \&file_new,
		       );
  $w_menu_file->command(-label => 'Sauvegarder',
			-command => \&file_save,
		       );
  $w_menu_file->command(-label => 'Sauvegarder comme',
			-command => \&file_save_as,
		       );
  $w_menu_file->command(-label => 'Quitter',
			-command => \&file_quit,
			-accelerator => 'C-q',
		       );
  $w_top->bind( '<Control-q>', \&file_quit );
  $w_menu_file->pack(-side => 'left');

  my $w_menu_help = $w_menubar->Menubutton(-text => 'Help',
					   -underline => 0,
					   -tearoff => 0,
					  );
  $w_menu_help->command(-label => 'About', 
			-command => \&help_about,
		       );
  $w_menu_help->command(-label => 'Manual', 
			-command => \&help_manual,
		       );
  $w_menu_help->pack(-side => 'right');

  $w_menubar->pack(-fill => 'x'); # Important, pour que les menus 
                                  # ne soient pas au milieu.

  my $text = "Bla bla bla bla. ";
  $text = $text x 8;
  $w_top->Label(-text => $text,
		-wraplength => '5c',
		-justify => 'left',
	       )->pack;

  sub error { 
    my ($message) = @_;
    print STDERR "$message\n";
  }

  sub file_load    { error "Not implemented"; }
  sub file_new     { error "Not implemented"; }
  sub file_save    { error "Not implemented"; }
  sub file_save_as { error "Not implemented"; }
  sub file_quit    { exit; }

  sub help_about  { error "Not implemented"; }
  sub help_manual { error "Not implemented"; }

  MainLoop;

Le widget Entry permet la saisie de texte. Dans l'exemple suivant, la commande focus nous évite d'avoir à cliquer sur la zône de saisie avant de pouvoir taper le texte.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_entry = $w_top->Entry(-relief => 'sunken', -width=>30);
  $w_entry->pack(-padx => 10, -pady => 10)->focus;

  MainLoop;

Quand il y a plusieures zônes de saisie, on peut passer de l'une à l'autre à l'aide de la touche de tabulation.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_entry1 = $w_top->Entry(-relief => 'sunken', -width=>30);
  $w_entry1->pack(-padx => 10, -pady => 10)->focus;

  my $w_entry2 = $w_top->Entry(-relief => 'sunken', -width=>30);
  $w_entry2->pack(-padx => 10, -pady => 10);

  my $w_entry3 = $w_top->Entry(-relief => 'sunken', -width=>30);
  $w_entry3->pack(-padx => 10, -pady => 10);

  $w_top->Button(-text => 'OK', 
		 -command => sub {
		   print STDERR "1: ". $w_entry1->get ."\n";
		   print STDERR "2: ". $w_entry2->get ."\n";
		   print STDERR "3: ". $w_entry3->get ."\n";
		 },
		)->pack(-padx => 10, -pady => 10);
  MainLoop;

Voici un formulaire, créé à l'aide de ce genre de widget.

#! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_frame = $w_top->Frame->grid;

  $w_frame->Label(-text => 'Nom'
		 )->grid(-row => 0, -column => 0, 
			 -sticky => 'e');
  my $w_entry1 = $w_frame->Entry(-relief => 'sunken', -width=>30);
  $w_entry1->grid(-padx => 10, -pady => 10, 
		  -row => 0, -column => 1)->focus;

  $w_frame->Label(-text => 'Adresse'
		 )->grid(-row => 1, -column => 0, 
			 -sticky => 'e');
  my $w_entry2 = $w_frame->Entry(-relief => 'sunken', -width=>30);
  $w_entry2->grid(-padx => 10, -pady => 10, 
		  -row => 1, -column => 1)->focus;

  $w_frame->Label(-text => 'Quelques remarques'
		 )->grid(-row => 2, -column => 0, 
			 -sticky => 'e');
  my $w_entry3 = $w_frame->Entry(-relief => 'sunken', -width=>30);
  $w_entry3->grid(-padx => 10, -pady => 10, 
		  -row => 2, -column => 1)->focus;

  $w_frame->pack;

  $w_top->Button(-text => 'OK', 
		 -command => sub {
		   print STDERR "1: ". $w_entry1->get ."\n";
		   print STDERR "2: ". $w_entry2->get ."\n";
		   print STDERR "3: ". $w_entry3->get ."\n";
		 },
		)->pack(-padx => 10, -pady => 10);
  MainLoop;

Le widget FileSelect permet de sélectionner un fichier (déjà existant ou non).

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_button = $w_top->Button(-text => 'Choose a file', 
				-command => sub {
				  my $w_file = $w_top->FileSelect;
				  print STDERR "You have chosen ". $w_file->Show ."\n";
				})->pack(-padx => 10, -pady => 10);  

  MainLoop;

On a très souvent besoin d'afficher quelque chose ou de demander une confirmation.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->Button(-text => "Quit", 
		 -command => sub {
		   my $reponse = 
		     $w_top->messageBox(-type => 'OKCancel', # ou AbortRetryIgnore, OK, 
					                     #    OKCancel, RetryCancel, 
                                                             #    YesNo, YesNoCancel
					-icon => 'warning', # ou info, question, error
					-message => 'Do you really want to leave ?',
				       );
		   exit if $reponse eq "Ok";
		 })->pack;

  MainLoop;

Néanmoins, on n'est pas limité à des réponses aussi ambiguës que chez Bill Gates, comme dans l'exemple précédent.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->Button(-text => "Quit", 
		 -command => sub {
		   my $reponse = 
		     $w_top->messageBox(-type => 'YesNo', # ou AbortRetryIgnore, OK, 
					                     #    OKCancel, RetryCancel, 
                                                             #    YesNo, YesNoCancel
					-icon => 'question', # ou info, warning, error
					-message => 'Do you really want to leave ?',
				       );
		   exit if $reponse eq "Yes";
		 })->pack;

  MainLoop;

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->Button(-text => "Push me", 
		 -command => sub {
		   $w_top->messageBox(-type => 'OK', # ou AbortRetryIgnore, OK, 
					             #    OKCancel, RetryCancel, 
                                                     #    YesNo, YesNoCancel
				      -icon => 'error', # ou info, question, warning
				      -message => "You oughtn't to have done that...",
				     );
		 })->pack;

  MainLoop;

Quand on écrit une interface graphique pour répondre à certaines questions, très nombreuses, on peut les séparer en plusieures pages à l'aide du widget NoteBook.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;
  use Tk::NoteBook;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_book = $w_top->NoteBook;

  my $w_page1 = $w_book->add("one", -label => "Page 1");
  $w_page1->Label(-text => "Please answer the following questions")->pack;

      my $w_frame = $w_page1->Frame->grid;

      $w_frame->Label(-text => 'Nom'
		     )->grid(-row => 0, -column => 0, 
			     -sticky => 'e');
      my $w_entry1 = $w_frame->Entry(-relief => 'sunken', -width=>30);
      $w_entry1->grid(-padx => 10, -pady => 10, 
		      -row => 0, -column => 1)->focus;

      $w_frame->Label(-text => 'Adresse'
		     )->grid(-row => 1, -column => 0, 
			     -sticky => 'e');
      my $w_entry2 = $w_frame->Entry(-relief => 'sunken', -width=>30);
      $w_entry2->grid(-padx => 10, -pady => 10, 
		      -row => 1, -column => 1)->focus;

      $w_frame->Label(-text => 'Quelques remarques'
		     )->grid(-row => 2, -column => 0, 
			     -sticky => 'e');
      my $w_entry3 = $w_frame->Entry(-relief => 'sunken', -width=>30);
      $w_entry3->grid(-padx => 10, -pady => 10, 
		      -row => 2, -column => 1)->focus;

      $w_frame->pack;


  my $w_page2 = $w_book->add("two", -label => "Page 2");
  $w_page2->Label(-text => "Please answer the following questions")->pack;

  my $w_page3 = $w_book->add("three", -label => "Page 3");
  $w_page3->Label(-text => "This page is still empty")->pack;

  $w_book->pack;

  MainLoop;

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my ($a, $b, $c);
  $w_top->Label(-text => "fdskjhsdlfk")->pack;
  $w_top->Checkbutton(-text => "azerty", -variable => \$a)->pack(-anchor => 'w');
  $w_top->Checkbutton(-text => "qsdfgh", -variable => \$b)->pack(-anchor => 'w');
  $w_top->Checkbutton(-text => "wxcvbn sdf", -variable => \$c)->pack(-anchor => 'w');

  MainLoop;

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my ($age);
  $w_top->Label(-text => "How old are you?")->pack;
  $w_top->Radiobutton(-text => "under 18", 
		      -variable => \$age,
		      -value => 18,
		     )->pack(-anchor => 'w');
  $w_top->Radiobutton(-text => "18-30", 
		      -variable => \$age,
		      -value => 30,
		     )->pack(-anchor => 'w');
  $w_top->Radiobutton(-text => "30-50", 
		      -variable => \$age,
		      -value => 50,
		     )->pack(-anchor => 'w');
  $w_top->Radiobutton(-text => "50-infinity", 
		      -variable => \$age,
		      -value => 100,
		     )->pack(-anchor => 'w');

  MainLoop;

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;
  use Tk::LabFrame;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my ($os);
  my $w_frame = $w_top->LabFrame(-label => "OS",
				 -labelside => 'acrosstop',
				 );
  $w_frame->Radiobutton(-text => "Linux", 
		      -variable => \$os,
		      -value => "Linux",
		     )->pack(-anchor => 'w');
  $w_frame->Radiobutton(-text => "Other unices", 
		      -variable => \$os,
		      -value => "Unix",
		     )->pack(-anchor => 'w');
  $w_frame->Radiobutton(-text => "Windoze", 
		      -variable => \$os,
		      -value => "Windoze",
		     )->pack(-anchor => 'w');
  $w_frame->Radiobutton(-text => "other", 
		      -variable => \$os,
		      -value => "none",
		     )->pack(-anchor => 'w');
  $w_frame->pack;
  MainLoop;

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->Label(-text => "Which operating system do you use?")->pack;
  my $os;
  $w_top->Optionmenu(-textvariable => \$os, 
		     -options => [qw(Linux Solaris BeOS FreeBSD NetBSD Windoze Macintosh)],
		    )->pack;

  MainLoop;

Dessins au format GIF

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->Label(-image       => $w_top->Photo(-file => Tk->findINC('Xcamel.gif')),
		-borderwidth => 2,
		-relief      => 'sunken',
	       )->pack(-padx => 5, -pady => 5);

  MainLoop;

Dessins au format JPEG

  #! perl -w

  use strict;
  use Tk;
  use Tk::JPEG;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Image JPEG");

  $w_top->Label(-image       => $w_top->Photo(-format => 'jpeg', 
                                              -file   => 'something.jpg'),
                -borderwidth => 2,
                -relief      => 'sunken',
               )->pack(-padx => 5, -pady => 5);

  MainLoop;
Pour éviter les fuites de mémoire, on prendra soin de libérer la place occupée par les images dont on n'a plus besoin :
  $photo->delete();

Dessins au format JPEG dont on change la taille (100 pixels).

  #! perl -w

  use strict;
  use Tk;
  use Tk::JPEG;

  # Pour avoir des images de 100 pixels de côté.
  my $pixels = 100;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Petite image JPEG");

  my $photo = $w_top->Photo(-format => 'jpeg', 
                            -file   => 'something.jpg');
  my $smallphoto = $w_top->Photo;
  $smallphoto->copy( $photo, 
                     -subsample => ($photo->width  / $pixels, 
                                    $photo->height / $pixels),
                   );
  
  $w_top->Label(-image       => $smallphoto,
                -borderwidth => 2,
                -relief      => 'sunken',
               )->pack(-padx => 5, -pady => 5);

  MainLoop;

Il est possible de mettre de telles images sur des boutons.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->Button(-image   => $w_top->Photo(-file => Tk->findINC('Xcamel.gif')),
		 -command => sub { print STDERR "Vive Perl !\n"; },
	       )->pack(-padx => 5, -pady => 5);

  MainLoop;









Zône de dessin

Passons maintenant à l'un des Widgets les plus compliqués, le canvas : c'est l'endroit où on dessine.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;


  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Voici quelques exemples de dessins qu'on peut y mettre.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  $w_canvas->createLine(0,0, 100, 100,
			);
  $w_canvas->createLine(10,90, 90, 50,
			-width => 5,
			-fill => 'red',
			-arrow => 'last',
			);
  $w_canvas->createText(100, 20,
			-text => "Coucou !",
			-anchor => 'center',
			);
#  $w_canvas->createImage(150, 50,
#			 -image => "Tk.xbm",
#			 -anchor => 'center');
  my $button = $w_top->Button(-text => "OK");
  $w_canvas->createWindow(100, 80, -window => $button);
  $w_canvas->createOval(10, 10, 30, 90,
			-fill => 'white',
			-outline => 'black',
			-width => 2,
			);



  $w_top->Button(-text => "Quit",
                 -command => sub { exit 0; },
                )->pack;

  MainLoop;

Il est possible de donner des noms aux différents éléments d'un Canvas, de manière à pouvoir les modifier ou les effacer facilement.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  sub draw_line {
    my ($tag) = @_;
    $w_canvas->createLine(200*rand(), 100*rand(), 
			  200*rand(), 100*rand(), 
			  -tags => $tag);
  }

  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 

  foreach( $w_canvas->find(withtag => 'toto') )
    { $w_canvas->delete($_); }

  MainLoop;

Le même exemple, mais avec une temporisation.
  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  sub draw_line {
    my ($tag) = @_;
    $w_canvas->createLine(200*rand(), 100*rand(), 
			  200*rand(), 100*rand(), 
			  -tags => $tag);
  }

  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 

  $w_top->after( 1000, sub {
    foreach( $w_canvas->find(withtag => 'toto') )
      { $w_canvas->delete($_); }
  });

  MainLoop;

Le même exemple, mais avec une boucle.
  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  sub draw_line {
    my ($tag) = @_;
    $w_canvas->createLine(200*rand(), 100*rand(), 
			  200*rand(), 100*rand(), 
			  -tags => $tag);
  }

  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 
  draw_line("toto");   draw_line("tutu"); 

  sub replace {
    my ($tag) = @_;
    foreach( $w_canvas->find(withtag => $tag) )
      { $w_canvas->delete($_); }
    draw_line($tag);
    draw_line($tag);
    draw_line($tag);
    draw_line($tag);
    draw_line($tag);
    $tag = ($tag eq "toto") ? "tutu" : "toto";
    $w_top->after( 1000, sub { replace($tag) });
  }

  $w_top->after( 1000, sub { replace("toto") });

  MainLoop;

Signalons aussi que les objets peuvent avoir plusieurs noms : il suffit de les mettre dans une liste. Ainsi, on aurait pu écrire l'exemple précédent ainsi.
  sub draw_line {
    my ($tag) = @_;
    $w_canvas->createLine(200*rand(), 100*rand(), 
			  200*rand(), 100*rand(), 
			  -tags => ['tmp', $tag],
                         );
  }

Pour l'instant, notre présentation de Perl/Tk était essentiellement descriptive : nos exemple (concernant la zône de dessin) n'interagissaient pas avec un utilisateur. L'exemple suivant va lier le bouton gauche de la souris à une action : rajouter quelque chose dans le dessin.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  sub draw_line {
    $w_canvas->createLine(200*rand(), 100*rand(), 
			  200*rand(), 100*rand(), 
			 );
  }

  $w_canvas->Tk::bind('<1>' => \&draw_line);
  $w_top->bind('<q>' => sub{exit});

  MainLoop;

Remarquons qu'il est possible d'utiliser la commande bind pour réagir à des touches. (Pourquoi fallait-il mettre Tk::bind ?)
  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  $w_top->bind('<q>' => sub{exit});

  MainLoop;

Autre exemple :
  #! perl -w
  use strict;
  use Tk;
  my $w_top = new MainWindow;
  $w_top->Label(-text => "Hello World")->pack();
  $w_top->bind( '', sub { print STDERR "You pressed a\n" } );
  $w_top->bind( '', sub { print STDERR "You pressed b\n" } );
  MainLoop;

Encore un autre exemple (tiré de la FAQ) ; dans lequel on regarde plus préciséménet le contenu des évènements.
  #!/usr/local/bin/perl -w
  use Tk;
  $top = MainWindow->new();
  $frame = $top->Frame( -height => '6c', -width => '6c',
                        -background => 'black', -cursor => 'gobbler' );
  $frame->pack;
  $top->bind( '' => sub
  {
    my($c) = @_;
    my $e = $c->XEvent;
    my( $x, $y, $W, $K, $A ) = ( $e->x, $e->y, $e->K, $e->W, $e->A );

    print "A key was pressed:\n";
    print "  x = $x\n";
    print "  y = $y\n";
    print "  W = $K\n";
    print "  K = $W\n";
    print "  A = $A\n";
  } );
  MainLoop();

Dans l'exemple précédent, l'utilisation de la souris n'était pas très pertinente : on n'utilisait pas l'endroit où se trouvait le curseur de la souris. Ce problème est corrigé dans l'exemple suivant.

#! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  sub draw_cross {
    my $e = $w_canvas->XEvent;
    $w_canvas->createLine($e->x + 5, $e->y + 5, 
			  $e->x - 5, $e->y - 5, 
			  -width => 4,
			 );
    $w_canvas->createLine($e->x + 5, $e->y - 5, 
			  $e->x - 5, $e->y + 5, 
			  -width => 4,
			 );
  }

  $w_canvas->Tk::bind('<1>' => \&draw_cross);
  $w_top->bind('<q>' => sub{exit});

  MainLoop;

Voici un exemple comparable, mais avec des lignes.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  my ($x, $y); # Variables globales...

  sub draw_line_first_point {
    my $e = $w_canvas->XEvent;
    ($x, $y) = ($e->x, $e->y);
    $w_canvas->Tk::bind('<1>' => \&draw_line_second_point);
  }

  sub draw_line_second_point {
    my $e = $w_canvas->XEvent;
    $w_canvas->createLine( $x, $y, $e->x, $e->y );
    $w_canvas->Tk::bind('<1>' => \&draw_line_first_point);
  }

  $w_canvas->Tk::bind('<1>' => \&draw_line_first_point);
  $w_top->bind('<q>' => sub{exit});

  MainLoop;

Cet exemple présente un gros défaut : on est obligé de dessiner « à l'aveuglette » : ce n'est quaprès avoir défini les deux points que l'on voit la droite que l'on a tracé. Il est possible de porogrammer les choses de manière plus dynamique, afin de voir, à chaque instant, ie, après chaque mouvement de souris, la droite que l'on obtiendrait si on cliquait à cet endroit-là.

  #! perl -w
  use strict;
  use Tk;
  use Tk::FileSelect;

  my $w_top = new MainWindow;
  $w_top->configure(-title => "Essai");

  my $w_canvas = $w_top->Canvas(-relief=>'raised', 
				-borderwidth => 2,
				-width => 200, -height => 100, 
				-closeenough => 10
			       )->pack;

  my ($x, $y); # Variables globales...

  sub draw_line_first_point {
    my $e = $w_canvas->XEvent;
    ($x, $y) = ($e->x, $e->y);
    $w_canvas->Tk::bind('<1>' => \&draw_line_second_point);
    $w_canvas->Tk::bind('<Motion>' => \&draw_line_motion);
  }

  sub draw_line_motion {
    my $e = $w_canvas->XEvent;
    foreach( $w_canvas->find(withtag => 'tmp') )
      { $w_canvas->delete($_); }
    $w_canvas->createLine( $x, $y, $e->x, $e->y, -tag => 'tmp');
  }

  sub draw_line_second_point {
    my $e = $w_canvas->XEvent;
    $w_canvas->createLine( $x, $y, $e->x, $e->y );
    $w_canvas->Tk::bind('<1>' => \&draw_line_first_point);
    $w_canvas->Tk::bind('<Motion>' => sub{});
  }

  $w_canvas->Tk::bind('<1>'      => \&draw_line_first_point);
  $w_canvas->Tk::bind('<Motion>' => sub{});
  $w_top->bind('<q>' => sub{exit});

  MainLoop;

L'évènement peut être « passer au dessus d'un objet dont le « tag » soit $tag.


Déplacer des objets.


















Les caputures d'écran sont réalisées grace à la commande xwd.
    for i in *.pl
    do
      perl $i &
      xwd -frame | xwdtopnm | ppmtogif > $i.gif
      kill $!
    done
    rename 's/\.pl\.gif$/.gif/' *.pl.gif

Les captures d'écran plus grandes que la fenêtre (principalement celles concernant les menus) sont toujours réalisées à l'aide de la commande xwd et retaillées « à la main » grace à xv.
    perl toto.pl &
    sleep 4; xwd -frame -root | xwdtopnm | ppmquant 256 | ppmtogif > toto.gif
    xv toto.gif

zoonek@math.jussieu.fr
Décembre 1999
Last modified: Thu Sep 19 15:32:27 CEST 2002