home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / LabFrame.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  2.9 KB  |  110 lines
  1. # $Id: LabFrame.pm,v 1.2 1997/02/03 17:26:03 rsi Exp rsi $
  2. #
  3. # Labeled frame. Derives from Tk::Frame, but intercepts the labeling
  4. # part.
  5.  
  6. package Tk::LabFrame;
  7.  
  8. use Tk;
  9. require Tk::Frame;
  10.  
  11. use strict;
  12.  
  13. Tk::Widget->Construct("LabFrame");
  14.  
  15. @Tk::LabFrame::ISA = qw(Tk::Frame);
  16.  
  17. sub Populate {
  18.     my ($cw, $args) = @_;
  19.     my $f;
  20.     my $label;
  21.     my $lside = exists $args->{-labelside} ?
  22.     delete $args->{-labelside} : 'top';
  23.     my $ltext = delete $args->{-label};
  24.     $cw->SUPER::Populate($args);
  25.     
  26.     if ($lside =~ /acrosstop/) {
  27.     my $border = $cw->Frame(-relief => "groove", -bd => 2);
  28.     my $pad = $border->Frame;
  29.     $f = $border->Frame;
  30.     $label = $cw->Label(-text => $ltext);
  31.     my $y = int($label->winfo('reqheight')) / 2;
  32.     my $ph = $y - int($border->cget(-bd));
  33.     if ($ph < 0) {
  34.         $ph = 0;
  35.     }
  36.     $label->form(-top => 0, -left => 4, -padx => 6, -pady => 2);
  37.     $border->form(-top => $y, -bottom => -1, -left => 0, -right => -1, -padx => 2, -pady => 2);
  38.     $pad->form(-left => 0, -right => -1, -top => 0, -bottom => $ph);
  39.     $f->form(-top => $pad, -bottom => -1, -left => 0, -right => -1);
  40.     $cw->Delegates('pack' => $cw);
  41.     } else {
  42.     $f = $cw->Frame(-relief => 'groove', -bd => 2, %{$args});
  43.     $label = $cw->Label(-text => $ltext);
  44.     $label->pack(-side => $lside);
  45.     $f->pack(-side => $lside, -fill => 'both', -expand => 1);
  46.     }
  47.     $cw->Advertise('frame' => $f);
  48.     $cw->Advertise('label' => $label);
  49.     $cw->Delegates(DEFAULT => $f);
  50.     $cw->ConfigSpecs(-labelside => ["PASSIVE", "labelSide", "LabelSide", "acrosstop"],
  51.              "DEFAULT" => [$f]);
  52. }
  53.  
  54. =head1 NAME
  55.  
  56. Tk::LabFrame - labeled frame.
  57.  
  58. =head1 SYNOPSIS
  59.  
  60.     use Tk::LabFrame;
  61.     $f = $top->LabFrame(-label => "Something",
  62.             -labelside => 'acrosstop');
  63.  
  64. =head1 DESCRIPTION
  65.  
  66. B<LabFrame> is exactly like B<Frame> except that it takes two
  67. additional options:
  68.  
  69. =over 4
  70.  
  71. =item B<-label>
  72. The text of the label to be placed with the Frame.
  73.  
  74. =item B<-labelside>
  75. Can be one of B<left>, B<right>, B<top>, B<bottom> or B<acrosstop>.
  76. The first four work as might be expected and place the label to the
  77. left, right, above or below the frame respectively. The last one
  78. creates a grooved frame around the central frame and puts the label
  79. near the northwest corner such that it appears to "overwrite" the
  80. groove. Run the following test program to see this in action:
  81.  
  82.     use Tk;
  83.     require Tk::LabFrame;
  84.     require Tk::LabEntry;
  85.  
  86.     my $test = 'Test this';
  87.     $top = MainWindow->new;
  88.     my $f = $top->LabFrame(-label => "This is a label",
  89.                -labelside => "acrosstop");
  90.     $f->LabEntry(-label => "Testing", -textvariable => \$test)->pack;
  91.     $f->pack;
  92.     MainLoop;
  93.     
  94. =back
  95.     
  96. =head1 BUGS
  97.  
  98. Perhaps B<LabFrame> should be subsumed within the generic pTk
  99. labeled widget mechanism.
  100.     
  101. =head1 AUTHOR
  102.  
  103. B<Rajappa Iyer> rsi@earthling.net
  104.  
  105. This code is derived from LabFrame.tcl and LabWidg.tcl in the Tix4.0
  106. distribution by Ioi Lam. The code may be redistributed under the same
  107. terms as Perl.
  108.     
  109. =cut
  110.