Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::NoteBook; |
2 | # | |
3 | # Implementation of NoteBook widget. | |
4 | # Derived from NoteBook.tcl in Tix 4.0 | |
5 | ||
6 | # Contributed by Rajappa Iyer <rsi@earthling.net> | |
7 | # Hacked by Nick for 'menu' traversal. | |
8 | # Restructured by Nick | |
9 | ||
10 | use vars qw($VERSION); | |
11 | ||
12 | $VERSION = '3.024'; # $Id: //depot/Tk8/Tixish/NoteBook.pm#24 $ | |
13 | require Tk::NBFrame; | |
14 | ||
15 | use base qw(Tk::Derived Tk::NBFrame); | |
16 | Tk::Widget->Construct('NoteBook'); | |
17 | use strict; | |
18 | ||
19 | use Tk qw(Ev); | |
20 | ||
21 | use Carp; | |
22 | require Tk::Frame; | |
23 | ||
24 | sub TraverseToNoteBook; | |
25 | ||
26 | sub ClassInit | |
27 | { | |
28 | my ($class,$mw) = @_; | |
29 | # class binding does not work right due to extra level of | |
30 | # widget hierachy | |
31 | $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]); | |
32 | $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]); | |
33 | ||
34 | $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]); | |
35 | $mw->bind($class,'<Left>', ['FocusNext','prev']); | |
36 | $mw->bind($class,'<Right>', ['FocusNext','next']); | |
37 | ||
38 | $mw->bind($class,'<Return>', 'SetFocusByKey'); | |
39 | $mw->bind($class,'<space>', 'SetFocusByKey'); | |
40 | return $class; | |
41 | } | |
42 | ||
43 | sub raised | |
44 | { | |
45 | return shift->{'topchild'}; | |
46 | } | |
47 | ||
48 | sub Populate | |
49 | { | |
50 | my ($w, $args) = @_; | |
51 | ||
52 | $w->SUPER::Populate($args); | |
53 | $w->{'pad-x1'} = 0; | |
54 | $w->{'pad-x2'} = 0; | |
55 | $w->{'pad-y1'} = 0; | |
56 | $w->{'pad-y2'} = 0; | |
57 | ||
58 | $w->{'nWindows'} = 0; | |
59 | $w->{'minH'} = 1; | |
60 | $w->{'minW'} = 1; | |
61 | ||
62 | $w->{'counter'} = 0; | |
63 | $w->{'resize'} = 0; | |
64 | ||
65 | $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0], | |
66 | -ipady => ['PASSIVE', 'ipadY', 'Pad', 0], | |
67 | -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0], | |
68 | -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]); | |
69 | ||
70 | # SetBindings | |
71 | $w->bind('<Configure>','MasterGeomProc'); | |
72 | ||
73 | $args->{-slave} = 1; | |
74 | $args->{-takefocus} = 1; | |
75 | $args->{-relief} = 'raised'; | |
76 | ||
77 | $w->QueueResize; | |
78 | } | |
79 | ||
80 | ||
81 | #--------------------------- | |
82 | # Public methods | |
83 | #--------------------------- | |
84 | ||
85 | sub page_widget | |
86 | { | |
87 | my $w = shift; | |
88 | $w->{'_pages_'} = {} unless exists $w->{'_pages_'}; | |
89 | my $h = $w->{'_pages_'}; | |
90 | if (@_) | |
91 | { | |
92 | my $name = shift; | |
93 | if (@_) | |
94 | { | |
95 | my $cw = shift; | |
96 | if (defined $cw) | |
97 | { | |
98 | $h->{$name} = $cw; | |
99 | } | |
100 | else | |
101 | { | |
102 | return delete $h->{$name}; | |
103 | } | |
104 | } | |
105 | return $h->{$name}; | |
106 | } | |
107 | else | |
108 | { | |
109 | return (values %$h); | |
110 | } | |
111 | } | |
112 | ||
113 | sub add | |
114 | { | |
115 | my ($w, $child, %args) = @_; | |
116 | ||
117 | croak("$child already exists") if defined $w->page_widget($child); | |
118 | ||
119 | my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised'); | |
120 | ||
121 | my $ccmd = delete $args{-createcmd}; | |
122 | my $rcmd = delete $args{-raisecmd}; | |
123 | $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd); | |
124 | $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd); | |
125 | ||
126 | # manage our geometry | |
127 | $w->ManageGeometry($f); | |
128 | # create default bindings | |
129 | $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]); | |
130 | $f->bind('<Destroy>', [$w,'delete',$child,1]); | |
131 | $w->page_widget($child,$f); | |
132 | $w->{'nWindows'}++; | |
133 | push(@{$w->{'windows'}}, $child); | |
134 | $w->SUPER::add($child,%args); | |
135 | return $f; | |
136 | } | |
137 | ||
138 | sub raise | |
139 | { | |
140 | my ($w, $child) = @_; | |
141 | return unless defined $child; | |
142 | if ($w->pagecget($child, -state) eq 'normal') | |
143 | { | |
144 | $w->activate($child); | |
145 | $w->focus($child); | |
146 | my $childw = $w->page_widget($child); | |
147 | if ($childw) | |
148 | { | |
149 | if (defined $childw->{-createcmd}) | |
150 | { | |
151 | $childw->{-createcmd}->Call($childw); | |
152 | delete $childw->{-createcmd}; | |
153 | } | |
154 | # hide the original visible window | |
155 | my $oldtop = $w->{'topchild'}; | |
156 | if (defined($oldtop) && ($oldtop ne $child)) | |
157 | { | |
158 | $w->page_widget($oldtop)->UnmapWindow; | |
159 | } | |
160 | $w->{'topchild'} = $child; | |
161 | my $myW = $w->Width; | |
162 | my $myH = $w->Height; | |
163 | ||
164 | my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0); | |
165 | my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0); | |
166 | my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0); | |
167 | my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0); | |
168 | ||
169 | if ($cW > 0 && $cH > 0) | |
170 | { | |
171 | $childw->MoveResizeWindow($cX, $cY, $cW, $cH); | |
172 | $childw->MapWindow; | |
173 | $childw->raise; | |
174 | } | |
175 | if ((not defined $oldtop) || ($oldtop ne $child)) | |
176 | { | |
177 | if (defined $childw->{-raisecmd}) | |
178 | { | |
179 | $childw->{-raisecmd}->Call($childw); | |
180 | } | |
181 | } | |
182 | } | |
183 | } | |
184 | } | |
185 | ||
186 | sub pageconfigure | |
187 | { | |
188 | my ($w, $child, %args) = @_; | |
189 | my $childw = $w->page_widget($child); | |
190 | if (defined $childw) | |
191 | { | |
192 | my $ccmd = delete $args{-createcmd}; | |
193 | my $rcmd = delete $args{-raisecmd}; | |
194 | $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd); | |
195 | $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd); | |
196 | $w->SUPER::pageconfigure($child, %args) if (keys %args); | |
197 | } | |
198 | } | |
199 | ||
200 | sub pages { | |
201 | my ($w) = @_; | |
202 | return @{$w->{'windows'}}; | |
203 | } | |
204 | ||
205 | sub pagecget | |
206 | { | |
207 | my ($w, $child, $opt) = @_; | |
208 | my $childw = $w->page_widget($child); | |
209 | if (defined $childw) | |
210 | { | |
211 | return $childw->{-createcmd} if ($opt =~ /-createcmd/); | |
212 | return $childw->{-raisecmd} if ($opt =~ /-raisecmd/); | |
213 | return $w->SUPER::pagecget($child, $opt); | |
214 | } | |
215 | else | |
216 | { | |
217 | carp "page $child does not exist"; | |
218 | } | |
219 | } | |
220 | ||
221 | sub delete | |
222 | { | |
223 | my ($w, $child, $destroy) = @_; | |
224 | my $childw = $w->page_widget($child,undef); | |
225 | if (defined $childw) | |
226 | { | |
227 | $childw->bind('<Destroy>', undef); | |
228 | $childw->destroy; | |
229 | @{$w->{'windows'}} = grep($_ !~ /$child/, @{$w->{'windows'}}); | |
230 | $w->{'nWindows'}--; | |
231 | $w->SUPER::delete($child); | |
232 | # see if the child to be deleted was the top child | |
233 | if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child)) | |
234 | { | |
235 | delete $w->{'topchild'}; | |
236 | if ( @{$w->{'windows'}}) | |
237 | { | |
238 | $w->raise($w->{'windows'}[0]); | |
239 | } | |
240 | } | |
241 | } | |
242 | else | |
243 | { | |
244 | carp "page $child does not exist" unless $destroy; | |
245 | } | |
246 | } | |
247 | ||
248 | #--------------------------------------- | |
249 | # Private methods | |
250 | #--------------------------------------- | |
251 | ||
252 | sub MouseDown { | |
253 | my ($w, $x, $y) = @_; | |
254 | my $name = $w->identify($x, $y); | |
255 | $w->focus($name); | |
256 | $w->{'down'} = $name; | |
257 | } | |
258 | ||
259 | sub MouseUp { | |
260 | my ($w, $x, $y) = @_; | |
261 | my $name = $w->identify($x, $y); | |
262 | if ((defined $name) && | |
263 | ($name eq $w->{'down'}) && | |
264 | ($w->pagecget($name, -state) eq 'normal')) { | |
265 | $w->raise($name); | |
266 | } else { | |
267 | $w->focus($name); | |
268 | } | |
269 | } | |
270 | ||
271 | sub FocusNext { | |
272 | my ($w, $dir) = @_; | |
273 | my $name; | |
274 | ||
275 | if (not defined $w->info('focus')) { | |
276 | $name = $w->info('active'); | |
277 | $w->focus($name); | |
278 | } else { | |
279 | $name = $w->info('focus' . $dir); | |
280 | $w->focus($name); | |
281 | } | |
282 | } | |
283 | ||
284 | sub SetFocusByKey { | |
285 | my ($w) = @_; | |
286 | ||
287 | my $name = $w->info('focus'); | |
288 | if (defined $name) { | |
289 | if ($w->pagecget($name, -state) eq 'normal') { | |
290 | $w->raise($name); | |
291 | $w->activate($name); | |
292 | } | |
293 | } | |
294 | } | |
295 | ||
296 | sub NoteBookFind { | |
297 | my ($w, $char) = @_; | |
298 | ||
299 | my $page; | |
300 | foreach $page (@{$w->{'windows'}}) { | |
301 | my $i = $w->pagecget($page, -underline); | |
302 | my $c = substr($page, $i, 1); | |
303 | if ($char =~ /$c/) { | |
304 | if ($w->pagecget($page, -state) ne 'disabled') { | |
305 | return $page; | |
306 | } | |
307 | } | |
308 | } | |
309 | return undef; | |
310 | } | |
311 | ||
312 | # This is called by TraveseToMenu when an <Alt-Keypress> occurs | |
313 | # See the code in Tk.pm | |
314 | sub FindMenu { | |
315 | my ($w, $char) = @_; | |
316 | ||
317 | my $page; | |
318 | foreach $page (@{$w->{'windows'}}) { | |
319 | my $i = $w->pagecget($page, -underline); | |
320 | my $l = $w->pagecget($page, -label); | |
321 | next if (not defined $l); | |
322 | my $c = substr($l, $i, 1); | |
323 | if ($char =~ /$c/i) { | |
324 | if ($w->pagecget($page, -state) ne 'disabled') { | |
325 | $w->raise($page); | |
326 | return $w; | |
327 | } | |
328 | } | |
329 | } | |
330 | return undef; | |
331 | } | |
332 | ||
333 | ||
334 | sub MasterGeomProc | |
335 | { | |
336 | my ($w) = @_; | |
337 | if (Tk::Exists($w)) | |
338 | { | |
339 | $w->{'resize'} = 0 unless (defined $w->{'resize'}); | |
340 | $w->QueueResize; | |
341 | } | |
342 | } | |
343 | ||
344 | sub SlaveGeometryRequest | |
345 | { | |
346 | my $w = shift; | |
347 | if (Tk::Exists($w)) | |
348 | { | |
349 | $w->QueueResize; | |
350 | } | |
351 | } | |
352 | ||
353 | sub LostSlave { | |
354 | my ($w, $s) = @_; | |
355 | print "Loosing $s\n"; | |
356 | $s->UnmapWindow; | |
357 | } | |
358 | ||
359 | sub ClientGeomProc | |
360 | { | |
361 | my ($w, $flag, $client) = @_; | |
362 | $w->QueueResize if (Tk::Exists($w)); | |
363 | if ($flag =~ /-lostslave/) | |
364 | { | |
365 | carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w"; | |
366 | } | |
367 | } | |
368 | ||
369 | sub QueueResize | |
370 | { | |
371 | my $w = shift; | |
372 | $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++); | |
373 | } | |
374 | ||
375 | sub Resize { | |
376 | ||
377 | my ($w) = @_; | |
378 | ||
379 | return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'}; | |
380 | ||
381 | my ($tW, $tH) = $w->geometryinfo; | |
382 | $w->{'pad-x1'} = 2; | |
383 | $w->{'pad-x2'} = 2; | |
384 | $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1; | |
385 | $w->{'pad-y2'} = 2; | |
386 | $w->{'minW'} = $tW; | |
387 | $w->{'minH'} = $tH; | |
388 | ||
389 | $w->{'resize'} = 0; | |
390 | my $reqW = $w->{-width} || 0; | |
391 | my $reqH = $w->{-height} || 0; | |
392 | ||
393 | if ($reqW * $reqH == 0) | |
394 | { | |
395 | if ((not defined $w->{-dynamicgeometry}) || | |
396 | ($w->{-dynamicgeometry} == 0)) { | |
397 | $reqW = 1; | |
398 | $reqH = 1; | |
399 | ||
400 | my $childw; | |
401 | foreach $childw ($w->page_widget) | |
402 | { | |
403 | my $cW = $childw->ReqWidth; | |
404 | my $cH = $childw->ReqHeight; | |
405 | $reqW = $cW if ($reqW < $cW); | |
406 | $reqH = $cH if ($reqH < $cH); | |
407 | } | |
408 | } else { | |
409 | if (defined $w->{'topchild'}) { | |
410 | my $topw = $w->page_widget($w->{'topchild'}); | |
411 | $reqW = $topw->ReqWidth; | |
412 | $reqH = $topw->ReqHeight; | |
413 | } else { | |
414 | $reqW = 1; | |
415 | $reqH = 1; | |
416 | } | |
417 | } | |
418 | $reqW += $w->{'pad-x1'} + $w->{'pad-x2'} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0); | |
419 | $reqH += $w->{'pad-y1'} + $w->{'pad-y2'} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0); | |
420 | $reqW = ($reqW > $w->{'minW'}) ? $reqW : $w->{'minW'}; | |
421 | $reqH = ($reqH > $w->{'minH'}) ? $reqH : $w->{'minH'}; | |
422 | } | |
423 | if (($w->ReqWidth != $reqW) || | |
424 | ($w->ReqHeight != $reqH)) { | |
425 | $w->{'counter'} = 0 if (not defined $w->{'counter'}); | |
426 | if ($w->{'counter'} < 50) { | |
427 | $w->{'counter'}++; | |
428 | $w->GeometryRequest($reqW, $reqH); | |
429 | $w->afterIdle([$w,'Resize']); | |
430 | $w->{'resize'} = 1; | |
431 | return; | |
432 | } | |
433 | } | |
434 | $w->{'counter'} = 0; | |
435 | $w->raise($w->{'topchild'} || ${$w->{'windows'}}[0]); | |
436 | $w->{'resize'} = 0; | |
437 | } | |
438 | ||
439 | 1; | |
440 | ||
441 | __END__ | |
442 | ||
443 | =cut |