Einführung in TkPerl

Einführung in TkPerl

Dr. Rudolf Strub


Literatur:
  1. Nancy Walsh, ''Learning Perl/Tk''; O'Reilly, First Edition Jan. 1999 ISBN: 1-56592-314-6L, 376 pages
  2. dito unter
    http://safari2.oreilly.com/table.asp?bookname=lperltk
  3. ins Deutsche übersetzt von M.K.Dalheimer: ''Einführung in Perl/Tk'' 1. Aufl.2000 ISBN 3-89721-142-4
  4. Tk Documentation:
    http://www.lns.cornell.edu/ pvhp/ptk/doc/
  5. Perl and the Tk Extension:
    http://www.lehigh.edu/ sol0/ptk/tpj1.html (a very good introduction)
  6. Writing GUI Applications in Perl/Tk:
    http://www.perl.com/pub/2001/03/gui.html
  7. Perl/Tk:
    http://www.mathematik.uni-ulm.de/help/perl5/tk.html
  8. GUI Interfaces with Perl/Tk:
    http://www-mtl.mit.edu/ kush/PERL5_UNLEASHED/CH17.HTM

1  Perl + Tk = perl/Tk

Tk ist ursprünglich ein Zusatz zu Tcl zur Erstellung von Grafical User Interfaces (GUI) in Tcl unter X11.
Es gibt zwei unterschiedliche Implementationen von Tk in Perl.

  • Tkperl von Malcolm Beattie. Es gestattet die Einbindung von Tcl-Code in Perl-Scripts.
  • perl/Tk von Nick Ing-Simons (auch ptk oder pTk) gestattet den Aufruf von Tcl-Funktionen in der Syntax von OOP-Perl. Diese Implementation ist hier Gegenstand. Es wird häufig ebenfalls Tkperl genannt.

Unter einem Package versteht man in Perl einen abgeschlossenen Namensraum für Funktionen und Variablen. Durch dieses Konstrukt können in einem Programm Namenskollisionen vermieden werden. Aufrufe innerhalb eines packages können durch Angabe des einfachen Names, Aufrufe aus anderen packages müssen mit ihrem full qualified Namen erfolgen: package::name.

Unter einem Modul versteht man in Perl eine Datei mit der Endung .pm. Sie enthält ein Teilprogramm (vergleichbar mit Units in Pascal oder Includes in C). In Module ausgelagert werden packages. Ein Modul wird im Hauptprogramm aufgerufen durch

use < modulname >

Durch diese Anweisung werden alle im Modul stehenden Package-, Funktions und Variablenanweisungen übernommen, und die Befehle ausgeführt, welche ausserhalb von Subroutinen stehen (Initialisierungen). Perl erwartet von der use-Funktion die Rückgabe des Wertes 1, deshalb enden Module mit der Zeile "´1;"´,
Module können auch hierarchisch geschachtelt werden in (Sub-)Directories. Die Anweisung use SUBDIR::MODUL sucht in allen Directories die sich im INC-Pfad (@INC-Array) befinden nach einem Subdirectory SUBDIR und dort nach der Datei MODUL.pm .

perl/Tk ist ein Perl-Modul (Tk.pm), der mit use Tk aufgerufen wird. Durch use wird das Modul beim Kompilieren geladen und die Namen in den Namensraum eingefügt. (Die Anweisung require lädt ebenfalls Module, jedoch zur Laufzeit und importiert keine Namen).

2  Installation von Perl/Tk

Von

http://sunsite.cnlab-switch.ch/ftp/mirror/CPAN/modules/by-authors/Nick_Ing-Simmons/

holt man sich

Tk800.023.tar.gz


  gunzip Tk800.023.tar.gz
  tar -xvf Tk800.023.tar
 
  cd  Tk800.023 
  perl Makefile.PL
  make
  make install  

Nähere Hinweise in Literatur *.

3  OOP

Unter Perl5 ist eine Klasse lediglich eine Package, deren Subroutinen Objekte manipulieren können und damit Methoden im Sinne der OOP sind.

perl/Tk stellt mit dem Modul Tk.pm Widgets in Form von Objektklassen zur Verfügung.

Der Pfeil-Operator für die Dereferenzierung - > bedeutet den Aufruf einer Methode (Subroutine) eines Objekts.
Ein neues Widget wird nach dem Schema:

$kind = $vater - > Widget-Typ([ -option= > wert, ... ] )

