Tips und Tricks zu Perl

Perl/Tk

• Programm-schließen abfangen
• Wie kann man in einem Entry-Feld die Maximalzeichenanzahl beschränken?
• Diverses zu Tk::Photo

Wenn man auf ein Programm-Schließen-Ereignis (entweder durch <Alt><F4> oder Mausklick auf das X rechts oben nicht will, daß sich das Programm einfach beendet, sondern z.B. eine lästige Nachfrage ausgeben will (so auf die Art: Wollen Sie wirklich mein wunderschönes Programm verlassen???), dann könnte man dies folgendermaßen machen:

#! /usr/bin/perl
use warnings;
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( lc($answer) =~ /y/i ){
        # maybe do some cleaning up and
        exit;
    }
    else {
    # continue
    }
 
} # ExitApplication

Am einfachsten benützt man dafür die Entry-Optionen -validate und -validatecommand, womit man die eingegebenen Werte on-the-fly überprüfen kann, z.B.

my $text = '';
my $entry = $parent->Entry(-textvariable => \$text, -validate => 'all', -validatecommand => \&Validate);

sub Validate {
  my ($text, $newText, $oldText, $position, $mode) = @_;
  if (length($text) > 10) { # auf 10 Zeichen beschraenken
    return 0; # falsch: der letzte Input wird abgelehnt
  }
  return 1; # der input wird angenommen
} # Validate

Für genauere Erklärung der Parameter: siehe perldoc Tk::Entry und auch das folgene Beispiel (vor allem die Probleme):

Wie kann man in einem Entry-Feld die Maximalzeichenanzahl beschränken?

Indem man den Inhalt von $text und $newText überprüft. Etwas flexibler kann man das folgendermaßen machen:

my $text = "";
my $entry = $mw->EntryCheck($parent, -textvariable => \$text,
                            -maxLength => 10,
					  	       -pattern => qr~[A-Za-z0-9]~, # nur Buchstaben und Ziffern gestatten
						  )
    ->pack(); # oder was auch immer
# ---------------------------------------------------------------------------
# Eine Zwischensubroutine, die einem gerade bei vielen Entry-Feldern viel
# Tipparbeit ersparen kann, fungiert als Zwischenstation zu Entry
sub EntryCheck { 
  my ($parent, %options) = @_;
 
  # Eigene Parameter herausspeichern und aus %options entfernen
  my $maxLength = delete $options{-maxLength};
  my $pattern   = delete $options{-pattern};

  return $parent->Entry(-validate => 'all', 
                        -validatecommand => [ \&Validate, $pattern, $maxLength ],
                        %options, 
} # EntryCheck
# ---------------------------------------------------------------------------
sub Validate {
  my ($pattern, $maxLength, $text, $newText, $oldText, $position, $mode) = @_;

  # laenge ueberpruefen: wenn $maxLength vorhanden und der text laenger ist: FEHLER
  return 0 if defined ($maxLength) and length($text) > $maxLength;

  # wenn das pattern angegeben wurde, ueberpruefe das/die neuhinzugekommene(n) Zeichen
  if (defined $pattern) {
    if (defined($newText)) {
      return 0 unless $newText =~ /^$pattern+$/; # check pattern
	  } # if
  
    # falls $newText leer ist, halten wir uns an den kompletten $text
    else {
  	return 0 unless $text =~ /^$pattern+$/; # check pattern
    } # else
  } # if

  return 1;
} # Validate

Mögliche Probleme:

• wenn mehr in das Entry-Widget über Copy&Paste eingefügt wird, wird nichts übernommen, wenn die eingefügte Zeichenkette zu lang ist.
• Der Wert für -pattern kann unter Umständen Probleme bereiten, weil die Zeichen darin eventuell als Sonderzeichen behandelt werden.
• Man sollte darauf achten, daß auch da die Überprüfung stattfindet, wenn man den Wert über die Variable $text setzt.

Ich habe auf CPAN das Modul Tk::EntryCheck gestellt, das genau das macht.

use Tk;
use Tk::JPEG;
use Tk::Photo;

my $imageFile = "myImage.jpg"

my $mw    = MainWindow->new();
my $image = $mw->Photo( -format => 'jpeg', -file => $imageFile ); # oder 'gif'
$mw->Label( -image => $image )->pack();

MainLoop();

Auf die folgende Weise kann man mehrere Bilder nacheinander darstellen

#! /usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::JPEG;
use Tk::Photo;
use MIME::Base64;

use vars qw($RepeatId);

my @images = glob("*.jpg"); # alle jpg im aktuellen verzeichnis

my $mw = MainWindow->new;
my $image = $mw->Photo(); # leeres Bildobjekt erstellen
my $label = $mw->Label( -image => $image )->pack();

$RepeatId = $mw->repeat( 2000, [ \&ShowImage, $mw, $image, \@images] );

MainLoop();
# ------------------------------------------------------------
sub ReadImageData {
  my( $imageFile ) = @_;

  open( my $IMAGE, "<", $imageFile )
    or die "Error in reading image: $!\n";
  binmode( $IMAGE );
  local $/ = undef; # slurp mode

  # bild einlesen und MIME-encoden
  return MIME::Base64::encode_base64( <$IMAGE> );

  # close( $IMAGE ) ist nicht noetig wegen my $IMAGE
}; # ReadImageData
# ------------------------------------------------------------
sub ShowImage {
  my( $mw, $image, $images ) = @_;

  # wenn keine Bilder mehr zum Anzeigen vorhanden
  $RepeatId->cancel() unless scalar @$images;
  
  my $imageFilename = shift @$images;
  my $imageData = &ReadImageData( $imageFilename );

  # fuelle die Bilddaten in das $image-Objekt
  $image->configure( -format => 'jpeg', -data => $imageData );

  # und aktualisiere das MainWindow
  $mw->update();
} # ShowImage

Habe mal spasshalber die Spiele Käsekästchen und Tk-Mines mit Perl/Tk implementiert. Interessierte können es sich unter Eigene Scripte downloaden.

Letztes Update dieser Seite: Wednesday, 02-Aug-2006 23:12:14 CEST