1package 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
10use vars qw($VERSION);
11
12#$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
13$VERSION = '4.012';
14require Tk::NBFrame;
15
16use base  qw(Tk::Derived Tk::NBFrame);
17Tk::Widget->Construct('NoteBook');
18use strict;
19
20use Tk qw(Ev);
21
22use Carp;
23require Tk::Frame;
24
25sub TraverseToNoteBook;
26
27sub ClassInit
28{
29 my ($class,$mw) = @_;
30 # class binding does not work right due to extra level of
31 # widget hierachy
32 $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]);
33 $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]);
34
35 $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]);
36 $mw->bind($class,'<Left>', ['FocusNext','prev']);
37 $mw->bind($class,'<Right>', ['FocusNext','next']);
38
39 $mw->bind($class,'<Return>', 'SetFocusByKey');
40 $mw->bind($class,'<space>', 'SetFocusByKey');
41 return $class;
42}
43
44sub raised
45{
46 return shift->{'topchild'};
47}
48
49sub Populate
50{
51 my ($w, $args) = @_;
52
53 $w->SUPER::Populate($args);
54 $w->{'pad-x1'} = undef;
55 $w->{'pad-x2'} = undef;
56 $w->{'pad-y1'} = undef;
57 $w->{'pad-y2'} = undef;
58
59 $w->{'windows'} = [];
60 $w->{'nWindows'} = 0;
61 $w->{'minH'} = 1;
62 $w->{'minW'} = 1;
63
64 $w->{'counter'} = 0;
65 $w->{'resize'} = 0;
66
67 $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0],
68		 -ipady => ['PASSIVE', 'ipadY', 'Pad', 0],
69		 -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0],
70		 -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]);
71
72 # SetBindings
73 $w->bind('<Configure>','MasterGeomProc');
74
75 $args->{-slave} = 1;
76 $args->{-takefocus} = 1;
77 $args->{-relief} = 'raised';
78
79 $w->QueueResize;
80}
81
82
83#---------------------------
84# Public methods
85#---------------------------
86
87sub page_widget
88{
89 my $w = shift;
90 $w->{'_pages_'} = {} unless exists $w->{'_pages_'};
91 my $h = $w->{'_pages_'};
92 if (@_)
93  {
94   my $name = shift;
95   if (@_)
96    {
97     my $cw = shift;
98     if (defined $cw)
99      {
100       $h->{$name} = $cw;
101      }
102     else
103      {
104       return delete $h->{$name};
105      }
106    }
107   return $h->{$name};
108  }
109 else
110  {
111   return (values %$h);
112  }
113}
114
115sub add
116{
117 my ($w, $child, %args) = @_;
118
119 croak("$child already exists") if defined $w->page_widget($child);
120
121 my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised');
122
123 my $ccmd = delete $args{-createcmd};
124 my $rcmd = delete $args{-raisecmd};
125 $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
126 $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
127
128 # manage our geometry
129 $w->ManageGeometry($f);
130 # create default bindings
131 $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]);
132 $f->bind('<Destroy>',  [$w,'delete',$child,1]);
133 $w->page_widget($child,$f);
134 $w->{'nWindows'}++;
135 push(@{$w->{'windows'}}, $child);
136 $w->SUPER::add($child,%args);
137 return $f;
138}
139
140sub raise
141{
142 my ($w, $child) = @_;
143 return unless defined $child;
144 if ($w->pagecget($child, -state) eq 'normal')
145  {
146   $w->activate($child);
147   $w->focus($child);
148   my $childw = $w->page_widget($child);
149   if ($childw)
150    {
151     if (defined $childw->{-createcmd})
152      {
153       $childw->{-createcmd}->Call($childw);
154       delete $childw->{-createcmd};
155      }
156     # hide the original visible window
157     my $oldtop = $w->{'topchild'};
158     if (defined($oldtop) && ($oldtop ne $child))
159      {
160       $w->page_widget($oldtop)->UnmapWindow;
161      }
162     $w->{'topchild'} = $child;
163     my $myW = $w->Width;
164     my $myH = $w->Height;
165
166     if (!defined $w->{'pad-x1'}) {
167	 $w->InitTabSize;
168     }
169
170     my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
171     my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
172     my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
173     my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
174
175     if ($cW > 0 && $cH > 0)
176      {
177       $childw->MoveResizeWindow($cX, $cY, $cW, $cH);
178       $childw->MapWindow;
179       $childw->raise;
180      }
181     if ((not defined $oldtop) || ($oldtop ne $child))
182      {
183       if (defined $childw->{-raisecmd})
184	{
185	 $childw->{-raisecmd}->Call($childw);
186	}
187      }
188    }
189  }
190}
191
192sub pageconfigure
193{
194 my ($w, $child, %args) = @_;
195 my $childw = $w->page_widget($child);
196 if (defined $childw)
197  {
198   my $ccmd = delete $args{-createcmd};
199   my $rcmd = delete $args{-raisecmd};
200   $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
201   $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
202   $w->SUPER::pageconfigure($child, %args) if (keys %args);
203  }
204}
205
206sub pages {
207    my ($w) = @_;
208    return @{$w->{'windows'}};
209}
210
211sub pagecget
212{
213 my ($w, $child, $opt) = @_;
214 my $childw = $w->page_widget($child);
215 if (defined $childw)
216  {
217   return $childw->{-createcmd} if ($opt =~ /-createcmd/);
218   return $childw->{-raisecmd} if ($opt =~ /-raisecmd/);
219   return $w->SUPER::pagecget($child, $opt);
220  }
221 else
222  {
223   carp "page $child does not exist";
224  }
225}
226
227sub delete
228{
229 my ($w, $child, $destroy) = @_;
230 my $childw = $w->page_widget($child,undef);
231 if (defined $childw)
232  {
233   $childw->bind('<Destroy>', undef);
234   $childw->destroy;
235   @{$w->{'windows'}} = grep($_ ne $child, @{$w->{'windows'}});
236   $w->{'nWindows'}--;
237   $w->SUPER::delete($child);
238   # see if the child to be deleted was the top child
239   if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child))
240    {
241     delete $w->{'topchild'};
242     if ( @{$w->{'windows'}})
243      {
244       $w->raise($w->{'windows'}[0]);
245      }
246    }
247  }
248 else
249  {
250   carp "page $child does not exist" unless $destroy;
251  }
252}
253
254#---------------------------------------
255# Private methods
256#---------------------------------------
257
258sub MouseDown {
259    my ($w, $x, $y) = @_;
260    my $name = $w->identify($x, $y);
261    $w->focus($name);
262    $w->{'down'} = $name;
263}
264
265sub MouseUp {
266    my ($w, $x, $y) = @_;
267    my $name = $w->identify($x, $y);
268    if ((defined $name) && (defined $w->{'down'}) &&
269	($name eq $w->{'down'}) &&
270	($w->pagecget($name, -state) eq 'normal')) {
271	$w->raise($name);
272    } else {
273	$w->focus($name);
274    }
275}
276
277sub FocusNext {
278    my ($w, $dir) = @_;
279    my $name;
280
281    if (not defined $w->info('focus')) {
282	$name = $w->info('active');
283	$w->focus($name);
284    } else {
285	$name = $w->info('focus' . $dir);
286	$w->focus($name);
287    }
288}
289
290sub SetFocusByKey {
291    my ($w) = @_;
292
293    my $name = $w->info('focus');
294    if (defined $name) {
295	if ($w->pagecget($name, -state) eq 'normal') {
296	    $w->raise($name);
297	    $w->activate($name);
298	}
299    }
300}
301
302sub NoteBookFind {
303    my ($w, $char) = @_;
304
305    my $page;
306    foreach $page (@{$w->{'windows'}}) {
307	my $i = $w->pagecget($page, -underline);
308	my $c = substr($page, $i, 1);
309	if ($char =~ /$c/) {
310	    if ($w->pagecget($page, -state) ne 'disabled') {
311		return $page;
312	    }
313	}
314    }
315    return undef;
316}
317
318# This is called by TraveseToMenu when an <Alt-Keypress> occurs
319# See the code in Tk.pm
320sub FindMenu {
321    my ($w, $char) = @_;
322
323    my $page;
324    foreach $page (@{$w->{'windows'}}) {
325	my $i = $w->pagecget($page, -underline);
326	next if $i < 0;
327	my $l = $w->pagecget($page, -label);
328	next if (not defined $l);
329	my $c = substr($l, $i, 1);
330	if ($char =~ /\Q$c/i) {
331	    if ($w->pagecget($page, -state) ne 'disabled') {
332		$w->raise($page);
333		return $w;
334	    }
335	}
336    }
337    return undef;
338}
339
340
341sub MasterGeomProc
342{
343 my ($w) = @_;
344 if (Tk::Exists($w))
345  {
346   $w->{'resize'} = 0 unless (defined $w->{'resize'});
347   $w->QueueResize;
348  }
349}
350
351sub SlaveGeometryRequest
352{
353 my $w = shift;
354 if (Tk::Exists($w))
355  {
356   $w->QueueResize;
357  }
358}
359
360sub LostSlave {
361    my ($w, $s) = @_;
362    $s->UnmapWindow;
363}
364
365sub ClientGeomProc
366{
367 my ($w, $flag, $client) = @_;
368 $w->QueueResize if (Tk::Exists($w));
369 if ($flag =~ /-lostslave/)
370  {
371   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";
372  }
373}
374
375sub QueueResize
376{
377 my $w = shift;
378 $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++);
379}
380
381sub Resize {
382
383    my ($w) = @_;
384
385    return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'};
386
387    $w->InitTabSize;
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->cget('-dynamicgeometry')) ||
396	    ($w->cget('-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
439sub InitTabSize {
440    my ($w) = @_;
441    my ($tW, $tH) = $w->geometryinfo;
442    $w->{'pad-x1'} = 2;
443    $w->{'pad-x2'} = 2;
444    $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1;
445    $w->{'pad-y2'} = 2;
446    $w->{'minW'} = $tW;
447    $w->{'minH'} = $tH;
448}
449
450sub BalloonInfo
451{
452 my ($notebook,$balloon,$X,$Y,@opt) = @_;
453 my $page = $notebook->identify($X-$notebook->rootx,$Y-$notebook->rooty);
454 foreach my $opt (@opt)
455  {
456   my $info = $balloon->GetOption($opt,$notebook);
457   if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
458    {
459     if (!defined $page)
460      {
461       $balloon->Deactivate;
462       return;
463      }
464     $balloon->Subclient($page);
465     if (exists $info->{$page})
466      {
467       return $info->{$page}
468      }
469     else
470      {
471       return '';
472      }
473    }
474   return $info;
475  }
476}
477
4781;
479
480__END__
481
482