Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / Region.pm

package Tk::Region;

# Ideas in progress do not document ...

use strict;

use vars qw($VERSION);
$VERSION = '3.004'; # $Id: //depot/Tk8/Tk/Region.pm#4 $

use Tk::Widget ();

Construct Tk::Widget 'Region';

my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5);

sub _attr
{
 my ($obj,$key,$val) = @_;
 if (@_ > 2)
  {
   $obj->{$key} = $val;
  }
 return $obj->{$key}
}

foreach my $name (qw(widget x y width height))
 {
  my $key = "-$name";
  no strict 'refs';
  *{$name} = sub { shift->_attr($key,@_) };
 }

sub new
{
 my $class  = shift;
 my $widget = shift;
 my $obj = bless [\%index,$widget,0,0,0,0],$class;
 $obj->configure(@_);
}

sub cfgDefault
{
 my ($class,$key) = @_;
 return undef;
}

sub cfgName
{
 my ($class,$key) = @_;
 $key =~ s/^-//;
 return lcfirst($key);
}

sub cfgClass
{
 return ucfirst(shift->cfgName(@_));
}

sub configure
{
 my $obj = shift;
 my @results;
 if (@_ > 1)
  {
   while (@_)
    {
     my $key = shift;
     my $val = shift;
     if (exists $obj->{$key})
      {
       $obj->{$key} = $val;
      }
     else
      {
       my ($meth) = $key =~ /^-(\w+)$/;
       croak("Invalid option $key") unless $obj->can($meth);
       $obj->$meth($val);
      }
    }
  }
 elsif (@_ == 1)
  {
   my $key     = shift;
   my $value   = $obj->cget($key);
   push(@results,$key,$obj->cfgName($key),$obj->cfgClass($key),$obj->cfgDefault($key),$value);
  }
 else
  {
   foreach my $key (sort keys %$obj)
    {
     push(@results,scalar($obj->configure($key)))
    }
  }
 return wantarray ? @results : \@results;
}

sub cget
{
 my $obj = shift;
 my $key = shift;
 return $obj->{$key} if exists $obj->{$key};
 my ($meth) = $key =~ /^-(\w+)$/;
 croak("Invalid option $key") unless $obj->can($meth);
 return $obj->$meth();
}

sub bbox
{
 my $obj = shift;
 my @results;
 if (@_)
  {
   my $ref = (@_ == 1) ? shift : \@_;
   my ($x1,$y1,$x2,$y2) = (ref $ref) ? @$ref : split(/\s+/,$ref);
   ($x2,$x1) = ($x1,$x2) if ($x2 < $x1);
   ($y2,$y1) = ($y1,$y2) if ($y2 < $y1);
   $obj->width($x2-$x1);
   $obj->height($y2-$y1);
   $obj->x($x1);
   $obj->y($y1);
  }
 else
  {
   my $x = $obj->x;
   my $y = $obj->x;
   push(@results,$x,$y,$x+$obj->width,$y+$obj->height);
  }
 return wantarray ? @results : \@results;
}

sub rootx
{
 my $obj = shift;
 if (@_)
  {
   my $x = shift;
   $obj->x($x-$obj->widget->rootx);
  }
 return $obj->widget->rootx + $obj->{'-x'}
}

sub rooty
{
 my $obj = shift;
 if (@_)
  {
   my $y = shift;
   $obj->y($y-$obj->widget->rootx);
  }
 return $obj->widget->rooty + $obj->{'-y'}
}

sub rootxy
{
 my $obj = shift;
 if (@_)
  {
   $obj->rootx(shift);
   $obj->rooty(shift);
  }
 my @results = ($obj->rootx,$obj->rooty);
 return wantarray ? @results : \@results;
}

sub rootbbox
{
 my $obj = shift;
 my ($x1,$y1) = $obj->rootxy;
 my $x2 = $x1+$obj->width;
 my $y2 = $y1+$obj->height;
 my @results = ($x1,$y1,$x2,$y2);
 return wantarray ? @results : \@results;
}


*Width  = \&width;
*Height = \&height;
*X      = \&rootx;
*Y      = \&rooty;

1;
__END__