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