erzeugt.

Syntax für die Erzeugung eines Fensters auf der Root-Fläche:

$object = MainWindow - > new

in diesem Fenster können weitere Widgets erzeugt werden durch:

$newobject = $object - > widget (options)

Die möglichen widgets sind in Kapitel aufgeführt. Die Optionen unterscheiden sich naturgemäss für die verschiedenen widgets und finden sich in der Tabelle im Anhang. Ebenso unterscheiden sich die Methoden, die mit der Syntax:

$object - > methode(options)

z.B.: $object - > configure(-background= > 'beige');

4  Erste Beispiele

Als erstes Beispiel wird in einem Fenster ein Text ausgegeben und mit einem "´Quit"´-Button das Fenster wieder geschlosssen.




#!/usr/bin/perl -w

use Tk;

$top = MainWindow -> new();
$top -> title("Hello");

my $out = $top -> Label(-text => "´Guten Morgen, sonnige Welt!"´); 
my $Quit_Button = $top -> Button ( -text    => "´Quit"´, 
                                   -command => sub{exit 0});
   $out -> pack();
   $Quit_Button -> pack();
MainLoop;

hello.jpg

Im zweiten Beispiel werden die Standardoptionen am Beipiel eines Buttons, sowie das Ausblenden von Widgets gezeigt. Dieses Beispiel enthält alle möglichen Optionen des Widgets Button und (auskommentiert) die Anweisung, die verhindert, dass das entsprechende Window grösser ''gezogen'' werden kann.




#!/usr/bin/perl -w
use Tk;
my $count = 0;
my $top = MainWindow->new();

#   $top -> resizable ('0','0'); # verhindert das 'Groesserziehen'
   $top -> title ("Button-Test");
   $top -> geometry ('+20+20');
   
my $degscht = " Auch dies ist \n ein Button \n nur groesser!
                \n und mit anderem Font";

my $Quit_Button = $top-> Button (
                  # -text    => "    Press     " # statt -textvariable 
                    -textvariable => \$degscht,
                  # -bitmap=>"question",
                    -borderwidth=> '5',
                  # -bd => '3',                  # statt -borderwidth
                  # -highlightthickness => '30', # ohne Wirkung
                    -highlightcolor => 'SkyBlue',
                    -activebackground => 'green',
                    -relief => 'raised',
                    -width=>'20',
                    -height=>'20',
                    -command => sub{$top->destroy},
                    -font => "9x15",
                    -foreground => "red",
                    -activeforeground => 'white',
                    -background => "yellow",
                    -cursor => 'arrow',
                    -state => "normal");
		    		    
my $Quit_Button2 = $top-> Button ( -text    => "    Quit     ", 
                                   -command => [sub{&machput}]);
   $Quit_Button -> pack();
   $Quit_Button2 -> pack();
MainLoop;

sub machput {$Quit_Button2->destroy} 

button.jpg

5  Übersicht über die Widgets

Button Create and manipulate button widgets
Canvas Create and manipulate canvas widgets (graphics)
Checkbutton Create and manipulate checkbutton widgets
Entry Create and manipulate entry widgets
Frame Create and manipulate frame widgets
Label Create and manipulate label widgets
Listbox Create and manipulate listbox widgets
MainWindow Create the first window, a special form of Toplevel
Menu Create and manipulate menu widgets
Menubutton Create and manipulate menubutton widgets
Radiobutton Create and manipulate radiobutton widgets
Scale Create and manipulate scale widgets
Scrollbar Create and manipulate scrollbar widgets
Text Create and manipulate text widgets
Toplevel Create and manipulate toplevel widgets

5.1  Das Widget frame

Das Widget frame nimmt eine Sonderrolle ein, da es lediglich einen Rahmen zur Verfügung stellt,in den weitere Widgets plaziert werden können. Dadurch wird die Gestaltung von Windows flexibler und einfacher zu handhaben.
Daneben haben frames aber auch noch eine Dekorationsfunktion. So wie bei anderen Widgets auch kann durch die Angabe der relief-Option ein unterschiedliches 3-dimensionale Aussehen erzielt werden.




#!/usr/bin/perl -w
use Tk;
my $top = MainWindow->new();

