tcl/tabnotebook.tcl

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