home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _8beefe89970e4beef1759628fe47c305 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.7 KB  |  64 lines
  1. # Class LabeledRadiobutton
  2.  
  3. package Tk::LabRadiobutton;
  4.  
  5. use vars qw($VERSION);
  6. $VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/LabRadio.pm#4 $
  7.  
  8. require Tk::Frame;
  9. use base  qw(Tk::Frame);
  10.  
  11. Construct Tk::Widget 'LabRadiobutton';
  12.  
  13.  
  14. # Although there is no fundamental reason why -radiobuttons
  15. # should be fixed at create time converting to METHOD form
  16. # is extra work an this can serve as an example of CreateArgs
  17. # checking.
  18.  
  19. sub CreateArgs
  20. {
  21.  my ($package,$parent,$args) = @_;
  22.  $parent->BackTrace("Must specify -radiobuttons for $package")
  23.     unless (defined $args->{'-radiobuttons'});
  24.  return $package->SUPER::CreateArgs($parent,$args);
  25. }
  26.  
  27. sub Populate
  28. {
  29.     require Tk::Radiobutton;
  30.  
  31.     my ($cw,$args) = @_;
  32.     $cw->SUPER::Populate($args);
  33.  
  34.     # LabeledRadiobutton(s) constructor.
  35.     #
  36.     # Advertised subwidgets:  the name(s) of your radiobutton(s).
  37.  
  38.  
  39.  
  40.     my (@widgets) = ();
  41.  
  42.     my $rl;
  43.     foreach $rl (@{$args->{'-radiobuttons'}})
  44.      {
  45.        my $r = $cw->Component( Radiobutton => $rl,
  46.                                -text     => $rl,
  47.                                -value    => $rl );
  48.        $r->pack(-side => 'left', -expand => 1, -fill => 'both');
  49.        push(@widgets,$r);
  50.        $cw->{Configure}{-value} = $rl;
  51.      }
  52.  
  53.     $cw->BackTrace('No buttons') unless (@widgets);
  54.  
  55.     $cw->ConfigSpecs('-variable'     => [ \@widgets, undef, undef, \$cw->{Configure}{-value} ],
  56.                      '-radiobuttons' => [ 'PASSIVE', undef, undef, undef ],
  57.                      '-value'        => [ 'PASSIVE', undef, undef, $cw->{Configure}{-value} ],
  58.                      'DEFAULT'       => [ \@widgets ]
  59.                     );
  60. }
  61.  
  62.  
  63. 1;
  64.