Perl Tk

A graphical user interface toolkit for Perl
Perl Tk
Perl Tk resource in German but with images!

Perl Tk Plain Window

Tk
MainWindow
MainLoop

use strict;
use warnings;

use Tk;
my $top = MainWindow->new;
MainLoop;

Perl Tk Label

Label

use strict;
use warnings;

use Tk;
my $top = MainWindow->new;
my $label = $top->Label(
    -text => 'Hello World!',
    -font => ['fixed', 20],
    -background => 'red',
);
$label->pack;
MainLoop;

Tk::Label

Perl Tk Button

Button

use strict;
use warnings;

use Tk;

sub do_on_click {
    print("Clicked\n");
}


my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;

MainLoop;

Tk::Button

Perl Tk Entry (visible and hidden for secrets)

Entry

use strict;
use warnings;

use Tk;


my $top = MainWindow->new;
my $entry = $top->Entry(
    -font => ['fixed', 40],
);
$entry->pack;

my $secret = $top->Entry(
    -font => ['fixed', 40],
    -show => 0,
);
$secret->pack;


my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;

sub do_on_click {
    print($entry->get, "\n");
    print($secret->get, "\n");
    print("Clicked\n");
}


MainLoop;

Tk::Entry

Perl Tk Text editor

Text

use strict;
use warnings;

use Tk;


my $top = MainWindow->new;
my $text = $top->Text(
    -state => 'disabled'
);
$text->pack;

my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;

sub do_on_click {
    $text->configure('state', 'normal');
    $text->Insert(scalar(localtime) . "\n");
    $text->configure('state', 'disabled');
}


MainLoop;

use strict;
use warnings;

use Tk;

my $top = MainWindow->new;

my $main_menu = $top->Menu();

my $file_menu = $main_menu->cascade(-label => 'File', -underline => 0);
$file_menu->command(-label => 'Open', -underline => 0, -command => \&do_open);
$file_menu->command(-label => 'Quit', -underline => 0, -command => sub { exit });

my $action_menu = $main_menu->cascade(-label => 'Action', -underline => 0);
my $run = $action_menu->command(-label => 'Run', -command => \&run, -state => 'disabled');
$action_menu->separator;
$action_menu->command(-label => 'Enable', -command => \&enable);
$action_menu->command(-label => 'Disable', -command => \&disable);
my $debug = 0;
$action_menu->checkbutton(-label => 'Debug', -variable => \$debug);

my $about_menu = $main_menu->cascade(-label => 'Help', -underline => 0);
$about_menu->command(-label => 'About', -command => \&about);

$top->configure(-menu => $main_menu);

MainLoop;

sub do_open {
    print("open\n");
}

sub run {
    print $debug, "\n";
    print("run\n");
}

sub about {
    print("about\n");
}

sub enable {
    $run->configure(-state => 'normal');
}

sub disable {
    $run->configure(-state => 'disabled');
}

Tk::Menu

Perl Tk Keyboard binding

Tk::bind

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my $label = $top->Label(
    -text => 'Press a, A, Ctrl-A, Alt-a, F1 and observe on the console',
    -font => ['fixed', 40],
    -background => 'yellow',
);
$label->pack();

$top->bind("<a>", sub { say 'a pressed' });
$top->bind("<A>", sub { say 'A pressed (shift-a)' });
$top->bind("<Control-a>", sub { say 'Ctrl-a pressed' });
$top->bind("<Alt-a>", sub { say 'Alt-a pressed' });
$top->bind("<F1>", sub { say 'F1' });

MainLoop;

Alt-F4 is already use to exit the application

Perl Tk Any Key binding

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my $label = $top->Label(
    -text => 'Press any key',
    -font => ['fixed', 40],
    -background => 'yellow',
);
$label->pack();

sub key_pressed {
    my $window = shift;
    my $event = $window->XEvent;
    #say $event;
    say $event->K;
}

$top->bind("<Any-KeyPress>", \&key_pressed);


MainLoop;

