Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # |
2 | # Labeled frame. Derives from Tk::Frame, but intercepts the labeling | |
3 | # part. | |
4 | ||
5 | package Tk::LabFrame; | |
6 | ||
7 | use vars qw($VERSION); | |
8 | $VERSION = '3.021'; # $Id: //depot/Tk8/Tixish/LabFrame.pm#21 $ | |
9 | ||
10 | use Tk; | |
11 | require Tk::Frame; | |
12 | ||
13 | use strict; | |
14 | use base qw(Tk::Frame); | |
15 | Construct Tk::Widget 'LabFrame'; | |
16 | ||
17 | ||
18 | sub Populate { | |
19 | my ($cw, $args) = @_; | |
20 | my $f; | |
21 | my $label; | |
22 | my $lside = exists $args->{-labelside} ? | |
23 | delete $args->{-labelside} : 'top'; | |
24 | my $ltext = delete $args->{-label}; | |
25 | $cw->SUPER::Populate($args); | |
26 | ||
27 | if ($lside =~ /acrosstop/) { | |
28 | my $border = $cw->Frame(-relief => 'groove', -bd => 2); | |
29 | $cw->Advertise('border' => $border); | |
30 | my $pad = $border->Frame; | |
31 | $f = $border->Frame; | |
32 | $label = $cw->Label(-text => $ltext); | |
33 | my $y = int($label->winfo('reqheight')) / 2; | |
34 | my $ph = $y - int($border->cget(-bd)); | |
35 | if ($ph < 0) { | |
36 | $ph = 0; | |
37 | } | |
38 | $label->form(-top => 0, -left => 4, -padx => 6, -pady => 2); | |
39 | # $label->place('-y' => 2, '-x' => 10); | |
40 | $border->form(-top => $y, -bottom => -1, -left => 0, -right => -1, -padx => 2, -pady => 2); | |
41 | $pad->form(-left => 0, -right => -1, -top => 0, -bottom => $ph); | |
42 | $f->form(-top => $pad, -bottom => -1, -left => 0, -right => -1); | |
43 | # $cw->Delegates('pack' => $cw); | |
44 | } else { | |
45 | $f = $cw->Frame(-relief => 'groove', -bd => 2, %{$args}); | |
46 | $label = $cw->Label(-text => $ltext); | |
47 | $label->pack(-side => $lside); | |
48 | $f->pack(-side => $lside, -fill => 'both', -expand => 1); | |
49 | } | |
50 | $cw->Advertise('frame' => $f); | |
51 | $cw->Advertise('label' => $label); | |
52 | $cw->Delegates(DEFAULT => $f); | |
53 | $cw->ConfigSpecs(-labelside => ['PASSIVE', 'labelSide', 'LabelSide', 'acrosstop'], | |
54 | 'DEFAULT' => [$f]); | |
55 | } | |
56 | ||
57 | 1; | |
58 | ||
59 | __END__ |