use strict;
use Tk;

my use Tk;
use strict;

my $mw = MainWindow->new;
my $f = $mw->Frame->
   pack(-padx => 5, -pady => 5);

my $message = $f->Label->
   grid(-columnspan => 2, -sticky => 'ew');

my $userEntry = $f->Entry;
$f->Label(-text => "User:")->
   grid($userEntry, -sticky => 'e');
 
my $passwdEntry = $f->Entry(-show => '*');
$f->Label(-text => "Password:")->
   grid($passwdEntry, -sticky => 'e');

my $button = $f->Button(
   -text => "Login",
   -command => [\&login, $userEntry, $passwdEntry, $message]
)->grid(-columnspan => 2, -pady => 3);

MainLoop;

sub login
{
    my ($userE, $passE, $msg) = @_;

    if ($userE->get ne "eric" || $passE->get ne "stigisdead") {
       $userE->delete(0, 'end');
       $passE->delete(0, 'end');
       $msg->configure(-text => "Login Failed!");
    }  
    else {
       $msg->configure(-text => "Login Successful");
    }
}

##</code><code>##

package AuthService;

sub login
{
   my ($user, $password) = @_;
   return 
      (defined($user) && defined($password) &&
      $user eq "eric" && $password eq "swordfish");
}
1;

package main;

use Test::More tests => 7;

ok(AuthService::login("eric", "swordfish"), 
   "good user/password combo");

ok(!AuthService::login("", "swordfish"), 
   "no user, good passwd");
ok(!AuthService::login(undef, "swordfish"), 
   "undef user, good passwd");

ok(!AuthService::login("eric", ""), 
   "good user, undef password");
ok(!AuthService::login("eric", undef), 
   "good user, no password");

ok(!AuthService::login("", ""), "Empty user/passord");
ok(!AuthService::login(), "undef user/password");

##</code><code>##

## LoginForm.pm
package LoginForm;

use strict;
use base qw(Tk::Frame);
Tk::Widget->Construct('LoginForm');

sub Populate 
{
   my ($cw, $args) = @_;
   $cw->SUPER::Populate($args);

   my $f = $cw->Frame->pack;
   my $msg = $f->Label->
      grid(qw/-columnspan 2 -sticky ew/);

   my $userE = $f->Entry;
   $f->Label(-text => "User:")->
      grid($userE, -sticky => 'e');

   my $passE = $f->Entry(-show => '*');
   $f->Label(-text => "Password:")->
      grid($passE, -sticky => 'e');   

   my $button = $f->Button(
      -text => 'Login',
      -command => [Login => $cw]
   )->grid(qw/-columnspan 2 -pady 4/);

   $cw->Advertise(Message     => $msg);
   $cw->Advertise(UserEntry   => $userE);
   $cw->Advertise(PassEntry   => $passE);
   $cw->Advertise(LoginButton => $button);
} 

sub Login 
{
   my $cw = shift;
   my $user = $cw->Subwidget('UserEntry')->get;
   my $pass = $cw->Subwidget('PassEntry')->get;
   print "$user/$pass\n";
}
1;
  
## login.pl
use Tk;
use LoginForm;

my $mw = MainWindow->new;
$mw->LoginForm->pack;

MainLoop; 

##</code><code>##

package LoginForm;

use strict;
use base qw(Tk::Frame);

sub Populate 
{
   my ($cw, $args) = @_;
  $cw->SUPER::Populate($args);

   my $f = $cw->Frame->pack;
   my $msg = $f->Label->
      grid(qw/-columnspan 2 -sticky ew/);

   my $userE = $f->Entry;
   $f->Label(-text => "User:")->
      grid($userE, -sticky => 'e');

   my $passE = $f->Entry(-show => '*');
   $f->Label(-text => "Password:")->
      grid($passE, -sticky => 'e');   

   my $button = $f->Button(
      -text => 'Login',
      -command => [Login => $cw]
   )->grid(qw/-columnspan 2 -pady 4/);

   $cw->Advertise(Message     => $msg);
   $cw->Advertise(UserEntry   => $userE);
   $cw->Advertise(PassEntry   => $passE);
   $cw->Advertise(LoginButton => $button);

   $cw->ConfigSpecs(-logincmd => [qw/CALLBACK/]);
} 

sub Login 
{
   my $cw = shift;
   my $user = $cw->Subwidget('UserEntry')->get;
   my $pass = $cw->Subwidget('PassEntry')->get;
   my $msgL = $cw->Subwidget('Message'); 

   if ($cw->cget(-logincmd) && 
       $cw->Callback(-logincmd => $user, $pass)) 
   {
      $msgL->configure(-text => "Login Successful");
   }
   else
   {
      $msgL->configure(-text => "Login Failed!");
   }
}
1;

##</code><code>##

package AuthService;

sub login
{
   my ($user, $password) = @_;
   return 
      (defined($user) && defined($password) &&
      $user eq "eric" && $password eq "swordfish");
}
1;

use Test::More tests => 4;
use Tk;
use strict;
use LoginForm;

my $mw = MainWindow->new;

my $lf = LoginForm->new($mw, 
   -logincmd => \&AuthService::login
)->pack;
my $msg = $lf->Subwidget('Message');

#####################################
## No Parameters Set
#####################################
$lf->Login;
is($msg->cget(-text), "Login Failed!",
   "No user or password set");

