#!/usr/bin/perl
use warnings;
use strict;
use Tk;

# an 8 x 13 grid
my @keys = (
'~','`','!','@','#','$','%','^','&','*','(',')','_',    
'1','2','3','4','5','6','7','8','9','0','-','+','=',  
'Q','W','E','R','T','Y','U','I','O','P','{','}','"', 
'q','w','e','r','t','y','u','i','o','p','[',']','\'',
'A','S','D','F','G','H','J','K','L',':','|','\\','/',
'a','s','d','f','g','h','j','k','l',';','<','>','?', 
'Z','X','C','V','B','N','M','BackSpace','dummy','dummy','dummy','dummy
+','dummy',
'z','x','c','v','b','n','m','.','Clear','dummy','dummy','dummy','dummy
+');

#print "@keys\n";

my $mw=tkinit;

$mw->fontCreate('big',
   -family=>'arial',
  -weight=>'bold',
  -size=>int(-18*18/14));

 my $tframe = $mw->Frame()->pack(-expand=>1,-fill=>'both');   
 my $passwd = '';
 my $label = $tframe->Label(-text => "Password: ",
                            -font => 'big',
 )->pack(-side=>'left');
 
 my $entry = $tframe->Entry(
         -show => '*',
         -textvariable => \$passwd,
         -bg => 'black',
         -fg => 'white',
         -font => 'big',
         )->pack(-side=>'left',-expand=>1,-fill=>'x', -padx=> 5);

 my $submit = $tframe->Button(
                 -text=>'Submit',
                 -font => 'big',
                 -bg => 'yellow',
                 -activebackground => 'hotpink',
                 -command => \&submit,
          )->pack(-side=>'right',-expand=>1,-fill=>'x', -padx=> 5);


 for my $row (1..8){
    my $frame = $mw->Frame()->pack(-expand=>1,-fill=>'both');   
   
   for my $col (1..13){
     my $l = shift @keys;
     if($l eq 'dummy'){next}else{
          $frame->Button(-text=> $l,
               -bg => 'beige',
               -activebackground => 'lightyellow',
               -font => 'big',
               -command => [\&process_key, $l],
                 )->pack(-side=>'left',-anchor=>'w', -expand=>1,-fill=
+>'both');   
          
      }
   }
 
 }
MainLoop;
#####################
sub process_key{
  my $key = shift;
  print "$key\n";
  if ($key eq 'Clear'){$passwd = '';}
  elsif ($key eq 'BackSpace'){ chop $passwd;}
  else{ $passwd .= $key;}

}
#####################
sub submit {
 print $entry->get(),"\n";
 $entry->delete(0,'end');
}
[download]