home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _278be386095f67d2ee8a8206ca1e6b12 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.1 KB  |  183 lines
  1. package Tk::Region;
  2.  
  3. # Ideas in progress do not document ...
  4.  
  5. use strict;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Region.pm#6 $
  9.  
  10. use Tk::Widget ();
  11.  
  12. Construct Tk::Widget 'Region';
  13.  
  14. my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5);
  15.  
  16. sub _attr
  17. {
  18.  my ($obj,$key,$val) = @_;
  19.  if (@_ > 2)
  20.   {
  21.    $obj->{$key} = $val;
  22.   }
  23.  return $obj->{$key}
  24. }
  25.  
  26. foreach my $name (qw(widget x y width height))
  27.  {
  28.   my $key = "-$name";
  29.   no strict 'refs';
  30.   *{$name} = sub { shift->_attr($key,@_) };
  31.  }
  32.  
  33. sub new
  34. {
  35.  my $class  = shift;
  36.  my $widget = shift;
  37.  my $obj = bless [\%index,$widget,0,0,0,0],$class;
  38.  $obj->configure(@_);
  39. }
  40.  
  41. sub cfgDefault
  42. {
  43.  my ($class,$key) = @_;
  44.  return undef;
  45. }
  46.  
  47. sub cfgName
  48. {
  49.  my ($class,$key) = @_;
  50.  $key =~ s/^-//;
  51.  return lcfirst($key);
  52. }
  53.  
  54. sub cfgClass
  55. {
  56.  return ucfirst(shift->cfgName(@_));
  57. }
  58.  
  59. sub configure
  60. {
  61.  my $obj = shift;
  62.  my @results;
  63.  if (@_ > 1)
  64.   {
  65.    while (@_)
  66.     {
  67.      my $key = shift;
  68.      my $val = shift;
  69.      if (exists $obj->{$key})
  70.       {
  71.        $obj->{$key} = $val;
  72.       }
  73.      else
  74.       {
  75.        my ($meth) = $key =~ /^-(\w+)$/;
  76.        croak("Invalid option $key") unless $obj->can($meth);
  77.        $obj->$meth($val);
  78.       }
  79.     }
  80.   }
  81.  elsif (@_ == 1)
  82.   {
  83.    my $key     = shift;
  84.    my $value   = $obj->cget($key);
  85.    push(@results,$key,$obj->cfgName($key),$obj->cfgClass($key),$obj->cfgDefault($key),$value);
  86.   }
  87.  else
  88.   {
  89.    foreach my $key (sort keys %$obj)
  90.     {
  91.      push(@results,scalar($obj->configure($key)))
  92.     }
  93.   }
  94.  return wantarray ? @results : \@results;
  95. }
  96.  
  97. sub cget
  98. {
  99.  my $obj = shift;
  100.  my $key = shift;
  101.  return $obj->{$key} if exists $obj->{$key};
  102.  my ($meth) = $key =~ /^-(\w+)$/;
  103.  croak("Invalid option $key") unless $obj->can($meth);
  104.  return $obj->$meth();
  105. }
  106.  
  107. sub bbox
  108. {
  109.  my $obj = shift;
  110.  my @results;
  111.  if (@_)
  112.   {
  113.    my $ref = (@_ == 1) ? shift : \@_;
  114.    my ($x1,$y1,$x2,$y2) = (ref $ref) ? @$ref : split(/\s+/,$ref);
  115.    ($x2,$x1) = ($x1,$x2) if ($x2 < $x1);
  116.    ($y2,$y1) = ($y1,$y2) if ($y2 < $y1);
  117.    $obj->width($x2-$x1);
  118.    $obj->height($y2-$y1);
  119.    $obj->x($x1);
  120.    $obj->y($y1);
  121.   }
  122.  else
  123.   {
  124.    my $x = $obj->x;
  125.    my $y = $obj->x;
  126.    push(@results,$x,$y,$x+$obj->width,$y+$obj->height);
  127.   }
  128.  return wantarray ? @results : \@results;
  129. }
  130.  
  131. sub rootx
  132. {
  133.  my $obj = shift;
  134.  if (@_)
  135.   {
  136.    my $x = shift;
  137.    $obj->x($x-$obj->widget->rootx);
  138.   }
  139.  return $obj->widget->rootx + $obj->{'-x'}
  140. }
  141.  
  142. sub rooty
  143. {
  144.  my $obj = shift;
  145.  if (@_)
  146.   {
  147.    my $y = shift;
  148.    $obj->y($y-$obj->widget->rootx);
  149.   }
  150.  return $obj->widget->rooty + $obj->{'-y'}
  151. }
  152.  
  153. sub rootxy
  154. {
  155.  my $obj = shift;
  156.  if (@_)
  157.   {
  158.    $obj->rootx(shift);
  159.    $obj->rooty(shift);
  160.   }
  161.  my @results = ($obj->rootx,$obj->rooty);
  162.  return wantarray ? @results : \@results;
  163. }
  164.  
  165. sub rootbbox
  166. {
  167.  my $obj = shift;
  168.  my ($x1,$y1) = $obj->rootxy;
  169.  my $x2 = $x1+$obj->width;
  170.  my $y2 = $y1+$obj->height;
  171.  my @results = ($x1,$y1,$x2,$y2);
  172.  return wantarray ? @results : \@results;
  173. }
  174.  
  175.  
  176. *Width  = \&width;
  177. *Height = \&height;
  178. *X      = \&rootx;
  179. *Y      = \&rooty;
  180.  
  181. 1;
  182. __END__
  183.