1package Tk::Region;
2
3# Ideas in progress do not document ...
4
5use strict;
6
7use vars qw($VERSION);
8$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Region.pm#6 $
9
10use Tk::Widget ();
11
12Construct Tk::Widget 'Region';
13
14my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5);
15
16sub _attr
17{
18 my ($obj,$key,$val) = @_;
19 if (@_ > 2)
20  {
21   $obj->{$key} = $val;
22  }
23 return $obj->{$key}
24}
25
26foreach 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
33sub 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
41sub cfgDefault
42{
43 my ($class,$key) = @_;
44 return undef;
45}
46
47sub cfgName
48{
49 my ($class,$key) = @_;
50 $key =~ s/^-//;
51 return lcfirst($key);
52}
53
54sub cfgClass
55{
56 return ucfirst(shift->cfgName(@_));
57}
58
59sub 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
97sub 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
107sub 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
131sub 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
142sub 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
153sub 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
165sub 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
1811;
182__END__
183