foreach $reliefstyle ("flat", "raised", "sunken", 
                      "ridge", "groove") {

                      # Frame um das Label erzeugen
    $frame = $top->Frame(-relief => $reliefstyle, 
                         -borderwidth => 5);

                      # Mit 2mm Abstand seitlich und nach
                      # oben packen
    $frame->pack(-side => "left", -padx => "2m", 
                                  -pady => "2m"); 

                      # Label erzeugen
    $frame->Label(-text => $reliefstyle)->pack();
}
MainLoop;

framestyle.gif

6  Die Geometrie-Manager

Der Geometrie-Manager sind für die Anordnung der Widgets innerhalb eines Windows oder Frames zuständig. Perl/Tk kennt drei verschiedene Windows-Manager:

  • pack - packt ein Widget ans andere, mit Vorgabe der ''Himmelsrichtung''
  • grid - teilt Window in ein regelmässiges Gitter
  • place - platziert Widgets gezielt im Window

6.1  Die Methode pack

Name Funktion Optionen
pack Macht das Widget auf das die Methode pack angewendet wird sichtbar, entsprechend den Optionen -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, -side

Die Methode pack befördert die davor definierten Widgets auf den Bildschirm. Die Plazierung erfolgt anhand der angegebenen Optionen und mit Rücksicht auf die bereits platzierten Widgets. Als regel gilt: das Widget wird so weit in die gewünschte Richtung geschoben, wie es schon vorhandene Widgets zulassen. Zusammen mit dem Widget frame (siehe 5.1 kann so auf einfache Art eine (nahezu) beliebige Windowgestaltung erreicht werden.




#!/usr/drwho/local/bin/perl -w
use Tk;
my $top = MainWindow -> new();

my $label1 = $top -> Label (-text=>'Label 1 - top  ',-relief=>'sunken');
my $label2 = $top -> Label (-text=>'Label 2 - left ',-relief=>'sunken');
my $label3 = $top -> Label (-text=>'Label 3 - top  ',-relief=>'sunken');
my $label4 = $top -> Label (-text=>'Label 4 - left ',-relief=>'sunken');
my $label5 = $top -> Label (-text=>'Label 5 - right',-relief=>'sunken');

$label1 -> pack(-side=>'top');
$label2 -> pack(-side=>'left');
$label3 -> pack(-side=>'top');
$label4 -> pack(-side=>'left');
$label5 -> pack(-side=>'right');
MainLoop;

Man sieht wie sowohl die Reihenfolge der pack-Anweisungen, als auch die Werte der side-Option sich auf die Aufteilung des Fensters auswirken. Die relief-Option wurde lediglich benutzt um die Label-Positionen besser erkennen zu können.

pack.gif

6.2  Die Methode grid

Name Funktion Optionen
grid Macht das Widget auf das die Methode grid angewendet wird sichtbar, und plaziert es entsprechend den Optionen. -, x, Ù, -column, -row, -columnspan, -rowspan, -sticky, -in, -ipadx, -ipady, -padx, -pady




#!/usr/sepp/bin/perl -w
use Tk;
my $top = MainWindow -> new();
$top -> title('grid-test');

my $label1 = $top -> Label (-text=>'Label 0 - 1,1  ',-relief=>'sunken');
my $label2 = $top -> Label (-text=>'Label 1 - 2,2 ',-relief=>'sunken');
my $label3 = $top -> Label (-text=>'Label 2 - 3,3  ',-relief=>'sunken');
my $label4 = $top -> Label (-text=>'Label 3 --------- 4,1-2 ',-relief=>'sunken');
my $label5 = $top -> Label (-text=>'Label 4 --------- 5,2-3',-relief=>'sunken');

$label1 -> grid(-row=>'0', -column=>'0');
$label2 -> grid(-row=>'1', -column=>'1');
$label3 -> grid(-row=>'2', -column=>'2');
$label4 -> grid(-row=>'3', -columnspan=>'2',);
$label5 -> grid(-row=>'4', -column=>'1', -columnspan=>'2',);
MainLoop;

grid1.gif




#!/usr/sepp/bin/perl -w
use Tk;
my $top = MainWindow -> new();
$top -> title('grid-test-2');

my $label1 = $top -> Label (-text=>' - Label 0 - ', -relief=>'sunken');
my $label2 = $top -> Label (-text=>' - Label 1 - ', -relief=>'sunken');
my $label3 = $top -> Label (-text=>' - Label 2 - ', -relief=>'sunken');
my $label4 = $top -> Label (-text=>' - Label 3 - ', -relief=>'sunken');
my $label5 = $top -> Label (-text=>' - Label 4 - ', -relief=>'sunken');

$label1 -> grid($label2, $label3);
$label4 -> grid('x',$label5);
MainLoop;

grid2.gif

6.3  Die Methode place

Name Funktion Optionen
place Macht das Widget auf das die Methode place angewendet wird sichtbar, und plaziert es entsprechend gewählten x- und y-Koordinaten. -anchor, -bordermode, -height, -in, -relheight, -relwidth, -relx, -rey, -width, -x, -y

Mit place können die Widgets beliebig innerhalb des Windows gesetzt werden, also auch übereinander. Die Koordinaten können absolut (bezogen auf den Bildschirm) oder relativ (bezogen auf das Elternwidget) angegeben werden.




#!/usr/sepp/bin/perl -w
use Tk;
my $top = MainWindow -> new();
$top -> title('grid-test-2');

my $label1 = $top -> Label (-text=>' - Label 0 - ', -relief=>'sunken');
my $label2 = $top -> Label (-text=>' - Label 1 - ', -relief=>'sunken');
my $label3 = $top -> Label (-text=>' - Label 2 - ', -relief=>'sunken');
my $label4 = $top -> Label (-text=>' - Label 3 - ', -relief=>'sunken');
my $label5 = $top -> Label (-text=>' - Label 4 - ', -relief=>'sunken');

$label1 -> place(-x=>10, -y => 25);
$label2 -> place(-x=>20, -y => 50);
$label3 -> place(-x=>30, -y => 75);
$label4 -> place(-x=>40, -y => 85);
$label5 -> place(-x=>20, -y => 150);

MainLoop;

place.gif

7  Die wichtigsten Optionen

Option Parameter Funktion Beispiel
-activebackground < color > Hintergrund, aktiv siehe -background
-activeforeground < color > Vordergrund, aktiv siehe -background
-anchor n, ne, e, se, s, sw, w, nw, center Anker, Anbindungsrichtung -anchor= > 'sw'
-background < color > Hintergrundfarbe nicht aktiv -background= > 'gray50'
-bitmap < bitmap > Flächenmuster -bitmap= > @bitmap.xbm
-borderwidth < width > c, m, i, p Randbreite -borderwidth= > '2m'
-command sub{... } oder \& < funcname > oder [ < commandlist > ] Kommandoaufruf -command= > sub{&machwas}
-cursor arrow, circle ... Kursorform -cursor= > 'arrow'
-disabledforeground-image-text
-expand yes, no Ausdehnung ja/nein -expand= > 'no'
-fill none, x, y, both Füllausdehnungsrichtung -fill=>'both'
-font < Zeichensätze > Wahl des Zeichensatzes -font=>''courierb10''
-foreground < color > Vordergrundfarbe (Schriftfarbe) -foreground= > 'black'
-height < width > Höhe eines Widgets -height= > '10m'
-highlightbackground < color > wenn Mouse auf Widget siehe -background
-highlightcolor < color > -highlightcolor= > 'beige'
-highlightthickness-takefocus
-image < photo > legt Bild auf button oder Label -image=>$myphoto
-in $ < widget > Geometrisches Parent
-justify
-label < text > Ausgabe von Text -label= > 'text'
-padx < width > c, m, i, p Abstand seitlich -padx= > '2m'
-pady < width > c, m, i, p Abstand oben und unten -pady= > '3m'
-pady-wraplength
-relief flat, groove, raised, ridge, sunken Art 3D-Darstellung der Widgets -relief= > 'raised'
-side top, left, bottom, right Positionierung -side= > 'top'
-state normal, disabled, active Aktivierbar, gesperrt, aktiv -state= > 'normal'
-status normal, disabled Editieren oder Readonly -status= > 'normal'
-text < text > Beschriftung -text= > 'text'
-textvariable < variablenreferenz > Referenz auf Variable -textvariable = > $myvar
-underline < offset > Hotkey-Zeichen als Offset -underline= > '1'
-width < width > Breite -width= > 30m
-wrap none, char, word Zeilenumbruch

< color > :
ist eine Farbe entweder mit Namen aus /usr/lib/X11/rgb.txt oder in der RGB-Dartsellung #rrggbb (rr, gg, bb in Hex)
< width > :
Masseinheiten: c = cm, m = mm, i = inch, p = pixel(Default)
< bitmap > :
entweder @filename oder der Name eines Tk-eigenen Bitmaps: error, gray25, gray50, hourglas, info, questhead, question oder warning.

< offset > :
Zahl die Offset in einem String anzeigt
< Zeichensätze > :
eine der unter X11 möglichen Bezeichnungen eines Zeichensatzes (bzw. der entsprechenden Window-Implementierung anderer OS).
< text > :
Textstring in einfachen oder doppelten (Perl-Variable werden aufgelöst) Anführungszeichen.
< photo > :
Photowidget als Wert der -image-Option der beiden Widgets Button und Label.

8  Methoden

Neben einigen spezifischen Methoden, die es nur für einige Widgets gibt, gibt es dauch Methoden, die in allen Widgets implementiert sind. sind.

Der grösste Teil der Methoden haben Informationscharakter, d.h. sie manipulieren nichts, sondern liefern nur Werte zurück. Eine volständige Aufstellung ist in der Literatur 1. bis 3. zu finden

pack allOrdnet Widget im Windows an $widget -> pack (options);
grid all Ordnet Widget im Windows an $widget -> grid (options);
place allOrdnet Widget im Windows an $widget -> place (options);
packForget all Widget loeschen ohne zu zerstören $widget->packForget();
gridForget all Widget loeschen ohne zu zerstören $widget->gridForget();
placeForget all Widget loeschen ohne zu zerstören $widget->placeForget();
configure all Änderung der aktuellen Optionen $widget -> configure(-background=>"grey");
destroy all Zerstören eines Widgets $widget -> destroy();
bind all Verkn"pfung Erreignissfolge und Widget entry->bind(«Return>",\&checkin($textvar));
insert Text fügt Zeile ein $widget->insert('end',"Die letzte Zeile");
Listbox
delete Text löscht Zeile(n) $widget->delete( 5,10);
Listbox
select Text Auswahl von Zeile(n) $widget->select(5, 'end');
Listbox
after all Zeitverzögerung $messag -> after(2*1000, sub { exit });
repeat all wiederholtes Aufrufen einer Subroutine $widget = repeat (600,\&wieder);

9  Weitere Beispiele

Weitere Beispiele finden sich im Verzeichnis

/usr/drwho/local/pack/perl-5.004/lib/site_perl/Tk/demos/prog

Mit perl widget

erscheint ein MenueFenster, in dem man Demos für alle Widgets aufrufen kann.

( auf tardis: /usr/pack/perl-solaris260-5.6.1-ds/bin/widget )

Das folgende Beispiel enthält ein kleines Tool zur Darstellung der in X11 möglichen Farben, mit Testfeldern deren Vorder- und Hintergund durch anklicken mit der linken bzw. rechten Maustaste in der Liste gewählt werden können.




#!/usr/bin/perl -w

use Tk;
use strict;

my($r, $p);
my $fgcolor = 'black';
my $bgcolor = 'white';

my $top = MainWindow->new();
   $top -> title ("Xcolors");
   
my $frame = $top->Frame();
my $text  = $frame->Text(-wrap => 'none');

my $yscrollbar = $frame->Scrollbar(-command => [yview => $text]);

my $Buttonframe = $top -> Frame();
my $OK_Button   = $Buttonframe->Button (-text    => "Quit",
                                        -background => 'gray50',
                                        -foreground => 'white',
                                        -command => [sub{$top->destroy}]);
### Anzeige: Anzahl der Farben
my $labelvar = "";
my $label = $Buttonframe->Label(-textvariable => \$labelvar);