Perl Tk Mouse button and movement bindings

Tk::bind

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my $label = $top->Label(
    -text => "Click on the buttons of the mouse\nand look at the terminal.",
    -font => ['fixed', 40],
    -background => 'purple',
);
$label->pack;


$top->bind('<ButtonPress-1>', sub { say 'ButtonPress-1' }); # Mouse left button click
$top->bind('<ButtonPress-2>', sub { say 'ButtonPress-2' }); # Mouse middle button click
$top->bind('<ButtonPress-3>', sub { say 'ButtonPress-3' }); # Mouse right button click

$top->bind('<ButtonRelease-1>', sub { say 'ButtonRelease-1' }); # Mouse left button release
$top->bind('<ButtonRelease-2>', sub { say 'ButtonRelease-2' }); # Mouse middle button release
$top->bind('<ButtonRelease-3>', sub { say 'ButtonRelease-3' }); # Mouse right button release

$top->bind('<B1-Motion>',sub { say 'Motion-1' } ); # Moving mouse while left button is pressed
$top->bind('<B2-Motion>',sub { say 'Motion-2' } ); # - middle button -
$top->bind('<B3-Motion>',sub { say 'Motion-3' } ); # - right button -

MainLoop;

Perl Tk Mouse events, coordinates

XEvent
See the explanations Tk::bind

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my $label = $top->Label(
    -text => "Click on the buttons of the mouse\nand look at the terminal.",
    -font => ['fixed', 40],
    -background => 'blue',
);
$label->pack;

$top->bind('<ButtonPress-1>', \&mouse);
$top->bind('<ButtonPress-2>', \&mouse);
$top->bind('<ButtonPress-3>', \&mouse);

$top->bind('<ButtonRelease-1>', \&mouse);
$top->bind('<ButtonRelease-2>', \&mouse);
$top->bind('<ButtonRelease-3>', \&mouse);

MainLoop;

sub mouse {
    my ($window) = @_;
    my $event = $window->XEvent;
    say $event->b;
    say $event->s;
    say $event->x;
    say $event->y;
    say '-----';
}

Perl Tk Checkbutton (Checkbox)

Checkbutton
Tk::Checkbutton

use strict;
use warnings;

use Tk;

my $top = MainWindow->new;

my @planets = ('Mercury', 'Venus', 'Earth', 'Mars', 'Jupiter', 'Saturn');
my %plnt;
for my $planet (@planets) {
    $plnt{$planet} = 0;
    my $cb = $top->Checkbutton(
        -text     => $planet,
        -variable => \$plnt{$planet},
        -font     => ['fixed', 15]
    );
    $cb->pack(-side => 'left');
}

my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack();
MainLoop;

sub do_on_click {
    print("Clicked\n");
    for my $planet (sort keys %plnt) {
        printf("%-10s %s\n", $planet, $plnt{$planet});
    }
    print("----\n");
}

Perl Tk Radiobutton

Radiobutton
Tk::Radiobutton

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my @planets = ('Mercury', 'Venus', 'Earth', 'Mars', 'Jupiter', 'Saturn');
my $the_planet;
for my $planet (@planets) {
    my $rb = $top->Radiobutton(
        -text     => $planet,
        -variable => \$the_planet,
        -value    => $planet,
        -font     => ['fixed', 15]
    );
    $rb->pack(-side => 'left');
}

my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack();
MainLoop;

sub do_on_click {
    say $the_planet;
    say '----';
}

Perl Tk Listbox

Listbox
Tk::Listbox

use strict;
use warnings;

use Tk;

my @planets = qw(Mercury Venus Earth Mars Jupiter Saturn);

my $top = MainWindow->new;

my $listbox = $top->Listbox(
    -selectmode => 'single',
    #-selectmode => 'browse',
    #-selectmode => 'multiple',  # just click and select
    #-selectmode => 'extended',  # Ctrl-click to select more
);
$listbox->pack;
$listbox->delete('0','end');
$listbox->insert('end', @planets);

my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;

