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:
|
Einige interessante Perl Links:
|
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:
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:
|
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.
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.
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).
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 '.'; } |
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
...
|
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) {} }, }); } |
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.
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
|
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: |
Das Bild '../ged.gif' hat die Ausmaße 608x527
|
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'
];
|
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)");.
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
|
hash_an_funktion.pl |
sub Subroutine { my (%namedParams) = %{ shift() }; # () nicht vergessen! my ($param2, $param3) = @_; # ... } Subroutine( { key1 => 'value1', key2 => 'value2' }, $param2, $param3); |
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
|
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); } |
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; |
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
|
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
|
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
|
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
|
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
|
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
|
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
|
tail-f.pl |
open (LOG, ....) or die $!; for (;;) { print <LOG>; sleep 1; seek (LOG, 0, 1); } |
(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 |
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; } |
zeichen_ueberschreiben_DOSBOX.pl |
binmode STDOUT; $| = 1; # Windows 98 braucht das, Windows 2000 nicht. for (1..100) { print "$_%\r"; sleep(1); } |
Ausgabe: |
100%
|
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'
}
];
|
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
|
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'
];
|
(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
|
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 |
tk_farbwahl2.pl |
#!/usr/bin/perl use Tk; $mw = new MainWindow; $mw->chooseColor(-title => 'Farbe wählen'); |
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!
|
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
|
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(); |
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(); |
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], ); } } } |
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(); |
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(); |
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(); |
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; } |
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(); |
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(); |
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
|
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(); |
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(); |
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
|
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', ); } |
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 |
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 # ----------------------------------------------------------------------------- |
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(); |
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); |
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:
Script in script.ptk umbenennen
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).
(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 |
Quasiblockieren |
$var = 0; $mw->after(10000, sub { $var = 1 }); # 10 s warten $mw->waitVariable(\$var); |
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); |
(Für Active-State-Perl unter Windows.)
Tk-Dosfenster öffnen |
my ($DOS) = Win32::GUI::GetPerlWindow(); Win32::GUI::Show($DOS); |
Hier folgen einige längere Quellcodesnippets, die nicht im Code abgebildet werden, aber die man sich herunterladen kann.
(Ist nicht von mir, ich habe den Code als Snippet erhalten.)
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
|
Hier stelle ich kleinere Module von mir vor.
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.
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 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:
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).
... Baustelle ...
Dies ist kein eigentliches Projekt, sondern meine Antworten zum "Quest Of The Week". Näheres findet auf meiner QOTW-Seite.
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:
Der Quellcode findet sich hier: rdw06_crian.pl.
Pentris ist ein Tetris-Clone mit Pentominosteinen, die zu den normalen Tetrissteinen dazukommen.
Genaueres findet man auf der Pentris-Seite.
Hier ein aktueller Screenshot:
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