$text->configure(-yscrollcommand => [set => $yscrollbar]);
$text-> configure (-font => '-misc-fixed-medium-r-normal--13-100-100-100-c-80-iso8859-8' );

### Alles packen
$yscrollbar->pack(-side => 'right', -fill => 'y');

$label->pack(-fill => 'x', -side => 'right');

$frame->pack(-expand => 'yes', -fill => 'both');
$text->pack(-expand => 'yes', -fill => 'both', -side => 'left');
$Buttonframe->pack(-expand => 'yes', -fill => 'both', -side => 'bottom');
$OK_Button->pack (-side => 'left');


### Farben auslesen und Textzeilen einfaerben
open(COLORS, "< /usr/lib/X11/rgb.txt") || 
                       die "rgb.txt not found";

my ($tagname,$grauwert, $foreground);
my $i=1;
while(<COLORS>) {
    s/!.*//;          # Kommentare entfernen
    next if /^\s*$/;  # Leerzeilen ignorieren

    my ($red, $green, $blue) = split(' ', $_);
    my  $name = substr ($_,12);
       $name =~ s/^\s*//;chomp $name; 
    my $col = sprintf("#%02x%02x%02x", $red, $green, $blue);

    ### Beschriftungsfarbe weiß fuer dunkle Hintergrundfarben
    $grauwert = $red + 3*$green + $blue;
    $foreground = 'white';if ($grauwert > 625){$foreground='black'} 
    $name = substr ($name."                            ",0,20);
    
    $text->insert("end", "$name  $col  \n");  # Text in Text-Widget
                                      # einfügen (mit \n)

    ### Tag definieren und Farbe dort setzen
    $tagname = "zeile$i";
    $text->tag("add", $tagname, "$i.0", sprintf("%d.0", $i+1));
    $text->tag("configure", $tagname, -background => $col, 
                                      -foreground => $foreground);
    $text->tag("bind",$tagname,"<Button-1>"=>sub{&doit($name)});
    $text->tag("bind",$tagname,"<Button-3>"=>sub{&shiftdoit($name)});

    ### Jede neue Farbe sofort anzeigen
    $text->update();

    ### Anzeige auffrischen
    $i++;
    $labelvar="There are $i colors in /usr/lib/X11/rgb.txt      ";
}
close(COLORS);

