The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Tk::LoginDialog;
my $RCSRevKey = '$Revision: 1.2 $';
$RCSRevKey =~ /Revision: (.*?) /;
$VERSION=0.61;
use vars qw($VERSION @EXPORT_OK);

use Tk qw(Ev);
use Tk::CmdLine;
use strict;
use Carp;
use base qw(Tk::Toplevel);
use Tk::widgets qw(LabEntry DialogBox);

Construct Tk::Widget 'LoginDialog';

my $font="*-helvetica-medium-r-*-*-12-*";

Tk::CmdLine::SetResources ('*font: ' . $font);

sub Populate {
  my ($w, $args) = @_;
  require Tk::Toplevel;
  require Tk::DialogBox;
  require Tk::LabEntry;
  require Tk::Button;
  require Tk::Frame;
  $w->SUPER::Populate($args);

  my $l = $w -> Component( Label => 'toplabel',
			   -text => 'Please enter your user name and password.'
			 ) -> pack( -expand => '1', -fill => 'x', 
				    -ipady => 5, -ipadx => 5);
  $l = $w -> Component( LabEntry => 'userid',
			 -labelVariable => \$w -> {'Configure'}{'-uidlabel'},
			 -textvariable => \$w -> {'Configure'}{'-userid'} )
    -> pack( -anchor => 'w', -expand => '1', -fill => 'x', 
	     -ipady => 5, -ipadx => 5);
  $l = $w -> Component( LabEntry => 'password',
			-labelVariable => \$w -> {'Configure'}{'-pwdlabel'},
			-textvariable => \$w -> {'Configure'}{'-password'},
			-show => '*' )
    -> pack( -anchor => 'w', -expand => '1', -fill => 'x' );
  my $f = $w -> Component( Frame => 'buttons',
			   -container => '0',
			   -relief => 'groove',
			   -borderwidth => '3' );
  my $ok = $f -> Button( -text => 'Login', -width => 6,
			 -default => 'active',
			 -command => sub{ $w->Accept})
    -> pack( -padx => 30, -pady => 5, -side => 'left', -anchor => 'w');
  my $cancel = $f -> Button( -text => 'Cancel', -width => 6,
			     -default => 'normal',
			     -command =>sub{$w->WmDeleteWindow})
    -> pack( -padx => 30, -pady => 5, -side => 'right', -anchor => 'e' );
  $f -> pack( -ipadx => 10, -expand => '1', -fill => 'x' );
  $w->ConfigSpecs(
		-userid   => ['PASSIVE', undef, undef, "" ],
		-password => ['PASSIVE', undef, undef, "" ],
		  -accept => ['PASSIVE', undef, undef, "" ],
		-uidlabel => ['PASSIVE', undef, undef, 'User ID'],
		-pwdlabel => ['PASSIVE', undef, undef, 'Password'],
		);
  $ok -> focus;
  return $w;
}

sub Accept {
  my $w = shift;
  $w -> {Configure}{-accept} = '1';
}

sub Show {
  my( $w, @args) = @_;
  $w -> waitVariable( \$w -> {'Configure'}{'-accept'} );
  $w -> withdraw;
  return 'Login';
}


1;