home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _d14bf3d3782fc027678ea452e952bc13 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.3 KB  |  70 lines
  1. package Tk::Configure;
  2. use vars qw($VERSION);
  3. $VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $
  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;
  70.