#####################################
## Good credentials
#####################################
setUserPassword($lf, "eric", "swordfish");
$lf->Login;
is($msg->cget(-text), "Login Successful",
   "Valid credentials set");

#####################################
## No username set, good password
#####################################
setUserPassword($lf, "", "swordfish");
$lf->Login;
is($msg->cget(-text), "Login Failed!",
   "User not set, Password set");

#####################################
## Correct User set, no password
#####################################
setUserPassword($lf, "eric", "");
$lf->Login;
is($msg->cget(-text), "Login Failed!",
   "User set, no password");

$mw->destroy;

###############################################
## Convenience routines
###############################################

sub setUserPassword
{
   my ($lf, $user, $pass) = @_;
   clearLoginForm($lf);
   $lf->Subwidget('UserEntry')->insert(0, $user);
   $lf->Subwidget('PassEntry')->insert(0, $pass);
}

sub clearLoginForm
{
   my $lf = shift;
   $lf->Subwidget('Message')->configure(-text => "");
   $lf->Subwidget('UserEntry')->delete(0, 'end');
   $lf->Subwidget('PassEntry')->delete(0, 'end');
}

##</code><code>##

package AuthService;

sub login
{
   my ($user, $password) = @_;
   return 
      (defined($user) && defined($password) &&
      $user eq "eric" && $password eq "swordfish");
}
1;
package main;

use strict;
use LoginForm;
use Test::More tests => 4;
use Tk;

my $mw = MainWindow->new;

my $lf = LoginForm->new($mw, 
   -logincmd => \&AuthService::login
)->pack;
my $msg = $lf->Subwidget('Message');

#####################################
## No Parameters Set
#####################################
$lf->Login;
is($msg->cget(-text), "Login Failed!",
   "No user or password set");

#####################################
## Good credentials
#####################################
simulateLogin($lf, "eric", "swordfish");
is($msg->cget(-text), "Login Successful",
   "Valid credentials set");

#####################################
## No username set, good password
#####################################
simulateLogin($lf, "", "swordfish");
is($msg->cget(-text), "Login Failed!",
   "User not set, Password set");

#####################################
## Correct User set, no password
#####################################
simulateLogin($lf, "eric", "");
is($msg->cget(-text), "Login Failed!",
   "User set, no password");

sub simulateLogin
{
   my ($lf, $user, $pass) = @_;
   clearLoginForm($lf);
   my $userE = $lf->Subwidget('UserEntry');
   my $passE = $lf->Subwidget('PassEntry');
   my $button = $lf->Subwidget('LoginButton');

   $lf->update;

   $userE->focusForce;
   setEntry($userE, $user);
   $userE->eventGenerate('<Tab>');
   setEntry($passE, $pass);
   $userE->eventGenerate('<Tab>');
   $button->eventGenerate('<Return>');
 }

sub clearLoginForm
{
   my $lf = shift;
   $lf->Subwidget('Message')->configure(-text => "");
   $lf->Subwidget('UserEntry')->delete(0, 'end');
   $lf->Subwidget('PassEntry')->delete(0, 'end');
}

sub setEntry 
{
   my ($entry, $text) = @_;
   foreach my $ch (split(//, $text)) {
      $entry->eventGenerate('<Key>', -keysym => $ch);
   }
}

##</code><code>##

package AuthService;

sub login
{
   my ($user, $password) = @_;
   return 
      (defined($user) && defined($password) &&
      $user eq "eric" && $password eq "swordfish");
}
1;
package main;

use strict;
use LoginForm;
use Test::More tests => 4;
use Tk;
use Win32::GuiTest qw(SendKeys SetForegroundWindow);

my $mw = MainWindow->new;

my $lf = LoginForm->new($mw, 
   -logincmd => \&AuthService::login
)->pack;
my $msg = $lf->Subwidget('Message');

$mw->update;
SetForegroundWindow(oct($mw->id));

#####################################
## No Parameters Set
#####################################
simulateLogin($lf, "", "");
is($msg->cget(-text), "Login Failed!",
   "No user or password set");

#####################################
## Good credentials
#####################################
simulateLogin($lf, "eric", "swordfish");
is($msg->cget(-text), "Login Successful",
   "Valid credentials set");

#####################################
## No username set, good password
#####################################
simulateLogin($lf, "", "swordfish");
is($msg->cget(-text), "Login Failed!",
   "User not set, Password set");

#####################################
## Correct User set, no password
#####################################
simulateLogin($lf, "eric", "");
is($msg->cget(-text), "Login Failed!",
   "User set, no password");
			

sub simulateLogin
{
   my ($lf, $user, $pass) = @_;

   clearLoginForm($lf);
   my $userH = oct($lf->Subwidget('UserEntry')->id);
   my $passH = oct($lf->Subwidget('PassEntry')->id);
   my $butH = oct($lf->Subwidget('LoginButton')->id);

   SendKeys("{TAB}"); 
   SendKeys($user) if $user ne "";
   SendKeys("{TAB}");
   SendKeys($pass) if $user ne "";
   SendKeys("{TAB}");
   SendKeys("{ENTER}");
   $lf->update;
 }

sub clearLoginForm
{
   my $lf = shift;
   $lf->Subwidget('Message')->configure(-text => "");
   $lf->Subwidget('UserEntry')->delete(0, 'end');
   $lf->Subwidget('PassEntry')->delete(0, 'end');
}