#!/usr/bin/perl
#
-----------------------------------------------------------------------------
#
Programm : m e n u . p l
#
-----------------------------------------------------------------------------
#
Autor : Christian Dόhl
#
Erstellt : 01. Januar 2004
#
Zuletzt geδndert : 14. Mδrz 2004
#
Aufgabe : Ein kleiner Editor
als Beispielprogramm zum Thema Menόs
# unter Perl/Tk.
#
-----------------------------------------------------------------------------
#------------------------------------------------------------------------------
#
Pragmas und Module:
#------------------------------------------------------------------------------
use
strict;
use
warnings;
use
Tk;
#------------------------------------------------------------------------------
#
Prototypen:
#------------------------------------------------------------------------------
sub
init ($);
#------------------------------------------------------------------------------
#
Globales Kofigurationshash:
#------------------------------------------------------------------------------
my
%Config = ( debug => 1, # Debuginformationen?
version => '0.0.1', # Programmversion
version_datum =>
'01.01.2004',
main_window => undef, # Hauptfenster-Widget
text_widget => undef, # Textarea-Widget
Menu => undef, # Menu-Widget
Menuefont => '{Arial} 8 {normal}', # Schriftart
des Menu
breite => 300, # Fensterbreite
hoehe => 500, # Fensterhoehe
Titel => 'Editor menu', # Fenstertitel
Dateiname => '', # Name d. geladenen
Datei
);
#------------------------------------------------------------------------------
#
Programmablauf:
#------------------------------------------------------------------------------
tk_main();
init('menu.pl');
MainLoop();
exit;
###############################################################################
###############################################################################
####
####
#### TTTTT K
K
####
#### T K
K
####
#### T KKK ####
#### T K
K
####
#### T K
K
####
####
####
###############################################################################
###############################################################################
sub
tk_main {
#
-----------------------------------------------------------------------------
#
sub : t k _ m a i n
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Tk-Hauptfenster starten,
Widgets einrichten.
#
Parameter : keine (in %Config)
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "tk_main()\n" if
$Config{debug};
#--------------------------------------------------------------------------
# Hauptfenster erzeugen:
#--------------------------------------------------------------------------
my $mw = new MainWindow;
$Config{main_window} = $mw;
$mw->title($Config{Titel});
#$mw->geometry($Config{breite} . 'x'.
$Config{hoehe});
#--------------------------------------------------------------------------
# Menu:
#--------------------------------------------------------------------------
# 1. Menu-Bar erstellen:
$Config{Menu} = $mw->Menu(-type =>
'menubar',
-font =>
$Config{Menuefont},
);
# 2. Dem Fensterwidget sagen, dass unsere
Menubar sein Menu ist:
$mw->configure(-menu =>
$Config{Menu});
# 3. Eintrδge in der Menu-Bar:
$Config{Menu}->cascade(-label => 'Datei',
-underline =>
0,
-font => $Config{Menuefont},
);
$Config{Menu}->cascade(-label => 'Bearbeiten',
-underline =>
0,
-font => $Config{Menuefont},
);
$Config{Menu}->separator(); # dadurch
wird der Rest rechtsbόndig
$Config{Menu}->cascade(-label => 'Hilfe',
-underline =>
0,
-font => $Config{Menuefont},
);
# 4. Die einzelnen Untermenόs
definieren:
# Zunδchst das Dateimenό:
my $menu_datei = $Config{Menu}
->Menu(-font => $Config{Menuefont}, # Schriftart
des Menόs
-tearoff => 0, # Menό nicht abreiΓbar
-menuitems => [
[
'command' => 'Datei
neu',
-command => \&datei_neu,
-accelerator
=> 'Ctrl-N',
-font => $Config{Menuefont},
-underline => 6,
],
[
'command' => 'Datei
φffnen',
-command => \&datei_oeffnen,
-accelerator
=> 'F3',
-font => $Config{Menuefont},
-underline => 6,
],
[
'command' => 'Datei
speichern',
-command => \&datei_speichern,
-accelerator
=> 'F2',
-font => $Config{Menuefont},
-underline => 6,
],
[
'command' => 'Datei
speichern unter',
-command => \&datei_speichern_unter,
-accelerator
=> 'F12',
-font => $Config{Menuefont},
-underline => 16,
],
'-',
[
'command' =>
'Beenden',
-command => \&tk_ende,
-accelerator
=> 'Ctrl-B',
-font => $Config{Menuefont},
-underline => 0,
],
],
);
# Dazu gehφrt auch, der Menubar zu sagen,
dass dieses Untermenό zu seinem
# Eintrag "Datei" gehφrt:
$Config{Menu}->entryconfigure('Datei',
-menu => $menu_datei);
# Analog fόr die beiden anderen
Menόs:
# Bearbeiten-Menu:
my $menu_bearb = $Config{Menu}
->Menu(-font => $Config{Menuefont},
-tearoff => 0,
-menuitems => [
[
'command' =>
'Sortieren',
-command => [ \&bearbeiten, 'sortieren'
],
-accelerator
=> 'F5',
-font => $Config{Menuefont},
-underline => 0,
],
],
);
$Config{Menu}->entryconfigure('Bearbeiten', -menu =>
$menu_bearb);
# Hilfemenό:
my $menu_hilfe = $Config{Menu}
->Menu(-font => $Config{Menuefont},
-tearoff => 0,
-menuitems => [
[
'command' =>
"Hilfe",
-command => \&hilfe,
-accelerator
=> 'F1',
-font => $Config{Menuefont},
-underline => 0,
],
[
'command' =>
"Historie",
-command => \&historie,
-font => $Config{Menuefont},
-underline => 1,
],
'-',
[
'command' => "Γber
menu2",
-command => \&ueber,
-font => $Config{Menuefont},
-underline => 0,
],
],
);
$Config{Menu}->entryconfigure('Hilfe',
-menu => $menu_hilfe);
#--------------------------------------------------------------------------
# Textwidget:
#--------------------------------------------------------------------------
$Config{text_widget} =
$mw->Scrolled('Text',
-scrollbars =>
'osoe',
-width => 120,
-height => 50,
-exportselection => 1,
)
->pack(-expand =>
1,
-fill =>
'both',
);
#--------------------------------------------------------------------------
# Bindungen:
#--------------------------------------------------------------------------
# Menό aufrufbar machen mit Alt und dem
unterstrichenen Buchstaben:
$mw->bind('<Alt-d>', sub
{$Config{Menu}->postcascade('Datei'
);});
$mw->bind('<Alt-b>', sub
{$Config{Menu}->postcascade('Bearbeiten');});
$mw->bind('<Alt-h>', sub
{$Config{Menu}->postcascade('Hilfe'
);});
$mw->bind('<Control-n>',
\&datei_neu);
$mw->bind('<F3>', \&datei_oeffnen);
$mw->bind('<F2>', \&datei_speichern);
$mw->bind('<F12>', \&datei_speichern_unter);
$mw->bind('<Control-b>',
\&tk_ende);
$mw->bind('F5', [ \&bearbeiten,
'sortieren']);
$mw->bind('<F1>', \&hilfe);
}
# sub tk_main;
sub
anzeige_fenster ($$$$;$$) {
#
-----------------------------------------------------------------------------
#
sub : a n z e i g e _ f e n s t
e r
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Zeigt etwas in einem
Extra-Fenster an.
#
Parameter : Notwendig:
# 1) Titel
# 2) Label
# 3) Font
# 4) anzuzeigender Text
# Optional:
# 5) Breite (default: 80 )
# 6) Hφhe (default: 35 )
# 7) Textfarbe (default: 'blue' )
# 8) Hintergrundfarbe
(default: '#d7d7d7')
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 18.11.2003 - CD - Erstellt
#
0.0.2 - 20.11.2003 - CD - Bindungen fόr PageUp, PageDn, Home und End...
# Optionale Parameter
fόr Breite, Hφhe, Textfarbe und
# Hintergrundfarbe
eingebaut.
#
0.0.3 - 04.12.2003 - CD - Verbesserungen: Button in Extraframe, das vor
dem
# Textfeld gepackt
wird, beim Expanden wird die
# Zeile mit dem
Schalter nicht mehr vergrφΓert.
#
-----------------------------------------------------------------------------
my $titel
= shift;
my $label
= shift;
my $font
= shift;
my $text
= shift;
my $width
= shift || 80;
my $height = shift || 35;
my $tcolor = shift || 'blue';
my $bcolor = shift || '#d7d7d7';
print "anzeige_fenster(\n",
" Titel : $titel\n",
" Label : $label\n",
" Font : $font\n",
" )\n"
if $Config{debug};
#
-------------------------------------------------------------------------
# Neues Toplevel-Fenster erzeugen, das den
Text anzeigt:
#
-------------------------------------------------------------------------
my $tl =
$Config{main_window}->Toplevel();
$tl->title($titel);
$tl->Label(-text => $label,
#-anchor => 'w',
)
->pack(-anchor => 'w');
my $fr = $tl->Frame()
->pack(-expand =>
'0',
-fill => 'x',
-side => 'bottom',
);
my $txt =
$tl->Scrolled("Text",
-scrollbars =>
'osoe',
-background =>
$bcolor,
-foreground =>
$tcolor,
-state => 'disabled',
-width => $width,
-height => $height,
-relief => 'flat',
-font => $font,
-wrap => 'none',
)
->pack(-side => 'top',
-expand => 1,
-fill => 'both',
);
my $ok = $fr->Button(-text => 'OK',
-command => sub {$tl->destroy();
#$Config{main_window}
# ->bind('<Escape>',
\&beenden);
$Config{main_window}->focus();
},
-default => 'active',
-padx => 15,
)
->pack(-expand => '0',
-fill => 'none',
-side => 'right',
);
$txt->configure(-state =>
'normal');
$txt->delete('1.0', 'end');
$txt->insert('end', $text);
#$txt->insert('end',
"\n");
$txt->configure(-state =>
'disabled');
#
# Bindungen zum $MW fόr Escape lφsen und
an Lφschen dieses Fensters binden.
# (Beim Beenden des Fensters wird ESC
wieder an $MW gebunden (siehe oben).)
#
$tl->bind('<Return>',
sub{$ok->invoke()});
#$Config{main_window}->bind
('<Escape>', '');
$tl->bind('<Escape>',
sub{$ok->invoke()});
#
*$text*->yviewScroll(*number, what*)
# This command adjust the view in
the window up or down
# according to *number* and *what*.
*Number* must be an
# integer. *What* must be either
units or pages. If *what* is
# units, the view adjusts up or down
by *number* lines on the
# display; if it is pages then the
view adjusts by *number*
# screenfuls. If *number* is
negative then earlier positions
# in the text become visible; if it
is positive then later
# positions in the text become
visible.
$txt->bind('<Prior>', sub {
$txt->yviewScroll(-1, 'units') } );
$txt->bind('<Next>', sub { $txt->yviewScroll( 1, 'units') }
);
#$txt->bind('<Home>', sub { $txt->see('1.0') } );
#$txt->bind('<End>', sub { $txt->see('end') } );
$txt->bind('<Home>', sub { $txt->yviewMoveto(0) } );
$txt->bind('<End>', sub { $txt->yviewMoveto(1) } );
# geht beides, unteres wohl etwas
schneller
$txt->bind('<Left>', sub { $txt->yviewScroll(-1, 'units') }
);
$txt->bind('<Up>', sub { $txt->yviewScroll(-1, 'units') }
);
$txt->bind('<Right>', sub {
$txt->yviewScroll( 1, 'units') } );
$txt->bind('<Down>', sub { $txt->yviewScroll( 1, 'units') }
);
# irgendwas stimmt noch nicht ganz... da
mόssen eingebaute Funktionalitδten
# mit reinspielen...
#$txt->bind('<F9>', sub { $txt->yviewScroll(-1, 'units') }
);
#$txt->bind('<F10>', sub { $txt->yviewScroll( 1, 'units') }
);
#$txt->bind('<F5>', sub { $txt->yviewScroll(-1, 'pages') }
);
#$txt->bind('<F6>', sub { $txt->yviewScroll( 1, 'pages') }
);
#
# Rest:
# (grab verhindert das zurόckschalten auf
$WM per Klick, focus sorgt dafόr,
# dass $tl auch wirklich aktiv ist.)
#
$tl->grab();
$tl->focus();
$txt->focus(); # ?
}
# sub anzeige_fenster
sub
hilfe () {
#
-----------------------------------------------------------------------------
#
sub : h i l f e
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Zeigt die Hilfe an.
#
Parameter : keine
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "hilfe\n" if
$Config{debug};
my $text = qq(
menu2
V$Config{version} vom $Config{version_datum}
~~~~~
menu2
ist ein kleiner Editor als Demonstration der Menόs im Perl/Tk-Tutorial.
);
anzeige_fenster('Hilfe zu Wichtig',
'Hilfe:',
'{Courier New} 10
{normal}',
$text,
);
}
# sub hilfe
sub
historie () {
#
-----------------------------------------------------------------------------
#
sub : h i s t o r i e
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Zeigt die History
an.
#
Parameter : keine
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "historie\n" if
$Config{debug};
my $text = qq(
Version
0.0.1 (01.01.2004)
~~~~~~~~~~~~~
Programm
erstellt
);
anzeige_fenster('Historie von menu2',
'Historie:',
'{Courier New} 10
{normal}',
$text,
);
}
# sub history
sub
ueber () {
#
-----------------------------------------------------------------------------
#
sub : u e b e r
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Zeigt Informationen όber
menu2 an.
#
Parameter : keine
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "ueber\n" if
$Config{debug};
#
-------------------------------------------------------------------------
# History-Text:
#
-------------------------------------------------------------------------
my $text = qq(
menu2
~~~~~
Version
: V$Config{version} vom $Config{version_datum}
Autor : Christian Dόhl
E-Mail : crian AT perl-community DOT de
christian AT duehl DOT de
Webseite:
http://www.duehl.de/christian/perl/
http://wiki.perl-community.de/bin/view/Wissensbasis/PerlTkTutorialKapitel13
);
anzeige_fenster('Informationen όber
menu2',
'Γber menu2:',
'{Courier New} 10
{normal}',
$text,
);
}
# sub ueber_wichtig
sub
tk_ende { $Config{main_window}->destroy() }
###############################################################################
###############################################################################
####
####
#### EEEEE DDDD
I TTTTT OOO
RRRR ####
#### E D
D I T
O O R
R ####
#### EEEE D
D I T
O O RRRR ####
#### E D
D I T
O O R
R ####
#### EEEEE DDDD
I T OOO
R R ####
####
####
###############################################################################
###############################################################################
sub
load ($) {
#
-----------------------------------------------------------------------------
#
sub : l o a d
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Lδdt die angegebene Datei
in den Editor.
#
Parameter : Dateinamen
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
my $file = shift;
print "load($file)\n" if
$Config{debug};
my $text = '';
if (open(LIES, $file)) {
local $/;
$text = <LIES>;
close LIES;
}
else {
die "Kann Datei '$file' nicht
oeffnen: $!";
}
$Config{text_widget}->delete('1.0',
'end'); # alten Inhalt lφschen
$Config{text_widget}->insert('end',
$text); # neuen Inhalt rein
$Config{text_widget}->see('1.0'); # Anfang sichtbar machen
$Config{text_widget}->markSet('insert',
'1.0');
$Config{main_window}->title($Config{Titel} . " [ $file
]");
}
# sub load
sub
save ($) {
#
-----------------------------------------------------------------------------
#
sub : s a v e
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Speichert den
Editorinhalt unter dem angegebene Dateiname.
#
Parameter : Dateinamen
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
my $file = shift;
print "save($file)\n" if
$Config{debug};
if (open(LIES, ">$file"))
{
print LIES
$Config{text_widget}->get('1.0', 'end');
close LIES;
}
else {
die "Kann Datei '$file' nicht zum
Schreiben oeffnen: $!";
}
}
# sub save
sub
datei_neu () {
#
-----------------------------------------------------------------------------
#
sub : d a t e i _ n e u
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Erzeugt eine neue, leere
Datei im Editorfenster.
#
Parameter : Dateinamen
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "datei_neu\n" if
$Config{debug};
$Config{text_widget}->see('1.0'); # Anfang sichtbar machen
$Config{text_widget}->delete('1.0',
'end'); # alten Inhalt lφschen
$Config{Dateiname} = '';
$Config{main_window}->title($Config{Titel});
}
# sub datei_neu
sub
datei_oeffnen () {
#
-----------------------------------------------------------------------------
#
sub : d a t e i _ o e f f n e
n
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Γffnet per Dialog eine
Datei zum Bearbeiten.
#
Parameter : Dateinamen
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "datei_oeffnen\n" if
$Config{debug};
my $typen = [
[ 'Perl-Dateien', ['.pl', '.cgi' ] ],
[ 'HTML-Dateien', ['.html', '.htm' ] ],
[ 'Alle Dateien', '*' ],
];
my $dn =
$Config{main_window}->getOpenFile(-filetypes => $typen,
-initialdir => '.',
);
if (defined $dn and $dn ne '') {
$Config{Dateiname} = $dn;
load($dn);
}
}
# sub datei_oeffnen
sub
datei_speichern () {
#
-----------------------------------------------------------------------------
#
sub : d a t e i _ s p e i c h e
r n
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Speichert den
Editorinhalt unter dem angegebene Dateiname oder
# lδsst einen neuen Dateinamen
angeben.
#
Parameter : Dateinamen
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "datei_speichern\n" if
$Config{debug};
if ($Config{Dateiname} eq '') {
datei_speichern_unter();
}
else {
save($Config{Dateiname});
}
}
# sub datei_speichern
sub
datei_speichern_unter () {
#
-----------------------------------------------------------------------------
#
sub : d a t e i s _ p e i c h e
r n _ u n t e r
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Ermφglicht es, die Datei
unter einem anderen Namen
# abzuspeichern.
#
Parameter : Dateinamen
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
print "datei_speichern_unter\n"
if $Config{debug};
my $name = $Config{Dateiname};
my $typen = [
[ 'Perl-Dateien', ['.pl', '.cgi' ] ],
[ 'HTML-Dateien', ['.html', '.htm' ] ],
[ 'Alle Dateien', '*' ],
];
my $dn =
$Config{main_window}->getSaveFile(-filetypes => $typen,
-defaultextension => 'pl',
-initialfile =>
$name,
);
if (defined $dn and $dn ne "")
{
$Config{Dateiname} = $dn;
$Config{main_window}->title($Config{Titel} . " [ $dn
]");
speichere_datei();
}
}
# sub datei_speichern_unter
sub
bearbeiten ($) {
#
-----------------------------------------------------------------------------
#
sub : b e a r b e i t e n
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Verschiedene
Bearbeitungschritte per Parameter.
#
Parameter : Aufgaben: 'sortieren' -
sortiert den selektierten Text.
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
my $aufgabe = shift; # 'sortieren'
print "bearbeiten($aufgabe)" if
$Config{debug};
if ($aufgabe eq 'sortieren') {
print "... sortieren
...\n";
print "\a";
# ... muss noch codiert werden
...
}
else {
print "... unbekannte
Aufgabe!\n";
}
}
# sub bearbeiten
sub
init ($) {
#
-----------------------------------------------------------------------------
#
sub : i n i t
#
-----------------------------------------------------------------------------
#
Autor : CD
#
Aufgabe : Initialisierungen zu
Beginn des Programms.
#
Parameter : Aufgaben: 'sortieren' -
sortiert den selektierten Text.
#
Rόckgabewert : keiner
#
-----------------------------------------------------------------------------
#
0.0.1 - 01.01.2004 - CD - Erstellt
#
-----------------------------------------------------------------------------
my $n = shift;
$Config{Dateiname} = $n;
load($n);
$Config{text_widget}->focus();
}
# sub init