1 files changed, 138 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Tk/LabFrame.pm b/Master/tlpkg/tlperl0/lib/Tk/LabFrame.pm
new file mode 100755
index 00000000000..6fcab1acc56
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Tk/LabFrame.pm
@@ -0,0 +1,138 @@
+#
+# Labeled frame. Derives from Tk::Frame, but intercepts the labeling
+# part.
+
+package Tk::LabFrame;
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#11 $
+
+use Tk;
+use base qw(Tk::Frame);
+Tk::Widget->Construct('LabFrame');
+
+sub autoLabel { 0 }
+
+sub Populate {
+    my ($cw, $args) = @_;
+
+    $cw->{m_geoMgr} = "";
+
+    my $border = $cw->Component(
+    Frame => 'border',
+        -relief => 'groove',
+        -bd => 2,
+    );
+
+    my $pad = $border->Frame;
+    $cw->Advertise(pad => $pad);
+
+    my $frame = $border->Frame;
+    $cw->Advertise(frame => $frame);
+
+    my $label = $cw->Component(Label => 'label');
+
+    $cw->SUPER::Populate($args);
+
+    $cw->Delegates(DEFAULT => $frame);
+    $cw->ConfigSpecs(
+        -background    => [[qw/SELF ADVERTISED/],
+                            qw/background Background/],
+        -borderwidth   => [$border, qw/borderWidth Border 2/],
+        -font          => [$label, qw/font Font/],
+        -foreground    => [$label, qw/foreground Foreground black/],
+        -label         => [{-text => $label}, qw/label Label/],
+        -labelside     => [qw/METHOD labelSide LabelSide acrosstop/],
+        -labelvariable => [{-textvariable => $label}],
+        -relief        => [$border, qw/relief Relief groove/],
+        DEFAULT        => [$frame]
+    );
+    return $cw;
+}
+
+use Tk::Submethods(
+    form  => [qw/check forget grid info slaves/],
+    grid  => [qw/bbox columnconfigure configure forget info location
+                 propagate rowconfigure remove size slaves/],
+    pack  => [qw/forget info propagate slaves/],
+    place => [qw/forget info slaves/]
+);
+
+sub labelside {
+    my ($cw, $side) = @_;
+    return $cw->{Configure}{-labelside} unless $side;
+
+    my $border = $cw->Subwidget('border');
+    my $pad = $cw->Subwidget('pad');
+    my $frame = $cw->Subwidget('frame');
+    my $label = $cw->Subwidget('label');
+
+    ## packForget/formForget as appropriate
+    foreach ($border, $label, $pad, $frame) {
+        $_->formForget if $cw->{m_geoMgr} eq "form";
+        $_->packForget if ($cw->{m_geoMgr} eq "pack" && $_->ismapped);
+    }
+
+    if ($side eq "acrosstop") {
+
+        my $y = $label->reqheight / 2;
+        my $ph = $y - ($border->cget(-bd));
+        $ph = 0 if $ph < 0;
+
+        $label->form(qw/-top 0 -left 4 -padx 6 -pady 2/);
+        $border->form(-top => $y,
+            qw/-bottom -1 -left 0 -right -1 -padx 2 -pady 2/);
+        $pad->form(-bottom => $ph,
+            qw/-top 0 -left 0 -right -1/);
+        $frame->form(-top => $pad,
+            qw/-bottom -1 -left 0 -right -1 -fill both/);
+        $cw->{m_geoMgr} = "form";
+
+    } else {
+
+        $label->pack(-side => $side);
+        $frame->pack(-expand => 1, -fill => 'both');
+        $border->pack(-side => $side, -expand => 1, -fill => 'both');
+        $cw->{m_geoMgr} = "pack";
+    }
+}
+
+sub form {
+    my $cw = shift;
+    $cw = $cw->Subwidget('frame')
+        if (@_ && $_[0] =~ /^(?:slaves)$/);
+    $cw->SUPER::form(@_);
+}
+
+sub grid {
+    my $cw = shift;
+    $cw = $cw->Subwidget('frame') if (@_ && $_[0] =~
+        /^(?:bbox
+            |columnconfigure
+            |location
+            |propagate
+            |rowconfigure
+            |size
+            |slaves)
+        $/x);
+    $cw->SUPER::grid(@_);
+}
+
+
+sub pack {
+    my $cw = shift;
+    $cw = $cw->Subwidget('frame')
+        if (@_ && $_[0] =~ /^(?:propagate|slaves)$/);
+    $cw->SUPER::pack(@_);
+}
+
+sub place {
+    my $cw = shift;
+    $cw = $cw->Subwidget('frame')
+        if (@_ && $_[0] =~ /^(?:slaves)$/);
+    $cw->SUPER::place(@_);
+}
+
+1;
+
+