Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::Adjuster; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Adjuster.pm#25 $ | |
5 | ||
6 | use base qw(Tk::Frame); | |
7 | ||
8 | # We cannot do this : | |
9 | ||
10 | # Construct Tk::Widget 'packAdjust'; | |
11 | ||
12 | # because if managed object is Derived (e.g. a Scrolled) then our 'new' | |
13 | # will be delegated and hierachy gets turned inside-out | |
14 | # So packAdjust is autoloaded in Widget.pm | |
15 | ||
16 | ||
17 | Construct Tk::Widget qw(Adjuster); | |
18 | ||
19 | {package Tk::Adjuster::Item; | |
20 | ||
21 | use strict; | |
22 | use base qw(Tk::Frame); | |
23 | ||
24 | sub ClassInit | |
25 | { | |
26 | my ($class,$mw) = @_; | |
27 | $mw->bind($class,'<1>',['BDown', 1]); | |
28 | $mw->bind($class,'<Shift-1>',['BDown', 0]); | |
29 | $mw->bind($class,'<B1-Motion>',['Motion',1]); | |
30 | $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]); | |
31 | $mw->bind($class,'<ButtonRelease-1>',['Motion',0]); | |
32 | return $class; | |
33 | } | |
34 | ||
35 | sub BDown | |
36 | { | |
37 | my($w, $delay_mask) = @_; | |
38 | $w->{'start_x'} = $w->XEvent->x; | |
39 | $w->{'start_y'} = $w->XEvent->y; | |
40 | my $adj = $w->Parent; | |
41 | delete $adj->{'lin_info'}; | |
42 | my $delay = $delay_mask && $adj->cget('-delay'); | |
43 | if ($delay) | |
44 | { | |
45 | $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0); | |
46 | } | |
47 | } | |
48 | ||
49 | sub Motion | |
50 | { | |
51 | my($w, $delay_mask) = @_; | |
52 | my $ev = $w->XEvent; | |
53 | my $adj = $w->Parent; | |
54 | ||
55 | my $delay = $delay_mask && $adj->cget('-delay'); | |
56 | if ($adj->vert) | |
57 | { | |
58 | my $dx = $ev->x - $w->{'start_x'}; | |
59 | $delay ? $adj->delta_width_bar($dx) : $adj->delta_width($dx); | |
60 | } | |
61 | else | |
62 | { | |
63 | my $dy = $ev->y - $w->{'start_y'}; | |
64 | $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy); | |
65 | } | |
66 | } | |
67 | ||
68 | } | |
69 | ||
70 | ||
71 | ||
72 | sub packAfter | |
73 | { | |
74 | my ($w,$s,%args) = @_; | |
75 | my $side = $args{'-side'} ? $args{'-side'} : 'top'; | |
76 | $w->configure(-side => $side, -widget => $s); | |
77 | $w->packed($s, %args); | |
78 | } | |
79 | ||
80 | sub packForget | |
81 | { | |
82 | my ($w,$forget_slave) = @_; | |
83 | $w->Tk::Widget::packForget; | |
84 | $w->slave->packForget if $forget_slave; | |
85 | } | |
86 | ||
87 | # Called by Tk::Widget::packAdjust. It was here before packAfter was added | |
88 | sub packed | |
89 | { | |
90 | my ($w,$s,%args) = @_; | |
91 | delete $args{'-before'}; | |
92 | $args{'-expand'} = 0; | |
93 | $args{'-after'} = $s; | |
94 | $args{'-fill'} = (($w->vert) ? 'y' : 'x'); | |
95 | $w->pack(%args); | |
96 | } | |
97 | ||
98 | sub gridded | |
99 | { | |
100 | my ($w,$s,%args) = @_; | |
101 | # delete $args{'-before'}; | |
102 | # $args{'-expand'} = 0; | |
103 | # $args{'-after'} = $s; | |
104 | # $args{'-fill'} = (($w->vert) ? 'y' : 'x'); | |
105 | $w->grid(%args); | |
106 | } | |
107 | ||
108 | sub ClassInit | |
109 | { | |
110 | my ($class,$mw) = @_; | |
111 | $mw->bind($class,'<Configure>','SizeChange'); | |
112 | $mw->bind($class,'<Unmap>','Restore'); | |
113 | $mw->bind($class,'<Map>','Mapped'); | |
114 | return $class; | |
115 | } | |
116 | ||
117 | sub SizeChange | |
118 | { | |
119 | my $w = shift; | |
120 | # reqwidth/height of Adjuster is stored here. If it is partially pushed out | |
121 | # of the window, then $w->width/height returns that of the visible part. | |
122 | if ($w->vert) | |
123 | { | |
124 | my $sx = ($w->Width - $w->{'sep'}->Width)/2; | |
125 | $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18); | |
126 | $w->{'sep'}->place('-x' => $sx, '-y' => 0, -relheight => 1); | |
127 | $w->configure(-width => $w->{'but'}->ReqWidth); | |
128 | $w->{'reqwidth'} = $w->reqwidth; | |
129 | } | |
130 | else | |
131 | { | |
132 | my $sy = ($w->Height - $w->{'sep'}->Height)/2; | |
133 | $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0); | |
134 | $w->{'sep'}->place('-x' => 0, '-y' => $sy, -relwidth => 1); | |
135 | $w->configure(-height => $w->{'but'}->ReqHeight); | |
136 | $w->{'reqheight'} = $w->reqheight; | |
137 | } | |
138 | # Turn off geometry propagation in the slave. Do only if necessary, as this | |
139 | # causes repacking. | |
140 | my $s = $w->slave; | |
141 | $s->packPropagate('0') if $s->packSlaves && $s->packPropagate(); | |
142 | $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate(); | |
143 | } | |
144 | ||
145 | sub Mapped | |
146 | { | |
147 | my $w = shift; | |
148 | $w->idletasks; | |
149 | my $m = $w->manager; | |
150 | if ($m =~ /^(?:pack|grid)$/) | |
151 | { | |
152 | my %info = $w->$m('info'); | |
153 | my $master = $info{'-in'}; | |
154 | $master->$m('propagate',0); | |
155 | $w->{'master'} = $master; | |
156 | } | |
157 | $w->slave_expand_off; | |
158 | } | |
159 | ||
160 | sub Populate | |
161 | { | |
162 | my ($w,$args) = @_; | |
163 | $w->SUPER::Populate($args); | |
164 | $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken'); | |
165 | $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised'); | |
166 | ||
167 | # Need to explicitly set frame width to 0 for Win32 | |
168 | my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0); | |
169 | ||
170 | my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent], | |
171 | -side => ['METHOD','side','Side','top'], | |
172 | -delay => ['PASSIVE','delay','Delay', 1], | |
173 | -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef], | |
174 | -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'], | |
175 | -restore => ['PASSIVE','restore', 'Restore', 1], | |
176 | ); | |
177 | $w->_OnDestroy(qw(sep but lin master)); | |
178 | } | |
179 | ||
180 | sub side | |
181 | { | |
182 | my ($w,$val) = @_; | |
183 | if (@_ > 1) | |
184 | { | |
185 | $w->{'side'} = $val; | |
186 | my $cursor; | |
187 | if ($w->vert) | |
188 | { | |
189 | $cursor = 'sb_h_double_arrow'; | |
190 | $w->{'sep'}->configure(-width => 2, -height => 10000); | |
191 | } | |
192 | else | |
193 | { | |
194 | $cursor = 'sb_v_double_arrow'; | |
195 | $w->{'sep'}->configure(-height => 2, -width => 10000); | |
196 | } | |
197 | my $x; | |
198 | foreach $x ($w->{'sep'},$w->{'but'}) | |
199 | { | |
200 | $x->configure(-cursor => $cursor); | |
201 | } | |
202 | } | |
203 | return $w->{'side'}; | |
204 | } | |
205 | ||
206 | sub slave | |
207 | { | |
208 | my $w = shift; | |
209 | my $s = $w->cget('-widget'); | |
210 | return $s; | |
211 | } | |
212 | ||
213 | sub vert | |
214 | { | |
215 | my $w = shift; | |
216 | my $side = $w->cget('-side'); | |
217 | return 1 if $side eq 'left'; | |
218 | return -1 if $side eq 'right'; | |
219 | return 0; | |
220 | } | |
221 | ||
222 | # If the Adjuster gets unmapped, it attempts to restore itself. If its | |
223 | # slave is mapped, then it reduces the size of the slave so that there is | |
224 | # then room in the master for the Adjuster widget. | |
225 | sub Restore | |
226 | { | |
227 | my $w = shift; | |
228 | return if ! $w->toplevel->IsMapped || | |
229 | ! $w->slave->IsMapped || | |
230 | ! $w->cget('-restore'); | |
231 | $w->vert ? $w->delta_width(0) : $w->delta_height(0); | |
232 | } | |
233 | ||
234 | sub delta_width_bar | |
235 | { | |
236 | my ($w,$dx) = @_; | |
237 | my $l = $w->{'lin'}; | |
238 | my $r = $w->{'sep'}; | |
239 | my $t = $w->toplevel; | |
240 | my $m = $w->{'master'}; | |
241 | my $s = $w->slave; | |
242 | my ($min_rootx, $max_rootx, $t_border); | |
243 | if (! $w->{'lin_info'}) | |
244 | { | |
245 | my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); | |
246 | $t_border = $t->cget('-bd') + $t->cget('-highlightthickness'); | |
247 | if ($w->cget('-side') eq 'right') | |
248 | { | |
249 | $min_rootx = $m->rootx + $m_border; | |
250 | $max_rootx = $s->rootx + $s->width - 1; | |
251 | } | |
252 | else | |
253 | { | |
254 | $min_rootx = $s->rootx; | |
255 | $max_rootx = $m->rootx + $m->width - $m_border - 1; | |
256 | } | |
257 | $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border]; | |
258 | } | |
259 | else | |
260 | { | |
261 | ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}}; | |
262 | } | |
263 | $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped; | |
264 | ||
265 | my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx; | |
266 | $new_rootx = $min_rootx if $new_rootx < $min_rootx; | |
267 | $new_rootx = $max_rootx if $new_rootx > $max_rootx; | |
268 | my $placex = $new_rootx - $t->rootx - $t_border; | |
269 | my $placey = $w->rooty - $t->rooty - $t_border; | |
270 | $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey); | |
271 | my $this = $w->containing($new_rootx, $w->rooty + 1); | |
272 | $l->raise($this) if $this && $this ne $t; | |
273 | } | |
274 | ||
275 | sub delta_width | |
276 | { | |
277 | my ($w,$dx) = @_; | |
278 | my $l = $w->{'lin'}; | |
279 | $l->placeForget; | |
280 | my $s = $w->slave; | |
281 | if ($s) | |
282 | { | |
283 | my $m = $w->{'master'}; | |
284 | my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); | |
285 | my $w_width = $w->{'reqwidth'}; | |
286 | my $m_width = $m->width; | |
287 | my $s_width = $s->width; | |
288 | my $max_width = $m_width - $w_width; | |
289 | my $max_s_width; | |
290 | if ($w->cget('-side') eq 'right') | |
291 | { | |
292 | $dx = -$dx; | |
293 | $max_s_width = $max_width - | |
294 | ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border; | |
295 | } | |
296 | else | |
297 | { | |
298 | $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border; | |
299 | } | |
300 | my $new_width = $s_width+$dx; | |
301 | $new_width = $max_s_width if $new_width > $max_s_width; | |
302 | $new_width = 0 if $new_width < 0; | |
303 | $s->GeometryRequest($new_width, $s->height); | |
304 | } | |
305 | } | |
306 | ||
307 | sub delta_height_bar | |
308 | { | |
309 | my ($w,$dy) = @_; | |
310 | my $l = $w->{'lin'}; | |
311 | my $r = $w->{'sep'}; | |
312 | my $t = $w->toplevel; | |
313 | my $m = $w->{'master'}; | |
314 | my $s = $w->slave; | |
315 | my ($min_rooty, $max_rooty, $t_border); | |
316 | if (! $w->{'lin_info'}) | |
317 | { | |
318 | my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); | |
319 | $t_border = $t->cget('-bd') + $t->cget('-highlightthickness'); | |
320 | if ($w->cget('-side') eq 'bottom') | |
321 | { | |
322 | $min_rooty = $m->rooty + $m_border; | |
323 | $max_rooty = $s->rooty + $s->height - 1; | |
324 | } | |
325 | else | |
326 | { | |
327 | $min_rooty = $s->rooty; | |
328 | $max_rooty = $m->rooty + $m->height - $m_border - 1; | |
329 | } | |
330 | $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border]; | |
331 | } | |
332 | else | |
333 | { | |
334 | ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}}; | |
335 | } | |
336 | $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped; | |
337 | ||
338 | my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy; | |
339 | $new_rooty = $min_rooty if $new_rooty < $min_rooty; | |
340 | $new_rooty = $max_rooty if $new_rooty > $max_rooty; | |
341 | my $placey = $new_rooty - $t->rooty - $t_border; | |
342 | my $placex = $w->rootx - $t->rootx - $t_border; | |
343 | $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey); | |
344 | my $this = $w->containing($w->rootx + 1, $new_rooty); | |
345 | $l->raise($this) if $this && $this ne $t; | |
346 | } | |
347 | ||
348 | sub delta_height | |
349 | { | |
350 | my ($w,$dy) = @_; | |
351 | my $l = $w->{'lin'}; | |
352 | $l->placeForget; | |
353 | my $s = $w->slave; | |
354 | if ($s) | |
355 | { | |
356 | my $m = $w->{'master'}; | |
357 | my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); | |
358 | my $w_height = $w->{'reqheight'}; | |
359 | my $m_height = $m->height; | |
360 | my $s_height = $s->height; | |
361 | my $max_height = $m_height - $w_height; | |
362 | my $max_s_height; | |
363 | if ($w->cget('-side') eq 'bottom') | |
364 | { | |
365 | $dy = -$dy; | |
366 | $max_s_height = $max_height - | |
367 | ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border; | |
368 | } | |
369 | else | |
370 | { | |
371 | $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border; | |
372 | } | |
373 | my $new_height = $s_height+$dy; | |
374 | ||
375 | $new_height = $max_s_height if $new_height > $max_s_height; | |
376 | $new_height = 0 if $new_height < 0; | |
377 | $s->GeometryRequest($s->width, $new_height); | |
378 | } | |
379 | } | |
380 | ||
381 | # Turn off expansion in the slave. | |
382 | # This is done only if necessary, as calls to pack/gridConfigure cause | |
383 | # repacking. | |
384 | # Before call to pack/gridConfigure, the reqwidth/reqheight is set to the | |
385 | # current width/height. This is because the geometry managers use | |
386 | # the requested values, not the actual, to calculate the new geometry. | |
387 | sub slave_expand_off | |
388 | { | |
389 | my $w = shift; | |
390 | my $s = $w->slave; | |
391 | return if ! $s; | |
392 | ||
393 | my $manager = $s->manager; | |
394 | if ($manager eq 'pack') | |
395 | { | |
396 | my %info = $s->packInfo; | |
397 | my $expand = $info{'-expand'}; | |
398 | if ($expand) | |
399 | { | |
400 | $s->GeometryRequest($s->width, $s->height); | |
401 | $s->packConfigure(-expand => 0); | |
402 | } | |
403 | } | |
404 | elsif ($manager eq 'grid') | |
405 | { | |
406 | my %info = $s->gridInfo; | |
407 | my $master = $info{'-in'}; | |
408 | if ($w->vert) | |
409 | { | |
410 | my $col = $info{'-column'}; | |
411 | my $expand = $master->gridColumnconfigure($col, '-weight'); | |
412 | if ($expand) | |
413 | { | |
414 | $s->GeometryRequest($s->width, $s->height); | |
415 | $master->gridColumnconfigure($col, -weight => 0); | |
416 | } | |
417 | } | |
418 | else | |
419 | { | |
420 | my $row = $info{'-row'}; | |
421 | my $expand = $master->gridRowconfigure($row, '-weight'); | |
422 | if ($expand) | |
423 | { | |
424 | $s->GeometryRequest($s->width, $s->height); | |
425 | $master->gridRowconfigure($row, -weight => 0); | |
426 | } | |
427 | } | |
428 | } | |
429 | } | |
430 | ||
431 | 1; | |
432 | ||
433 | __END__ | |
434 | ||
435 | =cut #' emacs hilighting... |