#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use MIME::Base64 qw( encode_base64 decode_base64 );
use Crypt::CBC;

my $mw=tkinit;
my $tl;

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

my $getp = $mw->Button(
                 -text=>'Get Password',
                 -font => 'big',
                 -bg => 'yellow',
                 -activebackground => 'hotpink',
                 -command => \&build_keyboard,
          )->pack(-expand=>1,-fill=>'x', -padx=> 5);

MainLoop;

sub build_keyboard{

 if ( !Exists( $tl ) ) {
   $tl = $mw->Toplevel();
   $tl->title( "Virtual Keyboard" );

#prevents $tl from destroying on window manager close                 
+                 
$tl->protocol('WM_DELETE_WINDOW' => sub {                             
+                
       $tl->withdraw; });

# 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','.','Space','Clear','dummy','dummy','dummy
+');

 my $tframe = $tl->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,$entry],
          )->pack(-side=>'right',-expand=>1,-fill=>'x', -padx=> 5);


 for my $row (1..8){
    my $frame = $tl->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,\$passwd ],
                 )->pack(-side=>'left',-anchor=>'w', -expand=>1,-fill=
+>'both');   
          
      }
   }
 
 }


  }
  else {
   $tl->deiconify();
   $tl->raise();
 }

}

#####################
sub process_key{
  my $key = shift;
  my $passwd_ref = shift;
  #print "$key\n";
  if ($key eq 'Clear'){$$passwd_ref = '';}
  elsif ($key eq 'BackSpace'){ chop $$passwd_ref;}
  elsif ($key eq 'Space'){ $$passwd_ref .= ' '; }
  else{ $$passwd_ref .= $key;}
}
#####################
sub submit {
 my $entry = shift;
 
#print $entry->get(),"\n";
#my $string = 'yadda yadda yadda yadda';
#print "$string\n";
#my $enc = encryptString( $string );
#print $enc,"\n";
#my $enc64 = encode_base64($enc);
#print $enc64,"\n";

#help avoid prying eyes by storing in encoding
my $enc64 = 'UmFuZG9tSVaifEsw5ZfchSwgyXj0JSxm5UoAgAcwrvX1MQeuK41kow=='
+;
if( $entry->get() eq decryptString(decode_base64($enc64)) ){

     $entry->delete(0,'end');
     $tl->withdraw;  # save the keyboard for reuse, so second use is f
+aster

     $mw->messageBox(
           -icon => 'warning',
           -message => 'You are in Mr. Phelps',
           -type => 'OK'
         );

 
 }else{
 
     $mw->messageBox(
           -icon => 'error',
           -message => 'Wrong Guess Try Again',
           -type => 'OK'
         );
  
     $entry->delete(0,'end');
  }
}
############################################################
sub encryptString {
   my $string = shift;

#my $KEY = 'secret_foo';
#hex of $KEY 
my $KEY = join '', map { chr } (0x73, 0x65, 0x63, 0x72, 0x65, 0x74, 0x
+5f, 0x66, 0x6f, 0x6f);
 
   my $cipher = Crypt::CBC->new(
      -key        => $KEY,
      -cipher     => 'Blowfish',
      -padding  => 'space',
      -add_header => 1
   );

   my $enc = $cipher->encrypt( $string  );
   return $enc; 
}

###################################################################

sub decryptString {
   my $string = shift;
   my $KEY = join '', map { chr } (0x73, 0x65, 0x63, 0x72, 0x65, 0x74,
+ 0x5f, 0x66, 0x6f, 0x6f);

   my $cipher = Crypt::CBC->new(
      -key        => $KEY,
      -cipher     => 'Blowfish',
      -padding  => 'space',
      -add_header => 1
   );

   my $dec = $cipher->decrypt( $string  );
   return $dec; 
}

[download]

In reply to Tk Virtual Keyboard Example by zentara

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.