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