MainLoop;

sub do_on_click {
    my $selected = $listbox->curselection;
    if (defined $selected) {
        print("Selection: @$selected\n");
        for my $ix (@$selected) {
            print("$planets[$ix]\n");
        }
    } else {
        print "Nothing is selected\n";
    }
}

Perl Tk Dialog

Dialog
Tk::Dialog

use strict;
use warnings;
use 5.010;

use Tk;
use Tk::Dialog;

my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;
MainLoop;

sub do_on_click {
    my $dialog = $top->Dialog(
        -title   => 'Versions',
        -popover => $top,
        -text    => "Perl $]",
        -justify => 'left',
        -buttons => ['Yes', 'No', 'Cancel', 'Redo'],
    );
    my $res = $dialog->Show;
    say $res;
}

Perl Tk DialogBox with custom buttons and widgets

use strict;
use warnings;
use 5.010;

use Tk;
use Tk::DialogBox;

my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;
MainLoop;

sub set_color {
    my ($dialog, $color) = @_;
    say $color;
    $btn->configure(-background => $color);
    $dialog->Exit();
}

sub do_on_click {
    my $dialog = $top->DialogBox(
        -title   => 'Versions',
        -popover => $top,
        -buttons => ['Yes', 'No', 'Cancel', 'Redo'],
    );

    $dialog->add("Label", -background => 'yellow', -text => 'Just some yellow text', -font => ['fixed', 20])->pack();
    my $entry = $dialog->add("Entry", -font => ['fixed', 20],)->pack();
    my $res = $dialog->Show;
    if ($res) {
        say $res;
        say $entry->get;
    }
}

use strict;
use warnings;
use 5.010;

use Tk;
use Tk::DialogBox;

my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;
MainLoop;

sub set_color {
    my ($dialog, $color) = @_;
    say $color;
    $btn->configure(-background => $color);
    $dialog->Exit();
}

sub do_on_click {
    my $dialog = $top->DialogBox(
        -title   => 'Versions',
        -popover => $top,
        -buttons => ['Cancel'],
    );

    my @colors = qw(red green blue yellow);
    for my $color (@colors) {
        $dialog->add("Button", -background => $color, -command => [\&set_color, $dialog, $color])->pack();
    }
    my $res = $dialog->Show;
    #if ($res) {
    #    say $res;
    #}
}

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;

my $pop;

MainLoop;


sub do_on_click {
    print("Clicked\n");
    if (not $pop) {
        say 'Creating';
        $pop = $top->Toplevel();
        $pop->Frame(-width => 150, -height => 230)->pack;
        $pop->protocol('WM_DELETE_WINDOW' => [\&picked, $pop, undef]);
        #$pop->overrideredirect(1);

        my @colors = qw(blue red yellow);
        for my $color (@colors) {
            my $btn = $pop->Button(
            -font    => ['fixed', 20],
            -command => [\&picked, $pop, $color],
            -width   => 20,
            -bg      => $color,
            );
            $btn->pack;
        }
    }
    $pop->Popup(-popanchor  => 'c', -overanchor => 'c', -popover => $top);
}
# TODO: modal (so I cannot click on the main window as long as this is here)

sub picked {
    my ($pop, $color) = @_;
    if ($color) {
        say $color;
        $btn->configure(-background => $color);
    }
    $pop->withdraw;
}

Perl Tk Notepad (Simple editor)

use strict;
use warnings;
use 5.010;

use Tk;
use Tk::FileSelect;
use Cwd qw(getcwd);

my $text;

main();
exit;
###########################


sub main {
    my $top = MainWindow->new;
    add_menu($top);

    $text = $top->Text(
        -state => 'normal'
    );
    $text->pack(-fill => 'both', -expand => 1);

    MainLoop;
}

