Sybase::Login - A highly configurable Login widget for Sybperl and Perl/Tk

##########################################
##########################################
##					##
##	Login - a reusable Tk-widget	##
##		login screen		##
##					##
##	Version 1.4			##
##					##
##	Brent B. Powers	(B2Pi)		##
##	Merrill Lynch			##
##	powers@swaps-comm.ml.com	##
##					##
##					##
##########################################
##########################################

### Gevalt.  That's the end... now the code (350 lines of docs?)
#;

package Sybase::Login;

require 5.002;

use Tk;
use Tk::Dialog;
use Sybase::DBlib;
use Carp;
use strict;

@Sybase::Login::ISA = qw (Tk::Toplevel);
Tk::Widget->Construct('Login');

$Sybase::VERSION = 1.4;

my(@topside) = (-side => 'top');
my(@leftside) = (-side => 'left');
my(@rightside) = (-side => 'right');
my(@xfill) = (-fill => 'x');
my(@expand) = (-expand => 1);
my(@wanchor) = (-anchor => 'w');
my(@eanchor) = (-anchor => 'e');
my(@raised) = (-relief => 'raised');
my(@sunken) = (-relief => 'sunken');
my(@bw2) = (-borderwidth => 2);

sub Populate {

    ## Constructor for Login (password verification) widget.  Inherits
    ## new from base class

    my($self, @args) = @_;

    $self->SUPER::Populate(@args);

    $self->withdraw;

    ## This is a good chance to initialize some values
    $self->{Verified} = 0;
    $self->{DBList} = undef;

    $self->BuildBox;

    $self->ConfigSpecs(-User  =>	['PASSIVE', undef, undef, ''],
		       -Password =>	['PASSIVE', undef, undef, ''],
		       -Title =>	['PASSIVE', undef, undef, 'Database Login'],
		       -Database =>	['METHOD', undef, undef, ''],
		       -Server =>	['METHOD', undef, undef, ''],
		       -presentDBMenu =>['PASSIVE', undef, undef, 1],
		       -presentSrvMenu=>['PASSIVE', undef, undef, 1],
		       -OKText =>	['PASSIVE', undef, undef, 'OK'],
		       -CancelText =>	['PASSIVE', undef, undef, 'Cancel'],
		       -ULabel =>	['PASSIVE', undef, undef, 'User:'],
		       -PLabel =>	['PASSIVE', undef, undef, 'Password:'],
		       -DLabel =>	['PASSIVE', undef, undef, 'Database:'],
		       -SLabel =>	['PASSIVE', undef, undef, 'Server:'],
		       -Labelfont =>	['PASSIVE', undef, undef,
					 '-Adobe-Courier-Bold-R-Normal--*-120-*'],
		       -EDlgTitle =>	['PASSIVE', undef, undef,
					 'Database Login Error!'],
		       -EDlgText =>	['PASSIVE', undef, undef,
					 'Unable to login to $db at $srv'],
		       -EDlgRetry =>	['PASSIVE', undef, undef,'Retry'],
		       -EDlgCancel =>	['PASSIVE', undef, undef,'Cancel'],
		      );
}

sub Version {return $Sybase::Login::VERSION;}

sub addDatabase {
    my($self,$db,@srvlist) = @_;
    ### $db is the Database being added,
    ### @srvlist is the list of servers

    if (defined($db)) {
	$db =~ s/^\s+|\s+$//g;
    } else {
	$db = '';
    }
    if ($db eq '') {
	carp "Use Login->addDatabase(database, server [, server ...])";
	return;
    }

    ## Kvetch if somebody's trying to add a blank database
    if (!defined(@srvlist)) {
	carp "No servers defined for $db";
	return;
    }

    ### The user may either be modifying a current entry,
    ### implicitly deleting a current entry, or
    ### creating a new entry
    $self->{DBList}{$db} = \@srvlist;

    my($db1,$srv1);

    ### If the current Database is that just modified, check that the
    ### current server is still valid.  If not, set it to the default.
    if ($self->{Configure}{-Database} eq $db) {
	foreach (@srvlist) {
	    if ($self->{Configure}{'-Server'} eq $_) {
		# Found it, so we're OK
		return;
	    }
	}
	# Didn't find it, so set it to the default
	$self->{Configure}{'-Server'} = @srvlist[0];
    }
}

