1 files changed, 68 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Configure.pm b/Master/tlpkg/tlperl/lib/Tk/Configure.pm
new file mode 100644
index 00000000000..8c19fe8efb8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Configure.pm
@@ -0,0 +1,68 @@
+package Tk::Configure;
+use vars qw($VERSION);
+$VERSION = '4.009'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $
+
+use Carp;
+
+
+# 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;