sub do_open {
    my ($top) = @_;

    my $start_dir = getcwd();
    my $file_selector = $top->FileSelect(-directory => $start_dir);
    my $filename = $file_selector->Show;
    if ($filename and -f $filename) {
        if (open my $fh, '<', $filename) {
            local $/ = undef;
            my $content = <$fh>;
            $text->delete("0.0", 'end');
            $text->insert("0.0", $content);
        } else {
            say "TODO: Report error $! for '$filename'";
        }
    }
}

sub do_quit {
    say "TODO check if file is changed or not";
    exit();
}


sub add_menu {
    my ($top) = @_;

    my $main_menu = $top->Menu();

    my $file_menu = $main_menu->cascade(-label => 'File');
    $file_menu->command(-label => 'Open', -command => [\&do_open, $top]);
    $file_menu->command(-label => 'Quit', -command => \&do_quit);

    my $about_menu = $main_menu->cascade(-label => 'Help', -underline => 0);
    $about_menu->command(-label => 'About', -command => \&do_about);

    $top->configure(-menu => $main_menu);
}

Perl Tk Message

Message
Tk::Message

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;
MainLoop;

sub do_on_click {
    my $msg = $top->Message(-text => 'This is some message');
    $msg->pack(-fill => 'x');
}

Perl Tk with HTML

HTML
Tk::HyperText
Tk::HyperText

use strict;
use warnings;

use Tk;
use Tk::HyperText;

use Browser::Open qw(open_browser open_browser_cmd);


my $top = MainWindow->new;

my $html = $top->HyperText();
$html->pack;
$html->setHandler (Resource => \&onResource);

$html->loadString(qq{<html>
  <head>
  <title>Hello world!</title>
  </head>
  <body bgcolor="#0099FF">
  <font size="6" family="Impact" color="#FFFFFF">
  <strong>Hello, world!</strong>
  </font>
   <h1>Links</h1>
   <ul>
      <li><a href="https://perlmaven.com/">Perlmaven</a></li>
      <li><a href="https://code-maven.com/">Code Maven</a></li>
      <li><a href="https://www.patreon.com/szabgab">Patreon of Gabor</a></li>
   </ul>
  </body>
  </html>
});


MainLoop;

sub onResource {
    my ($html, %info) = @_;
    my $url = $info{href};
    #print $url, "\n";
    #open_browser($url); # https://rt.cpan.org/Public/Bug/Display.html?id=133315
    #print "done\n";
    my $cmd = open_browser_cmd($url);
    # TODO: verify that the URL is well formatted before passing it to system
    if ($^O eq 'MSWin32') {
        system("$cmd $url");
    } else {
        system("$cmd $url &");
    }
}

Perl Tk Dialog Box with HTML

HTML
Tk::HyperText
Tk::HyperText

use strict;
use warnings;
use 5.010;

use Tk;
use Tk::DialogBox;
use Tk::HyperText;
use Browser::Open qw(open_browser open_browser_cmd);

my $top = MainWindow->new;
my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&do_on_click,
);
$btn->pack;
MainLoop;

sub set_color {
    my ($dialog, $color) = @_;
    say $color;
    $btn->configure(-background => $color);
    $dialog->Exit();
}

sub do_on_click {
    my $dialog = $top->DialogBox(
        -title   => 'Versions',
        -popover => $top,
        -buttons => ['OK'],
    );

    my $html = $dialog->HyperText();
    $html->pack;
    $html->setHandler (Resource => \&onResource);
    $html->loadString(q{<html>
      <head>
      <title>Hello world!</title>
      </head>
      <body>
      <h1>Links</h1>
       <ul>
          <li><a href="https://perlmaven.com/">Perlmaven</a></li>
          <li><a href="https://code-maven.com/">Code Maven</a></li>
          <li><a href="https://www.patreon.com/szabgab">Patreon of Gabor</a></li>
       </ul>
      </body>
      </html>
    });

    $dialog->Show;
}

sub onResource {
    my ($html, %info) = @_;
    my $url = $info{href};
    #print $url, "\n";
    #open_browser($url); # https://rt.cpan.org/Public/Bug/Display.html?id=133315
    #print "done\n";
    my $cmd = open_browser_cmd($url);
    # TODO: verify that the URL is well formatted before passing it to system
    if ($^O eq 'MSWin32') {
        system("$cmd $url");
    } else {
        system("$cmd $url &");
    }
}

