home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _fb23fe2641e5d5777ee28d745c70cc02 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.0 KB  |  131 lines
  1. # Copyright (c) 1995-2003 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. use Carp;
  8.  
  9. use vars qw($VERSION);
  10. $VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/Optionmenu.pm#13 $
  11.  
  12. use base  qw(Tk::Derived Tk::Menubutton);
  13.  
  14. use strict;
  15.  
  16. Construct Tk::Widget 'Optionmenu';
  17.  
  18. sub Populate
  19. {
  20.  my ($w,$args) = @_;
  21.  $w->SUPER::Populate($args);
  22.  $args->{-indicatoron} = 1;
  23.  my $menu = $w->menu(-tearoff => 0);
  24.  
  25.  # Should we allow -menubackground etc. as in -label* of Frame ?
  26.  
  27.  $w->ConfigSpecs(-command => ['CALLBACK',undef,undef,undef],
  28.                  -options => ['METHOD', undef, undef, undef],
  29.          -variable=> ['PASSIVE', undef, undef, undef],
  30.          -font    => [['SELF',$menu], undef, undef, undef],
  31.          -foreground => [['SELF', 'CHILDREN'], undef, undef, undef],
  32.  
  33.    -takefocus          => [ qw/SELF takefocus          Takefocus          1/ ],
  34.    -highlightthickness => [ qw/SELF highlightThickness HighlightThickness 1/ ],
  35.    -relief             => [ qw/SELF relief             Relief        raised/ ],
  36.  
  37.                 );
  38.  
  39.  # configure -variable and -command now so that when -options
  40.  # is set by main-line configure they are there to be set/called.
  41.  
  42.  my $tvar = delete $args->{-textvariable};
  43.  my $vvar = delete $args->{-variable};
  44.  if (!defined($vvar))
  45.   {
  46.    if (defined $tvar)
  47.     {
  48.      $vvar = $tvar;
  49.     }
  50.    else
  51.     {
  52.      my $new;
  53.      $vvar = \$new;
  54.     }
  55.   }
  56.  $tvar = $vvar if (!defined($tvar));
  57.  $w->configure(-textvariable => $tvar, -variable => $vvar);
  58.  $w->configure(-command  => $vvar) if ($vvar = delete $args->{-command});
  59. }
  60.  
  61. sub setOption
  62. {
  63.  my ($w, $label, $val) = @_;
  64.  my $tvar = $w->cget(-textvariable);
  65.  my $vvar = $w->cget(-variable);
  66.  if (@_ == 2)
  67.   {
  68.    $val = $label;
  69.   }
  70.  $$tvar = $label if $tvar;
  71.  $$vvar = $val   if $vvar;
  72.  $w->Callback(-command => $val);
  73. }
  74.  
  75. sub addOptions
  76. {
  77.  my $w     = shift;
  78.  my $menu  = $w->menu;
  79.  my $tvar  = $w->cget(-textvariable);
  80.  my $vvar  = $w->cget(-variable);
  81.  my $oldt  = $$tvar;
  82.  my $width = $w->cget('-width');
  83.  my %hash;
  84.  my $first;
  85.  while (@_)
  86.   {
  87.    my $val = shift;
  88.    my $label = $val;
  89.    if (ref $val)
  90.     {
  91.      if ($vvar == $tvar)
  92.       {
  93.        my $new = $label;
  94.        $w->configure(-textvariable => ($tvar = \$new));
  95.       }
  96.      ($label, $val) = @$val;
  97.     }
  98.    my $len = length($label);
  99.    $width = $len if (!defined($width) || $len > $width);
  100.    $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]);
  101.    $hash{$label} = $val;
  102.    $first = $label unless defined $first;
  103.   }
  104.  if (!defined($oldt) || !exists($hash{$oldt}))
  105.   {
  106.    $w->setOption($first, $hash{$first}) if defined $first;
  107.   }
  108.  $w->configure('-width' => $width);
  109. }
  110.  
  111. sub options
  112. {
  113.  my ($w,$opts) = @_;
  114.  if (@_ > 1)
  115.   {
  116.    $w->menu->delete(0,'end');
  117.    $w->addOptions(@$opts);
  118.   }
  119.  else
  120.   {
  121.    return $w->_cget('-options');
  122.   }
  123. }
  124.  
  125. 1;
  126.  
  127. __END__
  128.  
  129. =cut
  130.  
  131.