File Coverage

blib/lib/Tk/Panel.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

#! /usr/bin/env perl

package Tk::Panel;

use 5.014000;
use warnings;
use strict;

use vars qw(@ISA $VERSION);

use Tk;
use Carp;
require Tk::Widget;

our $VERSION = '1.5';

Construct Tk::Widget 'Panel';
use base qw(Tk::Derived Tk::Frame);

sub debug {};

# Class initialisation function.
# Called exactly once for each MainWindow widget tree, just
# before the first widget is created.
sub ClassInit
{
	debug "args: @_\n";
	# nothing.
}

# Constructor.  Uses new inherited from base class
sub Populate
{
	debug "args: @_\n";

	my $self = shift;

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

	# Create 2 more frames, boundary with groove, and inside.
	$self->{boundary}	= $self->Component('Frame', 'boundary');
	$self->{inside}		= $self->Component('Frame', 'inside');
	# Create the title widgets.
	$self->{label}	= $self->Component('Label', 'label');

	$self->{check}	= $self->Component('Checkbutton', 'check',
			-variable	=> \$self->{Configure}->{'-show'},
			-command	=> [ 'refresh', $self ],
		);

	#debug "boundary: $self->{boundary}\n";
	#debug "inside: $self->{inside}\n";
	#debug "check: $self->{check}\n";
	#debug "label: $self->{label}\n";

	# Set up extra configuration
	$self->ConfigSpecs(
		'-relief'	=> [$self->{boundary},'relief','Relief','groove'],
		'-border'	=> [$self->{boundary},'borderwidth','BorderWidth', 3],
		'-background'	=> [['SELF','DESCENDANTS'],undef,undef, undef],
		'-foreground'	=> [['SELF','DESCENDANTS'],undef,undef, undef],

		'-margin'	=> ['PASSIVE','margin','Margin', 10],

		'-text'		=> [
				[$self->{check}, $self->{label}],
				'text','Text', ''],

		'-show'		=> ['PASSIVE','','', 1],

		'-flatheight'	=> ['PASSIVE','','', 'standard'],

		'-state'	=> [$self->{check},'','', 'active'],
		'-toggle'	=> ['PASSIVE','','', 1],

		'-fg'		=> '-foreground',
		'-bg'		=> '-background',
	);

	# Where to create children.
	$self->Delegates('Construct' => $self->{inside});

	$self;
}

# DoWhenIdle seems to be replaced by afterIdle in Tk800.018.
sub afterIdle { &DoWhenIdle; }

;## Update the widget when you get a chance.
sub DoWhenIdle
{
	debug "args: @_\n";

	my $self = shift;

	$self->refresh();
}

sub refresh
{
	debug "args: @_\n";

	my $self = shift;

	local ($_);

	# ------------- display the title. ---------------

	# Choose which title widget is on and which is off.
	my ($on, $off) = $self->cget('-toggle') ?
				qw(check label) :
				qw(label check) ;

	# Turn off the one we don't want.
	$self->{$off}->placeForget();

	# position the one we do want to see.
	my $h = $self->{$on}->ReqHeight;
	my $b = $self->cget('-border');

	debug "label height $h\n";

	$self->{$on}->place(
		'-in'	=> $self->{boundary},
		'-relx'	=> 0.05,
		'-y'	=> -0.5 * $h - 0.5*$b,
	);

	# If there is no real title and its the label that
	# requested then don't show it. Otherwise a gap
	# appears in the boundary.
	$self->{label}->placeForget()
		if ($self->cget('-text') eq '' && $on eq 'label');

	# ----------  Set the margins. -----------------
	my $m = $self->cget('-margin');

	my @config = (
		-padx	=> $m,
		-pady	=> $m,
		-fill	=> "both",
		-expand => "y",
	);

	$self->{boundary}->pack(@config);
	$self->{inside}->pack(-in=>$self->{boundary}, @config);

	# ----------------------------------------------

	unless ($self->cget('-show'))
	{
		debug "inside hidden.\n";

		# what is the closed height.
		my $ht = $self->cget('-flatheight');
		$ht = $self->{$on}->ReqHeight if ($ht eq 'standard');
		$ht = $self->cget('-border') if ($ht eq 'flat');

		croak "Option '-flatheight' must be a number, 'flat' or 'standard' (not '$ht').\n"
			unless ($ht =~ /^\d+$/);

		# We need to known the width so that we can set it
		# after hiding the inside so that the width
		# doesn't jump.
		my $wt = $self->{boundary}->Width;

		# collapse the boundary.
		$self->{boundary}->configure(
			'-height' => $ht,
			'-width' => $wt,
		);

		# hide the inside.
		$self->{inside}->packForget();
	}
}

