#!/usr/bin/perl

=head

Skinning Perl/Tk
This window is an experiment for skinning Perl/Tk windows.
Author: Cerone Kirsle - Aug 2 2006

=cut

use strict;
use warnings;
use Tk;

my $main = MainWindow->new;
$main->overrideredirect(1);
$main->geometry ('400x400+10+20');
$main->optionAdd ('*tearOff','false');

my $isMin = 0; # is Minimized
my $isMax = 0; # is Maximized

my $dragger = $main->Frame (
   -background => 'orange',
   -relief     => 'raised',
   -border     => 3,
   -height     => 25,
)->pack (-side => 'top', -fill => 'x');

   my $taskbar = $main->Toplevel (
      -title => 'WindowSkinned',
   );
   $taskbar->geometry ('10x10');
   $taskbar->MoveToplevelWindow (-50,-50);

   $taskbar->bind ('<FocusIn>', sub {
      # If minimized...
      if ($isMin) {
         &min;
      }
      $dragger->focusForce;
   });

   $taskbar->bind ('<Destroy>', sub {
      $main->destroy;
   });

   my $titleFrame = $dragger->Frame (
      -background => 'orange',
   )->pack (-side => 'left');

      my $titleIcon = $titleFrame->Label (
         -bitmap => 'Tk',
         -width => 16,
         -height => 16,
         -background => 'orange',
         -foreground => 'black',
      )->pack (-side => 'left');

      my $titleText = $titleFrame->Label (
         -text => 'WindowSkinned',
         -background => 'orange',
         -foreground => 'black',
         -font => [
            -family => 'Verdana',
            -size   => 9,
            -weight => 'bold',
         ],
      )->pack (-side => 'left');

   my $bttnFrame = $dragger->Frame (
      -background => 'orange',
   )->pack (-side => 'right');

      my $xBttn = $bttnFrame->Label (
         -text => 'r',
         -width => 2,
         -height => 1,
         -relief => 'raised',
         -border => 2,
         -foreground => 'white',
         -activeforeground => 'white',
         -background => 'red',
         -activebackground => 'red',
         -font => [
            -family => 'Webdings',
            -size   => 8,
            -weight => 'bold',
         ],
      )->pack (-side => 'right', -padx => 1);

      my $maxBttn = $bttnFrame->Label (
         -text => '1',
         -width => 2,
         -height => 1,
         -relief => 'raised',
         -border => 2,
         -foreground => 'black',
         -activeforeground => 'black',
         -background => 'orange',
         -activebackground => 'orange',
         -font => [
            -family => 'Webdings',
            -size   => 8,
            -weight => 'bold',
         ],
      )->pack (-side => 'right', -padx => 1);

      my $minBttn = $bttnFrame->Label (
         -text => '0',
         -width => 2,
         -height => 1,
         -relief => 'raised',
         -border => 2,
         -foreground => 'black',
         -activeforeground => 'black',
         -background => 'orange',
         -activebackground => 'orange',
         -font => [
            -family => 'Webdings',
            -size   => 8,
            -weight => 'bold',
         ],
      )->pack (-side => 'right', -padx => 1);

      $minBttn->bind ('<ButtonRelease-1>', \&min);
      $maxBttn->bind ('<ButtonRelease-1>', \&max);
      $xBttn->bind ('<ButtonRelease-1>', sub { exit(0); });

