** Combobox megawidget with adjusted width **

SourceForge: https://sourceforge.net/p/tcl-combobox-enhanced/

Download From:
https://sourceforge.net/p/tcl-combobox-enhanced/code/ci/default/tree/

[bll] 2017-9-20: This widget will automatically adjust the width of the combobox to 
match the values supplied.  Good for localized test.

It has an internal cache, as in my particular use case, I have certain screens that display the same 
combobox multiple times.  This can be turned off or removed.

The -popdownfont argument is an addition and can be used to set the popdown listbox's font.  The code is
set up to do this once the popdown listbox is mapped.  (If the popdown listbox is force-created early, it may 
display in the entirely wrong place on the screen).

[bll] 2018-9-6: 1.2: Change to use tailcall.

[bll] 2018-3-16: 1.1: Make the bindtag more specific.

======
#!/usr/bin/tclsh
#
# Copyright 2017 Brad Lanam Walnut Creek CA
# 2018: change to use tailcall per Koen Danckaert
#

package require Tcl 8.5-
package require Tk

# cboxadj is a width-adjusted combobox
#   -popdownfont : will set the font for the popdown listbox.
proc ::cboxadj { nm args } {
  cboxadjust new $nm {*}$args
  return $nm
}

namespace eval ::cboxadj {
  variable vars

  proc handler { cbox args } {
    $cbox {*}$args
  }

  proc setpopdownfont { w } {
    variable vars

    if { $w in $vars(bindlist) } {
      $w configure -font [dict get $vars(fontlist) $w]
    }
  }

  proc bindpopdown { wprefix font } {
    variable vars

    if { ! $vars(bound) } {
      bind ComboboxListbox <Map> \
          +[list ::cboxadj::setpopdownfont %W]
      set vars(bound) true
    }
    lappend vars(bindlist) $wprefix.popdown.f.l
    dict set vars(fontlist) $wprefix.popdown.f.l $font
  }

  proc init { } {
    variable vars

    set vars(bound) false
    set vars(bindlist) [list]
    set vars(fontlist) [dict create]
  }

  init
}

::oo::class create ::cboxadjust {
  constructor { nm args } {
    my variable vars

    set vars(usecache) true

    set vars(widget) [ttk::combobox ${nm}]
    set vars(cbox) ${nm}_cboxadj
    rename $vars(widget) ::$vars(cbox)
    interp alias {} $vars(widget) {} ::cboxadj::handler [self]
    uplevel 2 [list $vars(widget) configure {*}$args]

    set bt cboxadjbt$vars(widget)
    bindtags $vars(widget) [concat [bindtags $vars(widget)] $bt]
    bind $bt <space> { ::ttk::combobox::Post %W }
    bind $vars(widget) <Destroy> [list [self] destruct]

    set wid [my _getWidth $vars(cbox)]
    $vars(cbox) configure -width $wid
  }

  method destruct { } {
    my variable vars
    interp alias {} $vars(widget) {}
    [self] destroy
  }

  method _getWidth { nm } {
    my variable vars

    set values [$nm cget -values]
    set found false
    if { $vars(usecache) } {
      set svalues [join $values {}]
      if { [info exists vars(cboxadj.cache.$svalues)] } {
        set found true
        set wid $vars(cboxadj.cache.$svalues)
      }
    }
    if { ! $found } {
      set pwid 0
      set font [$nm cget -font]
      foreach {val} $values {
        set pwid [expr {max($pwid,[font measure $font $val])}]
      }
      set wid [expr {round($pwid / [font measure $font 0])}]
      if { $::tcl_platform(platform) eq "windows" } {
        incr wid 2
      } else {
        # the wider the combobox is, the greater chance of error...
        set wid [expr {$wid + round($wid/15) + 2}]
      }
      if { $vars(usecache) } {
        set vars(cboxadj.cache.$svalues) $wid
      }
    }
    return $wid
  }

  method unknown { args } {
    my variable vars

    tailcall $vars(cbox) {*}$args
  }

  method configure { args } {
    my variable vars

    foreach {k v} $args {
      if { $k eq "-textvariable" } {
        set fqv {}
        if { [string match {::*} $v] } {
          set fqv $v
        }
        if { $fqv eq {} } {
          set fqv [uplevel 2 [list namespace which -variable $v]]
          if { $fqv eq {} } {
            set ns [uplevel 2 [list namespace current]]
            set fqv $ns$v
            if { [string match ::::* $fqv] } {
              set fqv [string range $fqv 2 end]
            }
          }
        }
        $vars(cbox) configure -textvariable $fqv
      } elseif { $k eq "-popdownfont" } {
        set vars($k) $v
        ::cboxadj::bindpopdown $vars(widget) $v
      } elseif { $k eq "-values" } {
        $vars(cbox) configure $k $v
        set wid [my _getWidth $vars(cbox)]
        $vars(cbox) configure -width $wid
      } else {
        $vars(cbox) configure $k $v
      }
    }
    return -code ok
  }
}

package provide cboxadj 1.2
======

<<categories>>Widget | Megawidget