summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Configure.pm
blob: 26252ae4958bcc063a8bd13a1d528233942aa72a (plain)
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
61
62
63
64
65
66
67
68
69
package Tk::Configure;
use vars qw($VERSION);
$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $

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;
 $widget->$get(@args);
}

sub configure
{
 my $alias = shift;
 shift if (@_);
 my ($set,$get,$widget,@args) = @$alias;
 if (wantarray)
  {
   my @results;
   eval { @results = $widget->$set(@args,@_) };
   croak($@) if $@;
   return @results;
  }
 else
  {
   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;