my $body = $main->Frame (
   -background => 'lightblue',
   -relief     => 'raised',
   -border     => 2,
   -cursor     => ($^O =~ /^(MSWin32|DOS)$/ ? 'size_nw_se' : 'bottom_r
+ight_corner'),
)->pack (-fill => 'both', -expand => 1);

my $content = $body->Frame (
   -background => 'white',
   -relief     => 'sunken',
   -borderwidth => 2,
   -cursor     => 'arrow',
)->pack (-fill => 'both', -expand => 1, -padx => 5, -pady => 5);

   my $text = $content->Scrolled ('ROText',
      -scrollbars => 'ose',
      -background => 'white',
      -foreground => 'black',
      -wrap       => 'word',
      -font       => [
         -family => 'Arial',
         -size   => 10,
      ],
      -border     => 0,
   )->pack (-fill => 'both', -expand => 1);

   $text->tagConfigure ('header', -font => [ -size => 26, -family => '
+Arial', -weight => 'bold' ]);
   $text->tagConfigure ('bold', -font => [ -size => 10, -family => 'Ar
+ial', -weight => 'bold' ]);

   $text->insert ('end',"Skinning Perl/Tk",'header');
   $text->insert ('end',"\n\n"
      . "This window is an experiment for skinning Perl/Tk windows. Wh
+at you see is a ");
   $text->insert ('end',"overrideredirect(1)",'bold');
   $text->insert ('end'," window, which doesn't have the normal window
+ chrome. Everything else "
      . "on this window is a result of frames and other normal widgets
+.\n\n"
      . "The skinned window spawns a normal child window. Clicking thi
+s window puts the focus "
      . "back on the skinned window, and will also restore it only if 
+it is currently in "
      . "'minimized' mode.\n\n");
   $text->insert ('end',"Tag Bindings",'header');
   $text->insert ('end',"\n\n"
      . "Clicking and dragging anywhere on the title bar frame can rep
+osition the window. "
      . "Double-click the title bar to maximize or restore the window.
+ Click the Tk icon "
      . "to get a (standard-looking) popup menu. The buttons in the to
+p right corner can "
      . "minimize, maximize, and close the window. When focus is lost,
+ the title bar turns gray "
      . "instead of orange.\n\n");

   $text->insert ('end',"Author",'header');
   $text->insert ('end',"\n\n"
      . "Cerone Kirsle ~ Aug 2 2006");

my $winX = 10;
my $winY = 20;

my $dragFromX = 0;
my $dragFromY = 0;

my $isDragging = 0;

# Add some fun active window things.
$main->bind ('<FocusOut>', sub {
   $dragger->configure (-background => 'gray');
   $titleFrame->configure (-background => 'gray');
   $titleIcon->configure (-background => 'gray');
   $titleText->configure (-background => 'gray');
   $bttnFrame->configure (-background => 'gray');
   $minBttn->configure (-background => 'gray');
   $maxBttn->configure (-background => 'gray');
});
$main->bind ('<FocusIn>', sub {
   $dragger->configure (-background => 'orange');
   $titleFrame->configure (-background => 'orange');
   $titleIcon->configure (-background => 'orange');
   $titleText->configure (-background => 'orange');
   $bttnFrame->configure (-background => 'orange');
   $minBttn->configure (-background => 'orange');
   $maxBttn->configure (-background => 'orange');
});

$dragger->bind ('<Double-Button-1>', \&max);
$dragger->bind ('<ButtonPress-1>', \&buttonPress);
$dragger->bind ('<ButtonRelease-1>', \&buttonRelease);
$dragger->bind ('<Motion>', \&motion);

$titleFrame->bind ('<Double-Button-1>', \&max);
$titleFrame->bind ('<ButtonPress-1>', \&buttonPress);
$titleFrame->bind ('<ButtonRelease-1>', \&buttonRelease);
$titleFrame->bind ('<Motion>', \&motion);

$titleIcon->bind ('<Double-Button-1>', sub { exit(0); });
$titleIcon->bind ('<ButtonPress-1>', \&showMenu);

$titleText->bind ('<Double-Button-1>', \&max);
$titleText->bind ('<ButtonPress-1>', \&buttonPress);
$titleText->bind ('<ButtonRelease-1>', \&buttonRelease);
$titleText->bind ('<Motion>', \&motion);

$body->bind ('<ButtonPress-1>', \&startResize);
$body->bind ('<ButtonRelease-1>', \&endResize);
$body->bind ('<Motion>', \&doResize);

my $isResizing = 0;
my $sizeX = 400;
my $sizeY = 400;

MainLoop;

sub buttonPress {
   $isDragging = 1;

   # dragFrom vars should be the offset from 0,0 to the current positi
+on.
   $dragFromX = $Tk::event->X - $winX;
   $dragFromY = $Tk::event->Y - $winY;

   print "Drag from: $dragFromX,$dragFromY\n";
}

sub buttonRelease {
   $isDragging = 0;
}

sub motion {
   return unless $isDragging;
   return if $isMax; # no dragging when maximized

   # Get the new position.
   my $curX = $Tk::event->X;
   my $curY = $Tk::event->Y;

   $curX -= $dragFromX;
   $curY -= $dragFromY;

   $winX = $curX;
   $winY = $curY;

   print "Cur: $curX,$curY;   MoveTo: $winX,$winY (dragFrom: $dragFrom
+X,$dragFromY)\n";

   $main->MoveToplevelWindow ($winX,$winY);
}

sub startResize {
   $isResizing = 1;
}
sub endResize {
   $isResizing = 0;
}
sub doResize {
   return unless $isResizing;
   return if $isMax;

   my $curX = $Tk::event->X - $winX;
   my $curY = $Tk::event->Y - $winY;

   $sizeX = $curX;
   $sizeY = $curY;

   $main->geometry ($sizeX . "x" . $sizeY);
}

sub showMenu {
   my $ct = $main->Menu;

   $ct->command (-label => '~Maximize', -command => \&max);
   $ct->command (-label => '~Minimize', -command => \&min);
   $ct->command (-label => '~Restore', -command => \&restore);
   $ct->separator;
   $ct->command (-label => '~Exit', -command => sub {
      exit(0);
   });

   $ct->Popup (-popanchor => 'nw', -popover => 'cursor');
}

sub max {
   if ($isMax) {
      # Restore.
      $main->geometry ($sizeX . "x" . $sizeY);
      $main->MoveToplevelWindow ($winX,$winY);
      $maxBttn->configure (-text => '1');
      $isMax = 0;
   }
   else {
      # Maximize.
      $main->geometry ($main->screenwidth . 'x' . $main->screenheight)
+;
      $main->MoveToplevelWindow (0,0);
      $maxBttn->configure (-text => '2');
      $isMax = 1;
   }
}

sub min {
   if ($isMin) {
      # Restore.
      if ($isMax) {
         $main->geometry ($main->screenwidth . 'x' . $main->screenheig
+ht);
         $main->MoveToplevelWindow (0,0);
      }
      else {
         $main->geometry ($sizeX . "x" . $sizeY);
         $main->MoveToplevelWindow ($winX,$winY);
      }
      $isMin = 0;
   }
   else {
      # Minimize
      $main->geometry ('5x5');
      $main->MoveToplevelWindow (-50,-50);
      $isMin = 1;
   }
}

sub restore {
   if ($isMax) {
      # Restore.
      $main->geometry ($sizeX . "x" . $sizeY);
      $main->MoveToplevelWindow ($winX,$winY);
      $maxBttn->configure (-text => '1');
      $isMax = 0;
   }
   if ($isMin) {
      $main->geometry ($sizeX . "x" . $sizeY);
      $main->MoveToplevelWindow ($winX,$winY);
   }
}
[download]