package Tk::IFrame;
use Tk;
use strict;
use vars qw(@ISA $VERSION);
@ISA = qw(Tk::Derived Tk::Frame);
$VERSION = "0.02";
Construct Tk::Widget "IFrame";
sub Populate {
my($frame,$args) = @_;
$frame->Tk::configure(-borderwidth => 0, -highlightthickness => 0);
my $c = $frame->Component(Frame => 'container',
-borderwidth => 2,
-relief => 'raised'
);
$c->place(
'-x' => 0,
'-y' => 0,
-relwidth => 1.0,
-relheight => 1.0
);
$frame->ConfigSpecs(
-borderwidth => [PASSIVE => undef, undef, 2],
-relief => [PASSIVE => undef, undef, 'raised'],
-selectbackground =>
[PASSIVE => 'selectBackground', 'SelectBackground', 'red'],
-background => ['SELF']
);
$frame->bind('<Configure>', [\&layoutRequest, 1]);
$frame->bind('<Map>', [
sub {
my $f = shift;
my $info = $f->privateData;
my $tags;
return
unless defined($tags = $info->{'tags'}) && @$tags;
$f->update;
$f->selectCard($tags->[0]);
},
]);
$frame->privateData->{'tags'} = [];
$frame;
}
sub layoutRequest {
my($f,$why) = @_;
$f->DoWhenIdle(['adjustLayout',$f]) unless $f->{'layout_pending'};
$f->{'layout_pending'} |= $why;
}
sub adjustLayout {
my $f = shift;
$f->{'layout_pending'} = 0;
my $info = $f->privateData;
my $tags = $info->{'tags'};
return unless $tags;
my $bw = $f->{Configure}{'-borderwidth'};
my($w,$h) = (0,0,0,0);
my $t;
my @rowHeight;
my @rowWidth;
foreach $t (@$tags) {
$t->update;
my $cardinfo = $t->privateData;
my($lbl,$row) =($cardinfo->{label},$cardinfo->{row});
my ($rw,$rh) = ($t->ReqWidth, $t->ReqHeight);
$w = $rw
if $rw > $w;
$h = $rh
if $rh > $h;
$rowWidth[$row] = 0
unless defined($rowWidth[$row]);
$rowWidth[$row] += $lbl->ReqWidth;
$rh = $lbl->ReqHeight + $bw;
$rowHeight[$row] = $rh
if !defined($rowHeight[$row]) || $rh > $rowHeight[$row];
}
my $nrows = @rowHeight;
return unless $nrows > 0;
my $tagHeight = 0;
my @rowOrder = ();
my $i;
for($i = 0 ; $i < @rowHeight ; $i++) {
next
unless defined($rowHeight[$i]);
$tagHeight += $rowHeight[$i];
unshift(@rowOrder, $i);
}
my $tw = $bw * 2 * @$tags;
$w = $tw if $tw > $w;
my $x = $bw;
foreach $t (@$tags) {
my $inf = $t->privateData;
$inf->{tag}->place(
'-x' => $x,
'-y' => $bw,
-width => $inf->{label}->ReqWidth + $bw*2,
-height => $tagHeight + $bw
);
$inf->{label}->place(
-in => $inf->{tag},
'-x' => 0,
'-y' => 0,
-relwidth => 1.0,
-height => $tagHeight
);
$f->Subwidget('container')->place(
'-x' => 0,
'-y' => $tagHeight,
-height => -$tagHeight - $bw,
-relwidth => 1.0,
-relheight => 1.0
);
$x += $inf->{label}->ReqWidth + $bw*2;
}
$f->GeometryRequest($w,$h + $tagHeight + $bw + $bw);
$f->{'layout_pending'} = 0;
}
sub selectCard {
my $f = shift;
my $page = shift;
my $cntr = $f->Subwidget('container');
$page = $cntr->Subwidget(lc $page)
unless ref($page);
my $info = $f->privateData;
my $cur = $info->{'current'};
return
if defined($cur) && $cur == $page;
my $con;
my $bw = $f->{Configure}{'-borderwidth'};
foreach $con ($cntr->Subwidget) {
my $cardinfo = $con->privateData;
if($con == $page) {
my %info = $cardinfo->{'tag'}->placeInfo;
$info{'-x'} -= $bw;
$info{'-y'} -= $bw;
$info{'-width'} += $bw*2;
$cardinfo->{'tag'}->place(%info);
$cardinfo->{'tag'}->raise;
$cardinfo->{'tag'}->lower($cntr) if $info{'-x'} == 0;
$cardinfo->{'label'}->raise;
$con->raise;
$info->{'current'} = $page;
}
elsif(defined($cur) && $con == $cur) {
my %info = $cardinfo->{'tag'}->placeInfo;
$info{'-x'} += $bw;
$info{'-y'} += $bw;
$info{'-width'} -= $bw*2;
$cardinfo->{'tag'}->place(%info);
$cardinfo->{'label'}->lower($cntr);
$cardinfo->{'tag'}->lower;
}
}
}
sub addCard {
my $f = shift;
my $name = shift;
my %arg = @_;
my $row = delete $arg{-row} || 0;
my $tf = $f->Frame(
-borderwidth => 2,
-relief => 'raised'
);
my $l = $f->Label(
-text => $arg{'-label'},
-borderwidth => 0,
-padx => 4, -pady => 4,
-anchor => $arg{'-anchor'} || 'w'
);
my $cf = $f->Subwidget('container')->Component( Frame => lc $name,
-borderwidth => 0
);
$l->bind('<1>', [
sub {
my($lbl,$f,$cf) = @_;
$f->selectCard($cf)
},
$f, $cf
]);
$l->bind('<Any-Enter>', [
sub {
my $l = shift;
my $s = $l->parent->cget('-selectbackground');
$l->configure(-background => $s);
}
]);
$l->bind('<Any-Leave>', [
sub {
my $l = shift;
my $s = $l->parent->cget('-background');
$l->configure(-background => $s);
}
]);
my $info = $cf->privateData;
$info->{label} = $l;
$info->{tag} = $tf;
$info->{row} = $row;
push(@{$f->privateData->{'tags'}}, $cf);
$cf->place(
-relwidth => 1.0,
-relheight => 1.0,
);
$tf->raise;
$tf->lower($f->Subwidget('container'));
$l->lower;
$l->raise($tf);
$cf->lower;
$f->layoutRequest(2);
$cf;
}
__END__
=head1 NAME
Tk::IFrame - An Indexed Frame
=head1 SYNOPSIS
use Tk::IFrame;
=head1 DESCRIPTION
C<Tk::IFrame> defines a widget which enables multiple frames (cards) to be
defined, and then stacked on top of each other. Each card has an associated
tag, selecting this tag will cause the associated card to be brought to
the top of the stack.
=head1 STANDARD OPTIONS
I<-borderwidth -relief -selectbackground -background>
=head1 WIDGET-SPECIFIC OPTIONS
=over 4
=item none
=back
=head1 AUTHOR
Graham Barr E<lt>F<gbarr@ti.com>E<gt>
=head1 ACKNOWLEDGEMENTS
None - (yet :-)
=head1 COPYRIGHT
Copyright (c) 1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut