Perlseite von Christian Dühl

Rund um Perl - Allgemeines - Module - Optimierung - Snippets - Tk Snippets - Tipps zu Perl/Tk - Eigene Module - Eigene Projekte

Rund um Perl:

Online-Dokumentation - Offline-Dokumentation - Links - Tutorials - Newsgroups - Reguläre Ausdrücke - Private Perlseiten - Buchtipps - FAQ's - Perlquellen - Editoren

Online Dokumentation zu Perl:

Perl FAQ's:

Offline Dokumentation zu Perl:

Zu jeder Perlinstallation gehört eine Dokumentation, die mit dem Befehl perldoc aufgerufen werden kann.

So lässt sich zu allgemeinen Themen und auch zu installierten Modulen und Perlfunktionen Hilfe erhalten.

perldoc ist ein Kommandozeilen-Tool, das die Information aus den Modulen bzw. perlfunc extrahiert. Bei Active-State Perl wird noch ein HTML-Baum generiert unter

%PERLPATH%\html\index.html

Dieser könnte unter C:\Perl\html\ oder unter D:\Perl\html\ oder sonst irgendwo liegen, wo Sie Active-State's Perl installiert haben.

Beispiele:

  • perldoc -h gibt eine Hilfe zum Umgang mit perldoc aus. (Z.B. muss man als user root unter *nix die Option -U verwenden [eigentlich sollte man sich lieber einen Arbeitsuser anlegen und nicht als root Programme entwickeln!].)
  • perldoc perl zeigt eine Liste der Begriffe an, mit denen man perldoc füttern kann.
  • perldoc perlthrtut Hinweise zum Umgang mit threads.
  • perldoc perlfunc gibt Informationen zu den eingebauten Funktionen aus.
  • perldoc -f split gibt Informationen zur Funktion split aus.
  • perldoc perlfaq zeigt FAQ's an.
  • perldoc -q environment zeigt eine FAQ (hier zur Umgebung) an.
  • perldoc Time::Local zeigt Informationen zum angegeben Modul an.
  • perldoc perlre zeigt Hilfe zu regulären Ausdrücken an.
  • perldoc perlopentut zeigt Hilfe zum Öffnen von Dateien an.
  • perldoc -q "weird spaces"
  • perldoc -q locking zeigt Hilfe zum Locking von Dateien an.
  • perldoc perlmodlib zeigt alle Module (und Pragmas), die bei Perl schon dabei sind. Eine wichtige Lektüre, gerade auch, wenn man anderen ein Modul empfiehlt.

Tutorials / Guides:

Einige Perl Newsgroups:

Obwohl ich früher viel und gerne in Newsgroup gelesen und geschrieben habe (C / C++), muss ich sagen, dass ich mir die Perl-Newsgroups noch nicht angesehen habe, da ich im Perl-Forum der Perl-Community meine "perlische Heimat" gefunden habe.

Reguläre Ausdrücke:



Private Perlseiten:

Buchtipps:

  • Das Kamelbuch "Programmieren mit Perl" von Larry Wall, Tom Christiansen und Randal L. Schwartz bei O'Reilly.
  • "CGI Programmierung mit Perl" von Scott Guelich, Sishir Gundavaram und Gunther Birznieks bei O'Reilly.
  • "Reguläre Ausdrücke" von Jeffrey E. F. Friedl bei O'Reilly.
  • "Algorithmen mit Perl" von Jon Orwant, Jarkko Hietaniemi und John Macdonald bei O'Reilly.
  • "Einführung in Perl für Win32-Systeme" von Randal L. Schwartz, Erik Olson und Tom Christiansen bei O'Reilly.
  • "Perl Kochbuch" von Tom Christansen und Nathan Torkington bei O'Reilly.
  • "Einführung in Perl/TK" von Nancy Walsh bei O'Reilly.
    Dieses Buch gefällt mir nicht so gut wie die anderen O'Reilly Bücher, nichts desto Trotz kann man sich mit diesem Buch und den perldoc-Informationen zu den verschiedenen Tk-Widgets an die Programmierung mit Perl-Tk heranwagen.
  • "Mastering Perl/Tk" von Steve Lidie und Nancy Walsh bei O'Reilly.
    Dieses Buch habe ich selbst noch nicht gelesen, es wurde mir aber empfohlen.
  • "Professional Perl Programming" von Peter Wainwright et al. bei Wrox Press
    Dieses Buch ist mir in einer Grabbelkiste für 5 Euro in die Hände gefallen und ich bin ziemlich angetan. Allerdings habe ich bisher auch noch nicht in alle Kapitel hineinlesen können.
  • "Netzwerk-Programmierung mit Perl" von Lincoln D. Stein bei Addison-Wesley, ISBN 3-8273-1968-4, ca. 60 Euro
Dies soll keine Werbeveranstaltung für O'Reilly werden und ich bekomme auch keine Prozente - ich kann nichts dafür, dass O'Reilly so gute Bücher herrausbringt ;-)

Downloadquellen für Perl:

Editoren:

  • Komodo von ActiveState - nicht kostenlos, aber dafür sehr mächtig.
    Im Wiki der Perl-Community findet man eine längere Zusammenfassung (u.a. von mir) zu Komodo und auch viel von anderen über andere Editoren.
  • Open Perl IDE
    Diese Perl-IDE setzte ich lange ein. Sie ist zwar noch etwas buggy, aber trotzdem ein sehr schönes Werkzeug (imho). Ich habe schon eine längere Liste mit Bugs und Verbesserungsvorschlägen an den Autor geschickt, leider habe ich aber keine Antwort bekommen und es gibt auch keine neue Version... mal sehen, ob sich da noch was tut.

    Leider tat sich gar nichts, also habe ich weiter gesucht und bin so zu Komodo gekommen.
  • Proton
  • UltraEdit
  • DzSoft Perl Editor (kommerziell, für Quellcode bis 120 Zeilen frei testbar)
  • TextPad
  • Vim
  • FTE Text Editor
  • SciTE-Editor
  • Context Programmers editor
  • Emacs
  • ConTEXT

Allgemeines:

Ein Perlscript sollte mit folgenden Zeilen beginnen:

Perlscript - Anfang

#!/usr/bin/perl
use diagnostics;
use strict;
use warnings;

Damit werden Diagnosen und Warnungen angeschaltet und viele Dinge strikt gehandhabt (es müssen etwa alle Variablen mit my (oder anders) deklariert werden).
In den unten folgenden Snipptes lasse ich diese Zeilen jedoch weg, es sollen ja nur ausschnittshaft Sachverhalte verdeutlicht werden. (Auch wenn die Snippets alle ausführbar sind.)

Dadurch, dass auf die Shebang (#!/usr/bin/perl) kein -w folgt, werden die Warnungen (durch use warnings;) nur für diese Datei aktiviert, was verhindert, dass man Warnungen aus Modulen erhält, die nicht für dafür gedacht sind (etwa Tk.pm).

Zu diesem Thema gab es im Forum der Perl-Community mal eine Diskussion, in der ich die entsprechenden Stellen aus dem Kamelbuch zitiert und ein kleines Demonstrationsbeispiel gepostet habe.

Dazu braucht man zunächst einmal ein Modul, das eine Warnung auslöst, etwa dieses hier

Beweis.pm

package Beweis;
use strict;

sub drucke {
    print "undefinierter Wert im Paket : '", undef, "' :-)\n";
}

1;

und dann zwei Skripte, die einmal mit der Option -w und einmal mit use warnings; arbeiten:

beweis1.pl

#!/usr/bin/perl -w
use strict;

use Beweis;

Beweis::drucke();

beweis2.pl

#!/usr/bin/perl
use strict;
use warnings;

use Beweis;

Beweis::drucke();

Ausgabe:

C:\Daten\perl>beweis1.pl
Use of uninitialized value in print at Beweis.pm line 5.
undefinierter Wert im Paket : '' :-)

C:\Daten\perl>beweis2.pl
undefinierter Wert im Paket : '' :-)

C:\Daten\perl>

Die passenden Stellen dazu aus dem Kamelbuch lauten:

Kamelbuch, 2. Deutsche Ausgabe 2001, Kapitel 4 "Anweisungen und Deklarationen", S. 136:

Zu diesem Fehler erhalten Sie eine Warnung, wenn sie in der Kommandozeile -w oder -W angeben oder wenn sie (was die zu bevorzugende Variante ist) das später im Abschnitt "Pragmas" beschriebene use warnings verwendet haben.

Selbes Buch, gleiches Kapitel, Abschnitt "Warnungen steuern", S. 142:

Es ist aber wesentlich besser, die Pragmas use warnings und no warnings zu verwenden [als die Kommandozeilenoption -w oder die globale Variable $^W. Ein Pragma ist besser, weil es während der Kompilierung ausgeführt wird, weil es als lexikalische Deklaration keinen Code beeinflussen kann, den es nicht beeinflussen soll, und weil es eine sehr feine Kontrolle über verschiedene Klassen von Warnungen erlaubt (auch wenn Sie das bis jetzt nicht gesehen haben).

und schließlich im Kapitel 31 "Pragma-Module" auf S. 886 im Abschnitt "use warnings":

Dieses lexikalisch beschränkte Pragma erlaubt die flexible Kontrolle der in Perl eingebauten Warnungen, und zwar sowohl der Warnungen des Compilers als auch der Warnungen des Laufzeitsystems.

Es gab mal eine Zeit, da war die Kontrolle von Warnungen in Ihrem Perl-Programm nur über die Kommandozeilenoptionen -w bzw. die Variable $^W möglich. Obwohl sie nützlich waren, waren dies doch eher "Ganz-oder-gar-nicht-Ansätze". Die Verwendung der Option -w führt dazu, dass in Modulen, die Sie gar nicht geschrieben haben, Warnungen aktiviert werden, was für Sie gelegentlich problematisch und für den Autor peinlich ist.

Module:

Wenn man wissen möchte, welche Module bei der eigenen Perl-Installation dabei sind, hilft ein Blick in perldoc perlmodlib, da sind nämlich alle Module (und Pragmas) aufgeführt, die bei Perl schon dabei sind. Wichtige Lektüre, gerade auch, wenn man anderen ein Modul empfiehlt.

Einige nützliche Module:

Modul für Active-States Perl 8.X.X installieren:

Auf http://ppm.activestate.com/PPMPackages/zips/8xx-builds-only/Windows/ gibt es eine Liste aller Module von ActiveState für Perl 8.x.x.

(Die Liste, die man über http://www.activestate.com/, Klicken auf den Link unten links "Perl Modules" (der führt zur Seite http://aspn.activestate.com/ASPN/Modules), Klicken auf Language "Perl" und dann auf den Buchstaben "P" auf der Seite http://aspn.activestate.com/ASPN/Modules/Perl?module_name=P&order=name erhält ist unvollständig!)

Hat man nun herausgefunden, wie das Modul heißt (und dass es das gibt), so installiert man es so: Man öffnet eine Dos-Box und gibt dort ppm install MODULNAME ein, (beispielsweise ppm install PAR).

Verzeichnis des Moduls herausfinden:

Wie kann ein selbstgeschriebenes Modul (nennen wir es Modul.pm) herausfinden, in welchem Verzeichnis es sich befindet? Problem: $FindBin::Bin aus dem Modul FindBin gibt nur das Verzeichnis des aufrufenden Perlskripts zurück.

Lösung: Man durchsucht das Array @INC, etwa so:

Funktion finde_pfad

sub finde_pfad {
    for my $pfad (@INC) {
        return $pfad if -e "$pfad/Modul.pm";
    }
    return '.';
}

File::Find:

Mit diesem Modul kann man rekursiv Verzeichnisse suchen. Hierzu ein Beispiel, dass von allen Verzeichnissen aus, die in @INC eingetragen sind, rekursiv alle Module auflistet. (Das sind ev. mehr, als ein Perl-Programm finden könnte, da auch Unterverzeichnisse durchsucht werden, aber das Programm veranschaulicht ev. die Verwendung von File::Find.)

Näheres kann man wie immer perldoc File::Find entnehmen.

Beispiel zu File::Find

use File::Find;

my @moduleFiles = ();

find ( sub { push (@moduleFiles, $File::Find::name) if /\.pm$/ }, @INC);

print "$_\n" for @moduleFiles;

Ausgabe:

C:/Perl/lib/AnyDBM_File.pm
C:/Perl/lib/attributes.pm
C:/Perl/lib/attrs.pm
C:/Perl/lib/AutoLoader.pm
C:/Perl/lib/AutoSplit.pm
C:/Perl/lib/autouse.pm
C:/Perl/lib/B.pm
C:/Perl/lib/base.pm
C:/Perl/lib/Benchmark.pm
C:/Perl/lib/bigint.pm
C:/Perl/lib/bignum.pm
C:/Perl/lib/bigrat.pm
C:/Perl/lib/blib.pm
C:/Perl/lib/ByteLoader.pm
C:/Perl/lib/bytes.pm
C:/Perl/lib/Carp.pm
C:/Perl/lib/CGI.pm
...

Optimierung:

Die goldene Regel des Optimierens:
Optimiere nie.
Wenn du unbedingt optimieren musst, dann optimiere später.

Kommt man aufgrund zu langer Laufzeiten um das Optimieren nicht herum, so gilt zunächst, dass es meist mehr bringt, den Algorithmus zu verbessern als den verwendeten Algorithmus zu optimieren.

Hat man diesen Weg ausgeschöpft und meint immer noch, optimieren zu müssen, so sollte man zunächst mit einem Profiler feststellen, welche Funktionen den Flaschenhals darstellen und dann diese (oder die kritischen Bereiche dieser Funktionen) gezielt optimieren.

Eine Möglichkeit, dies zu tun, besteht im Einsatz von Devel::DProf. Man verwendet dann dprofpp, um die ausgegebene Datei zu analysieren.

Hierfür ruft man sein Perlprogramm einfach mit der Option -d:DProf auf:

perl5 -d:DProf test.pl

Wenn das Programm endet (oder er Ausgabepuffer gefüllt ist), wird der Profiler die Informationen in die Datei tmon.out dumpen.
Die Datei tmon.out sebst ist für den menschlichen Betrachter keine erbauliche Kost, aber mit Tools wie dprofpp lässt sich die Ausgabe in menschenlesbare Form übertragen. Der Aufruf

dprofpp

zeigt die 15 Funktionen, in denen am meisten Zeit verbraucht wurde, an.

Das Laufzeitverhalten verschiedener alternativer Codestücke lässt sich mit dem Modul Benchmark testen, wobei man darauf achten sollte, nicht nur verschiedene Codestücke zu testen, sondern auch verschiedene Eingaben. Dabei sollten möglichst solche verwendet werden, wie sie auch später im Einsatz vorkommen. Deren Häufigkeits-Verteilung sollte man bei der Anaylse der Ergebnisse dann auch berücksichtigen. Es nützt nichts, wenn der Algorithmus in fünf Prozent der vorkommenden Fälle wirklich schnell ist, aber sonst nur zäh seinen Dienst verrichtet.

Hier ein Beispiel für die Verwendung des Moduls Benchmark:

Beispiel zu Benchmark

#!/usr/bin/perl

use strict;
use Benchmark;

my @text = ('+5000*',
            'ein langer Text ohne solche Rechenoperationen...bla fasel laber schwaller sabbel erzähl ...',
            '8947573849575563542325375869676545343423232425347585764554534232432452673740-',
            '8947573849575563542325375869676545343423232425347585764554534232432452673740+',
            '8947573849575563542325375869676545343423232425347585764554534232432452673740*',
            '8947573849575563542325375869676545343423232425347585764554534232432452673740/',
            '89475738495755635423253758696765453434232324253475857645545342324324526737401',
            '-9475738495755635423253758696765453434232324253475857645545342324324526737401',
            '+9475738495755635423253758696765453434232324253475857645545342324324526737401',
            '*9475738495755635423253758696765453434232324253475857645545342324324526737401',
            '/9475738495755635423253758696765453434232324253475857645545342324324526737401',
           );

for (@text) {
    print "timethesis für '$_'\n";

    timethese(100_000, {
              A => sub {
                         if (m~(?:-|\+|\*|/)~) {}
                       },
              B => sub {
                        if (m~-~ or m~\+~ or m~\*~ or m~/~) {}
                       },
              C => sub {
                         if (m~[-+*/]~) {}
                       },
              D => sub {
                        if (m~[-]~ or m~[+]~ or m~[*]~ or m~[/]~) {}
                       },
              E => sub {
                        if (index($_, '-') > -1 or
                            index($_, '+') > -1 or
                            index($_, '*') > -1 or
                            index($_, '/') > -1) {}
                       },
             });
}

Snippets:


Ansi - Bildgröße - Data::Dumper - Encoding - Fontsuche - Hash an Funktion - Hash aus zwei Arrays - Inline C - STDOUT umleiten - Sortieren 1 - Sortieren 2 - Sortieren 3 - Sortieren 4a - Sortieren 4b - Sortieren 4c - Sortieren 4d - tail -f - Tastaturlogger - Dateien vergleichen - Zeichen überschreiben - Hash aus Datei - Schnitt von Arrays - Arraydifferenz

Die im folgenden aufgelisteten Snippets sind aufgehobene Bruchstücke aus eigener Arbeit, im Perl-Forum aufgesammelte Programmhäppchen sowie im Austausch mit anderen Perl-Programmieren erhaltene Snippets.
Einen besonders üppigen Batzen Snippets erhielt ich von Robert Winter alias Robby im Perl-Forum. Diese Snippets werde ich nach und nach zu den bereits eingefügten stellen.

  1. ansi1.pl und ansi2.pl - Beispiele zur Benutzung von Term::ANSIColor


    ansi1.pl
    use Term::ANSIColor;
    print color("red"), "Stop!\n", color("reset");
    print color("green"), "Go!\n", color("reset");

    ansi2.pl
    use Term::ANSIColor qw(:constants);
    print RED, "Stop!\n", RESET;
    print GREEN, "Go!\n", RESET;

    Ausgabe in beiden Fällen:
    
    [ESC][31mStop!
    [ESC][0m[ESC][32mGo!
    [ESC][0m

    Wenn man ansy.sys lädt, erhält man farbigen Text :)

  2. bildgroesse.pl - Mit dem Paket Image::Size (Image::Size) kann man die Größe eines Bildes in Erfahrung bringen:


    bildgroesse.pl
    use Image::Size;
    my $bild = '../ged.gif';
    my ($gx, $gy) = imgsize($bild);
    print "Das Bild '$bild' hat die Ausmaße ", $gx, "x", $gy, "\n";

    Ausgabe ist ein Zähler, der langsam hochzählt und sich dabei selbst überschreibt.

    Ausgabe:
    Das Bild '../ged.gif' hat die Ausmaße 608x527


  3. data_dumper.pl - ein Beispiel zur Benutzung von Data::Dumper


    data_dumper.pl
    use Data::Dumper;
    
    @array = (1..10, ['a'..'d']);
    
    print Dumper @array;

    Ausgabe:
    
    $VAR1 = 1;
    $VAR2 = 2;
    $VAR3 = 3;
    $VAR4 = 4;
    $VAR5 = 5;
    $VAR6 = 6;
    $VAR7 = 7;
    $VAR8 = 8;
    $VAR9 = 9;
    $VAR10 = 10;
    $VAR11 = [
               'a',
               'b',
               'c',
               'd'
             ];


  4. encoding_DOSBOX.pl - ein Beispiel zur Benutzung von Encode.

    Demonstriert die Ausgabe von Umlauten in der Commando "Dos"-Box.

    encoding_DOSBOX.pl
    use Encode;
    
    sub encprint {
        foreach (@_) {
            my $enc = encode ("cp850", $_);
            CORE::print $enc;
        }
    }
    
    my $string = "Ähndlich wärdn doiße string´ß äch öngezeicht nö ?";
    
    encprint "${string}\n";
    
    # DOS-Alt: cp437  (fuer deutschsprachiges DOS)
    # DOS-Neu: cp850
    # Windows: cp1252 (was annaehernd ISO Latin1 entspricht)

    Ausgabe:
    
    Ähndlich wärdn doiße string´ß äch öngezeicht nö ?


    Anmerkung von Christoph Bacher: "Den Effekt des encode_DOSBOX - Snippets kann man inzwischen (zumindest ab Perl 5.8, evtl. auch 5.6) einfacher haben:

    binmode(STDOUT, ":encoding(cp437)"); # MS-DOS-Codepage wg. deutschen Umlauten (OEM statt ANSI (cp1252))

    Dann tut's der normale "print" - Aufruf ohne encprint. Man kann das noch weiter treiben und den Aufruf an eine OS-Abfrage koppeln, damit ist es einfacher, portable Konsolenskripte zu erstellen."

    Anmerkung von ptk: Bei utf8-Terminals (häufig bei modernen Linux-Distributionen zu sehen) muss man entsprechend folgendes schreiben: binmode(STDOUT, ":encoding(utf-8)");.



  5. fontsuche.pl - ein Beispiel zum Suchen nach Inhalten von bestimmten Tags in Html-Quellcode.


    fontsuche.pl
    # 1. HTML-Datei zum Lesen öffnen oder Fehler ausgeben.
    #    Inhalt in @dateiinhalt speichern.
    # 2. Wenn in $dateiinhalt <font>irgendwas</font> kommt,
    #    speichere 'irgendwas' in $1 und lege es in @fonts ab,
    #    lösche den aktuellen <font></font> Block, so dass er
    #    nicht nochmal verarbeitet wird.
    
    my $datei = "fl.html";
    my @dateiinhalt;
    my @fonts;
    
    # 1.
    
    #open (HTML,"$datei") or
    #    die "Fehler beim Öffnen von '$datei': $!\n\n";
    @dateiinhalt = <DATA>; # HTML
    #close HTML or
    #    die "Fehler beim Schließen von '$datei': $!\n\n";
    
    # 2.
    
    for (@dateiinhalt) {
        while (/<font>(.*?)<\/font>/) {
                 # Tue mit $1 (= alles zwischen einem
            # <font></font> Block) irgendetwas
            push @fonts, $1;
            s/<font>$1<\/font>//g;
        }
    }
    
    print "$_\n" for @fonts;
    __DATA__
    <head>
    </head>
    <body>
    <font>TEST1</font>
    <font>TEST2</font> blubb <font>TEST3</font> laber
    grunz
    </body>

    Ausgabe:
    
    TEST1
    TEST2
    TEST3


  6. hash_an_funktion.pl - ein Beispiel zur Übergabe eines Hashs an eine Funktion.


    hash_an_funktion.pl
    sub Subroutine {
        my (%namedParams) = %{ shift() }; # () nicht vergessen!
        my ($param2, $param3) = @_;
    
        # ...
    }
    
    Subroutine( { key1 => 'value1', key2 => 'value2' }, $param2, $param3);
    

    (keine Ausgabe)

  7. hash_aus_zwei_arrays.pl - Aus zwei Arrays mit der gleichen Anzahl Elemente wird ein Hash, das erste Array liefert die Schlüssel, das zweite die Werte.

    Zu beachten: bei gleichen Schlüsseln wird der alte Wert überschrieben!

    hash_aus_zwei_arrays.pl
    # Ich habe zwei Arrays mit der gleichen Elementen-Zahl (kann mal 3,
    # aber auch mal 10 sein), nun will ich diese beiden Arrays zu einem
    # Hash machen, wobei $array1[0] der Schlüssel, und $array2[0] der Wert
    # für den Schlüssel sein soll.
    
    my @array1 = qw (a b c d e f);
    my @array2 = qw (1 2 3 4 5 6);
    
    # Möglichkeit 1:
    
    my %hash1;
    
    for my $i (0..$#array1){
        $hash1{$array1[$i]}=$array2[$i];
    }
    print "$_ => $hash1{$_}\n" for keys %hash1;
    
    
    print "\n ----\n\n";
    
    
    
    # Möglichkeit 2:
    
    my %hash2;
    
    @hash2{@array1} = @array2;
    
    print "$_ => $hash2{$_}\n" for keys %hash2;

    Ausgabe:
    
    e => 5
    c => 3
    a => 1
    b => 2
    d => 4
    f => 6
    
     ----
    
    e => 5
    c => 3
    a => 1
    b => 2
    d => 4
    f => 6


  8. inline_c.pl - ein Beispiel zur Benutzung von Inline.


    inline_c.pl
    use Inline C;
    
    my $var = shift;
    
    print +(isnum($var) ? "is a number" : "not a number"), ": $var", $/;
    
    __END__
    __C__
    
    int isnum(SV* val) {
      return Perl_looks_like_number(val);
    }

    Leider konnte ich das Beispiel nicht testen, da bei mir das Modul nicht vorhanden ist und ich es bei ActiveState auch nicht gefunden habe.

  9. redirect_STDOUT.pl - ein Beispiel zur Umleitung von STDOUT in eine Datei.


    redirect_STDOUT.pl
    #
    # Ein Beispiel dafür, wie man die Standardausgabe
    # in eine Datei umleiten kann.
    #
    
    my $file = "redirect_test.txt";
    
    open (OUT, ">$file") or
        die "Can't open file '$file': $!\n";
    
    *STDOUT = *OUT; #redirect STDOUT to PH
    
    print "TEST\n";
    
    close OUT;

    Die Ausgabe ("TEST") erfolgt in die Datei "redirect_test.txt".

  10. sort1.pl - ein Beispiel zur Sortierung eines Hashes. Hier werden die Schlüssel nach den Werten sortiert ausgegeben:


    sort1.pl
    my %liste1 = ("murks"   => "a",
                  "grumpf"  => "g",
                  "schluck" => "n",
                  "hust"    => "l",
                  "würg"    => "b",
                 );
    
    
    print join(' :: ', sort { $liste1{$a} cmp $liste1{$b} } keys %liste1), "\n";
    
    # Das Programm gibt die Schlüssel alphabetisch sortiert nach den Werten aus
    
    

    Ausgabe:
    
    murks :: würg :: grumpf :: hust :: schluck


  11. sort2.pl - noch ein Beispiel zur Sortierung eines Hashes. Hier werden einmal die Schlüssel nach den Werten sortiert und einmal die Werte nach den Werten sortiert ausgegeben:


    sort2.pl
    my @schluessel = ();
    my @werte      = ();
    my %liste1     = ("murks"   => "a",
                      "grumpf"  => "g",
                      "schluck" => "n",
                      "hust"    => "l",
                      "würg"    => "b",
                     );
    
    
    #
    # Schlüssel sortiert nach den Werten ausgeben:
    #
    print join(' :: ', (sort {$liste1{$a} cmp $liste1{$b}} keys %liste1)), "\n";
    
    #
    # Werte sortiert nach den Werten ausgeben:
    #
    print join(' :: ', (map $liste1{$_}, sort {$liste1{$a} cmp $liste1{$b}} keys %liste1)), "\n";

    Ausgabe:
    
    murks :: würg :: grumpf :: hust :: schluck
    a :: b :: g :: l :: n


  12. sort3.pl - noch ein Beispiel zur Sortierung eines Hashes.

    Das Programm gibt die Schlüssel sortiert nach den Werten aus, wobei die Werte auf folgende Weise sortiert werden:

    • Zahlen vor Alphanumerischen eintragen

    • Zahlen unter sich numerisch soriert (3 ist kleiner als 17)

    • Alphanumerische Strings unter sich alphanumerisch sortiert

    sort3.pl
    my %liste1 = ("murks"     => "a",
                  "grumpf"    => "g",
                  "schluck"   => "n",
                  "hust"      => "l",
                  "würg"      => "b",
                  "schnüffel" => "C",
                  "mecker"    => "3",
                  "argl"      => "17",
                 );
    
    sub vergl {
        my $aa = $liste1{$a};
        my $bb = $liste1{$b};
        my $a_is_number = $aa !~ /\D/;
        my $b_is_number = $bb !~ /\D/;
    
        #print "a='$a' b='$b', a_is_number='$a_is_number' b_is_number='$b_is_number'\n";
    
        return -1 if $a_is_number and not $b_is_number;
        return 1  if $b_is_number and not $a_is_number;
        return $aa <=> $bb if $a_is_number and $b_is_number;
        return lc($aa) cmp lc($bb);
    }
    
    print join(' :: ', sort vergl keys %liste1), "\n";
    
    #
    # Das Programm gibt die Schlüssel sortiert nach den Werten aus, wobei die
    # Werte auf folgende Weise sortiert werden:
    #   - Zahlen vor Alphanumerischen einträgen
    #   - Zahlen unter sich numerisch soriert (3 ist kleiner als 17)
    #   - Alphanumerische Strings unter sich alphanumerisch sortiert
    #

    Ausgabe:
    
    mecker :: argl :: murks :: würg :: schnüffel :: grumpf :: hust :: schluck


  13. sort4a.pl - ein Beispiel zur Sortierung eines Arrays nach erster und dritter Spalte.


    sort4a.pl
    my @array = ( [0,1,2,3,4],
                  [1,1,1,2,3],
                  [2,1,7,2,3],
                  [1,1,0,2,3],
                  [2,1,5,2,3],
                  [1,1,2,2,3],
                  [2,1,8,2,3],
                 );
    
    print join(' - ', @{$_}), "\n" for sort vergl @array;
    
    sub vergl {
        return -1 if $$a[0]<$$b[0];
        return  1 if $$a[0]>$$b[0];
        return -1 if $$a[2]<$$b[2];
        return  1 if $$a[2]>$$b[2];
        return  0;
    }
    
    #
    # Das Programm sortiert das Array nach der 1. und 3. Spalte
    #
    # Die Funktion vergl lässt sich auch durch
    #     {$$a[0]<=>$$b[0] || $$a[2]<=>$$b[2]}
    # ersetzen...
    #

    Ausgabe:
    
    0 - 1 - 2 - 3 - 4
    1 - 1 - 0 - 2 - 3
    1 - 1 - 1 - 2 - 3
    1 - 1 - 2 - 2 - 3
    2 - 1 - 5 - 2 - 3
    2 - 1 - 7 - 2 - 3
    2 - 1 - 8 - 2 - 3


  14. sort4b.pl - Fortsetzung des obigen Beispiels zur Sortierung eines Arrays nach erster und dritter Spalte.

    Hier wird die hinter __DATA__ angegebene Datei zunächst in ein Array eingelesen (nach dem Pipesymbol gesplittet), dann sortiert das Programm das Array nach der 1. und 3. Spalte.

    sort4b.pl
    my @array = <DATA>;
    map chomp, @array;
    map $_=[ split(/\|/, $_) ], @array;
    
    print join(' - ', @{$_}), "\n" for sort vergl @array;
    
    sub vergl {
        return -1 if $$a[0]<$$b[0];
        return  1 if $$a[0]>$$b[0];
        return -1 if $$a[2]<$$b[2];
        return  1 if $$a[2]>$$b[2];
        return  0;
    }
    
    #
    # Hier wird die hinter __DATA__ angegebene Datei zunächst in ein
    # Array eingelesen (nach dem Pipesymbol gesplittet), dann
    # sortiert das Programm das Array nach der 1. und 3. Spalte.
    #
    # Die Funktion vergl lässt sich auch durch
    #     {$$a[0]<=>$$b[0] || $$a[2]<=>$$b[2]}
    # ersetzen...
    #
    
    __DATA__
    0|1|2|3|4
    1|1|1|2|3
    2|1|7|2|3
    1|1|0|2|3
    2|1|5|2|3
    1|1|2|2|3
    2|1|8|2|3

    Ausgabe:
    
    0 - 1 - 2 - 3 - 4
    1 - 1 - 0 - 2 - 3
    1 - 1 - 1 - 2 - 3
    1 - 1 - 2 - 2 - 3
    2 - 1 - 5 - 2 - 3
    2 - 1 - 7 - 2 - 3
    2 - 1 - 8 - 2 - 3


  15. sort4c.pl - Fortsetzung des obigen Beispiels zur Sortierung eines Arrays nach erster und dritter Spalte.

    Hier wird die hinter __DATA__ angegebene Datei zunächst in ein Array eingelesen (nach dem Pipesymbol gesplittet), dann sortiert das Programm das Array nach der 1. und 3. Spalte.

    Diesmal allerdings alphanumerisch.

    sort4c.pl
    my @array = <DATA>;
    map chomp, @array;
    map $_=[ split(/\|/, $_) ], @array;
    
    print join(' - ', @{$_}), "\n" for sort vergl @array;
    
    sub vergl {
        return -1 if $$a[0] lt $$b[0];
        return  1 if $$a[0] gt $$b[0];
        return -1 if $$a[2] lt $$b[2];
        return  1 if $$a[2] gt $$b[2];
        return 0;
    }
    
    #
    # Hier wird die hinter __DATA__ angegebene Datei zunächst in ein
    # Array eingelesen (nach dem Pipesymbol gesplittet), dann
    # sortiert das Programm das Array nach der 1. und 3. Spalte.
    # (Diesmal allerdings alphanumerisch.)
    #
    # Die Funktion vergl lässt sich auch durch
    #     {$$a[0]cmp$$b[0] || $$a[2]cmp$$b[2]}
    # ersetzen...
    #
    
    __DATA__
    a|egal|c|egal|egal
    b|egal|b|egal|egal
    c|egal|h|egal|egal
    b|egal|a|egal|egal
    c|egal|f|egal|egal
    b|egal|c|egal|egal
    c|egal|i|egal|egal

    Ausgabe:
    
    a - egal - c - egal - egal
    b - egal - a - egal - egal
    b - egal - b - egal - egal
    b - egal - c - egal - egal
    c - egal - f - egal - egal
    c - egal - h - egal - egal
    c - egal - i - egal - egal


  16. sort4d.pl - obiges Beispiel nun mit "komprimierter" Vergleichsfunktion.


    sort4d.pl
    my @array = <DATA>;
    map chomp, @array;
    map $_=[ split(/\|/, $_) ], @array;
    
    
    print join(' - ', @{$_}), "\n" for sort {$$a[0]cmp$$b[0] || $$a[2]cmp$$b[2]} @array;
    
    #
    # Hier wird die hinter __DATA__ angegebene Datei zunächst in ein
    # Array eingelesen (nach dem Pipesymbol gesplittet), dann
    # sortiert das Programm das Array nach der 1. und 3. Spalte.
    #
    
    __DATA__
    a|egal|c|egal|egal
    b|egal|b|egal|egal
    c|egal|h|egal|egal
    b|egal|a|egal|egal
    c|egal|f|egal|egal
    b|egal|c|egal|egal
    c|egal|i|egal|egal

    Ausgabe:
    
    a - egal - c - egal - egal
    b - egal - a - egal - egal
    b - egal - b - egal - egal
    b - egal - c - egal - egal
    c - egal - f - egal - egal
    c - egal - h - egal - egal
    c - egal - i - egal - egal


  17. tail-f.pl - ein Beispiel, wie man Dateien anzeigen kann, in die fortlaufend andere Prozesse schreiben.


    tail-f.pl
    open (LOG, ....) or die $!;
    for (;;) {
        print <LOG>;
        sleep 1;
        seek (LOG, 0, 1);
    }

    (keine Ausgabe)

  18. tastaturlogger_win.pl - ein Beispiel zum Loggen von Tastaturanschlägen unter Windows.

    (Von JanE aus dem Perl-Forum.)

    tastaturlogger_win.pl
    # Ich gebe zu, für alle Tastatureingaben ist es umständlich, aber ich wollte
    # eigentlich nur bestimmte Tasten loggen (F12, ESC, RETURN, ...).
    # Das Beispiel habe ich jetzt kurz gemacht, es ist ohne TK, loggt die Eingaben
    # 1-0 auf der normalen Tastatur (nicht NUM) in das Textfile logfile.txt,
    # abzubrechen mit ESC.
    # Du wirst feststellen, das es immer funktioniert, auch wenn das Perlfenster
    # nicht aktiv ist.
    
    use Win32::GuiTest qw/SendKeys IsKeyPressed/;
    
    my @keys = qw/1 2 3 4 5 6 7 8 9 0/;
    my $logfile = "logfile.txt";
    
    open LOG, "> $logfile";
    until (IsKeyPressed("ESC")) {
        for (@keys) {
            if (IsKeyPressed($_)) {
                print LOG "Du hast gerade $_ gedrückt\n";
                SendKeys "{PAUSE 50}";
            }
            else {
               SendKeys "{PAUSE 20}";
            }
        }
    }
    close LOG;
    
    
    #Bitte immer mit ESC beenden,
    #
    #JanE

    Keine Ausgabe / von mir noch nicht getestet...

  19. vergleich_zweier_dateien.pl - ein Beispiel zum Vergleichen von zwei Dateien.


    vergleich_zweier_dateien.pl
    open(EINS, '<ErsteDatei.txt') or die $!;
    
    my (%pnr1, $cnt);
    
    $cnt = 0;
    
    while(<EINS>) {
        chomp;
        my @f = split(/\t/);
        $pnr1{join('|',@f[1..2])} = 1;
        ++$cnt % 1000 or print "Bei Satz $cnt.\n"
    }
    
    print "Fertig mit $cnt Saetzen.\n";
    
    close(EINS);
    
    
    open (ZWEI, '<ZweiteDatei.srt') or die $!;
    open (AUS,  '>Gefunden.txt')    or die $!;
    
    $cnt = 0;
    
    while(<ZWEI>) {
        my $vergleich = su_strip(su_strip(substr($_,67,30))."|".substr($_,157,30));
        print AUS $_ if defined $pnr1{$vergleich};
        ++$cnt % 1000 or print "Bei Satz $cnt.\n"
    }
    
    print "Fertig mit $cnt Saetzen.\n";
    
    close(ZWEI) or die $!;
    close(AUS)  or die $!;
    
    1;
    
    sub su_strip {
        my $s = shift;
        $s =~ s/\s+$//;
        $s =~ s/^\s+//;
        $s;
    }

    Auch dieses Snippet habe ich noch nicht getestet ...

  20. zeichen_ueberschreiben_DOSBOX.pl - ein Beispiel zum Überschreiben von Zeichen bei der Ausgabe in die Dos-Box.


    zeichen_ueberschreiben_DOSBOX.pl
    binmode STDOUT;
    
    $| = 1; # Windows 98 braucht das, Windows 2000 nicht.
    for (1..100)
    {
       print "$_%\r";
       sleep(1);
    }

    Ausgabe ist ein Zähler, der langsam hochzählt und sich dabei selbst überschreibt.

    Ausgabe:
    
    100%


  21. AoH_aus_Datei_aufbauen.pl - hier wird demonstriert, wie man ein Hash aus einer Datei aufbauen kann.

    Das besondere ist hier, dass die Anzahl der "Spalten" der Datei nicht feststehen, die Schlüssel des Hashes (bzw. die Spaltenüberschriften) stehen in der ersten Zeile der Datei.

    Zur Vereinfachung wird hier aus DATA statt aus einer echten Datei eingelesen. Außerdem wird die Option von Data::Dumper gezeigt, die Schlüssel von Hashes sortiert ausgibt.

    AoH_aus_Datei_aufbauen.pl
    use Data::Dumper;
    $Data::Dumper::Sortkeys = 1; # Gibt die Keys von Hashes sortiert aus beim Dumpen
    
    
    my @AoH = ();
    
    #
    # Erste Zeile einlesen und splitten,
    # Werte bilden Schlüssel des zu bildenden
    # AoH's:
    #
    my $Zeile1 = <DATA>;
    chomp $Zeile1;
    my @Keys = split / , /, $Zeile1;
    
    #
    # Restliche Datei einlesen, dabei das AoH aufbauen:
    #
    while (<DATA>) {
        chomp;
        my @Values = split / , /;
    
        die "Falsche Anzahl Elemente in Zeile $."
            if scalar @Keys != scalar @Values;
    
        # Hash aufbauen:
        my %Hash = ();
        for my $i (0..$#Keys) {
            $Hash{$Keys[$i]} = $Values[$i];
        }
    
        # Hash in AoH anhängen:
        push @AoH, { %Hash };
    }
    
    print Dumper \@AoH;
    
    __DATA__
    Datum , Verz_1 , Verz_2 , Verz_3
    1.5.03 , 15687 , 15235 , 1235
    2.5.03 , 15694 , 15300 , 1250



    Ausgabe:
    
    $VAR1 = [
              {
                'Datum' => '1.5.03',
                'Verz_1' => '15687',
                'Verz_2' => '15235',
                'Verz_3' => '1235'
              },
              {
                'Datum' => '2.5.03',
                'Verz_1' => '15694',
                'Verz_2' => '15300',
                'Verz_3' => '1250'
              }
            ];


  22. array_schnitt.pl - eine Funktion um die Schnittmenge zweier Arrays zu bilden.


    array_schnitt.pl
    my @array1 = qw/eins zwei drei   vier/;
    my @array2 = qw/null vier sieben eins/;
    
    my @schnitt = array_schnitt(\@array1, \@array2);
    
    print "@schnitt";
    
    
    sub array_schnitt ($$) {
        my $ar1 = shift;
        my $ar2 = shift;
    
        my @result = ();
    
        for my $elem (@$ar1) {
            push @result, $elem if grep $elem eq $_, @$ar2;
        }
    
        return @result;
    }


    Ausgabe:
    
    eins vier


  23. array_differenz.pl - eine Funktion um die Differenz zweier Arrays zu bilden.


    array_differenz.pl
    use Data::Dumper;
    
    sub array_differenz ($$);
    
    main();
    exit;
    
    sub main {
        my @a1 = qw/1 2 2 3 3 3 4 4 4 4/;
        my @a2 = qw/1 2 3 4/;
        my @a  = array_differenz(\@a1, \@a2);
        print "Ergebnis a:\n", Dumper \@a;
    
        print "-"x40, "\n";
    
        my @b1 = qw/eins eins zwei/;
        my @b2 = qw/eins zwei/;
        my @b  = array_differenz(\@b1, \@b2);
        print "Ergebnis b:\n", Dumper \@b;
    
        print "-"x40, "\n";
    
        my @c1 = qw/eins eins zwei/;
        my @c2 = qw/eins zwei drei/;
        my @c  = array_differenz(\@c1, \@c2);
        print "Ergebnis c:\n", Dumper \@c;
    
    } # sub main
    
    
    sub array_differenz ($$) {
        my $a1   = shift; # Array-Referenz
        my $a2   = shift; # Array-Referenz
    
        my @a1m2 = @$a1;  # Array 1 minus Array 2;
    
        for my $element (@$a2) {
            for my $index (0..$#a1m2) {
                if ($element eq $a1m2[$index]) {
                    splice @a1m2, $index, 1;
                    last;
                }
            }
        }
    
        my @a2m1 = @$a2;  # Array 2 minus Array 1;
    
        for my $element (@$a1) {
            for my $index (0..$#a2m1) {
                if ($element eq $a2m1[$index]) {
                    splice @a2m1, $index, 1;
                    last;
                }
            }
        }
    
        print "Array 1:\n", Dumper $a1;
        print "Array 2:\n", Dumper $a2;
        print "Array 1 minus Array 2:\n", Dumper \@a1m2;
        print "Array 2 minus Array 1:\n", Dumper \@a2m1;
    
    
        return (@a1m2, @a2m1);
    
    } # sub array_differenz


    Ausgabe:
    
    Array 1:
    $VAR1 = [
              '1',
              '2',
              '2',
              '3',
              '3',
              '3',
              '4',
              '4',
              '4',
              '4'
            ];
    Array 2:
    $VAR1 = [
              '1',
              '2',
              '3',
              '4'
            ];
    Array 1 minus Array 2:
    $VAR1 = [
              '2',
              '3',
              '3',
              '4',
              '4',
              '4'
            ];
    Array 2 minus Array 1:
    $VAR1 = [];
    Ergebnis a:
    $VAR1 = [
              '2',
              '3',
              '3',
              '4',
              '4',
              '4'
            ];
    ----------------------------------------
    Array 1:
    $VAR1 = [
              'eins',
              'eins',
              'zwei'
            ];
    Array 2:
    $VAR1 = [
              'eins',
              'zwei'
            ];
    Array 1 minus Array 2:
    $VAR1 = [
              'eins'
            ];
    Array 2 minus Array 1:
    $VAR1 = [];
    Ergebnis b:
    $VAR1 = [
              'eins'
            ];
    ----------------------------------------
    Array 1:
    $VAR1 = [
              'eins',
              'eins',
              'zwei'
            ];
    Array 2:
    $VAR1 = [
              'eins',
              'zwei',
              'drei'
            ];
    Array 1 minus Array 2:
    $VAR1 = [
              'eins'
            ];
    Array 2 minus Array 1:
    $VAR1 = [
              'drei'
            ];
    Ergebnis c:
    $VAR1 = [
              'eins',
              'drei'
            ];


Tk Snippets:


20 Felder - Farbwahl - Farbwahl 2 - Fenster minimieren - Grid Demo - HList Demo 1 - HList Demo 2 - HList Demo 3 - Icon 1 - Icon 2 - Key Code - LCD - Zwei Felder - Unterstrichener Labeltext - Tk::Notebook Demo - Popup-Button - Repeat/Cacel - Button erzeugen - Autocomplete - XTerm in Fenster - Fenster in Fenster
  1. tk_20felder.pl - ein Beispiel zur Verwendung von vielen Feldern.

    (Es sollten eigentlich 20 werden, es wurden dann 5, aber das Prinzip ist das Gleiche ;).

    tk_20felder.pl
    use Tk;
    
    $mw = new MainWindow;
    
    foreach (qw/Vorname Nachname Strasse PLZ Ort/) {
           $mw->Label(-text => $_)->pack();
           $mw->Entry(-textvariable => \$results{$_})->pack();
    }
    $mw->Button(-text => "Ok",
                -command => sub { print "$_ => $results{$_}\n" for keys %results })->pack();
    $mw->Button(-text => "Exit", -command => sub { exit } )->pack();
    
    MainLoop();



    Ausgabe:
    
    Ort => Stadt
    PLZ => 12345
    Strasse => XYZ Straße 123
    Vorname => Christian
    Nachname => Dühl


  2. tk_farbwahl.pl - Beispiel für ein Farbwahl-Fenster.


    tk_farbwahl.pl
    use Tk 8.0;
    use subs qw/native_optionmenu/;
    use strict;
    
    my $mw = MainWindow->new;
    
    my $palette;
    my @colors = qw/Black red4 DarkGreen NavyBlue gray75 Red Green Blue
        gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet/;
    
    my $nom = native_optionmenu(
        $mw,
        \$palette,
        [sub {print "args=@_.\n"}, 'First'],
        @colors,
    )->pack;
    my $menu = $nom->cget(-menu);
    
    my $topborder    = 'gray50';
    my $bottomborder = 'gray75';
    
    foreach my $i (0 .. $#colors) {
    
        # Create a 16 pixel x 16 pixel solid color swatch.
        # Add a black ring around the currently selected item.
    
        my $color = $menu->entrycget($i, -label);
        my $p = $mw->Photo(qw/-width 16 -height 16/);
        $p->put($topborder,    qw/-to  0  0 16  1/);
        $p->put($topborder,    qw/-to  0  1  1 16/);
        $p->put($bottomborder, qw/-to  1 15 16 16/);
        $p->put($bottomborder, qw/-to 15  1 16 15/);
        $p->put($color,        qw/-to  1  1 15 15/);
    
        my $r = $mw->Photo(qw/-width 16 -height 16/);
        $r->put(qw/black          -to  0  0 16  2/);
        $r->put(qw/black          -to  0  2  2 16/);
        $r->put(qw/black          -to  2 14 16 16/);
        $r->put(qw/black          -to 14  2 16 14/);
        $r->put($color       , qw/-to  2  2 14 14/);
    
        $menu->entryconfigure($i, -columnbreak => 1) unless $i % 4;
        $menu->entryconfigure($i,
            -image       => $p,
            -hidemargin  => 1,
            -selectimage => $r,
        );
    
    }
    
    $menu->configure(-tearoff => 1);
    
    $menu->bind('<<MenuSelect>>' => sub {
        my $label = undef;
        my $w = $Tk::event->W;
        Tk::catch {$label = $w->entrycget('active', -label)};
        print "palette=$palette, menu label=$label!\n" if defined $label;
    });
    
    MainLoop();
    
    sub native_optionmenu {
    
        my($parent, $varref, $command, @optionvals) = @_;
    
        $$varref = $optionvals[0];
    
        my $mb = $parent->Menubutton(
            -textvariable       => $varref,
            -indicatoron        => 1,
            -relief             => 'raised',
            -borderwidth        => 2,
            -highlightthickness => 2,
            -anchor             => 'c',
            -direction          => 'flush',
        );
        my $menu = $mb->Menu(-tearoff => 0);
        $mb->configure(-menu => $menu);
    
        my $callback = ref($command) =~ /CODE/ ? [$command] : $command;
    
        foreach (@optionvals) {
        $menu->radiobutton(
                -label     => $_,
                -variable  => $varref,
                -command   => [@$callback, $_],
            );
        }
    
       $mb;
    
    } # end native_optionmenu



  3. tk_farbwahl2.pl - Zweites Beispiel für ein Farbwahl-Fenster.

    tk_farbwahl2.pl
    #!/usr/bin/perl
    use Tk;
    $mw = new MainWindow;
    $mw->chooseColor(-title => 'Farbe wählen');



  4. tk_fenster_minimiert.pl - das Programm gibt seinen Status auf der Standardausgabe aus, je nachdem, ob es gerade minimiert ist oder nicht.


    tk_fenster_minimiert.pl
    use Tk;
    
    my $mw = MainWindow->new (-title => "Hello");
    $mw->Label (-text => 'Hello, world!')->pack;
    
    $mw->repeat (1000,
        sub { print ($mw->ismapped ? "Bin da!\n" : "Bin weg.\n") }
    );
    
    MainLoop();



    Ausgabe:
    
    Bin da!
    Bin weg.
    Bin weg.
    Bin da!
    Bin da!
    Bin weg.
    Bin weg.
    Bin weg.
    Bin weg.
    Bin da!
    Bin da!
    Bin da!
    Bin weg.
    Bin weg.
    Bin da!
    Bin da!


  5. tk_griddemo.pl - ein Beispiel zur Benutzung des Packers Grid.


    tk_griddemo.pl
    use Tk;
    
    $mw = new MainWindow;
    
    my %vars;
    
    foreach(qw/An: Von: Betreff:/) {
        $mw->Label(-text => $_)->grid($mw->Entry(-textvariable => \$vars{$_}));
    }
    
    $mw->Button(-text    => 'send',
                -command => sub { print "$_ ->> $vars{$_}\n" for keys %vars; })
         ->grid();
    
    MainLoop();



    Ausgabe:
    
    Von: ->> Crian
    Betreff: ->> Test des Snippets
    An: ->> Clia


  6. tk_hlist.pl - ein Beispiel zur HList.


    tk_hlist.pl
    use Tk;
    use Tk::HList;
    use Tk::ItemStyle;
    my ($l, $zeile);
    my @tete = ('aaa'..'aaz');
    $zeile = 3;
    my $mw = new MainWindow;
    my $hl = $mw->HList(-width => 50,
                        )->pack();
    my $style = $hl->ItemStyle('text',
                               -foreground => '#FF0000',
                               -selectforeground => '#FF0000'
                               );
    for (1..$#tete) {
        $l = $hl->addchild('');
        $hl->itemCreate($l, 0, -itemtype => 'text',
                               -style => ( $_ % $zeile) ? '' : $style,
                               -text => $tete[$_ - 1]
                       );
    }
    MainLoop();



  7. tk_hlist2.pl - ein zweites Beispiel zur HList.


    tk_hlist2.pl
    use Tk;
    use Tk::HList;
    
    $top = new MainWindow;
    
    $hlist = $top->Scrolled("HList",
                -header => 1,
                -columns => 4,
                -scrollbars => 'osoe',
                -width => 70,
                -selectbackground => 'SeaGreen3',
                   )->pack(-expand => 1, -fill => 'both');
    
    $hlist->header('create', 0, -text => 'From');
    $hlist->header('create', 1, -text => 'Subject');
    $hlist->header('create', 2, -text => 'Date');
    $hlist->header('create', 3, -text => 'Size');
    
    $hlist->add(0);
    $hlist->itemCreate(0, 0, -text => "test\@email.de");
    $hlist->itemCreate(0, 1, -text => "Re: HList?");
    $hlist->itemCreate(0, 2, -text => "1999-11-20");
    $hlist->itemCreate(0, 3, -text => "1432");
    
    $hlist->add(1);
    $hlist->itemCreate(1, 0, -text => "dummy\@foo.com");
    $hlist->itemCreate(1, 1, -text => "Re: HList?");
    $hlist->itemCreate(1, 2, -text => "1999-11-21");
    $hlist->itemCreate(1, 3, -text => "2335");
    
    MainLoop();



  8. tk_hlist3.pl - ein drittes Beispiel zur HList.

    In diesem Beispiel werden sortierende Buttons in der Titelleite der HList demonstriert.

    tk_hlist3.pl
    #!/usr/bin/perl
    use strict;
    use warnings;
    use Tk;
    use Tk::HList;
    use Tk::ItemStyle;
    
    my $mw = MainWindow->new();
    my $hlist = $mw->Scrolled("HList",
                              -header           => 1,
                              -columns          => 4,
                              -scrollbars       => 'osoe',
                              -width            => 70,
                              -selectbackground => 'SeaGreen3',
                              )
                        ->pack();
    
    
    my $headerstyle = $hlist->ItemStyle('window',
                                        -padx   => 0,
                                        -pady   => 0,
                                       );
    
    my $btn_from = $hlist->Button(-text => 'From',    -relief => 'flat', -command => [ \&MyTk::HList::order, 0, 0 ]);
    my $btn_subj = $hlist->Button(-text => 'Subject', -relief => 'flat', -command => [ \&MyTk::HList::order, 1, 0 ]);
    my $btn_date = $hlist->Button(-text => 'Date',    -relief => 'flat', -command => [ \&MyTk::HList::order, 2, 0 ]);
    my $btn_size = $hlist->Button(-text => 'Size',    -relief => 'flat', -command => [ \&MyTk::HList::order, 3, 1 ]);
    
    $hlist->header('create', 0, -itemtype => 'window', -widget => $btn_from, -style => $headerstyle);
    $hlist->header('create', 1, -itemtype => 'window', -widget => $btn_subj, -style => $headerstyle);
    $hlist->header('create', 2, -itemtype => 'window', -widget => $btn_date, -style => $headerstyle);
    $hlist->header('create', 3, -itemtype => 'window', -widget => $btn_size, -style => $headerstyle);
    
    my @mails = (['test@email.de',  'Re:HList?',       '1999-11-20', '1432'],
                 ["dummy\@foo.com", "Re: HList?",      "1999-11-21", "2335"],
                 ['abc@foo.com', 'Re: Re: HList xxx?', '2004-10-12',  '965'],
                );
    
    for my $index (0..$#mails) {
        $hlist->add($index);
        for my $textin (0..scalar(@{$mails[$index]}-1)) {
            $hlist->itemCreate($index, $textin,
                               -text => $mails[$index]->[$textin],
                              );
        }
    }
    
    MainLoop();
    
    
    # -----------------------------------------------------------------------------
    
    package MyTk::HList;
    
    my $last_btn;
    my $switch;
    
    BEGIN {
        $last_btn = -1;
        $switch   = 0;
    }
    
    sub order {
        my ($which, $numorder) = @_;
    
        $hlist->delete('all');
    
        my @sorted_mails = $numorder
                               ? sort{$a->[$which] <=> $b->[$which]} @mails
                               : sort{$a->[$which] cmp $b->[$which]} @mails;
    
        if ($which == $last_btn) {
            $switch       = 1 if $switch == 0;
            $switch       = -$switch;
            @sorted_mails = reverse @sorted_mails if $switch == -1;
        }
        else {
            $last_btn = $which;
            $switch   = 0;
        }
        
        for my $index(0..$#sorted_mails) {
            $hlist->add($index);
            for my $textin(0..scalar(@{$sorted_mails[$index]}-1)) {
                $hlist->itemCreate($index, $textin,
                                   -text => $sorted_mails[$index]->[$textin],
                                  );
            }
        }
    }



  9. tk_icon1.pl - ein Beispiel zur Einbindung eines eigenen Icons in das Tk-Programm.


    tk_icon1.pl
    use Tk;
    
    $mw = MainWindow->new( -height => 450, -width => 780);
    $main_icon = $mw->Photo( -file => "icon.bmp" );
    $mw->Icon( -image => $main_icon );
    $mw->title( 'test');
    
    
    my $Label0 = $mw->Label(
                             -text => "Suchen ...",
                             -anchor => "nw"
                             );
    $Label0->place( -x => 10, -y => 10, -height => 20, -width => 140);
    
    
    
    MainLoop();

    Mangels Icon nicht getestet... kommt vielleicht noch :)

  10. tk_icon2.pl - ein zweites Beispiel zur Einbindung eines eigenen Icons in das Tk-Programm.


    tk_icon2.pl
    use Tk;
    
    my $mw = MainWindow->new( -height => 40, -width => 70);
    $mw->title( 'tk_icon2');
    
    
    my $Label0 = $mw->Label(
                             -text => "Suchen ...",
                             -anchor => "nw"
                             );
    $Label0->place( -x => 10, -y => 10, -height => 20, -width => 140);
    
    my $xpm = <<'END';
    /* XPM */
    static char *test[]={
    "32 32 11 1",
    ". c None",
    "# c #000000",
    "h c #004000",
    "g c #004040",
    "f c #404000",
    "e c #808080",
    "i c #a0a0a4",
    "c c #c0c000",
    "d c #ffff00",
    "b c #ffffc0",
    "a c #ffffff",
    "................................",
    "................................",
    "................................",
    "................................",
    ".............#....###...........",
    "............#a##.#aba##.........",
    "...........#aaaa#aaaaaa##.......",
    "..........#aaaa#aaaaaaaba##.....",
    ".........#aaaa#aaaaaaaaaaab##...",
    "........#aaba#aaaaaaabaabaaaa##.",
    ".......#aaba#baaaaa#baaaaaabaaa#",
    "......#aaaa#aaaaab#a##baaaaaaa#.",
    ".....#aaba#aacbba#aaaa##baaab#..",
    "....#bbaa#abaacc#aaaaaaa##aa#...",
    "...#bbbb#aaabaa#aaabaaaaaa##....",
    "..#bbbb#bacaaa#aaaaaaaabaaaa##..",
    ".#bbbb#bbaacc#aacaaaaaaaaaaaba#.",
    "#ddbb#bbbbba#aaaaccaaaaaaaaaaaa#",
    "#edddfgcbbbfaacaaaaccaaaaaaaaa#e",
    ".#hedddfhcfabaaccaaabccaaaaaa#e.",
    "...##edddhaacbbaaccbaaaccaab#i..",
    ".....##e#baaaccabaaccbaabaa#i...",
    "......##bacbaabccbaaaccabb#e....",
    "......#bbbbccaabbccaaaaab#i.....",
    ".....#bbbbbbbccabbaccaab#i......",
    ".....#ebbbbbbbbccbaabba#i.......",
    "......##ebbbbbbbbccaabhe........",
    "........##ebbbbbbbbbb#e.........",
    "..........##ibbbbbbbhe..........",
    "............##ebbbb#e...........",
    "..............#hee#i............",
    "................##i............."};
    END
    
    my $bitmap = $mw->Pixmap(-data => $xpm); # oder -file=> $file
    $mw->Icon(-image => $bitmap);
    MainLoop();



  11. tk_key-code.pl - ein Beispiel wie man die Tk-Key-Codes erhält.


    tk_key-code.pl
    use Tk;
    
    my $mw = MainWindow->new;
    $mw->bind("<Key>", [ sub { print "Taste : '$_[1]'\n" }, Ev('K') ] );
    # oder auch Ev('k') mit kleinem K
    MainLoop();

    Ein leeres Tk-Fenster erscheint, die Ausgabe zu den gedrückten Tasten erscheint auf der Standardausgabe.

  12. tk_lcd.pl - ein Beispiel zur Benutzung von Tk::LCD.


    tk_lcd.pl
    use Tk;
    use Tk::LCD;
    
    my $mw = MainWindow->new;
    my $frog = 99 + 1;
    my $lcd = $mw->LCD(
               -elements => 3,
               -onoutline => 'yellow',
               -onfill => 'purple',
               -variable => \$frog,
    );
    $lcd->pack;
    my $lcd2 = $mw->LCD(-elements => 6);
    $lcd2->pack;
    
    while ($frog >= -9) {
        $mw->after(100);
        $frog--;
        $lcd2->set($frog);
        $mw->update;
    }

    Ungetestet in Ermangelung des Pakets...

  13. tk_zweitextfelder.pl - ein Beispiel zur Benutzung von gemeinsam gesteuerten Feldern. Es ist noch nicht perfekt, aber ein Anfang.


    tk_zweitextfelder.pl
    use Tk;
    
    my $mw = MainWindow->new();
    
    my $fr = $mw->Frame();
    
    my $scrollx = $fr->Scrollbar(-orient => 'horizontal');
    my $scrolly = $fr->Scrollbar();
    
    my $ltext = $fr->Text(-width          =>  5,
                          -height         => 30,
                          -wrap           => 'none',
                          -background     => 'black',
                          -foreground     => 'green',
                          -borderwidth    => 0,
                          -selectbackground     => 'white',
                          -selectforeground     => 'blue',
                          -insertbackground => 'red',
                         );
    
    my $rtext = $fr->Text(-width          => 80,
                          -height         => 30,
                          -wrap           => 'none',
                          -xscrollcommand => ['set' => $scrollx],
                          -yscrollcommand => ['set' => $scrolly],
                          -background     => 'lightgreen',
                          -foreground     => 'black',
                          -selectbackground     => 'black',
                          -selectforeground     => 'orange',
                          -borderwidth    => 0,
                         );
    
    $scrollx->configure(-command => ['xview' => $rtext]);
    
    
    # Den Scrollbalken so konfigurieren, dass er alle Listboxen scrollt:
    $scrolly->configure(-command => sub {$ltext->yview(@_);
                                         $rtext->yview(@_);
                                        }
                       );
    
    # Diese Methode wird aufgerufen, wenn eine der Textboxen mit der Tastatur
    # gescrollt wird. Sie sorgt dafür, dass der Scrollbalken die Veränderung
    # wiedergibt und die andere Textbox mitgescrollt werden.
    sub scroll_textboxen {
        my ($text, $textboxes, @args) = @_;
        $scrolly->set(@args);                  # Dem Scrollbalken mitteilen,
                                               # was angezeigt wird
        my ($top, $bottom) = $text->yview();   # Ausschnitt des gescrollten
                                               # Textfeldes auslesen
        for my $t (@$textboxes) {              # Alle Textboxen auf diesen Aus-
            $t->yviewMoveto($top);             # schnitt setzen.
        }
    } # sub scroll_listboxes
    
    $ltext->configure(-yscrollcommand => [ \&scroll_textboxen,
                                           $ltext,
                                           [$ltext, $rtext],
                                         ]
                     );
    $rtext->configure(-yscrollcommand => [ \&scroll_textboxen,
                                           $rtext,
                                           [$ltext, $rtext],
                                         ]
                     );
    
    $scrollx->pack(-side => 'bottom',
                   -fill => 'x',
                  );
    $scrolly->pack(-side => 'right',
                   -fill => 'y',
                  );
    $ltext->pack(-side => 'left',
                 -fill => 'y',
                );
    $rtext->pack(-side   => 'left',
                 -fill   => 'both',
                 -expand => 1,
                );
    
    
    $fr->pack(-side   => 'left',
              -fill   => 'both',
              -expand => 1,
             );
    
    for (1..200) {
        $_ = ' ' x (5-length($_)) . $_;
        $ltext->insert('end', "$_\n");
        $rtext->insert('end', $_ x 50 . "\n");
    }
    $ltext->insert('end', "  201");
    $rtext->insert('end', "  201" x 50);
    
    $ltext->focus();
    
    MainLoop();



  14. tk_underline_label.pl - ein Beispiel zur Benutzung von unterstrichenen Labeln.


    tk_underline_label.pl
    #!/usr/bin/perl
    use strict;
    use Tk;
    
    my $mw = MainWindow->new();
    my $lb = $mw->Label(-font => '{Arial} 8 {underline}',
                        -text => 'Schöner unterstrichener Text',
                       )
                 ->pack(-expand => '1',
                        -fill   => 'x',
                        -side   => 'top',
                       );
    my $ok = $mw->Button(-text        => 'OK',
                         -command     => sub { $mw->destroy() },
                         -default     => 'active',
                         -padx        => 15,
                        )
                  ->pack(-expand => '1',
                         -fill   => 'x',
                         -side   => 'bottom',
                        );
    
    MainLoop();



  15. tk_bind.pl - ein Beispiel zur Benutzung von Bindungen (an Hand von Buttons).


    tk_bind.pl
    use Tk;
    
    my $mw = new MainWindow;
    
    foreach my $text (qw/eins zwei drei/) {
        my $b = $mw->Button(-text    => "Button Nr. $text",
                            -command => sub { print "bzzzzzzzzz $text\n" },
                           )
                     ->pack(-fill => 'x');
        $b->bind('<ButtonPress>'   => [ \&printButtonLabel, $text, "gedrueckt" ] );
        $b->bind('<ButtonRelease>' => [ \&printButtonLabel, $text, "losgelassen" ] );
    }
    
    MainLoop();
    
    sub printButtonLabel ($$$) {
        my $widget     = shift;
        my $text       = shift;
        my $anhang     = shift;
        my $aufschrift = $widget->cget('-text');
    
    
        print "Button: $text (Aufschrift '$aufschrift') $anhang\n";
    }



    Ausgabe:
    
    Button: eins (Aufschrift 'Button Nr. eins') gedrueckt
    bzzzzzzzzz eins
    Button: eins (Aufschrift 'Button Nr. eins') losgelassen
    Button: zwei (Aufschrift 'Button Nr. zwei') gedrueckt
    Button: zwei (Aufschrift 'Button Nr. zwei') losgelassen
    Button: drei (Aufschrift 'Button Nr. drei') gedrueckt
    bzzzzzzzzz drei
    Button: drei (Aufschrift 'Button Nr. drei') losgelassen

    Wie man sieht, verhalten sich die drei gebundenen Ereignisse unterschiedlich. Das per ButtonPress gebundene Event wird sofort aufgerufen, wenn auf den Button geklickt wird, das per ButtonRelease gebundene Event wird dann ausgeführt, wenn der Mausknopf losgelassen wird, unabhängig davon, wo sich der Cursor befindet. Der per -command angegebene Callback wird beim Loslassen der Maustaste ausgeführt, falls sich der Cursor noch über dem Button befindet.

    So kann mit ButtonPress und ButtonRelease etwa eine "Drag and Paste" Funktionalität nachgebildet werden, was per -command nicht möglich ist. Dafür bietet letztere Möglichkeit die sichere Behandlung von "der Benutzer hat auf den Button gedrückt".

    Weiteres zum Thema Bindungen erfährt man hier: Tk-Bindungen

  16. tk_notebook.pl - ein Beispiel zur Benutzung des Tk::Notebooks.


    tk_notebook.pl
    use Tk;
    use Tk::NoteBook;
    
    my $mw = new MainWindow;
    
    my $nb = $mw->NoteBook()->pack();
    
    my $page1 = $nb->add('PageID-1', -label => 'ReiterEins');
    my $page2 = $nb->add('PageID-2', -label => 'ReiterZwei');
    
    $page1->Label(-text => 'In Seite 1')->pack();
    $page2->Label(-text => 'In Seite 2')->pack();
    
    MainLoop();



  17. tk_popupbutton.pl - ein Beispiel zur Erzeugung eines Popup-Buttons.


    tk_popupbutton.pl
    # Modul Tk/ButtonPopup.pm:
    
    package Tk::PopupButton;
    
    use strict;
    use warnings;
    
    use Tk::Frame;
    use Tk::Button;
    
    our @ISA = qw/Tk::Frame/;
    
    Construct Tk::Widget 'PopupButton';
    
    
    sub Populate ($$) {
        my $w    = shift;
        my $args = shift;
    
        my $menu = delete $args->{-menu};
    
        my $m = $w->Menu(-tearoff => 0,
                         -menuitems => $menu,
                        );
    
        $w->SUPER::Populate($args);
    
        my $b  = $w->Button(-relief => 'groove',
                           )
                     ->pack(-side   => 'left',
                           );
        my $ba = $w->Button(-image  => $w->Bitmap(-file =>
                                       Tk->findINC('cbxarrow.xbm')),
                           )
                     ->pack(-side   => 'left',
                            -fill   => 'y',
                           );
    
        $ba->bind('<ButtonPress-1>' => [\&popup, $m] );
    
        $w->ConfigSpecs(DEFAULT => [$b]);
    
    } # sub Populate
    
    
    sub popup {
        my $w = shift;
        my $m = shift;
    
        $m->Popup(-popover => "cursor",
                  -popanchor => 's',
                 );
    } # sub popup
    
    1;
    
    
    
    # Hauptprogramm:
    
    package main;
    
    use strict;
    use warnings;
    
    
    use Tk;
    #use Tk::PopupButton; # anschalten, wenn Paket in Extradatei
    
    my $mw = new MainWindow;
    
    my $menu = [
                [
                 'command' => 'Funktion1',
                 -command  => sub { print "Funktion1\n"; },
                ],
                [
                 'command' => 'Funktion2',
                 -command  => sub { print "Funktion2\n"; },
                ],
               ];
    
    $mw->PopupButton(-text => 'weitere Funktionen...',
                     -menu => $menu
                    )->pack();
    
    MainLoop();



  18. tk_repeat_und_cancel.pl - ein Beispiel zum An- und Abschalten von Wiederholungen.


    tk_repeat_und_cancel.pl
    use Tk;
    
    my $mw = new MainWindow;
    
    my $b = $mw->Button(-text => 'Run')->pack(-fill => 'x');
    
    my $id;
    my $i;
    
    $b->bind('<ButtonPress-1>' => sub { $i = 0;
                                        $id = $mw->repeat(2, sub {print ++$i, "\n"}) } );
    $b->bind('<ButtonRelease-1>' => sub { $id->cancel() } );
    
    MainLoop();
    



    Ausgabe:
    
    1
    2
    3
    4
    5
    1
    2
    3
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    1
    2


  19. tk_button_erzeugen.pl - ein Beispiel zur Erzeugen von neuen Buttons auf Knopfdruck.


    tk_button_erzeugen.pl
    use Tk;
    
    my $mw = new MainWindow;
    
    my $Count = 0;
    
    $mw->Button(-text    => "Button\nerzeugen",
                -command => \&button_erzeugen,
               )
        ->pack(-side    => 'right',
               -expand  => 1,
               -fill    => 'both',
              );
    
    MainLoop();
    
    sub button_erzeugen {
        ++$Count;
        $mw->Button(-text    => "erzeugter\nButton\n" . $Count,
                   )
             ->pack(-side    => 'left',
                    -expand  => 1,
                    -fill    => 'both',
                   );
    }



  20. tk_autocomplete.pl - ein Beispiel für Autocomplete von Dateinamen in einem Editfenster (wie unter Linux in der bash üblich).


    tk_autocomplete.pl
    use Tk;
    
    my $mw = new MainWindow;
    $mw->title('Autovervollständigung');
    
    
    my $e = $mw->Entry(-text    => '',
                       -width   => 80,
                      )
                ->pack(
                       -expand  => 1,
                       -fill    => 'x',
                      );
    
    $mw->bind ('<Tab>', \&vervollstaendige );
    
    
    $e->focus();
    MainLoop();
    
    sub vervollstaendige {
        my $text = $e->get();
        print $text, "\n";
        my @treffer;
    
        my ($pfad, $trenner, $anf) = $text =~ m~^(.*)([/\\])([^/\\]*)$~;
        print "pfad='$pfad', Anfang='$anf'\n";
    
        if (! -d $pfad) {
            print "'$pfad' ist kein Verzeichnis, Abbruch\n";
        }
        else {
            opendir PFAD, "$pfad/" or die "Kann Verzeichnis '$pfad' nicht öffnen: $!";
            my @verzeichnisse = grep -d "$pfad/$_", readdir PFAD;
            closedir PFAD;
    
            for my $v (@verzeichnisse) {
                print "Verzeichnis '$v'\n";
                if ($v =~ /^\Q$anf/i) { # bei Linux/Unix das i entfernen!
                    print "Anfang '$anf' passt auf '$v'\n";
                    push @treffer, $v;
                }
            }
        }
    
        $e->delete(0, 'end');
    
        if (scalar(@treffer) == 1) {
            $e->insert('end', "$pfad$trenner$treffer[0]");
        }
        else {
            $e->insert('end', "$pfad$trenner$anf");
        }
    
        $e->selectionClear();
        $e->icursor('end');
    
        $e->configure(state => 'disable');
        $e->configure(state => 'enable');
        $e->focus();
    } # sub vervollstaendige



  21. tk_xterm_in_tk.pl - ein Beispiel zur Darstellung eines XTerms in einem Tk-Programm.


    tk_xterm_in_tk.pl
    #!/usr/bin/perl
    #
    # This is just a simple demo of how to embed an xterm into a Tk application.
    # This one puts it into a canvas, which opens the possibilities of using
    # various backgrounds. I got the idea from a posting on the Tk::Zinc maillist
    # by Christophe Mertz.
    #
    # von zentara (Perlmonks)
    # "schön" gemacht von Crian
    #
    # Siehe thread http://www.perlmonks.org/index.pl?node_id=359764 .
    #
    
    use strict;
    use warnings;
    use Tk;
    
    # Idea ripped from a script by Christophe Mertz of the
    # Tk::Zinc module, to work with a plain canvas.
    # The Zinc module has much more flexibility in how
    # you can hide windows. I had to mask the xterm with a
    # toplevel to hide it in the plain old canvas.
    #
    
    my $mw = new MainWindow;
    
    my $canv = $mw->Canvas(-bg     => 'lightsteelblue',
                           -relief => 'sunken',
                           -width  => 550,
                           -height => 350,
                          )
                    ->pack(-expand => 1,
                           -fill   => 'both',
                          );
    
    my $xtermWidth  = 400;
    my $xtermHeight = 300;
    
    ## this Frame is needed for including the xterm in Tk::Canvas
    my $xtermContainer = $canv->Frame(-container => 1);
    my $xtid = $xtermContainer->id();
    # converting the id from HEX to decimal as xterm requires a decimal Id
    my ($xtId) = sprintf hex $xtid;
    
    my $dcontitem = $canv->createWindow(275, 175,
                                        -window => $xtermContainer,
                                        -width  => $xtermWidth+100,
                                        -height => $xtermHeight,
                                        -state  => 'normal',
                                       );
    
    my $label = $canv->createText(275, 10,
                                  -text => "Hide xterm",
                                 );
    
    $canv->Tk::bind("<Button-1>", \&hide_show);
    
    my $width  = $xtermWidth;
    my $height = $xtermHeight;
    
    $mw->Button(-text    => 'Exit',
                -command => [ sub{ Tk::exit } ],
               )
         ->pack();
    
    my $tl;  #used to mask xterm
    system("xterm -into $xtId &");
    
    
    MainLoop();
    
    
    # -----------------------------------------------------------------------------
    sub hide_show {
        if ($canv->itemcget($label, -text) =~ /Hide/) {
                 $canv->itemconfigure($label,
                        -fill => 'white',
                        -text => "Show xterm");
    
                 $tl = $mw->Toplevel(-use=>$xtId );
               } else {
                 $canv->itemconfigure($label,
                        -fill => 'black',
                        -text => "Hide xterm");
                 $tl->withdraw;
            }
    } # sub hide_show
    # -----------------------------------------------------------------------------


  22. tk_fnstr_in_fnstr.pl - ein Beispiel zur Benutzung von Tk-Fenstern in Tk-Fenstern.


    Leider funktioniert es nur unter Linux, nicht unter Windows.

    tk_fnstr_in_fnstr.pl
    #!/usr/bin/perl
    use strict;
    use warnings;
    use Tk;
    
    pipe(RDR,WTR);
    if (fork == 0) {
       close WTR;
       chomp(my $id = scalar <RDR>);
       close RDR;
       my $mw2 = MainWindow->new(-use => $id);
       $mw2->Label(-text => "Das andere Fenster")->pack();
       MainLoop();
       CORE::exit();
    }
    
    close RDR;
    my $mw = new MainWindow;
    $mw->Label(-text => "Hier kommt das eingebettete Fenster:")->pack();
    my $f  = $mw->Frame(-container => 1)->pack();
    my $id = $f->id;
    $mw->update; # wichtig, Fenster muss gemappt sein!
    print WTR "$id\n";
    close WTR;
    MainLoop();


Tipps und Tricks zu Perl/Tk:


Fenster zentrieren - Ohne Dosfenster - Nicht schließen - Quasiblockieren - Waitcursor - Tk-Dosfenster öffnen
  1. Eine Anleitung zum Zentrieren des Tk-Fensters:


    Tk-Fenster zentrieren
    my     $MamaGUI = new MainWindow( -title => "Mein Programm");
    
    # Größe des Fensters:
    my      $windowHeight       = "600";
    my      $windowWidth        = "800";
    
    # Bildschirmgröße holen:
    my      $screenHeight       = $MamaGUI->screenheight;
    my      $screenWidth        = $MamaGUI->screenwidth;
    
    # MamaGUI zentrieren:
    $MamaGUI->geometry($windowWidth."x".$windowHeight);
    $MamaGUI->geometry("+" .
                       int($screenWidth/2 - $windowWidth/2) .
                       "+" .
                       int($screenHeight/2 - $windowHeight/2)
                      );
    
    # minimale Größe festlegen:
    $MamaGUI->minsize( 400, 300);


  2. "Dosfenster" der Tk-Anwendung unter Windows verstecken:


    Tk-Dos-Fenster verstecken
    use Win32::GUI;
    
    #beim Programmstart:
    
    my ($DOS) = Win32::GUI::GetPerlWindow();
    Win32::GUI::Hide($DOS);
    
    #und nach dem MainLoop():
    
    Win32::GUI::Show($DOS);

    Bei der Perldistribution von Active-State kann man statt dessen auch das Script mit der mitgelieferten wperl.exe starten, dann erhält man auch kein Dosfenster.
    Dies lässt sich auch in Verknüpfungen auf der Windowsoberfläche so eintragen.

    Wenn man aber nicht dauernd wperl.exe script.pl ausführen möchte, kann man unter WinNT/2000/XP folgendes machen:


    1. Script in script.ptk umbenennen

    2. in der shell eingeben:

      assoc .ptk=Perl-Tk
      ftype Perl-Tk="c:\perl\bin\wperl.exe" "%1" %*

    (eventuell muss der Pfad zur Perlinstallation angepasst werden). Dann klappt's auch ohne wperl vorher (oder z.B. auch mit Doppelklick auf den Dateinamen).

  3. Fenster-Schließen abfangen:

    (von Strats Seite mit Einverständnis)

    Fenster-Schließen abfangen
    #!/usr/bin/perl
    use strict;
    use Tk;
    
    my $mw = MainWindow->new();
    $mw->protocol('WM_DELETE_WINDOW', \&ExitApplication);
    MainLoop();
    
    sub ExitApplication {
        # Prepare dialog yes|no
        my $dialog = $mw->Dialog(-text => 'Do you really want to quit?',
                                 -bitmap => 'question',
                                 -title => 'Quit?',
                                 -default_button => 'Yes',
                                 -buttons => [qw/Yes No/],
                                );
    
        my $answer = $dialog->Show(); # and display dialog
        if ($answer =~ /y/i){
            # maybe do some cleaning up and
            exit;
        }
        else {
            # continue
        }
    
    } # sub ExitApplication


  4. Quasiblockieren mit einer WaitVariablen.


    Quasiblockieren
    $var = 0;
    $mw->after(10000, sub { $var = 1 }); # 10 s warten
    $mw->waitVariable(\$var);


  5. Beschäftigung anzeigen mit Stundenglas- / Armbanduhr-Mauscursor.

    Leider ist nirgendwo so richtig gut beschrieben, wo man die Cursorarten findet. Ich habe einen Tipp gefunden, der mir weitergeholfen hat, und zwar in die Datei ...Perl\site\lib\Tk\X11\cursorfont.h zu gucken. Dort sieht man zumindestens die erlaubten Namen.

    Waitcursor
    my $oc = $Config{text_widget}->cget(-cursor);
    $Config{text_widget}->configure(-cursor => 'watch');
    # tue etwas zeitaufwändiges
    $Config{text_widget}->configure(-cursor => $oc);


  6. Minimiertes Dosfenster bei Programmstart wieder hochkommen lassen.

    (Für Active-State-Perl unter Windows.)

    Tk-Dosfenster öffnen
    my ($DOS) = Win32::GUI::GetPerlWindow();
    Win32::GUI::Show($DOS);


Längere Codestücke:

Hier folgen einige längere Quellcodesnippets, die nicht im Code abgebildet werden, aber die man sich herunterladen kann.

Cascadix - Pl-Anaylse

  1. cascadix.pl - ein süchtigmachendes kleines Spiel ;)

    (Ist nicht von mir, ich habe den Code als Snippet erhalten.)




  2. planalyse.zip - Ein kleines Perlprogramm von mir, das auf simple Weise einige Auszählungen in Perlcodes vornimmt.

    Hinweis: Dieses Programm benötigt die Funktion CDtools::taupu() aus meinem Modul CDtools.pm.

    Ausgabe des Programms auf sich selbst angewendet:
    
    C:\Daten\perl>planalyse.pl planalyse.pl
    analysing file 'planalyse.pl' ...
    Number of lines                 :      108
    Number of line breaks           :      108
    Number of empty lines           :       24
    Number of lines with code       :       72
    Number of characters            :    2.936
    Number of white space characters:      781
    Number of comment characters    :      976
    Number of code characters       :    1.852


Eigene Module:

Hier stelle ich kleinere Module von mir vor.


CD-Tools - CD-Datum - Check
  1. CDtools.zip - Dieses Modul enthält einige rudimäntäre Funktionen, wie etwa die verschönerte Darstellung von Zahlen mit tausender Trennpunkten oder eine Stoppuhr.


  2. CDdatum.zip - Dieses Modul enthält viele Funktionen rund um Zeit und Datum. Ich weiß, dass es zu diesem Thema schon viele Module auf CPAN gibt, aber ich wollte meine eigenen Funktionen schreiben.


  3. check.zip - Ein Modul von mir, was zu einer Menge Tests die Erfolgsmeldungen grafisch ausgibt.

    Die Anzeige kann im MainWindow, in einem vom Modul erzeugten Toplevel-Window oder in einem vom Modul erzeugten Frame erzeugt werden.

    Inzwischen liegt es in der Version 0.0.9 vor.

     



Eigene Projekte:

Hier stelle ich eigene Projekte in Perl vor, die mehr oder weniger weit gediehen sind. Eventuell werde ich von Zeit zu Zeit stabile Versionen zum "downloaden" anbieten. Wer vorher starkes Interesse hat, kann mich gerne anmailen.

GED - Wichtig - Stundenplaner - qotw - Verschiebespiel - Pentris - SPIP
  1. GED - ein Graphen Editor

    GED wird das, was ich mir während der Diplomarbeit verkniffen habe zu programmieren, obwohl ich das gerne gemacht hätte... aber er (der Graphen Editor) wächst wegen wenig Freizeit nur langsam...

    Da das Projekt inzwischen einen Anwender hat, ist es zu neuem Leben erwacht.

    Genaueres findet man auf der GED-Seite.

    Hier ein aktueller Screenshot:

    Ein Bild des Grapheneditors


  2. Wichtig

    Das Programm "Wichtig" erinnert mich bei jedem Betriebssystemstart an wichtige Termine, an die ich sonst garantiert nicht alle denken würde.
    Dieses Programm gibt es seit 1991, wo ich die erste Version in Turbo Pascal schrieb. Seit dem habe ich es in fast jede Sprache übersetzt - oder in der Sprache neu geschrieben - die ich gelernt habe.

    Die aktuelle Version (8.0.4.c) ist ein völlig neu geschriebenes Programm (jedenfalls seit Version 8.0.0.a) in Perl/Tk, in das aber die Erfahrungen der anderen Programme eingeflossen ist.
    Allen Versionen ist gemein, dass das Datenformat der anzuzeigenden Termine gleich ist.

    Die Datenstruktur liegt in drei Dateien vor, eine für einmalige Termine mit Datum (Verabredungen, Einladungen, Meetings etc. aber auch bewegliche Feiertage), sich jährlich an feststehenden Tagen wiederholende Termine (Geburtstage, feststehende Feiertage, ...) und Dinge, die man ohne Termin immer vor Augen haben möchte (ToDo's).

    Diese Dateien kann man mit einem normalen Editor bearbeiten, oder auch über das Programm Wichtig selbst.


    Man kann das Programm auf drei Arten anzeigen lassen:

    • Angedockt an den rechten Bildschirmrand ohne Titel, Menü und Ende-Taste, dafür mit Pseudotitel, dies ist der Standard.

    • Angedockt an den rechten Rand, aber mit Titel und Menü, das Programm taucht in der Taskleiste auf und ist verschieb- und in der Größe veränderbar. Dies wird mit dem Aufrufparameter -t erreicht.

    • In einem "normalen" Fenster "irgendwo" auf dem Desktop (via Parameter -w).

    Ich habe es in der Autostartgruppe (mit -t) eingetragen, so bekomme ich es bei jedem Rechnerstart zu sehen.


    Kleine Anekdote: 1991 habe ich mich impfen lassen (gegen Wundstarkrampf und anderes) und da ich gerade dieses Programm schrieb, hab ich, da ich die Impfung nach 10 Jahren wiederholen sollte, für den 01.01.2001 einen Erinnerungseintrag eingetragen, und siehe da, 10 Jahre später erinnerte mich das Programm (bzw. eines seiner Nachfolger) an die Impfung... und für 2011 ist natürlich auch wieder ein Eintrag da. ;-)


    Hier ein aktueller Screenshot (in der Variante mit -t):

    Wie man sieht, werden im oberen Bereich die Termine und Geburtstage sortiert nach Datum angezeigt, im unteren Bereich werden die ToDo's angezeigt. Beide Bereiche werden von einer Tk::HList verkörpert.
    Selektiert man einen Eintrag, kann man ihn mit den Buttons unter der Liste in der er steht bearbeiten oder löschen (wird dann in der Datei nur auskommentiert). Außerdem kann man mit den Buttons mit den Pluszeichen einzelne neue Termine, Geburtstage oder ToDo's eintragen (die Symbole Terminkalender, Geburtstagstorte und Pflichtenzettel dürften wohl selbsterklärend sein).
    Mit den Buttons in der untersten Reihe (oder über das Menü Datei) kann man die drei Dateien in einem Editor bearbeiten (hier ist eine Bearbeitung in einer eigenen Maske ähnlich dem Stundenplanerprogramm (siehe unten [sobald ich es hier beschrieben habe...]) geplant).

  3. Stundenplaner:


    ... Baustelle ...



  4. QOTW:


    Dies ist kein eigentliches Projekt, sondern meine Antworten zum "Quest Of The Week". Näheres findet auf meiner QOTW-Seite.



  5. Verschiebespiel:


    Im Rahmen des Rätsel der Woche habe ich ein Verschieberätsellöser mit Tk-Oberfläche programmiert.

    Genaueres findet man auf der Seite zum RDW 6.

    Hier ein aktueller Screenshot:

    Ein Bild vom Verschieberätsel

    Der Quellcode findet sich hier: rdw06_crian.pl.



  6. Pentris:


    Pentris ist ein Tetris-Clone mit Pentominosteinen, die zu den normalen Tetrissteinen dazukommen.

    Genaueres findet man auf der Pentris-Seite.

    Hier ein aktueller Screenshot:

    Ein Bild von Pentris   Ein Bild von Pentris


  7. SPIP:


    SPIP ist ein Programm zur Erzeugung einfach Präsentationen.

    Genaueres findet man auf der SPIP-Seite.

Keine Navigation am linken Rand? Oder zuviel Navigation? Wählen sie selbst:

Perlseite mit Frames und JavaScript (schönstes Menü) oder

Perlseite mit Frames und reinem HTML/CSS oder

Perlseite ohne Frames und JavaScript

zu meiner Homepage zu meiner Homepage

zur Startseite des Servers zur Startseite des Servers

Impressum

Valid CSS! Valid XHTML 1.0!

TOP Zum Seitenanfang

zuletzt geändert: