tcl/combobox.tcl

   1 ##
   2 ## Copyright 1996 Jeffrey Hobbs
   3 ##
   4
   5 ##------------------------------------------------------------------------
   6 ## PROCEDURE
   7 ##      combobox
   8 ##
   9 ## DESCRIPTION
  10 ##      Implements a Combobox mega-widget
  11 ##
  12 ## ARGUMENTS
  13 ##      combobox <window pathname> <options>
  14 ##
  15 ## OPTIONS
  16 ##      (Any entry widget option may be used in addition to these)
  17 ##
  18 ## -command script                      DEFAULT: {}
  19 ##      Script to evaluate when a selection is made.
  20 ##
  21 ## -editable TCL_BOOLEAN                DEFAULT: 1
  22 ##      Whether to allow the user to edit the entry widget contents
  23 ##
  24 ## -grab type                           DEFAULT: local
  25 ##      Type of grab (local, none, global) to use when listbox appears.
  26 ##
  27 ## -labelanchor anchor                  DEFAULT: c
  28 ##      Anchor for the label.  Reasonable values are c, w and e.
  29 ##
  30 ## -labeltext string                    DEFAULT: {}
  31 ##      Text for the label
  32 ##
  33 ## -labelwidth #                        DEFAULT: 0 (self-sizing)
  34 ##      Width for the label
  35 ##
  36 ## -list list                           DEFAULT: {}
  37 ##      List for the listbox
  38 ##
  39 ## -listheight #                        DEFAULT: 5
  40 ##      Height of the listbox.  If the number of items exceeds this
  41 ##      height, a scrollbar will automatically be added.
  42 ##
  43 ## -postcommand script                  DEFAULT: {}
  44 ##      A command which is evaluated before the listbox pops up.
  45 ##
  46 ## -prunelist TCL_BOOLEAN               DEFAULT: 0
  47 ##      Whether to prevent duplicate listbox items
  48 ##
  49 ## -tabexpand TCL_BOOLEAN               DEFAULT: 1
  50 ##      Whether to allow tab expansion in entry widget (uses listbox items)
  51 ##
  52 ## RETURNS: the window pathname
  53 ##
  54 ## BINDINGS (in addition to default widget bindings)
  55 ##
  56 ## <Double-1> or <Escape> in the entry widget, or selecting the
  57 ## button will toggle the listbox portion.
  58 ##
  59 ## <Escape> will close the listbox without a selection.
  60 ##
  61 ## <Tab> in the entry widget searches the listbox for a unique match.
  62 ##
  63 ## <Double-1> in the listbox selects that item.
  64 ##
  65 ## METHODS
  66 ##      These are the methods that the Combobox recognizes.  Aside from
  67 ##      those listed here, it accepts what is valid for entry widgets.
  68 ##
  69 ## configure ?option? ?value option value ...?
  70 ## cget option
  71 ##      Standard tk widget routines.
  72 ##
  73 ## add ?string?
  74 ##      Adds the string to the listbox.
  75 ##      If string is not specified, it uses what's in the entry widget.
  76 ##
  77 ## expand ?string?
  78 ##      Expands the string based on the contents of the listbox.
  79 ##      If string is not specified, it uses what's in the entry widget.
  80 ##
  81 ## popup
  82 ##      Toggles whether the listbox is mapped or not.
  83 ##
  84 ## set string
  85 ##      Sets the entry widget (or its textvariable, if it exists) to
  86 ##      the value of string.
  87 ##
  88 ## subwidget widget
  89 ##      Returns the true widget path of the specified widget.  Valid
  90 ##      widgets are label, listbox, entry, toplevel, scrollbar.
  91 ##
  92 ## NAMESPACE & STATE
  93 ##      The megawidget creates a global array with the classname, and a
  94 ## global array which is the name of each megawidget created.  The latter
  95 ## array is deleted when the megawidget is destroyed.
  96 ##      The procedure combobox and those beginning with Combobox are
  97 ## used.  Also, when a widget is created, commands named .$widgetname
  98 ## and Combobox$widgetname are created.
  99 ##
 100 ## EXAMPLE USAGE:
 101 ##
 102 ## pack [combobox .combo -label "Hello: "]
 103 ## pack [combobox .combo -width 15 -textvariable myvar]
 104 ##
 105 ##------------------------------------------------------------------------
 106
 107 ## FIX notes
 108 ## add -command
 109 ## single - not double click
 110 ## -listheight should be *max height*, not strict height
 111
 112 package require Widget 1.0
 113 package provide Combobox 1.1
 114
 115 array set Combobox {
 116     type                frame
 117     base                entry
 118     components          {
 119         label
 120         {button button button {-image Combobox:Image \
 121                 -command [list Combobox_popup $w]}}
 122         {toplevel toplevel drop {-cursor arrow}}
 123         {listbox listbox drop.lbox {-selectmode single \
 124                 -width 5 -height $data(-listheight) \
 125                 -yscrollcommand [list $data(scrollbar) set]}}
 126         {scrollbar scrollbar drop.sy {-orient vertical \
 127                 -command [list $data(listbox) yview]}}
 128     }
 129
 130     -bd                 -borderwidth
 131     -borderwidth        {borderWidth    BorderWidth     0}
 132     -bg                 -background
 133     -background         {ALIAS entry -background}
 134     -command            {command        Command         {}}
 135     -editable           {editable       Editable        1}
 136     -grab               {grab           Grab            local}
 137     -labeltext          {labelText      Text            {}}
 138     -labelwidth         {labelWidth     Width           0}
 139     -labelanchor        {ALIAS label -anchor labelAnchor Anchor}
 140     -list               {list           List            {}}
 141     -listheight         {listHeight     ListHeight      5}
 142     -postcommand        {postCommand    Command         {}}
 143     -prunelist          {pruneList      PruneList       0}
 144     -relief             {relief         Relief          flat}
 145     -tabexpand          {tabExpand      TabExpand       1}
 146 }
 147 # Create this to make sure there are registered in auto_mkindex
 148 # these must come before the [widget create ...]
 149 proc Combobox args {}
 150 proc combobox args {}
 151 widget create Combobox
 152
 153 ;proc Combobox:construct {w args} {
 154     upvar \#0 $w data
 155
 156     ## Removable List Box
 157     wm overrideredirect $data(toplevel) 1
 158     wm transient $data(toplevel) [winfo toplevel $w]
 159     wm group $data(toplevel) [winfo toplevel $w]
 160
 161     bind $w <Unmap> { catch {grab release %W} }
 162     bind $w <Destroy> { catch {grab release %W} }
 163     bind $data(toplevel) <Unmap> "catch {grab release {$w}}"
 164
 165     grid $data(label) $data(entry) $data(button) -in $w -sticky news
 166     grid config $data(button) -sticky ns
 167     grid columnconfig $w 1 -weight 1
 168     grid $data(listbox) $data(scrollbar) -in $data(toplevel) -sticky ns
 169     grid config $data(listbox) -sticky news
 170     grid remove $data(scrollbar) $data(label)
 171     grid columnconfig $data(toplevel) 0 -weight 1
 172     grid rowconfig $data(toplevel) 0 -weight 1
 173
 174     bind $data(listbox) <Escape>   [list $w popup]
 175     bind $data(listbox) <Double-1> "Combobox:get [list $w] \[%W get \[%W nearest %y\]\]"
 176     bind $data(listbox) <Return>   "Combobox:get [list $w] \[%W get active\]"
 177 }
 178
 179 ;proc Combobox:configure { w args } {
 180     upvar \#0 $w data
 181
 182     set truth {^(1|yes|true|on)$}
 183     foreach {key val} $args {
 184         switch -- $key {
 185             -borderwidth - -relief { .$w configure $key $val }
 186             -background {
 187                 $data(basecmd) configure -bg $val
 188                 $data(listbox) configure -bg $val
 189             }
 190             -editable   {
 191                 if {[set val [regexp $truth $val]]} {
 192                     $data(basecmd) configure -state normal
 193                 } else {
 194                     $data(basecmd) configure -state disabled
 195                 }
 196             }
 197             -grab       {
 198                 if {![regexp {^(local|global|none)$} $val junk val]} {
 199                     return -code error "bad $key option \"$val\": must be\
 200                             local, grab, or none"
 201                 }
 202             }
 203             -list       {
 204                 $data(listbox) delete 0 end
 205                 eval $data(listbox) insert end $val
 206             }
 207             -tabexpand  -
 208             -prunelist  { set val [regexp $truth $val] }
 209             -labelanchor { $data(label) configure -anchor $val }
 210             -labeltext  {
 211                 $data(label) configure -text $val
 212                 if {[string compare {} $val]} {
 213                     grid $data(label)
 214                 } else {
 215                     grid remove $data(label)
 216                 }
 217             }
 218             -labelwidth { $data(label) configure -width $val }
 219             -listheight { $data(listbox) configure -height $val }
 220         }
 221         set data($key) $val
 222     }
 223 }
 224
 225 bind Combobox <Double-1>        { %W popup }
 226 bind Combobox <Escape>          { %W popup }
 227 bind Combobox <Tab>             { %W expand [%W get]; break }
 228
 229 ;proc Combobox_popup {w} {
 230     upvar \#0 $w data
 231     if {[winfo ismapped $data(toplevel)]} {
 232         wm withdraw $data(toplevel)
 233         catch {grab release $w}
 234         focus $data(entry)
 235     } else {
 236         uplevel \#0 $data(-postcommand)
 237         focus $data(entry)
 238         set size [$data(listbox) size]
 239         if {$size > $data(-listheight)} {
 240             $data(listbox) configure -height $data(-listheight)
 241             grid $data(scrollbar)
 242         } else {
 243             $data(listbox) configure -height $size
 244             grid remove $data(scrollbar)
 245         }
 246         wm geometry $data(toplevel) [winfo width $data(entry)]x[winfo \
 247                 reqheight $data(toplevel)]+[winfo rootx $data(entry)]+[expr \
 248                 [winfo rooty $data(entry)]+[winfo reqheight $data(entry)]]
 249         update idletasks
 250         wm deiconify $data(toplevel)
 251         if {[string match local $data(-grab)]} {
 252             grab $w
 253         } elseif {[string match global $data(-grab)]} {
 254             grab -global $w
 255         }
 256         focus $data(listbox)
 257         raise $data(toplevel)
 258     }
 259 }
 260
 261 ;proc Combobox_expand {w {str {}}} {
 262     upvar \#0 $w data
 263     if {!$data(-tabexpand)} return
 264     if {[string match {} $str]} { set str [$data(basecmd) get] }
 265     set found 0
 266     foreach item [$data(listbox) get 0 end] {
 267         if {[string match ${str}* $item]} {
 268             incr found
 269             lappend match $item
 270         }
 271     }
 272     if {$found} {
 273         set state [$data(basecmd) cget -state]
 274         $data(basecmd) config -state normal
 275         $data(basecmd) delete 0 end
 276         if {$found>1} {
 277             set match [$data(class):BestMatch $match]
 278         } else {
 279             set match [lindex $match 0]
 280         }
 281         $data(basecmd) insert end $match
 282         $data(basecmd) config -state $state
 283     } else { bell }
 284 }
 285
 286 ;proc Combobox_add {w {str {}}} {
 287     upvar \#0 $w data
 288     if {[string match {} $str]} { set str [$data(basecmd) get] }
 289     set i 1
 290     if {!$data(-prunelist)} {
 291         foreach l [$data(listbox) get 0 end] {
 292             if {![string compare $l $str]} { set i 0 ; break }
 293         }
 294     }
 295     if {$i} { $data(listbox) insert end $str }
 296 }
 297
 298 ;proc Combobox_set {w str} {
 299     upvar \#0 $w data
 300     set var [$data(basecmd) cget -textvar]
 301     if {[string compare {} $var] && [uplevel \#0 info exists [list $var]]} {
 302         global $var
 303         set $var $str
 304     } else {
 305         set state [$data(basecmd) cget -state]
 306         $data(basecmd) config -state normal
 307         $data(basecmd) delete 0 end
 308         $data(basecmd) insert 0 $str
 309         $data(basecmd) config -state $state
 310     }
 311 }
 312
 313 ;proc Combobox:get {w i} {
 314     upvar \#0 $w data
 315     set e $data(basecmd)
 316     if {[$data(listbox) size]} {
 317         set state [$e cget -state]
 318         $e config -state normal
 319         $e delete 0 end
 320         $e insert end $i
 321         $e config -state $state
 322         if {[string compare $data(-command) {}]} {
 323             uplevel \#0 $data(-command) $i
 324         }
 325     }
 326     wm withdraw $data(toplevel)
 327     focus $data(base)
 328 }
 329
 330 ;proc Combobox:BestMatch l {
 331     set s [lindex $l 0]
 332     if {[llength $l]>1} {
 333         set i [expr [string length $s]-1]
 334         foreach l $l {
 335             while {$i>=0 && [string first $s $l]} {
 336                 set s [string range $s 0 [incr i -1]]
 337             }
 338         }
 339     }
 340     return $s
 341 }
 342
 343 ## Button Bitmap
 344 ##
 345 image create bitmap Combobox:Image -data {#define downbut_width 14
 346 #define downbut_height 14
 347 static char downbut_bits[] = {
 348     0x00, 0x00, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xfc, 0x0f,
 349     0xf8, 0x07, 0xf0, 0x03, 0xe0, 0x01, 0xc0, 0x00, 0x00, 0x00, 0xfe, 0x1f,
 350     0xfe, 0x1f, 0x00, 0x00};
 351 }
 352
 353 return