"Fossies" - the Fresh Open Source Software Archive 
Member "Tk-804.036/Tk/Adjuster.pm" (15 Nov 2013, 11173 Bytes) of package /linux/misc/Tk-804.036.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
For more information about "Adjuster.pm" see the
Fossies "Dox" file reference documentation.
1 package Tk::Adjuster;
2
3 use vars qw($VERSION);
4 $VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Adjuster.pm#7 $
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 delete $args{'-in'};
93 $args{'-expand'} = 0;
94 $args{'-after'} = $s;
95 $args{'-fill'} = (($w->vert) ? 'y' : 'x');
96 $w->pack(%args);
97 }
98
99 sub gridded
100 {
101 my ($w,$s,%args) = @_;
102 # delete $args{'-before'};
103 # $args{'-expand'} = 0;
104 # $args{'-after'} = $s;
105 # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
106 $w->grid(%args);
107 }
108
109 sub ClassInit
110 {
111 my ($class,$mw) = @_;
112 $mw->bind($class,'<Configure>','SizeChange');
113 $mw->bind($class,'<Unmap>','Restore');
114 $mw->bind($class,'<Map>','Mapped');
115 return $class;
116 }
117
118 sub SizeChange
119 {
120 my $w = shift;
121 # reqwidth/height of Adjuster is stored here. If it is partially pushed out
122 # of the window, then $w->width/height returns that of the visible part.
123 if ($w->vert)
124 {
125 my $sx = ($w->Width - $w->{'sep'}->Width)/2;
126 $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
127 $w->{'sep'}->place('-x' => $sx, '-y' => 0, -relheight => 1);
128 $w->configure(-width => $w->{'but'}->ReqWidth);
129 $w->{'reqwidth'} = $w->reqwidth;
130 }
131 else
132 {
133 my $sy = ($w->Height - $w->{'sep'}->Height)/2;
134 $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
135 $w->{'sep'}->place('-x' => 0, '-y' => $sy, -relwidth => 1);
136 $w->configure(-height => $w->{'but'}->ReqHeight);
137 $w->{'reqheight'} = $w->reqheight;
138 }
139 # Turn off geometry propagation in the slave. Do only if necessary, as this
140 # causes repacking.
141 my $s = $w->slave;
142 $s->packPropagate('0') if $s->packSlaves && $s->packPropagate();
143 $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate();
144 }
145
146 sub Mapped
147 {
148 my $w = shift;
149 $w->idletasks;
150 my $m = $w->manager;
151 if ($m =~ /^(?:pack|grid)$/)
152 {
153 my %info = $w->$m('info');
154 my $master = $info{'-in'};
155 $master->$m('propagate',0);
156 $w->{'master'} = $master;
157 }
158 $w->slave_expand_off;
159 }
160
161 sub Populate
162 {
163 my ($w,$args) = @_;
164 $w->SUPER::Populate($args);
165 $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
166 $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
167
168 # Force creation of Frame in widget's Toplevel. This makes a difference
169 # where the widget's Toplevel has Delegates('Construct') set.
170 # Need to explicitly set frame width to 0 for Win32
171 my $l = $w->{'lin'} = Tk::Frame->new($w->toplevel, -bd => 0);
172 # my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
173
174 my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
175 -side => ['METHOD','side','Side','top'],
176 -delay => ['PASSIVE','delay','Delay', 1],
177 -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
178 -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
179 -restore => ['PASSIVE','restore', 'Restore', 1],
180 );
181 $w->_OnDestroy(qw(sep but lin master));
182 }
183
184 sub side
185 {
186 my ($w,$val) = @_;
187 if (@_ > 1)
188 {
189 $w->{'side'} = $val;
190 my $cursor;
191 if ($w->vert)
192 {
193 $cursor = 'sb_h_double_arrow';
194 $w->{'sep'}->configure(-width => 2, -height => 10000);
195 }
196 else
197 {
198 $cursor = 'sb_v_double_arrow';
199 $w->{'sep'}->configure(-height => 2, -width => 10000);
200 }
201 my $x;
202 foreach $x ($w->{'sep'},$w->{'but'})
203 {
204 $x->configure(-cursor => $cursor);
205 }
206 }
207 return $w->{'side'};
208 }
209
210 sub slave
211 {
212 my $w = shift;
213 my $s = $w->cget('-widget');
214 return $s;
215 }
216
217 sub vert
218 {
219 my $w = shift;
220 my $side = $w->cget('-side');
221 return 1 if $side eq 'left';
222 return -1 if $side eq 'right';
223 return 0;
224 }
225
226 # If the Adjuster gets unmapped, it attempts to restore itself. If its
227 # slave is mapped, then it reduces the size of the slave so that there is
228 # then room in the master for the Adjuster widget.
229 sub Restore
230 {
231 my $w = shift;
232 return if ! $w->toplevel->IsMapped ||
233 ! $w->slave->IsMapped ||
234 ! $w->cget('-restore');
235 $w->vert ? $w->delta_width(0) : $w->delta_height(0);
236 }
237
238 sub delta_width_bar
239 {
240 my ($w,$dx) = @_;
241 my $l = $w->{'lin'};
242 my $r = $w->{'sep'};
243 my $t = $w->toplevel;
244 my $m = $w->{'master'};
245 my $s = $w->slave;
246 my ($min_rootx, $max_rootx, $t_border);
247 if (! $w->{'lin_info'})
248 {
249 my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
250 $t_border = $t->cget('-bd') + $t->cget('-highlightthickness');
251 if ($w->cget('-side') eq 'right')
252 {
253 $min_rootx = $m->rootx + $m_border;
254 $max_rootx = $s->rootx + $s->width - 1;
255 }
256 else
257 {
258 $min_rootx = $s->rootx;
259 $max_rootx = $m->rootx + $m->width - $m_border - 1;
260 }
261 $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
262 }
263 else
264 {
265 ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
266 }
267 $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
268
269 my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
270 $new_rootx = $min_rootx if $new_rootx < $min_rootx;
271 $new_rootx = $max_rootx if $new_rootx > $max_rootx;
272 my $placex = $new_rootx - $t->rootx - $t_border;
273 my $placey = $w->rooty - $t->rooty - $t_border;
274 $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
275 my $this = $w->containing($new_rootx, $w->rooty + 1);
276 $l->raise($this) if $this && $this ne $t;
277 }
278
279 sub delta_width
280 {
281 my ($w,$dx) = @_;
282 my $l = $w->{'lin'};
283 $l->placeForget;
284 my $s = $w->slave;
285 if ($s)
286 {
287 my $m = $w->{'master'};
288 my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
289 my $w_width = $w->{'reqwidth'};
290 my $m_width = $m->width;
291 my $s_width = $s->width;
292 my $max_width = $m_width - $w_width;
293 my $max_s_width;
294 if ($w->cget('-side') eq 'right')
295 {
296 $dx = -$dx;
297 $max_s_width = $max_width -
298 ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
299 }
300 else
301 {
302 $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
303 }
304 my $new_width = $s_width+$dx;
305 $new_width = $max_s_width if $new_width > $max_s_width;
306 $new_width = 0 if $new_width < 0;
307 $s->GeometryRequest($new_width, $s->height);
308 }
309 }
310
311 sub delta_height_bar
312 {
313 my ($w,$dy) = @_;
314 my $l = $w->{'lin'};
315 my $r = $w->{'sep'};
316 my $t = $w->toplevel;
317 my $m = $w->{'master'};
318 my $s = $w->slave;
319 my ($min_rooty, $max_rooty, $t_border);
320 if (! $w->{'lin_info'})
321 {
322 my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
323 $t_border = $t->cget('-bd') + $t->cget('-highlightthickness');
324 if ($w->cget('-side') eq 'bottom')
325 {
326 $min_rooty = $m->rooty + $m_border;
327 $max_rooty = $s->rooty + $s->height - 1;
328 }
329 else
330 {
331 $min_rooty = $s->rooty;
332 $max_rooty = $m->rooty + $m->height - $m_border - 1;
333 }
334 $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
335 }
336 else
337 {
338 ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
339 }
340 $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
341
342 my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
343 $new_rooty = $min_rooty if $new_rooty < $min_rooty;
344 $new_rooty = $max_rooty if $new_rooty > $max_rooty;
345 my $placey = $new_rooty - $t->rooty - $t_border;
346 my $placex = $w->rootx - $t->rootx - $t_border;
347 $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
348 my $this = $w->containing($w->rootx + 1, $new_rooty);
349 $l->raise($this) if $this && $this ne $t;
350 }
351
352 sub delta_height
353 {
354 my ($w,$dy) = @_;
355 my $l = $w->{'lin'};
356 $l->placeForget;
357 my $s = $w->slave;
358 if ($s)
359 {
360 my $m = $w->{'master'};
361 my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
362 my $w_height = $w->{'reqheight'};
363 my $m_height = $m->height;
364 my $s_height = $s->height;
365 my $max_height = $m_height - $w_height;
366 my $max_s_height;
367 if ($w->cget('-side') eq 'bottom')
368 {
369 $dy = -$dy;
370 $max_s_height = $max_height -
371 ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
372 }
373 else
374 {
375 $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
376 }
377 my $new_height = $s_height+$dy;
378
379 $new_height = $max_s_height if $new_height > $max_s_height;
380 $new_height = 0 if $new_height < 0;
381 $s->GeometryRequest($s->width, $new_height);
382 }
383 }
384
385 # Turn off expansion in the slave.
386 # This is done only if necessary, as calls to pack/gridConfigure cause
387 # repacking.
388 # Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
389 # current width/height. This is because the geometry managers use
390 # the requested values, not the actual, to calculate the new geometry.
391 sub slave_expand_off
392 {
393 my $w = shift;
394 my $s = $w->slave;
395 return if ! $s;
396
397 my $manager = $s->manager;
398 if ($manager eq 'pack')
399 {
400 my %info = $s->packInfo;
401 my $expand = $info{'-expand'};
402 if ($expand)
403 {
404 $s->GeometryRequest($s->width, $s->height);
405 $s->packConfigure(-expand => 0);
406 }
407 }
408 elsif ($manager eq 'grid')
409 {
410 my %info = $s->gridInfo;
411 my $master = $info{'-in'};
412 if ($w->vert)
413 {
414 my $col = $info{'-column'};
415 my $expand = $master->gridColumnconfigure($col, '-weight');
416 if ($expand)
417 {
418 $s->GeometryRequest($s->width, $s->height);
419 $master->gridColumnconfigure($col, -weight => 0);
420 }
421 }
422 else
423 {
424 my $row = $info{'-row'};
425 my $expand = $master->gridRowconfigure($row, '-weight');
426 if ($expand)
427 {
428 $s->GeometryRequest($s->width, $s->height);
429 $master->gridRowconfigure($row, -weight => 0);
430 }
431 }
432 }
433 }
434
435 1;
436
437 __END__
438