1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
package Tk::Configure;
use vars qw($VERSION);
$VERSION = '3.005'; # $Id: //depot/Tk8/Tk/Configure.pm#5$
use Carp;
use Tk::Pretty;
# Class that handles cget/configure for options that
# need translating from public form
# e.g. $cw->configure(-label => 'fred')
# into $cw->subwiget('label')->configure(-text => 'fred')
# Should probably do something clever with regexp's here
sub new
{
my ($class,@args) = @_;
unshift(@args,'configure','cget') if (@args < 3);
return bless \@args,$class;
}
sub cget
{
croak("Wrong number of args to cget") unless (@_ == 2);
my ($alias,$key) = @_;
my ($set,$get,$widget,@args) = @$alias;
my @result = $widget->$get(@args);
return (wantarray) ? @result : $result[0];
}
sub configure
{
my $alias = shift;
shift if (@_);
my ($set,$get,$widget,@args) = @$alias;
my @results;
eval { @results = $widget->$set(@args,@_) };
croak($@) if $@;
return @results;
}
*TIESCALAR = \&new;
*TIEHASH = \&new;
sub FETCH
{
my $alias = shift;
my ($set,$get,$widget,@args) = @$alias;
return $widget->$get(@args,@_);
}
sub STORE
{
my $alias = shift;
my ($set,$get,$widget,@args) = @$alias;
$widget->$set(@args,@_);
}
1;
|
