1## 2## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org, CADIX International 3## 4package require Widget 2.0 5package provide Tabnotebook 2.0 6 7## FIX: 8## option state of subitems could be kept in a clearer array 9 10##------------------------------------------------------------------------ 11## PROCEDURE 12## tabnotebook 13## 14## DESCRIPTION 15## Implements a Tabbed Notebook megawidget 16## 17## ARGUMENTS 18## tabnote <window pathname> <options> 19## 20## OPTIONS 21## (Any entry widget option may be used in addition to these) 22## 23## -activebackground color DEFAULT: {} 24## The background color given to the active tab. A value of {} 25## means these items will pick up the widget's background color. 26## 27## -background color DEFAULT: DEFAULT 28## The background color for the container subwidgets. 29## 30## -browsecmd script DEFAULT: {} 31## A script that is evaluated each time a tab changes. It appends 32## the old tab and the new tab to the script. An empty string ({}) 33## represents the blank (empty) tab. This is eval'ed before the 34## tab actually changes, allowing tab transitions to be aborted by 35## returning an error value in this script. 36## 37## -disabledbackground color DEFAULT: #c0c0c0 (dark gray) 38## The background color given to disabled tabs. 39## 40## -font DEFAULT: {Helvetica -12} 41## The font for the tab text. All tabs use the same font. 42## 43## -justify justification DEFAULT: center 44## The justification applied to the text in multi-line tabs. 45## Must be one of: left, right, center. 46## 47## -linewidth pixels DEFAULT: 2 48## The width of the line surrounding the tabs. Must be at least 1. 49## 50## -linecolor color DEFAULT: black 51## The color of the line surrounding the tabs. 52## 53## -normalbackground DEFAULT: {} 54## The background color of items with normal state. A value of {} 55## means these items will pick up the widget's background color. 56## 57## -padx pixels DEFAULT: 6 58## The X padding for folder tabs around the items. 59## 60## -pady pixels DEFAULT: 4 61## The Y padding for folder tabs around the items. 62## 63## RETURNS: the window pathname 64## 65## BINDINGS (in addition to default widget bindings) 66## 67## <1> in a tabs activates that tab. 68## 69## METHODS 70## These are the methods that the Tabnote widget recognizes. Aside from 71## these, it accepts methods that are valid for entry widgets. 72## 73## activate id 74## Activates the tab specified by id. id may either by the unique id 75## returned by the add command or the string used in the add command. 76## 77## add string ?options? 78## Adds a tab to the tab notebook with the specified string, unless 79## the string is the name of an image, in which case the image is used. 80## Each string must be unique. See ITEM OPTIONS for the options. 81## A unique tab id is returned. 82## 83## delete id 84## Deletes the tab specified by id. id may either by the unique id 85## returned by the add command or the string used in the add command. 86## 87## itemconfigure ?option? ?value option value ...? 88## itemcget option 89## Configure or retrieve the option of a tab notebook item. 90## 91## name tabId 92## Returns the text name for a given tabId. 93## 94## subwidget widget 95## Returns the true widget path of the specified widget. Valid 96## widgets are hold (a frame), tabs (a canvas), blank (a frame). 97## 98## ITEM OPTIONS 99## These are options for the items (tabs) of the notebook 100## 101## -window widget DEFAULT: {} 102## Specifies the widget to show when the tab is pressed. It must be 103## a child of the tab notebook (required for grid management) and exist 104## prior to this command. 105## 106## -state normal|disabled|active DEFAULT: normal 107## The optional state can be normal, active or disabled. 108## If active, then this tab becomes the active (displayed) tab. 109## 110## NAMESPACE & STATE 111## The megawidget creates a global array with the classname, and a 112## global array which is the name of each megawidget is created. The latter 113## array is deleted when the megawidget is destroyed. 114## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. 115## Other procs that begin with $CLASSNAME are private. For each widget, 116## commands named .$widgetname and $CLASSNAME$widgetname are created. 117## 118## EXAMPLE USAGE: 119## 120## pack [tabnotebook .t] -fill both -expand 1 121## text .t.t -height 10 -width 20 122## .t add "Text Widget" -window .t.t 123##------------------------------------------------------------------------ 124 125# Create this to make sure there are registered in auto_mkindex 126# these must come before the [widget create ...] 127proc Tabnotebook args {} 128proc tabnotebook args {} 129 130widget create Tabnotebook -type frame -base frame -components { 131 {frame hold hold {-relief raised -bd 1}} 132 {frame blank} 133 {frame hide hide {-background $data(-background) -height 1 -width 40}} 134 {canvas tabs tabs {-bg $data(-background) -highlightthick 0 -takefocus 0}} 135} -options { 136 {-activebackground activeBackground ActiveBackground {}} 137 {-bg -background} 138 {-background ALIAS frame -background} 139 {-bd -borderwidth} 140 {-borderwidth ALIAS frame -borderwidth} 141 {-browsecmd browseCmd BrowseCommand {}} 142 {-disabledbackground disabledBackground DisabledBackground #a3a3a3} 143 {-normalbackground normalBackground normalBackground #c3c3c3} 144 {-font font Font {Helvetica -12}} 145 {-justify justify Justify center} 146 {-minwidth minWidth Width -1} 147 {-minheight minHeight Height -1} 148 {-padx padX PadX 6} 149 {-pady padY PadY 4} 150 {-relief ALIAS frame -relief} 151 {-linewidth lineWidth LineWidth 1} 152 {-linecolor lineColor LineColor black} 153} 154 155namespace eval ::Widget::Tabnotebook {; 156 157;proc construct {w} { 158 upvar \#0 [namespace current]::$w data 159 160 ## Private variables 161 array set data { 162 curtab {} 163 numtabs 0 164 width 0 165 height 0 166 ids {} 167 } 168 169 $data(tabs) itemconfigure TEXT -font $data(-font) 170 171 $data(tabs) yview moveto 0 172 $data(tabs) xview moveto 0 173 174 grid $data(tabs) -sticky ew 175 grid $data(hold) -sticky news 176 grid $data(blank) -in $data(hold) -row 0 -column 0 -sticky nsew 177 grid columnconfig $w 0 -weight 1 178 grid rowconfigure $w 1 -weight 1 179 grid columnconfig $data(hold) 0 -weight 1 180 grid rowconfigure $data(hold) 0 -weight 1 181 182 bind $data(tabs) <Configure> [namespace code \ 183 "if {!\[string compare $data(tabs) %W\]} { resize [list $w] %w }"] 184 bind $data(tabs) <2> { %W scan mark %x 0 } 185 bind $data(tabs) <B2-Motion> [namespace code { 186 %W scan dragto %x 0 187 resize [winfo parent %W] [winfo width %W] 188 } 189 ] 190} 191 192;proc configure {w args} { 193 upvar \#0 [namespace current]::$w data 194 195 set truth {^(1|yes|true|on)$} 196 set post {} 197 foreach {key val} $args { 198 switch -- $key { 199 -activebackground { 200 if {[string compare $data(curtab) {}]} { 201 $data(tabs) itemconfig POLY:$data(curtab) -fill $val 202 } 203 if {[string compare $val {}]} { 204 $data(hide) config -bg $val 205 } else { 206 lappend post \ 207 [list $data(hide) config -bg $data(-background)] 208 } 209 } 210 -background { 211 $data(tabs) config -bg $val 212 $data(hold) config -bg $val 213 $data(blank) config -bg $val 214 } 215 -borderwidth { 216 $data(hold) config -bd $val 217 $data(hide) config -height $val 218 } 219 -disabledbackground { 220 foreach i $data(ids) { 221 if {[string match disabled $data(:$i:-state)]} { 222 $data(tabs) itemconfig POLY:$i -fill $val 223 } 224 } 225 } 226 -font { 227 $data(tabs) itemconfigure TEXT -font $val 228 recalculate $w 229 } 230 -justify { $data(tabs) itemconfigure TEXT -justify $val } 231 -linewidth { $data(tabs) itemconfigure LINE -width $val } 232 -linecolor { $data(tabs) itemconfigure LINE -fill $val } 233 -minwidth { 234 if {$val < 0} { set val 0 } 235 grid columnconfig $w 0 -minsize $val 236 } 237 -minheight { 238 if {$val < 0} { set val 0 } 239 grid rowconfigure $w 1 -minsize $val 240 } 241 -normalbackground { 242 foreach i $data(ids) { 243 if {[string match normal $data(:$i:-state)]} { 244 $data(tabs) itemconfig POLY:$i -fill $val 245 } 246 } 247 } 248 -padx - -pady { 249 if {$val < 1} { set val 1 } 250 } 251 -relief { 252 $data(hold) config -relief $val 253 } 254 } 255 set data($key) $val 256 } 257 if {[string compare $post {}]} { 258 eval [join $post \n] 259 } 260} 261 262;proc _add { w text args } { 263 upvar \#0 [namespace current]::$w data 264 265 set c $data(tabs) 266 if {[string match {} $text]} { 267 return -code error "non-empty text required for noteboook label" 268 } elseif {[string compare {} [$c find withtag ID:$text]]} { 269 return -code error "tab \"$text\" already exists" 270 } 271 array set s { 272 -window {} 273 -state normal 274 } 275 foreach {key val} $args { 276 switch -glob -- $key { 277 -w* { 278 if {[string compare $val {}]} { 279 if {![winfo exist $val]} { 280 return -code error "window \"$val\" does not exist" 281 } elseif {[string comp $w [winfo parent $val]] && \ 282 [string comp $data(hold) [winfo parent $val]]} { 283 return -code error "window \"$val\" must be a\ 284 child of the tab notebook ($w)" 285 } 286 } 287 set s(-window) $val 288 } 289 -s* { 290 if {![regexp {^(normal|disabled|active)$} $val]} { 291 return -code error "unknown state \"$val\", must be:\ 292 normal, disabled or active" 293 } 294 set s(-state) $val 295 } 296 default { 297 return -code error "unknown option '$key', must be:\ 298 [join [array names s] {, }]" 299 } 300 } 301 } 302 set tab [incr data(numtabs)] 303 set px [expr {int(ceil($data(-padx)/2))}] 304 set py [expr {int(ceil($data(-pady)/2))}] 305 if {[lsearch -exact [image names] $text] != -1} { 306 set i [$c create image $px $py -image $text -anchor nw \ 307 -tags [list IMG M:$tab ID:$text TAB:$tab]] 308 } else { 309 set i [$c create text [expr {$px+1}] $py -text $text -anchor nw \ 310 -tags [list TEXT M:$tab ID:$text TAB:$tab] \ 311 -justify $data(-justify)] 312 } 313 foreach {x1 y1 x2 y2} [$c bbox $i] { 314 set W [expr {$x2-$x1+$px}] 315 set FW [expr {$W+$px}] 316 set FH [expr {$y2-$y1+3*$py}] 317 } 318 set diff [expr {$FH-$data(height)}] 319 if {$diff > 0} { 320 $c move all 0 $diff 321 $c move $i 0 -$diff 322 set data(height) $FH 323 } 324 $c create poly 0 $FH $px $py $W $py $FW $FH -fill {} \ 325 -tags [list POLY POLY:$tab TAB:$tab] 326 $c create line 0 $FH $px $py $W $py $FW $FH -joinstyle round \ 327 -tags [list LINE LINE:$tab TAB:$tab] \ 328 -width $data(-linewidth) -fill $data(-linecolor) 329 $c move TAB:$tab $data(width) [expr {($diff<0)?-$diff:0}] 330 $c raise $i 331 $c raise LINE:$tab 332 incr data(width) $FW 333 $c configure -width $data(width) -height $data(height) \ 334 -scrollregion "0 0 $data(width) $data(height)" 335 $c bind TAB:$tab <1> [namespace code [list _activate $w $tab]] 336 array set data [list :$tab:-window $s(-window) :$tab:-state $s(-state)] 337 if {[string compare $s(-window) {}]} { 338 grid $s(-window) -in $data(hold) -row 0 -column 0 -sticky nsew 339 lower $s(-window) 340 } 341 switch $s(-state) { 342 active {_activate $w $tab} 343 disabled {$c itemconfig POLY:$tab -fill $data(-disabledbackground)} 344 normal {$c itemconfig POLY:$tab -fill $data(-normalbackground)} 345 } 346 lappend data(ids) $tab 347 return $tab 348} 349 350;proc _activate { w id } { 351 upvar \#0 [namespace current]::$w data 352 353 if {[string compare $data(-browsecmd) {}] && \ 354 [catch {uplevel \#0 $data(-browsecmd) \ 355 [list [_name $w $oldtab] [_name $w $tab]]}]} { 356 return 357 } 358 if {[string compare $id {}]} { 359 set tab [verify $w $id] 360 if {[string match disabled $data(:$tab:-state)]} return 361 } else { 362 set tab {} 363 } 364 if {[string match $data(curtab) $tab]} return 365 set c $data(tabs) 366 set oldtab $data(curtab) 367 if {[string compare $oldtab {}]} { 368 $c itemconfig POLY:$oldtab -fill $data(-normalbackground) 369 $c move TAB:$oldtab 0 2 370 set data(:$oldtab:-state) normal 371 } 372 set data(curtab) $tab 373 if {[string compare $tab {}]} { 374 set data(:$tab:-state) active 375 $c itemconfig POLY:$tab -fill $data(-activebackground) 376 $c move TAB:$tab 0 -2 377 } 378 if {[info exists data(:$tab:-window)] && \ 379 [winfo exists $data(:$tab:-window)]} { 380 raise $data(:$tab:-window) 381 } else { 382 raise $data(blank) 383 } 384 resize $w [winfo width $w] 385} 386 387;proc _delete { w id } { 388 upvar \#0 [namespace current]::$w data 389 390 set tab [verify $w $id] 391 set c $data(tabs) 392 foreach {x1 y1 x2 y2} [$c bbox TAB:$tab] { set W [expr {$x2-$x1-3}] } 393 $c delete TAB:$tab 394 for { set i [expr {$tab+1}] } { $i <= $data(numtabs) } { incr i } { 395 $c move TAB:$i -$W 0 396 } 397 foreach {x1 y1 x2 y2} [$c bbox all] { set H [expr {$y2-$y1-3}] } 398 if {$H<$data(height)} { 399 $c move all 0 [expr {$H-$data(height)}] 400 set data(height) $H 401 } 402 incr data(width) -$W 403 $c config -width $data(width) -height $data(height) \ 404 -scrollregion "0 0 $data(width) $data(height)" 405 set i [lsearch $data(ids) $tab] 406 set data(ids) [lreplace $data(ids) $i $i] 407 catch {grid forget $data(:$tab:-window)} 408 unset data(:$tab:-state) data(:$tab:-window) 409 if {[string match $tab $data(curtab)]} { 410 set data(curtab) {} 411 raise $data(blank) 412 } 413} 414 415;proc _itemcget { w id key } { 416 upvar \#0 [namespace current]::$w data 417 418 set tab [verify $w $id] 419 set opt [array names data :$tab:$key*] 420 set len [llength $opt] 421 if {$len == 1} { 422 return $data($opt) 423 } elseif {$len == 0} { 424 set all [array names data :$tab:-*] 425 foreach o $all { lappend opts [lindex [split $o :] end] } 426 return -code error "unknown option \"$key\", must be one of:\ 427 [join $opts {, }]" 428 } else { 429 foreach o $opt { lappend opts [lindex [split $o :] end] } 430 return -code error "ambiguous option \"$key\", must be one of:\ 431 [join $opts {, }]" 432 } 433} 434 435;proc _itemconfigure { w id args } { 436 upvar \#0 [namespace current]::$w data 437 438 set tab [verify $w $id] 439 set len [llength $args] 440 if {$len == 1} { 441 return [uplevel 1 _itemcget $w $tab $args] 442 } elseif {$len&1} { 443 return -code error "uneven set of key/value pairs in \"$args\"" 444 } 445 if {[string match {} $args]} { 446 set all [array names data :$tab:-*] 447 foreach o $all { lappend res [lindex [split $o :] end] $data($o) } 448 return $res 449 } 450 foreach {key val} $args { 451 switch -glob -- $key { 452 -w* { 453 if {[string comp $val {}]} { 454 if {![winfo exist $val]} { 455 return -code error "window \"$val\" does not exist" 456 } elseif {[string comp $w [winfo parent $val]] && \ 457 [string comp $data(hold) [winfo parent $val]]} { 458 return -code error "window \"$val\" must be a\ 459 child of the tab notebook ($w)" 460 } 461 } 462 set old $data(:$tab:-window) 463 if {[winfo exists $old]} { grid forget $old } 464 set data(:$tab:-window) $val 465 if {[string comp $val {}]} { 466 grid $val -in $data(hold) -row 0 -column 0 \ 467 -sticky nsew 468 lower $val 469 } 470 if {[string match active $data(:$tab:-state)]} { 471 if {[string comp $val {}]} { 472 raise $val 473 } else { 474 raise $data(blank) 475 } 476 } 477 } 478 -s* { 479 if {![regexp {^(normal|disabled|active)$} $val]} { 480 return -code error "unknown state \"$val\", must be:\ 481 normal, disabled or active" 482 } 483 if {[string match $val $data(:$tab:-state)]} return 484 set old $data(:$tab:-state) 485 switch $val { 486 active { 487 set data(:$tab:-state) $val 488 _activate $w $tab 489 } 490 disabled { 491 if {[string match active $old]} { _activate $w {} } 492 $data(tabs) itemconfig POLY:$tab \ 493 -fill $data(-disabledbackground) 494 set data(:$tab:-state) $val 495 } 496 normal { 497 if {[string match active $old]} { _activate $w {} } 498 $data(tabs) itemconfig POLY:$tab -fill {} 499 set data(:$tab:-state) $val 500 } 501 } 502 } 503 default { 504 return -code error "unknown option '$key', must be:\ 505 [join [array names s] {, }]" 506 } 507 } 508 } 509} 510 511## given a tab number, return the text 512;proc _name { w id } { 513 upvar \#0 [namespace current]::$w data 514 515 if {[string match {} $id]} return 516 set text {} 517 foreach item [$data(tabs) find withtag TAB:$id] { 518 set tags [$data(tabs) gettags $item] 519 if {[set i [lsearch -glob $tags {ID:*}]] != -1} { 520 set text [string range [lindex $tags $i] 3 end] 521 break 522 } 523 } 524 return $text 525} 526 527#;proc _order {w args} { 528# upvar \#0 [namespace current]::$w data 529# 530# foreach i $data(ids) { 531# } 532#} 533 534## Take all the tabs and reculate space requirements 535;proc recalculate {w} { 536 upvar \#0 [namespace current]::$w data 537 538 set c $data(tabs) 539 set px [expr {int(ceil($data(-padx)/2))}] 540 set py [expr {int(ceil($data(-pady)/2))}] 541 set data(width) 0 542 set data(height) 0 543 foreach i $data(ids) { 544 $c coords M:$i [expr \ 545 {[string match text [$c type M:$i]]?$px+1:$px}] $py 546 foreach {x1 y1 x2 y2} [$c bbox M:$i] { 547 set W [expr {$x2-$x1+$px}] 548 set FW [expr {$W+$px}] 549 set FH [expr {$y2-$y1+3*$py}] 550 } 551 set diff [expr {$FH-$data(height)}] 552 if {$diff > 0} { 553 $c move all 0 $diff 554 $c move M:$i 0 -$diff 555 set data(height) $FH 556 } 557 $c coords POLY:$i 0 $FH $px $py $W $py $FW $FH 558 $c coords LINE:$i 0 $FH $px $py $W $py $FW $FH 559 $c move TAB:$i $data(width) [expr {($diff<0)?-$diff:0}] 560 incr data(width) $FW 561 } 562 $c configure -width $data(width) -height $data(height) \ 563 -scrollregion "0 0 $data(width) $data(height)" 564} 565 566;proc resize {w x} { 567 upvar \#0 [namespace current]::$w data 568 569 if {[string compare $data(curtab) {}]} { 570 set x [expr {round(-[$data(tabs) canvasx 0])}] 571 foreach {x1 y1 x2 y2} [$data(tabs) bbox TAB:$data(curtab)] { 572 place $data(hide) -y [winfo y $data(hold)] -x [expr {$x1+$x+3}] 573 $data(hide) config -width [expr {$x2-$x1-5}] 574 } 575 } else { 576 place forget $data(hide) 577 } 578} 579 580;proc see {w id} { 581 upvar \#0 [namespace current]::$w data 582 583 set c $data(tabs) 584 set box [$c bbox $id] 585 if {[string match {} $box]} return 586 foreach {x y x1 y1} $box {left right} [$c xview] \ 587 {p q xmax ymax} [$c cget -scrollregion] { 588 set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}] 589 } 590 $c xview moveto $xpos 591} 592 593;proc verify { w id } { 594 upvar \#0 [namespace current]::$w data 595 596 set c $data(tabs) 597 if {[string compare [set i [$c find withtag ID:$id]] {}]} { 598 if {[regexp {TAB:([0-9]+)} [$c gettags [lindex $i 0]] junk id]} { 599 return $id 600 } 601 } elseif {[string compare [$c find withtag TAB:$id] {}]} { 602 return $id 603 } 604 return -code error "unrecognized tab \"$id\"" 605} 606 607}; #end of namespace ::Widget::Tabnotebook