Perl::Tk Minimize to Systray!

Finally!

After searching fruitlessly on the Perl mailing lists for a free alternative to PerlTray (from the ActiveState PDK) I have banged together my own Rube Goldberg-esque contraption which works!

I am doing it the wrong way: one thread (main) to mind the Tk GUI and another (asynchronous) which minds the SysTray icon. They send one another (window) messages in a very crude fashion which happens to be OK and somehow works cross-thread.

This may make a Win32 artist cry and that's what makes it sweet.

Also I am disrespectfully meddling with the innards of Win32::GUI::NotifyIcon. Life's good.

Enjoy the code! (You need to supply a valid Win32 ICON file named icon.ico.)

#!perl.exe

use strict;

use threads;
use threads::shared;

use Tk;

use POSIX ();
use File::Basename qw[dirname];
use File::Spec::Functions qw[ catfile rel2abs updir ];

use Win32::API;
use Win32::SysTray;

Win32::API->Import("user32", 'ShowWindow', 'II', 'I');
use constant SW_HIDE    => 0;
use constant SW_RESTORE => 9;
sub win_op($$)
{
  my $top = shift || return;
  my $op  = shift;
  ShowWindow(hex($top->frame), $op);
}

Win32::API->Import("user32", 'MessageBox', 'NPPI', 'I');
use constant MB_OK       => 0;
use constant MB_ICONSTOP => 16;
sub errorMessageBox($$)
{
  my $title = shift;
  my $msg = shift;

  MessageBox(0, $msg, $title, MB_OK|MB_ICONSTOP);
}

sub Die
{
  errorMessageBox('Sample SysTray', join('' => @_));
  POSIX::_exit(1); # NOTREACHED
}

my $Tray : shared;
sub tray_hide()
{
  return unless defined $Tray;
  my ($handle, $id) = split /:/ => $Tray;
  Win32::GUI::NotifyIcon::_Delete($handle, -id => $id); # HACK!!!
}
sub tray_thread($)
{
  my $top = shift || return;

  my $tray = new Win32::SysTray (
    name   => 'Sample SysTray',
    icon   => rel2abs(dirname($0)).'\icon.ico',
    single => 1,
  ) or Die 'Win32::SysTray failed!';

  $tray->setMenu (
    "> &Show" => sub { win_op($top, SW_RESTORE); },
    ">-"      => 0,
    "> E&xit" => sub {
                   $tray->{Tray}->Remove(); 
                   POSIX::_exit(0); # CORE::exit makes Tk barf
                 },
  ); 

  my $t = $tray->{Tray};
  $Tray = $t->{-handle}.':'.$t->{-id};

  $tray->runApplication;
}

sub main()
{
  my $mainw = MainWindow->new(-title=>'Sample SysTray');

  async { tray_thread($mainw); }
  
  $mainw->OnDestroy(sub {
    tray_hide(); # else we have zombie Systray icon
    POSIX::_exit(0); # should kill background threads
  });

  my $fr = $mainw->Frame->pack(-side => 'bottom', -fill => 'x');    

  $fr->Button(-text => "Exit",
              -command => sub { exit(0); }
  )->pack(-side => 'right');

  $mainw->bind('<Unmap>', sub { win_op($mainw, SW_HIDE); } );

  MainLoop();
}

main();

-ulianov