File Coverage

blib/lib/Tk/WaitBoxFixed.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

##########################################
##########################################
##                                      ##
##  WaitBoxFixed - a reusable Tk-widget ##
##                 Wait Dialog          ##
##                                      ##
##  Version 1.6                         ##
##                                      ##
##  Brent B. Powers	(B2Pi)              ##
##  [e-mail]                     ##
##                                      ##
##########################################
##########################################

###############################################################################
###############################################################################
## WaitBoxFixed
##    Object Oriented Wait Dialog for TkPerl
##    (Apologies to John Stoffel and Stephen O. Lidie)
##
## Changes:
## Ver 1.1 Changed show to Show, unshow to unShow, and general
##         cleanup for perl5.002 gamma
## Ver 1.2 Changed to general distribution, add VERSION and Version
## Ver 1.3 Added -takefocus param, on suggestion of Ben Hochstedler
##	   , some other stuff
## Ver 1.4 Cavac: Added some fixes
## Ver 1.5 Cavac: Added some fixes
## Ver 1.6 Cavac, ASB: fixes and cleanup of POD
##
###############################################################################
###############################################################################

package Tk::WaitBoxFixed;

use strict;
use Tk::Toplevel;

@Tk::WaitBoxFixed::ISA = qw (Tk::Toplevel);

Tk::Widget->Construct('WaitBoxFixed');

$Tk::WaitBoxFixed::VERSION = '1.6';

### A couple of convenience variables
my(@wd_fullpack) = (-expand => 1, -fill => 'both');
my(@wd_packtop) = (-side => 'top');
my(@wd_packleft) = (-side => 'left');

sub Populate {
    ### Wait box constructor.  Uses new inherited from base class
    my($cw, $wdtop, $fm, $bitmap, $txt1, $uframe, $txt2);
    $cw = shift;
    $cw->SUPER::Populate(@_);

    ## Create the toplevel window
    $cw->withdraw;
    $cw->protocol('WM_DELETE_WINDOW' => sub {});

    # See http://cpanratings.perl.org/dist/Tk-WaitBox
    #$cw->transient($cw->toplevel);

    ### Set up the status
    $cw->{Shown} = 0;

    ### Set up the cancel button and text
    $cw->{cancelroutine} = undef if !defined($cw->{cancelroutine});
    $cw->{canceltext} = 'Cancel' if !defined($cw->{canceltext});

    ### OK, create the dialog
    ### Start with the upper frame (which contains two messages)
    ## And maybe more....
    $wdtop = $cw->Frame->pack(@wd_fullpack, @wd_packtop);

    $fm = $wdtop->Frame(-borderwidth => 2, -relief => 'raised')
	    ->pack(@wd_packleft, -ipadx => 20, @wd_fullpack);

    $bitmap = $fm->Label(Name => 'bitmap')
	    ->pack(@wd_packleft, -ipadx => 36, @wd_fullpack);

    ## Text Frame
    $fm = $wdtop->Frame(-borderwidth => 2, -relief => 'raised')
	    ->pack(@wd_packleft, -ipadx => 20, @wd_fullpack);

    $txt1 = $fm->Label(-wraplength => '3i', -justify => 'center',
		       -textvariable => \$cw->{Configure}{-txt1})
	    ->pack(@wd_packtop, -pady => 3, @wd_fullpack);

    ### Eventually, I want to create a user configurable frame
    ### in between the two frames
    $uframe = $fm->Frame
	    ->pack(@wd_packtop);
    $cw->Advertise(uframe => $uframe);

    $cw->{Configure}{-txt2} = "Please Wait"
	    unless defined($cw->{Configure}{-txt2});

    $txt2 = $fm->Label(-textvariable => \$cw->{Configure}{-txt2})
	    ->pack(@wd_packtop, @wd_fullpack, -pady => 9);

    ### We'll let the cancel frame and button wait until Show time

    ### Set up configuration
    $cw->ConfigSpecs(-bitmap	=> [$bitmap, undef, undef, 'hourglass'],
		     -foreground=> [[$txt1,$txt2], 'foreground','Foreground','black'],
		     -background=> ['DESCENDANTS', 'background', 'Background',undef],
		     -font	=> [$txt1,'font','Font','-Adobe-Helvetica-Bold-R-Normal--*-180-*'],
		     -canceltext=> ['PASSIVE', undef, undef, 'Cancel'],
		     -cancelroutine=> ['PASSIVE', undef, undef, undef],
		     -txt1	=> ['PASSIVE', undef, undef, undef],
		     -txt2	=> ['PASSIVE',undef,undef,undef],
		     -resizeable => ['PASSIVE',undef,undef,1],
		     -takefocus => ['SELF', undef, undef, 1]);

    return;
}

sub Version {return $Tk::WaitBoxFixed::VERSION;}

sub Show {
    ## Do last minute configuration and Show the dialog
    my($wd, @args) = @_;

    if ( defined($wd->{Configure}{-cancelroutine}) &&
	!defined($wd->{CanFrame})) {
	my($canFrame) = $wd->Frame (-background => $wd->cget('-background'));
	$wd->{CanFrame} = $canFrame;
	$canFrame->pack(-side => 'top', @wd_packtop, -fill => 'both');
	$canFrame->configure(-cursor => 'top_left_arrow');
	$canFrame->Button(-text => $wd->{Configure}{-canceltext},
			  -command => $wd->{Configure}{-cancelroutine})
		->pack(-padx => 5, -pady => 5,
		       -ipadx => 5, -ipady => 5);
    }

    ## Grab the input queue and focus
    $wd->parent->configure(-cursor => 'watch') if $wd->{Configure}{-takefocus};
    $wd->configure(-cursor => 'watch');
    $wd->update;

    my($x) = int( ($wd->screenwidth
		 - $wd->reqwidth)/2
		 - $wd->vrootx);

    my($y) = int( ($wd->screenheight
		 - $wd->reqheight)/2
		 - $wd->vrooty);

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

    $wd->{Shown} = 1;

    $wd->deiconify;
    $wd->tkwait('visibility', $wd);

    if ($wd->{Configure}{-takefocus}) {
	$wd->grab();
	$wd->focus();
    }
    $wd->update;

    return $wd;

}

sub unShow {
    my($wd) = @_;

    return unless $wd->{Shown};
    $wd->{CanFrame}->destroy if defined($wd->{CanFrame});
    $wd->{CanFrame} = undef;
    $wd->parent->configure(-cursor => 'top_left_arrow');

    $wd->grab('release');
    $wd->withdraw;
    $wd->parent->update;
    $wd->{Shown} = 0;

    return;
}

1;

__END__