# ------------------------------ Color Frames -----
    my $color_frame = $top -> Frame;
       $color_frame -> pack (-side => 'bottom');
    my $probe1 = $color_frame -> Text;
       $probe1 -> configure (
                             -height => '5',
                             -width  => '15',
                             -state  => 'disabled',
			     -font => '-misc-fixed-medium-r-normal--13-100-100-100-c-80-iso8859-8',
                             );
       $probe1 -> pack (qw(-side left ));
    # -----
    my $probe2 = $color_frame -> Text;
       $probe2 -> configure (
                             -height => '5',
                             -width  => '15',
                             -state  => 'disabled',
			     -font => '-misc-fixed-medium-r-normal--13-100-100-100-c-80-iso8859-8',
                             );
       $probe2 -> pack (qw(-side left ));
    # -----
    my $probe3 = $color_frame -> Text;
       $probe3 -> configure (
                             -height => '5',
                             -width  => '15',
                             -state  => 'disabled',
			     -font => '-misc-fixed-medium-r-normal--13-100-100-100-c-80-iso8859-8',
                             );
       $probe3 -> pack (qw(-side left ));
    # -----
    my $probe4 = $color_frame -> Text;
       $probe4 -> configure (
                             -height => '5',
                             -width  => '15',
                             -state  => 'disabled',
			     -font => '-misc-fixed-medium-r-normal--13-100-100-100-c-80-iso8859-8',
                             );
       $probe4 -> pack (qw(-side left ));
    # -----
    my $probe5 = $color_frame -> Text;
       $probe5 -> configure (
                             -height => '5',
                             -width  => '15',
                             -state  => 'disabled',
			     -font => '-misc-fixed-medium-r-normal--13-100-100-100-c-80-iso8859-8',
                             );
       $probe5 -> pack (qw(-side left ));

    $probe1 -> bind ("<Button-1>", sub{set_wind('1')});
    $probe2 -> bind ("<Button-1>", sub{set_wind('2')});
    $probe3 -> bind ("<Button-1>", sub{set_wind('3')});
    $probe4 -> bind ("<Button-1>", sub{set_wind('4')});
    $probe5 -> bind ("<Button-1>", sub{set_wind('5')});