Perl Tk Browse Entry (ComboBox)

BrowseEntry
ComboBox


use strict;
use warnings;
use 5.010;

use Tk;
use Tk::BrowseEntry;

my $top = MainWindow->new;

my $browse_entry_value = 'three';

my $browse_entry = $top->BrowseEntry(
    -variable => \$browse_entry_value,
    -state => 'readonly',
    -command => \&browse_entry_changed,
    -choices => [qw(one two three four)],
);
$browse_entry->insert('end', qw(five six));

$browse_entry->pack();

my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&click_button,
);
$btn->pack;

MainLoop();

sub browse_entry_changed {
    my ($browse_entry) = @_;
    say "Option menu set to: $browse_entry_value"
}

sub click_button {
    say $browse_entry_value;
}

# [Tk::BrowseEntry](https://metacpan.org/pod/Tk::BrowseEntry)

OptionMenu

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my $option_menu_value = 'three';

my $option_menu = $top->Optionmenu(
    -variable => \$option_menu_value,
    -options  => [qw(one two three four)],
    -command  => \&option_menu_changed,
);
$option_menu->pack();

my $btn = $top->Button(
    -text    => 'Click me',
    -font    => ['fixed', 20],
    -command => \&click_button,
);
$btn->pack;

MainLoop();

sub option_menu_changed {
    my ($item) = @_;
    say "Option menu set to: $item"
}

sub click_button {
    say $option_menu_value;
}

# [Tk::Optionmenu](https://metacpan.org/pod/Tk::Optionmenu)

Perl Tk Table

Table

use Tk;
use Tk::Table;

my $top = MainWindow->new;

my $table  = $top->Table(-columns => 2, -rows => 8, -fixedrows => 1, -scrollbars => 'se');
$table->pack(-expand=> 1, -fill => 'both');

foreach my $col (0..1) {
    foreach $row (0..7) {
        my $btn = $table->Button(
            -text => "Entry $row, $col",
            -command => [\&click, $table , $row ,$col],
        );
        $table->put($row, $col, $btn);
    }
}

MainLoop;

sub click {
    my ($table, $row, $col) = @_;
    my $label = $table->Label(-text => "Pressed $row, $col",-relief => 'sunken');
    my $old = $table->put($row, $col, $label);
    #print "$old\n"
}

Menubutton

I am not sure when would you want to build a menu this way. I only have this example as this is the first one I managed to create and did not want to throw it away.

use strict;
use warnings;
use 5.010;

use Tk;

my $top = MainWindow->new;

my $main_menu = $top->Menubutton(-text => "File" );
my $file_menu = $main_menu->Menu(
    -menuitems => [
        [Button => 'Hello', -command => sub { say 'Hello' } ],
        [Button => 'Quit', -command => sub { exit } ],
    ]
);

$main_menu->configure(-menu => $file_menu);
$main_menu->pack();

MainLoop;

Perl Tk

Perl Tk

Perl Tk

Perl Tk

Perl Tk Plain Window

Perl Tk Label

Perl Tk Button

Perl Tk Entry (visible and hidden for secrets)

Perl Tk Text editor

Perl Tk Menu

Perl Tk Keyboard binding

Perl Tk Any Key binding

Perl Tk Mouse button and movement bindings

Perl Tk Mouse events, coordinates

Perl Tk Checkbutton (Checkbox)

Perl Tk Radiobutton

Perl Tk Listbox

Perl Tk Dialog

Perl Tk DialogBox with custom buttons and widgets

Perl Tk Notepad (Simple editor)

Perl Tk Message

Perl Tk with HTML

Perl Tk Dialog Box with HTML

Perl Tk Browse Entry (ComboBox)

Perl Tk Option Menu

Perl Tk Table

Perl Tk Menu Button

Keyboard shortcuts

Perl Tk