Perl Tk App Example

Note: The following is presented as large "code snippets". It will not work if directly copied!
(I especially got lazy with including all of the necessary "use" lines)

Another note: I'm sure this could all be done in an OO way as well. I just haven't attempted that yet.
Note #3: Though I didn't initially do it on purpose, I am purposefully not adding Exporter to these packages. It enforces a namespace.

app.pTk

use strict;
use warnings;
use Tk;
 
# (use Logging library/module)
 
# (use App controlling module)
# (use App::GUI module)
 
my $DEBUG = 0; # Debug/Logging level
 
# Get script's name
my $me = qx/basename $0/; # PORT: Unix only? Better to use regex?
chomp ($me);
 
# ------------
# MAIN SCRIPT
# ------------
{
   # Initialize
   # (initialize logger)
 
   _ParseArguments() or exit 1;
   # (App::GUI::Init();)
 
   # Run the Tk GUI
   MainLoop;
 
   # Shutdown (after the main window has closed)
 
} # End Main
 
# -------------
# SUBROUTINES
# -------------
 
sub _ParseArguments
{
   my $successful_parse = 1;
   #
   return $successful_parse;
 
} # End _ParseArguments
 
# -------------
 
sub _Usage
{
   #
}

App.pm

package App;
 
use strict;
use warnings;
 
# ------------------------
# APP GLOBAL CONSTANTS
# ------------------------
 
my %const = 
(
   'CONST 1' => 1,
   'CONST 2' => 2,
   # etc...
 
); # End %const
 
