home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Optionmenu.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  1.8 KB  |  84 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Optionmenu;
  5. require Tk::Menubutton;
  6. require Tk::Menu;
  7.  
  8. @ISA = qw(Tk::Derived Tk::Menubutton);
  9.  
  10. Construct Tk::Widget 'Optionmenu';
  11.  
  12. sub Populate
  13. {
  14.  my ($w,$args) = @_;
  15.  $w->SUPER::Populate($args);
  16.  $args->{-indicatoron} = 1;
  17.  my $var = delete $args->{-textvariable};
  18.  unless (defined $var)
  19.   {
  20.    my $gen = undef;
  21.    $var = \$gen;
  22.   }
  23.  $w->menu(-tearoff => 0);
  24.  $w->configure(-textvariable => $var);
  25.  
  26.  # Should we allow -menubackground etc. as in -label* of Frame ?
  27.  
  28.  $w->ConfigSpecs(-command => [CALLBACK,undef,undef,undef],
  29.                  -options => [METHOD, undef, undef, undef],
  30.          -variable=> [PASSIVE, undef, undef, undef],
  31.                 );
  32.  
  33.  $w->configure(-variable => delete $args->{-variable});
  34. }
  35.  
  36. sub setOption
  37. {
  38.  my ($w, $label, $val) = @_;
  39.  $val = $label if @_ == 2;
  40.  my $var = $w->cget(-textvariable);
  41.  $$var = $label;
  42.  $var = $w->cget(-variable);
  43.  $$var = $val if $var;
  44.  $w->Callback(-command => $val);
  45. }
  46.  
  47. sub addOptions
  48. {
  49.  my $w = shift;
  50.  my $menu = $w->menu;
  51.  my $var = $w->cget(-textvariable);
  52.  my $width = $w->cget('-width');
  53.  while (@_)
  54.   {
  55.    my $val = shift;
  56.    my $label = $val;
  57.    if (ref $val) 
  58.     {
  59.      ($label, $val) = @$val;
  60.     } 
  61.    my $len = length($label);                          
  62.    $width = $len if (!defined($width) || $len > $width);
  63.    $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]);
  64.    $w->setOption($label, $val) unless (defined $$var);
  65.   }
  66.  $w->configure('-width' => $width);
  67. }
  68.  
  69. sub options
  70. {
  71.  my ($w,$opts) = @_;
  72.  if (@_ > 1)
  73.   {
  74.    $w->menu->delete(0,'end');
  75.    $w->addOptions(@$opts);
  76.   }
  77.  else
  78.   {
  79.    return $w->_cget('-options');
  80.   }
  81. }
  82.  
  83. 1;
  84.