# overload these.
sub gridColumnconfigure
{
	(shift)->{'inside'}->gridColumnconfigure(@_);
}
sub gridRowconfigure
{
	(shift)->{'inside'}->gridRowconfigure(@_);
}

;# Called as the widget is destroyed.
sub OnDestroy
{
	debug "args: @_\n";
}

;######################################################################

sub test
{

	#use Tk;
	#use Tk::Panel;

	eval 'sub Panel::debug {
		my ($package, $filename, $line,
				$subroutine, $hasargs, $wantargs) = caller(1);
		print STDERR "$subroutine: ";

		if (@_) {print STDERR @_; }
		else    {print "Debug $filename line $line.\n";}
	}; ';

	# colours.
	my $lightgreen	= '#90ee90';
	my $lightblue	= '#9090ee';
	my $darkred	= '#8b0000';

	# ---- Main Window -----------------------------
	my $top = MainWindow->new();

	#-------------- Top panel. -----------------------
	my $g = $top->Panel('-text' => 'hello', '-fg'=>'red')->pack(
		-expand=>'yes', -fill=>'x',
	);

	my @pack = ('-side'=>'left');
	$top->after(10000, [ 'configure', $g, '-margin' => 20 ]);
	$top->after(20000, [ 'configure', $g, '-text' => 'Top panel' ]);

	# pack everything inside the inner frame.
	$b = $g->Button(
		-text		=> 'Exit',
		-command	=> sub {exit;},
	)->pack(@pack);

	$b = $g->Button(-text=>'hello', -command => [ 'configure', $g, '-text', 'hello'] )->pack(@pack);
	$b = $g->Button(-text=>'goodbye', -command => [ 'configure', $g, '-text', 'goodbye'] )->pack(@pack);
	$b = $g->Button('-text'=>'no label', -command => [ 'configure', $g, '-text', ''] )->pack(@pack);
	$b = $g->Button(-text=>'boo', -command => [ 'configure', $g, '-text', 'boo'] )->pack(@pack);
	$g->Button(
		-text => "toggle",
		-command => sub {
			$g->configure('-toggle'=>!$g->cget('-toggle'));
			},
	)->pack();


	#-------------- bottom panel. -----------------------
	my $h = $top->Panel(
		-fg	=> $darkred,
		-bg	=> $lightblue,
		-text	=> 'bottom panel',
		-toggle	=> 0,
		-flatheight	=> 'flat',
	)->pack();

	$b = $h->Button(
		-text => "double margin",
		-command => sub { $h->configure('-margin'=>$h->cget('-margin')*2); },
	)->pack();

	$b = $h->Button(
		-text => "halve margin",
		-command => sub { $h->configure('-margin'=>$h->cget('-margin')/2); },
	)->pack();

	$b = $h->Button(
		-text => "double border",
		-command => sub { $h->configure('-border'=>$h->cget('-border')*2); },
	)->pack();

	$b = $h->Button(
		-text => "halve border",
		-command => sub { $h->configure('-border'=>$h->cget('-border')/2); },
	)->pack();

	$b = $h->Button(
		-text => "toggle",
		-command => sub {
			$h->configure('-toggle'=>!$h->cget('-toggle'));
			},
	)->pack();

	$b = $h->Button(
		-text => "disable",
		-command => sub { $h->configure('-state'=>'disabled');},
	)->pack();
	$b = $h->Button(
		-text => "active",
		-command => sub { $h->configure('-state'=>'active');},
	)->pack();

	$b = $h->Button(
		-text => "unpack",
		-command => sub {
			$h->configure('-show'=>0);
			$h->after(3000, [ 'configure', $h, '-show' => 1]);
		},
	)->pack();

	# Start demonstration.
	MainLoop;
}

&test if ($0 eq __FILE__);

1;

__END__