← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to Tixish/LabFrame.pm

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tixish/LabFrame.pm
5
5
package Tk::LabFrame;
6
6
 
7
7
use vars qw($VERSION);
8
 
$VERSION = '3.021'; # $Id: //depot/Tk8/Tixish/LabFrame.pm#21 $
 
8
$VERSION = '3.024'; # $Id: //depot/Tk8/Tixish/LabFrame.pm#24 $
9
9
 
10
10
use Tk;
11
 
require Tk::Frame;
12
 
 
13
 
use strict;
14
11
use base qw(Tk::Frame);
15
 
Construct Tk::Widget 'LabFrame';
16
 
 
 
12
Tk::Widget->Construct('LabFrame');
17
13
 
18
14
sub Populate {
19
15
    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};
 
16
 
 
17
    $cw->{m_geoMgr} = "";
 
18
 
 
19
    my $border = $cw->Component(
 
20
    Frame => 'border',
 
21
        -relief => 'groove',
 
22
        -bd => 2,
 
23
    );
 
24
 
 
25
    my $pad = $border->Frame;
 
26
    $cw->Advertise(pad => $pad);
 
27
 
 
28
    my $frame = $border->Frame;
 
29
    $cw->Advertise(frame => $frame);
 
30
 
 
31
    my $label = $cw->Component(Label => 'label');
 
32
 
25
33
    $cw->SUPER::Populate($args);
26
34
 
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);
 
35
    $cw->Delegates(DEFAULT => $frame);
 
36
    $cw->ConfigSpecs(
 
37
        -background    => [[qw/SELF ADVERTISED/],
 
38
                            qw/background Background/],
 
39
        -borderwidth   => [$border, qw/borderWidth Border 2/],
 
40
        -font          => [$label, qw/font Font/],
 
41
        -foreground    => [$label, qw/foreground Foreground black/],
 
42
        -label         => [{-text => $label}, qw/label Label/],
 
43
        -labelside     => [qw/METHOD labelSide LabelSide acrosstop/],
 
44
        -labelvariable => [{-textvariable => $label}],
 
45
        -relief        => [$border, qw/relief Relief groove/],
 
46
        DEFAULT        => [$frame]
 
47
    );
 
48
    return $cw;
 
49
}
 
50
 
 
51
use Tk::Submethods(
 
52
    form  => [qw/check forget grid info slaves/],
 
53
    grid  => [qw/bbox columnconfigure configure forget info location
 
54
                 propagate rowconfigure remove size slaves/],
 
55
    pack  => [qw/forget info propagate slaves/],
 
56
    place => [qw/forget info slaves/]
 
57
);
 
58
 
 
59
sub labelside {
 
60
    my ($cw, $side) = @_;
 
61
    return $cw->{Configure}{-labelside} unless $side;
 
62
 
 
63
    my $border = $cw->Subwidget('border');
 
64
    my $pad = $cw->Subwidget('pad');
 
65
    my $frame = $cw->Subwidget('frame');
 
66
    my $label = $cw->Subwidget('label');
 
67
 
 
68
    ## packForget/formForget as appropriate
 
69
    foreach ($border, $label, $pad, $frame) {
 
70
        $_->formForget if $cw->{m_geoMgr} eq "form";
 
71
        $_->packForget if ($cw->{m_geoMgr} eq "pack" && $_->ismapped);
 
72
    }
 
73
 
 
74
    if ($side eq "acrosstop") {
 
75
 
 
76
        my $y = $label->reqheight / 2;
 
77
        my $ph = $y - ($border->cget(-bd));
 
78
        $ph = 0 if $ph < 0;
 
79
 
 
80
        $label->form(qw/-top 0 -left 4 -padx 6 -pady 2/);
 
81
        $border->form(-top => $y,
 
82
            qw/-bottom -1 -left 0 -right -1 -padx 2 -pady 2/);
 
83
        $pad->form(-bottom => $ph,
 
84
            qw/-top 0 -left 0 -right -1/);
 
85
        $frame->form(-top => $pad,
 
86
            qw/-bottom -1 -left 0 -right -1 -fill both/);
 
87
        $cw->{m_geoMgr} = "form";
 
88
 
44
89
    } 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);
 
90
 
 
91
        $label->pack(-side => $side);
 
92
        $frame->pack(-expand => 1, -fill => 'both');
 
93
        $border->pack(-side => $side, -expand => 1, fill => 'both');
 
94
        $cw->{m_geoMgr} = "pack";
49
95
    }
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]);
 
96
}
 
97
 
 
98
sub form {
 
99
    my $cw = shift;
 
100
    $cw = $cw->Subwidget('frame')
 
101
        if (@_ && $_[0] =~ /^(?:slaves)$/);
 
102
    $cw->SUPER::form(@_);
 
103
}
 
104
 
 
105
sub grid {
 
106
    my $cw = shift;
 
107
    $cw = $cw->Subwidget('frame') if (@_ && $_[0] =~
 
108
        /^(?:bbox
 
109
            |columnconfigure
 
110
            |location
 
111
            |propagate
 
112
            |rowconfigure
 
113
            |size
 
114
            |slaves)
 
115
        $/x);
 
116
    $cw->SUPER::grid(@_);
 
117
}
 
118
 
 
119
 
 
120
sub pack {
 
121
    my $cw = shift;
 
122
    $cw = $cw->Subwidget('frame')
 
123
        if (@_ && $_[0] =~ /^(?:propagate|slaves)$/);
 
124
    $cw->SUPER::pack(@_);
 
125
}
 
126
 
 
127
sub place {
 
128
    my $cw = shift;
 
129
    $cw = $cw->Subwidget('frame')
 
130
        if (@_ && $_[0] =~ /^(?:slaves)$/);
 
131
    $cw->SUPER::place(@_);
55
132
}
56
133
 
57
134
1;
58
135
 
59
 
__END__