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