sub clearDatabase {
    #	Parameters:	([Database[, Database, ...]])

    my($self) = shift;
    my($firstdeldb) = @_;
    if (defined($firstdeldb) and ($firstdeldb ne "")) {
	### Parameters given
	foreach (@_) {
	    delete $self->{DBList}{$_};

	    if ($self->{Configure}{'-Database'} eq $_ ) {
		$self->{Configure}{'-Database'} = '';
		$self->{Configure}{'-Server'} = '';
	    }
	}
    } else {
	### No parameters given, delete all databases
	undef $self->{DBList};
	$self->{Configure}{'-Database'} = '';
	$self->{Configure}{'-Server'} = '';
    }
}

sub Server {
    my($self, $server) = @_;

    my($db);

    # Verify that the server is correct before setting

    ## Note that the database must be configured first,
    ## and the given server valid for the configured database
    if (defined($server) &&
	($server ne '') &&
	($self->{Configure}{-Database} ne '')) {

	foreach (@{$self->{DBList}{$self->{Configure}{'-Database'}}}) {
	    if ($server eq $_) {
		## Found it... save it
		$self->{Configure}{'-Server'} = $server;
		last;
	    }
	}
    }
    return $self->{Configure}{'-Server'};
}

sub Database {
    #	Parameters:	(Database)
    my ($self, $db) = @_;

    if (defined($db) and ($db ne '')) {
	## Only set a database that is configured
	if (defined($self->{DBList}{$db})) {
	    $self->{Configure}{'-Database'} = $db;

	    ##  Now check that the server is still valid
	    foreach (@{$self->{DBList}{$db}}) {
		if ($self->{Configure}{'-Server'} eq $_) {
		    #  It matches, and we're done
		    return $db;
		}
	    }
	    ## Hmmm, no match, use default
	    $self->{Configure}{'-Server'} = $self->{DBList}{$db}[0];
	}
    }
    return $self->{Configure}{'-Database'};
}

sub BuildBox {

    my($self) = shift;

    ############ Create the User name frame #############
    my($tFrame) = $self->Frame
	    ->pack(@topside, @xfill);

    $self->{ULabel} = $tFrame->Label(@wanchor)
	    ->pack(@leftside);

    $self->{userEntry} =
	    $tFrame->Entry(-textvariable => \$self->{Configure}{-User},
			   @sunken)
		    ->pack(@rightside, @expand, @xfill, @wanchor);

    ############ Create the Password Frame #############
    $self->{PFrame} = $tFrame = $self->Frame
	    ->pack(@topside, @xfill);

    $self->{PLabel} = $tFrame->Label(@wanchor)
	    ->pack(@leftside);

    $self->{passEntry} =
	    $tFrame->Entry(-textvariable => \$self->{Configure}{-Password},
			   -show => '#',
			   @sunken)
		    ->pack(@rightside, @expand, @xfill, @wanchor);

    ############ Create the Button Frame #############
    $tFrame = $self->Frame(@bw2)
	    ->pack(@topside);

    $self->{OKButton} = $tFrame->Button(-command => sub {
					    $self->TestLogin($self);
					})
	    ->pack(@leftside, @expand);

    $self->{OKButton}->bind('<Return>' => [sub {$self->{OKButton}->invoke}]);

    $self->{CancelButton} = $tFrame->Button(-command => sub {
						$self->Exit(0);
					    })
	    ->pack(@leftside, @expand);

    $self->{CancelButton}->bind('<Return>' => sub {
				    $self->{CancelButton}->invoke});
    $self->bind('<Escape>' => [sub {$self->{CancelButton}->invoke}]);

    $self->{passEntry}->bind('<Return>'=> sub { $self->{OKButton}->focus; });
    $self->{passEntry}->bind('<Control-u>' => sub {
				 $self->{Configure}{-Password} = '';
			       });
    $self->{userEntry}->bind('<Control-u>' => sub {
				   $self->{Configure}{-User} = '';
			       });
    $self->{userEntry}->bind('<Return>'=> sub {
				   \$self->{passEntry}->focus; } );
}

sub getCurrentVerification {
    my($self) = shift;

    ### The caller wants to find out if the current user, password
    ### database and server are OK.
    &TestDatabase($self);
}

sub CvtBool {
    my($a) = shift;
    return 1 if defined($a) && $a =~ m/[ytYT1]/;
    return 0;
}

