milkbone/plugins/Tk-Logon/Milkbone/Logon.pm

# milkbone - sign-on toplevel mega-widget

package Milkbone::Logon;

use Milkbone;

use Tk::widgets qw(Frame Label);
use base qw(Tk::Toplevel);
use strict;
use warnings;

Construct Tk::Widget 'MBLogon';

my $mw = hook("tk_getmain");

my $slogan = "surely this convenience entices you.  it's so easy to use, and the surgery to implant it in the base of your skull is so painless that it's no wonder i'm number one. (athf)";

sub ClassInit
{
	my ($class, $mw) = @_;
	$class->SUPER::ClassInit($mw);
}

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

	$self->ConfigSpecs('DEFAULT' => ['SELF']);
	$self->Delegates();
}

sub clear
{
	my ($self) = @_;
	$self->{sname} = "";
	$self->{pass} = "";
	$self->{signed_on} = 0;
}

sub on_destroy
{
	my ($self) = @_;

	hook("protocol_signoff") if $self->{signed_on};
	$mw->destroy;
}

sub on_logon
{
	my ($self) = @_;

	return if $self->{signed_on} == 1;

	$self->{controls}->packForget;
	$self->{status}->pack(-expand => 1, -fill => 'both');
	$self->update;

	hook("protocol_signon", -user => $self->{sname}, -pass => $self->{pass});

	$self->{signed_on} = 1;
	data("me") = $self->{sname};
}

sub on_cancel
{
	my ($self) = @_;

	$self->{status}->packForget;
	$self->{controls}->pack(-expand => 1, -fill => 'both');

	hook("protocol_signoff");
	$self->{signed_on} = 0;
	$self->{status_label}->configure(-text => 'Connecting to the Evil Empire...');
	$self->{sn_entry}->focus;
        $self->update;
}

sub on_about
{
	my ($self) = @_;

	$mw->MBAbout(-title => "About milkbone $Milkbone::VERSION")->focus;
}

sub init
{
	my ($self, $mw, %args) = @_;

	$self->{sname} = "";
	$self->{pass} = "";
	$self->{signed_on} = 0;

	$self->withdraw();
	$self->resizable(0, 0);
	$self->configure(-title => "milkbone logon $Milkbone::VERSION");
	
	# WIDGET CREATION BEGIN
	my $image = $self->Photo(-file => path("images/logon.bmp"));
	$self->Label(-image => $image)->pack(-side => 'top', -ipadx => 0, -ipady => 2);

	# separate frames are used for the logon boxes and the status area
	$self->{controls} = $self->Frame->pack(-expand => 1, -fill => 'both');
	$self->{status} = $self->Frame;
	
	# create the screen name widget and focus it
	$self->{controls}->Label(-text => 'Screen name:', -anchor => 'w',
	  -borderwidth => 0)->
    pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 7);

	$self->{sn_entry} = $self->{controls}->Component('Entry' => 'sn', -background => 'white', -width => 16, -textvariable => \$self->{sname}, -insertwidth => 1)->
		pack(-side => 'top',  -fill => 'x', -padx => 5);
	$self->{sn_entry}->focus;
	
	# create the password widget
	$self->{controls}->Label(-text => 'Password:', -anchor => 'w')->
		pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 7);
	$self->{pass_entry} = $self->{controls}->Component('Entry' => 'pass', -background => 'white', -width => 16, -textvariable => \$self->{pass}, -show => '*', -insertwidth => 1)->
		pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 5);

	$self->{controls}->Label(-text => $slogan, -anchor => 'c', -justify => 'center', -wraplength => 250)->pack(-expand =>1, -fill => 'both');

	# create the status frame
	$self->{status_label} = $self->{status}->Label(-text => "Connecting to the Evil Empire...")->pack;
	$self->{status}->Button(-text => "Cancel", -command => [$self, "on_cancel"])->pack(-pady => 5);

	$self->{logon_button} = $self->{controls}->Button(-text => 'log on', -command => [$self, "on_logon"], 
		-height => 0.5, -borderwidth => 1)->
		pack(-pady => 7, -padx => 3, -expand => 0, -side => 'left');
	$self->{controls}->Button(-text => 'about', -command => sub { hook("show_about") }, 
		-height => 0.5)->
		pack(-pady => 7, -padx => 3, -expand => 0, -side => 'right');
	# WIDGET CREATION END

	$self->update;
	$self->geometry("+" . int(($mw->screenwidth() / 2) - int($self->width() / 2)) . "+" . int(($mw->screenheight() / 2) - int($self->height() / 2)) ) unless $^O =~ /linux/i;
	$self->deiconify;
	
	$self->bind('<Return>' => [$self, 'on_logon']);
	$self->bind("<Escape>" => [$self, "on_destroy"]);	
	$self->OnDestroy([sub { abort unless $_[0]->{signed_on} }, $self]);
	hook("tk_seticon", -wnd => $self);
}

sub on_signed_in
{
	my ($self) = @_;

	$self->withdraw;
}

1;