# ------------------------------ Radio Button Frame -----
   my $radio_frame = $top -> Frame(-relief => "sunken");
       $radio_frame -> pack (-side => 'bottom');

   my $actw = 1;
   my $helpvar ='Left-button = background              Right-button = foreground'; 
   
   my $helplabel = $radio_frame -> Label(-textvariable => \$helpvar, -relief=>"sunken");
      $helplabel -> configure (-background=>'gray50',-foreground=>'white');
      $helplabel->pack(-side => 'top', -expand => 'x', -fill=>'x');

  foreach $p ('probe1', 'probe2', 'probe3', 'probe4', 'probe5') {
	$r = $radio_frame->Radiobutton(
            -text     => "  $p             ",
            -variable => \$actw,
            -relief   => 'flat',
            -value    => $actw++,
        );

	$r->pack(-side => 'left', -pady => '2', -anchor => 'w');
	if ($p eq 'probe1'){$r -> configure (-state => 'active')};
}
$actw =1;
$text -> configure (-state => "disabled");
MainLoop;
# --------------------------------------------------------------
sub doit {

  $bgcolor = shift;$bgcolor =~ s|\s*$||;
 if ($actw == 1) {$probe1 ->configure (-state => 'normal');
                  $probe1 -> delete ('1.0','end');
                  $probe1 -> insert ('end',"f:$fgcolor\n\n");
                  $probe1 -> insert ('end',"b:$bgcolor");
                  $probe1 -> configure (-background=>$bgcolor,-state=>'disabled')}
 if ($actw == 2) {$probe2 ->configure (-state => 'normal');
                  $probe2 -> delete ('1.0','end');
                  $probe2 -> insert ('end',"f:$fgcolor\n\n");
                  $probe2 -> insert ('end',"b:$bgcolor");
                  $probe2 -> configure (-background=>$bgcolor,-state=>'disabled')}
 if ($actw == 3) {$probe3 ->configure (-state => 'normal');
                  $probe3 -> delete ('1.0','end');
                  $probe3 -> insert ('end',"f:$fgcolor\n\n");
                  $probe3 -> insert ('end',"b:$bgcolor");
                  $probe3 -> configure (-background=>$bgcolor,-state=>'disabled')}
 if ($actw == 4) {$probe4 ->configure (-state => 'normal');
                  $probe4 -> delete ('1.0','end');
                  $probe4 -> insert ('end',"f:$fgcolor\n\n");
                  $probe4 -> insert ('end',"b:$bgcolor");
                  $probe4 -> configure (-background=>$bgcolor,-state=>'disabled')}
 if ($actw == 5) {$probe5 ->configure (-state => 'normal');
                  $probe5 -> delete ('1.0','end');
                  $probe5 -> insert ('end',"f:$fgcolor\n\n");
                  $probe5 -> insert ('end',"b:$bgcolor");
                  $probe5 -> configure (-background=>$bgcolor,-state=>'disabled')}
}
# --------------------------------------------------------------
sub shiftdoit {

 $fgcolor = shift, $fgcolor =~ s|\s*$||;
 if ($actw == 1) {$probe1 ->configure (-state => 'normal');
                  $probe1 -> delete ('1.0','end');
                  $probe1 -> insert ('end',"f:$fgcolor\n\n");
                  $probe1 -> insert ('end',"b:$bgcolor");
                  $probe1 -> configure (-foreground=>$fgcolor,-state=>'disabled')}
 if ($actw == 2) {$probe2 ->configure (-state => 'normal');
                  $probe2 -> delete ('1.0','end');
                  $probe2 -> insert ('end',"f:$fgcolor\n\n");
                  $probe2 -> insert ('end',"b:$bgcolor");
                  $probe2 -> configure (-foreground=>$fgcolor,-state=>'disabled')}
 if ($actw == 3) {$probe3 ->configure (-state => 'normal');
                  $probe3 -> delete ('1.0','end');
                  $probe3 -> insert ('end',"f:$fgcolor\n\n");
                  $probe3 -> insert ('end',"b:$bgcolor");
                  $probe3 -> configure (-foreground=>$fgcolor,-state=>'disabled')}
 if ($actw == 4) {$probe4 ->configure (-state => 'normal');
                  $probe4 -> delete ('1.0','end');
                  $probe4 -> insert ('end',"f:$fgcolor\n\n");
                  $probe4 -> insert ('end',"b:$bgcolor");
                  $probe4 -> configure (-foreground=>$fgcolor,-state=>'disabled')}
 if ($actw == 5) {$probe5 ->configure (-state => 'normal');
                  $probe5 -> delete ('1.0','end');
                  $probe5 -> insert ('end',"f:$fgcolor\n\n");
                  $probe5 -> insert ('end',"b:$bgcolor");
                  $probe5 -> configure (-foreground=>$fgcolor,-state=>'disabled')}
}
# --------------------------------------------------------------
sub set_wind { $actw = $_[0]; }

xcolors.gif


File translated from TEX by TTH, version 2.60.
On 26 Jun 2001, 10:25.