Toolbutton with optional menu

Sometimes it's useful in a toolbar, to have a button which an optional popdown menu. For example, in an IDE you could have a "Compile" button but occasionally the user wants to "Clean & Compile" or "Compile docs". "optionbuttion" is a crossover between a regular pushbutton and a menubutton. When clicking, it executes the command as a pushbutton. When holding the button down for longer than a 0.5 s (adjustable delay), a menu appears. The menu entries execute the callback with an index corresponding to the selected entry. The menu can also be displayed with a right button click, like context menus.

Code:

# Copyright (c) 2021 Christian Gollwitzer
# 
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
 
package require Tk
package require snit

snit::widgetadaptor optionbutton {
        # a toolbutton that opens a menu upon 
        # longer click
        delegate option * to hull except -command
        delegate method * to hull
        
        # delay before opening the options menu
        option -delay -default 500
        # values for display
        option -values -default {} -configuremethod setvalues
        option -headline -default {}
        
        # callback before menu opens
        option -optcallback -default {}
        
        # callback after press / select
        option -command -default {} 

        component optmenu

        variable afterid {}

        constructor {args} {
                installhull using ttk::menubutton -style Toolbutton
                install optmenu using menu $win.m
                $hull configure -menu $optmenu

                $self configurelist $args
                
                # replace bindings
                bind $self <Button-1> [mymethod LeftBPress]
                bind $self <ButtonRelease-1> [mymethod LeftBRelease]
                bind $self <Button-3> [mymethod RightBPress]
        }

        destructor {
                if {$afterid ne {}} {
                        catch [after cancel $afterid]
                }
        }


        method LeftBPress {} {
                $hull state pressed
                set afterid [after $options(-delay) [mymethod openmenu]]
                return -code break
        }

        method LeftBRelease {} {
                if {$afterid ne {}} {
                        # the delay for the popdown menu is not passes
                        after cancel $afterid
                        set afterid {}
                        uplevel #0 $options(-command)
                }
                $hull state !pressed
                return -code break
        }

        method RightBPress {} {
                $self openmenu
                return -code break
        }

        method openmenu {} {
                set afterid {}
                uplevel #0 $options(-optcallback)
                $hull state !pressed
                ttk::menubutton::Popdown $win
        }

        method selected {i} {
                uplevel #0 [linsert $options(-command) end $i]
        }

        method setvalues {opt val} {
                set options($opt) $val
                $optmenu delete 0 end

                if {$options(-headline) ne {}} {
                        $optmenu add command -label $options(-headline) -state disabled
                        $optmenu add separator
                }
                set i 0
                foreach lbl $val {
                        $optmenu add command -label $lbl -command [mymethod selected $i]
                        incr i
                }
        }
}

Test:

proc echo args {
    puts $args
}

pack [optionbutton .b -text "Compile" -values {"Compile" "Clean & Compile" "Compile docs"} -command {echo called}]

# fill the values just before the menu appears
pack [optionbutton .c -text "I'm dynamic!" -values {1 2 3} -command {echo called} -optcallback {shuffle .c} -headline "Select number"]

proc shuffle {w} {
        $w configure -values [list [expr rand()] [clock scan now] [clock format [clock scan now]]]
}