summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Region.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Region.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Region.pm182
1 files changed, 182 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Region.pm b/Master/tlpkg/tlperl/lib/Tk/Region.pm
new file mode 100644
index 00000000000..3e02bd2ff49
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Region.pm
@@ -0,0 +1,182 @@
+package Tk::Region;
+
+# Ideas in progress do not document ...
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Region.pm#6 $
+
+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__