Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 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 | use vars qw($VERSION); | |
9 | $VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Optionmenu.pm#25 $ | |
10 | ||
11 | use base qw(Tk::Derived Tk::Menubutton); | |
12 | ||
13 | use strict; | |
14 | ||
15 | Construct Tk::Widget 'Optionmenu'; | |
16 | ||
17 | sub Populate | |
18 | { | |
19 | my ($w,$args) = @_; | |
20 | $w->SUPER::Populate($args); | |
21 | $args->{-indicatoron} = 1; | |
22 | my $var = delete $args->{-textvariable}; | |
23 | unless (defined $var) | |
24 | { | |
25 | my $gen = undef; | |
26 | $var = \$gen; | |
27 | } | |
28 | my $menu = $w->menu(-tearoff => 0); | |
29 | $w->configure(-textvariable => $var); | |
30 | ||
31 | # Should we allow -menubackground etc. as in -label* of Frame ? | |
32 | ||
33 | $w->ConfigSpecs(-command => ['CALLBACK',undef,undef,undef], | |
34 | -options => ['METHOD', undef, undef, undef], | |
35 | -variable=> ['PASSIVE', undef, undef, undef], | |
36 | -font => [['SELF',$menu], undef, undef, undef], | |
37 | ||
38 | -takefocus => [ qw/SELF takefocus Takefocus 1/ ], | |
39 | -highlightthickness => [ qw/SELF highlightThickness HighlightThickness 1/ ], | |
40 | -relief => [ qw/SELF relief Relief raised/ ], | |
41 | ||
42 | ); | |
43 | ||
44 | # configure -variable and -command now so that when -options | |
45 | # is set by main-line configure they are there to be set/called. | |
46 | $w->configure(-variable => $var) if ($var = delete $args->{-variable}); | |
47 | $w->configure(-command => $var) if ($var = delete $args->{-command}); | |
48 | } | |
49 | ||
50 | sub setOption | |
51 | { | |
52 | my ($w, $label, $val) = @_; | |
53 | $val = $label if @_ == 2; | |
54 | my $var = $w->cget(-textvariable); | |
55 | $$var = $label; | |
56 | $var = $w->cget(-variable); | |
57 | $$var = $val if $var; | |
58 | $w->Callback(-command => $val); | |
59 | } | |
60 | ||
61 | sub addOptions | |
62 | { | |
63 | my $w = shift; | |
64 | my $menu = $w->menu; | |
65 | my $var = $w->cget(-textvariable); | |
66 | my $old = $$var; | |
67 | my $width = $w->cget('-width'); | |
68 | my %hash; | |
69 | my $first; | |
70 | while (@_) | |
71 | { | |
72 | my $val = shift; | |
73 | my $label = $val; | |
74 | if (ref $val) | |
75 | { | |
76 | ($label, $val) = @$val; | |
77 | } | |
78 | my $len = length($label); | |
79 | $width = $len if (!defined($width) || $len > $width); | |
80 | $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]); | |
81 | $hash{$label} = $val; | |
82 | $first = $label unless defined $first; | |
83 | } | |
84 | if (!defined($old) || !exists($hash{$old})) | |
85 | { | |
86 | $w->setOption($first, $hash{$first}) if defined $first; | |
87 | } | |
88 | $w->configure('-width' => $width); | |
89 | } | |
90 | ||
91 | sub options | |
92 | { | |
93 | my ($w,$opts) = @_; | |
94 | if (@_ > 1) | |
95 | { | |
96 | $w->menu->delete(0,'end'); | |
97 | $w->addOptions(@$opts); | |
98 | } | |
99 | else | |
100 | { | |
101 | return $w->_cget('-options'); | |
102 | } | |
103 | } | |
104 | ||
105 | 1; | |
106 | ||
107 | __END__ | |
108 | ||
109 | =cut | |
110 |