sub getVerification {

    my($self, $force, $forceval) = @_;
    if (!defined($self->{DBList}) ||
	(keys %{$self->{DBList}}) == 0) {
	carp "No Databases defined";
	return 0;
    }

    if ((defined($force) &&
	 &CvtBool($forceval) &&
	 lc($force) eq '-force') ||
	!getCurrentVerification($self)) {

	## OK, do it
	$self->{Verified} = -1;

	$self->{Configure}{-presentDBMenu} =
		&CvtBool($self->{Configure}{-presentDBMenu});

	$self->{Configure}{-presentSrvMenu} =
		&CvtBool($self->{Configure}{-presentSrvMenu});

	$self->title($self->{Configure}{-Title});
	my($ParentState) = $self->parent->state;

	if ($ParentState ne 'withdrawn') {
	    $self->parent->withdraw;
	}

	## Set up the labels for the entries and menus
	$self->{ULabel}->configure(-text => $self->{Configure}{-ULabel},
				   -font => $self->{Configure}{-Labelfont});
	$self->{PLabel}->configure(-text => $self->{Configure}{-PLabel},
				   -font => $self->{Configure}{-Labelfont});


	############ Create the Database Frame, label, etc  #############
	$self->{dbFrame}->destroy if defined($self->{dbFrame});
	if ($self->{Configure}{-presentDBMenu}) {
	    $self->{dbFrame} = $self->Frame
		    ->pack(-after => $self->{PFrame}, @xfill);
	    $self->{DLabel} = $self->{dbFrame}->Label(@wanchor)
		    ->pack(@leftside);
	    $self->{DLabel}->
		    configure(-text => $self->{Configure}{-DLabel},
			      -font => $self->{Configure}{-Labelfont});
	}

	############ Create the Server Frame, label, etc  #############
	$self->{srvFrame}->destroy if defined($self->{srvFrame});
	if ($self->{Configure}{-presentSrvMenu}) {
	    my($f);
	    $f = $self->{srvFrame} = $self->Frame;
	    if ($self->{Configure}{-presentDBMenu}) {
		$f->pack(-after => $self->{dbFrame}, @xfill)
	    } else {
		$f->pack(-after => $self->{PFrame}, @xfill)
	    }

	    $self->{SLabel} = $self->{srvFrame}->Label(@wanchor)
		    ->pack(@leftside);
	    $self->{SLabel}->
		    configure(-text => $self->{Configure}{-SLabel},
			      -font => $self->{Configure}{-Labelfont});
	}

	$self->update;

	## Get the widest label...
	my($maxWidth) = $self->{ULabel}->reqwidth;
	my($max) = '-ULabel';

	if ($self->{PLabel}->reqwidth > $maxWidth) {
	    $max = $self->{PLabel}->reqwidth;
	    $max = '-PLabel';
	}

	if ($self->{Configure}{-presentDBMenu} &&
	    $self->{DLabel}->reqwidth > $maxWidth) {
	    $maxWidth = $self->{DLabel}->reqwidth;
	    $max = '-DLabel';
	}

	if ($self->{Configure}{-presentSrvMenu} &&
	    $self->{SLabel}->reqwidth > $maxWidth) {
	    $maxWidth = $self->{SLabel}->reqwidth;
	    $max = '-SLabel';
	}
	$max = length($self->{Configure}{$max});

	$self->{ULabel}->configure(-width => $max);
	$self->{PLabel}->configure(-width => $max);
	$self->{DLabel}->configure(-width => $max)
		if $self->{Configure}{-presentDBMenu};
	$self->{SLabel}->configure(-width => $max)
		if $self->{Configure}{-presentSrvMenu};
	$self->update;

	# Make sure that the Database is set
	if (!defined($self->{Configure}{'-Database'}) ||
	    ($self->{Configure}{'-Database'} eq '')) {
	    $self->{Configure}{'-Database'} = (keys %{$self->{DBList}})[0];
	    print "Set database to \"",(keys %{$self->{DBList}})[0],"\"\n";
	}

	## Set up the buttons
	$self->{OKButton}->configure(-text =>
				     $self->{Configure}{-OKText});
	$self->{CancelButton}->configure(-text =>
					 $self->{Configure}{-CancelText});

	$self->{databaseMB}->destroy if defined($self->{databaseMB});
	if ($self->{Configure}{-presentDBMenu}) {
	    $self->{databaseMB} = $self->{dbFrame}->Optionmenu
		    (-textvariable => \$self->{Configure}{'-Database'},
		     -command => sub {
			 &CreateSrvMenu($self);
		     },
		     @raised)
			    ->pack(@rightside, @eanchor, @expand, @xfill);

	    my(@opts);
	    foreach (sort keys(%{$self->{DBList}})) {
		push(@opts,$_);
	    }

	    $self->{databaseMB}->configure(-options => [@opts]);

	    $self->{databaseMB}->configure(-state => 'disabled') if 1 == @opts;
	}

	&CreateSrvMenu($self);


        # Set the focus to the user if it hasn't been set, or
        # to the password frame
        my ($oldFocus) = $self->focusCurrent;
        if ($self->{Configure}{-User} eq "") {
            $self->{userEntry}->focusForce;
        } else {
            $self->{passEntry}->focusForce;
        }

	# Take care of the window position
	my($x) = int(($self->screenwidth - $self->reqwidth)/2)
		- $self->parent->vrootx;
	my($y) = int(($self->screenheight - $self->reqheight)/2)
		- $self->parent->vrooty;

	$self->geometry("+$x+$y");

	$self->deiconify;

	## And do a grab
	$self->grab;

	## Wait for verification or cancel
	$self->tkwait('variable'=>\$self->{Verified});

	$self->grab('release');
        $oldFocus->focus if defined($oldFocus);

	$self->withdraw;
	if ($ParentState eq 'normal') {
	    $self->parent->deiconify;
	} elsif ($ParentState eq 'iconic') {
	    $self->parent->iconify;
	}

	return $self->{Verified};

    }
    return 1;
}

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

    $self->{serverMB}->destroy if (defined($self->{serverMB}));

    $self->{Configure}{'-Server'} =
	    $self->{DBList}{$self->{Configure}{'-Database'}}[0];

    return if !$self->{Configure}{-presentSrvMenu};

    my(@opts);
    foreach (@{$self->{DBList}{$self->{Configure}{'-Database'}}}) {
	push(@opts, $_);
    }

    $self->{serverMB} = $self->{srvFrame}->
	    Optionmenu(-textvariable => \$self->{Configure}{'-Server'},
		       -options => [@opts],
		       @raised)
		    ->pack(@rightside, @eanchor, @expand, @xfill);

    $self->{Configure}{'-Server'} =
	    $self->{DBList}{$self->{Configure}{'-Database'}}[0];

    $self->{serverMB}->configure(-state => 'disabled') if 1 == @opts;
}