# Get const value (accessor)
sub Const { if (exists $const{$_[0]}) {$const{$_[0]};} else {q//;} }
 
# Other App Controller data/functions...
 
# Module returns a true value
1;

App/GUI.pm

package App::GUI;
 
use strict;
use warnings;
use Tk;
 
# (use App controlling module)
# (use App::GUI::MainWin module)
# (use App::GUI::InitWin module)
# (use additional App::GUI::* modules)
 
# ----------
# Constants
# ----------
 
# Set up the color scheme
my %color_scheme;
$color_scheme{ 'text bg'        } = 'white';
$color_scheme{ 'normal text fg' } = 'black';
$color_scheme{ 'attn text fg'   } = 'red';
 
# Get color (accessor)
sub Color { $color_scheme{$_[0]}; }
 
# --------
# My Data
# --------
my %window;
 
# -------------
# SUBROUTINES
# -------------
 
sub Init
{
   # This is the Main Window widget (parent to all other widgets)
   $window{'Main'} = MainWindow->new(-title => App::Const('MAIN WIN TITLE'));  # Tk MainWindow object
   App::GUI::MainWin::Create(\$window{'Main'});   # Pass object as reference to the window's specific Create method
 
   # IF NEEDED, hide Main window until init complete.
   $window{'Main'}->withdraw();
 
   # Create initialization (progress) window to display while the App initializes
   $window{'Init'} = $window{'Main'}->Toplevel(-title => App::Const('INIT WIN TITLE'));
   App::GUI::InitWin::Create(\$window{'Init'});
   $window{'Init'}->update();
 
   # Create (other windows) (but hide it until needed)
   $window{'Other Window'} = $window{'Main'}->Toplevel(-title => App::Const('OTHER WIN TITLE'));
   App::GUI::OtherWin::Create(\$window{'Other Window'});
   $window{'Other Window'}->withdraw();
 
   # (Perform other App initializations here)
 
   # Switch to the Main window
   $window{'Init'}->withdraw();  # Should it be destroyed as well?
 
   $window{'Main'}->deiconify();
   $window{'Main'}->raise();
 
} # End Init
 
# -------------
 
sub Update
{
   # Subroutine parameters
   my ($win_name) = @_;
   if ($window{$win_name})
   {
      $window{$win_name}->update();
   }
 
} # End Update
 
# Module returns a true value
1;

App/GUI/MainWin.pm

package App::GUI::MainWin;
 
use strict;
use warnings;
 
# ----
# DATA
# ----
 
# My widgets
my %win_obj;
 
# Widget accessor
sub WinObj { $win_obj{$_[0]}; }
 
# Data variables linked to widgets
my %win_data;
 
# Data accessors
sub GetData { $win_data{$_[0]}; }
 
# Reference to Main Window (in App::GUI)
my $parent_win_ref;
 
# -------------
# SUBROUTINES
# -------------
 
sub Create
{
   ($parent_win_ref) = @_;
 
   App::GUI::ToolbarPix::Init($parent_win_ref);
 
   # Create the widget data
   _DefineWidgets();
 
   # Arrange the widgets on the window
   _LayoutWidgets();
 
   # Catch the window manager close (e.g. 'x' button) event
   $($parent_win_ref)->protocol('WM_DELETE_WINDOW', sub { _ExitHandler(); } );
 
} # End Create
 
# -------------
 
sub _DefineMenu
{
   # Returns the menu definition
 
   [
      # Menu 1
      [Cascade => '~Menu 1', -tearoff => 0, -menuitems =>
       [
          [Button => '~Item 1.1', 
           -command => sub { handlerfunction(); },
          ],
 
          [Separator => q//],
 
          [Button => 'I~tem 1.2',
           -command => sub { handlerfunction(); },
          ],
       ],
      ], # End Menu 1
 
      # Menu 2
      [Cascade => 'M~enu 2', -tearoff => 0, -menuitems =>
       [
          [Button => 'Item 2.1', 
           -command => sub { handlerfunction(); },
          ],
 
          [Separator => q//],
 
          [Button => 'Item 2.2',
           -command => sub { handlerfunction(); },
          ],
       ],
      ], # End Menu 2
 
   ]; # End menu definition
 
} # End _DefineMenu
 
# -------------
 
sub _DefineWidgets
{
   # ----
   # MENU
   # ----
 
   # Define the menu items
   my $menu_items = _DefineMenu();
 
   # Create the menubar widget
   $win_obj{'menu bar'} = ${$parent_win_ref}->Menu(-menuitems => $menu_items);
 
   # Set the menubar for the main window
   ${$parent_win_ref}->configure(-menu => $win_obj{'menu bar'});
 
   # ------
   # FRAMES
   # ------
 
   $win_obj{'toolbar frame'} = ${$parent_win_ref}->Frame();
 
   $win_obj{'main frame'} = ${$parent_win_ref}->Frame();
 
   # Frame for status messages
   $win_obj{'status frame'} = 
      ${$parent_win_ref}->Frame(-relief      => 'groove',
                                -borderwidth => 2,
                               );
 
   # ------------------------
   # Message frame widget(s)
   # ------------------------
 
   $win_obj{'status message label'} =
      $win_obj{'status frame'}->Label(-textvariable => \$win_data{'status message'},);
 
   # ---------------------
   # Toolbar frame widgets
   # ---------------------
 
   $win_obj{'tooltip'} =
      ${$parent_win_ref}->Balloon(-state     => 'status',
                                  -statusbar => $win_obj{'status message label'},
                                  -initwait  => App::Const{'TOOLTIP DELAY'},
                                  -postcommand => sub
                                     {
                                      # Called prior to displaying balloon message.
 
                                      # Ensure tooltips are 'normal' text color.
                                      $win_obj{'status message label'}->configure
                                         (-foreground => App::GUI::Color('normal text fg'));
 
                                      return 1; # Return "true" to display message.
                                     },
                                  );
 
   # Button and tooltip
   $win_obj{'toolbar button 1'} =
      $win_obj{'toolbar frame'}->Button(-image   => App::GUI::ToolbarPix::Get('Button 1'),
                                        -command => sub { handlerfunction(); },
                                       );
 
      $win_obj{'tooltip'}->attach
         ($win_obj{'toolbar button 1'},
          -statusmsg => App::Const('BUTTON 1 TOOLTIP TEXT'),
         );
 
} # End _DefineWidgets
 
# -------------
 
sub _LayoutWidgets
{
   #
 
} # End _LayoutWidgets
 
# -------------
 
sub StatusMessage
{
   # Subroutine arguments
   my ($type, $msg) = @_;
 
   # Default text color
   my $text_color = App::GUI::Color('normal text fg');
 
   if ( uc $type eq 'WARN' )
   {
      $text_color = App::GUI::Color('attn text fg');
   }
 
   # Apply the text color
   $win_obj{'status message label'}->configure(-foreground => $text_color);
 
   # Update the text
   $win_data{'status message'} = $msg;
 
   # (Log the text)
 
} # End StatusMessage
 
# -------------
 
sub SetBusy
{
   # Subroutine's arguments
   my ($value) = @_;
 
   if ( defined $value && !$value )
   {
      ${$parent_win_ref}->Unbusy();
   }
   else
   {
      ${$parent_win_ref}->Busy(-recurse => 1);
   }
 
} # End SetBusy
 
# Module returns a true value
1;

App/GUI/ToolbarPix.pm

package App::GUI::ToolbarPix;
 
use strict;
use warnings;
use Tk;
 
# ----
# DATA
# ----
 
# Pixmap Tk Items
my %pixmap;
 
# Pixmap definitions
my %pix_data;
 
# pix data format
# line 1 = '/* XPM */'
# line 2 = 'static char * Icon_xpm[] = {'
# line 3 = '"A B C 1"'
#    A, B = height, width of the icon (can't remember which is which, though)
#    C = number of colors defined
#    1 = ? (I don't know what this is for)
# lines 4 thru C+3 = 'D    c #XXXXXXXXXXXX",'
#    D = character to represent this color of pixel
#    X's = RGB color
# lines C+4 on = ascii art lines (in quotes) using the characters defined above
#    Each line except the last ends with a comma (,)
#    The last line ends with };
#
# The icon below is a 4x4 pixel magenta box.
# 24x24 is a decent size for toolbar icons.
 
$pix_data{'Button 1'} = <<'END_OF_PIXMAP_BUTTON';
/* XPM */
static char * Icon_xpm[] = {
"4 4 1 1",
"X    c #FFFF0000FFFF",
"XXXX",
"XXXX",
"XXXX",
"XXXX"};
END_OF_PIXMAP_BUTTON
 
# -------------
# SUBROUTINES
# -------------
 
# Pixmap accessor
sub Get { $pixmap{$_[0]}; }
 
# -------------
 
sub Init
{
   # Subroutine's arguments
   my ($parent_win_ref) = @_;
 
   foreach ( keys %pix_data)
   {
      $pixmap{$_} = ${$parent_win_ref}->Pixmap{-data => $pix_data{$_});
   }
 
} # End Init
 
# Module returns a true value
1;

Additional window functionality

Hide windows, don't destroy them

# (Put this in the "Create" sub, for example)
# Catch the window manager close (e.g. 'x' button) event
# Don't destroy the window on close, just hide it until it needs to be Displayed again (so we don't have to re-create it)
${$parent_win_ref}->protocol
   ('WM_DELETE_WINDOW',
    sub { ${$parent_win_ref}->withdraw(); },
   );
 
sub Display
{
   # Called by an external module (window) when I need to show up
   ${$parent_win_ref}->deiconify();
   ${$parent_win_ref}->raise();
 
} # End Display

Dialog behavior with a window

A complex dialog (to get information from the user) is defined as a window (we'll call it "DialogWin"). Here's how to pop it up as a modal dialog and then return the data and hide when "OK" is clicked.

Here is the code calling the DialogWin to get data results:

my $answer = App::GUI::DialogWin::GetAnswer(@dialog_input);

Now the code within DialogWin that makes it work as a modal dialog:

sub GetAnswer
{
   # (Handle dialog_input --- stored in @_)
 
   # Show the dialog
   ${$parent_win_ref}->deiconify();
   ${$parent_win_ref}->raise();
   ${$parent_win_ref}->grab();
 
   # Initialize/reset the inter-function variables.
   $win_data{'answer'} = q//;
   $win_data{'done'} = 0;
 
   # Let the user play with the dialog and produce an 'answer'.
   # This function won't continue until 'done' is true (set in the handler for the 'OK' or 'Cancel' button);
   # 'answer' will be updated by then.
   ${$parent_win_ref}->waitVariable(\$win_data{'done'});
 
   return $win_data{'answer'};
 
} # End GetAnswer
 
# Elsewhere in the code, the command handler for the 'OK' button...
 
sub _OKButtonHandler
{
   # $win_data{'answer'} equals something
 
   # Hide the window
   ${$parent_win_ref}->grabRelease();
   ${$parent_win_ref}->withdraw();
 
   # Tell GetAnswer that we've got an answer, so that it can finish and return the answer to whoever called it.
   $win_data{'done'} = 1;
 
} # End _OKButtonHandler
Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-ShareAlike 3.0 License