################################
## Password Screen Subroutines
################################

sub TestDatabase {
    ## Validate the current variables.

    my($self) = shift;

    $self->configure(-cursor => 'watch');
    $self->update;

    my($rslt,$mh, $eh);

    my($usr, $pwd, $srv, $db);
    $usr = $self->{Configure}{-User};
    $pwd = $self->{Configure}{-Password};
    $srv = $self->{Configure}{'-Server'};
    $db = $self->{Configure}{'-Database'};

    $mh = &dbmsghandle(undef);
    $eh = &dberrhandle(undef);
    $rslt = eval {
	&dbmsghandle(sub {return 1});
	&dberrhandle(sub {die;});

	my($MasterDB) = Sybase::DBlib->dblogin("$usr","$pwd", "$srv");
	$MasterDB->dbuse($db);
	$MasterDB->dbclose;
	return 1;
    };

    $rslt = $1 if !defined($rslt);

    if (defined($mh)) {
	&dbmsghandle($mh);
    } else {
	&dbmsghandle(undef);
    }
    if (defined($eh)) {
	&dberrhandle($eh);
    } else {
	&dberrhandle(undef);
    }

    $self->configure(-cursor => 'top_left_arrow');
    $self->update;
    return $rslt;
}

sub TestLogin {

    my($self) = @_;

    ## Validate the current set of login variables.
    ## If there's a failure, inform the user via a dialog
    if ($self->getCurrentVerification) {
	$self->Exit(1);
    } else {
	my($db) = $self->{Configure}{'-Database'};
	my($srv) = $self->{Configure}{'-Server'};
	my($usr) = $self->{Configure}{-User};
	my($pwd) = $self->{Configure}{-Password};

	eval "\$db = \"$self->{Configure}{-EDlgText}\"";

	if ($self->Dialog(-title => $self->{Configure}{-EDlgTitle},
			  -text => $db,
			  -bitmap => 'error',
			  -default_button => $self->{Configure}{-EDlgRetry},
			  -justify => 'center',
			  -buttons => [$self->{Configure}{-EDlgRetry},
				       $self->{Configure}{-EDlgCancel}])
	    ->Show eq $self->{Configure}{-EDlgCancel}) {
	    $self->Exit(0);
	}
    }
}

sub Exit {
    my($self, $arg) = @_;
    ## Trigger the change to the value Verified, enabling an exit
    ## from the tkwait.
    $self->{Verified} = $arg;
    return $self->{Verified};
}

### Return 1 to the calling  use statement ###
1;
### End of file Login.pm ###