#
# Copyright (c) 1993 Eric Schenk.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
# 
# IN NO EVENT SHALL ERIC SCHENK BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF ERIC
# SCHENK HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# ERIC SCHENK SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND ERIC SCHENK HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

# utility routines to handle popup menus.

#------------------------------------------------------------------------------
# Redo the class bindings for menu buttons and menus.
# We need to do this because menus running under Tkwm must
# be able to exclude other events from occuring until the menu
# action is completed.
#------------------------------------------------------------------------------


# Destroy the original class bindings on menus.
foreach i [bind Menu] {
    bind Menu $i ""
}
unset i

# Create new class bindings for menus
bind Menu <Any-ButtonRelease> "tkwm_invokemenu %W"
bind Menu <ButtonRelease-1> "tkwm_invokemenu %W"
bind Menu <Any-Enter> {set tkwm_priv(window) %W; %W activate @%y}
bind Menu <Any-Leave> {set tkwm_priv(window) {}; %W activate none}
bind Menu <Any-Motion> {
    if {$tkwm_priv(window) == "%W"} {
	%W activate @%y
    }
}
bind Menu <B2-Motion> {
    if {$tkwm_priv(window) == "%W"} {
	%W activate @%y
    }
}

bind Menu <Any-Button> {if {$tkwm_priv(grab) != ""} { grab -global $tkwm_priv(grab)}}

bind Menu <Escape> {tkwm_unpostmenu; set tkwm_priv(menudone) 1}

bind Menu <Any-KeyPress> {tkwm_traverseWithinMenu %W %A}
bind Menu <Up> {tkwm_nextMenuEntry -1}
bind Menu <Down> {tkwm_nextMenuEntry 1}
bind Menu <Return> {tkwm_invokemenu %W}

#------------------------------------------------------------------------------
# Procedures to handle menus.
#------------------------------------------------------------------------------

proc tkwm_postmenu {menu X Y} {
    exclusive-dispatch "real-tkwm_postmenu $menu $X $Y"
}

proc real-tkwm_postmenu {menu X Y} {
    global tkwm_priv tk_strictMotif
    install_root_colormap
    if {$tkwm_priv(button) != ""} {
        set tkwm_priv(relief) [lindex [$tkwm_priv(button) config -relief] 4]
        $tkwm_priv(button) config -relief sunken
    }
    if {$menu == $tkwm_priv(posted)} {
	grab -global $tkwm_priv(grab)
	return
    }
    set cur $tkwm_priv(posted)
    if {$cur != ""} {tkwm_unpostmenu; return}
    set tkwm_priv(posted) $menu
    if {$tkwm_priv(focus) == ""} {
	set tkwm_priv(focus) [focus]
    }
    set tkwm_priv(activeBg) [lindex [$menu config -activebackground] 4]
    set tkwm_priv(activeFg) [lindex [$menu config -activeforeground] 4]
    if $tk_strictMotif {
	$menu config -activebackground [lindex [$menu config -background] 4]
	$menu config -activeforeground [lindex [$menu config -foreground] 4]
    }
    $menu activate none
    focus $menu
    $menu post $X $Y
    # save the old bindings
    set tkwm_priv(grab) $menu
    grab -global $menu
    # wait for the finish
    set tkwm_priv(menudone) 0
    tkwait variable tkwm_priv(menudone)
    uninstall_root_colormap
}

# procedure to post from a "button", this can really be any widget with
# a relief.

proc tkwm_menubutton {menu button} {
    global tkwm_priv
    set tkwm_priv(button) $button
    tkwm_postmenu $menu [winfo rootx $button] \
         [expr [winfo rooty $button]+[winfo height $button]]
}


# modeled on "tk_invokeMenu".

proc tkwm_invokemenu {menu} {
    global tkwm_priv

    unwindProtect {
        set i [$menu index active]
        tkwm_unpostmenu
        # get the menu popped down now
        update idletasks
        noisyCatch {if {$i != "none"} {allow-dispatch "$menu invoke $i"}}
    } {
       set tkwm_priv(menudone) 1
    }
}

# modeled on "tk_mbUnpost".

proc tkwm_unpostmenu {} {
    global tkwm_priv
    set w $tkwm_priv(button)
    if {$w != "" && $tkwm_priv(relief) != ""} {
        $w config -relief $tkwm_priv(relief)
    }
    set w $tkwm_priv(posted)
    if {$w != ""} {
        catch {
            $w unpost
            $w config -activebackground $tkwm_priv(activeBg)
            $w config -activeforeground $tkwm_priv(activeFg)
	}
        catch {tkwm_unbindmenu $w}
        catch {focus $tkwm_priv(focus)}
        grab release $tkwm_priv(grab)
	set tkwm_priv(grab) ""
        set tkwm_priv(focus) ""
        set tkwm_priv(button) ""
        set tkwm_priv(posted) {}
    }
}

# The procedure below is used to implement keyboard traversal within
# the posted menu.  It takes two arguments:  the name of the menu to
# be traversed within, and an ASCII character.  It searches for an
# entry in the menu that has that character underlined.  If such an
# entry is found, it is invoked and the menu is unposted.

proc tkwm_traverseWithinMenu {w char} {
    global tkwm_priv

    if {$char == ""} {
        return
    }
    set char [string tolower $char]
    set last [$w index last]
    if {$last == "none"} {
        return
    }
    for {set i 0} {$i <= $last} {incr i} {
        if [catch {set char2 [string index \
                [lindex [$w entryconfig $i -label] 4] \
                [lindex [$w entryconfig $i -underline] 4]]}] {
            continue
        }
        if {[string compare $char [string tolower $char2]] == 0} {
            tkwm_unpostmenu
	    # this invoke could fail!
            noisyCatch {$w invoke $i}
	    set tkwm_priv(menudone) 1
            return
        }
    }
}

# The procedure below is used to traverse to the next or previous entry
# in the posted menu.  It takes one argument, which is 1 to go to the
# next entry or -1 to go to the previous entry.  Disabled entries are
# skipped in this process.

proc tkwm_nextMenuEntry count {
    global tkwm_priv
    # if there is no menu posted we can do this can we?
    if {$tkwm_priv(posted) == ""} {
        return
    }
    set menu $tkwm_priv(posted)
    # if there are no menu entries there is not much to do
    if {[$menu index last] == "none"} {
        return
    }
    set length [expr [$menu index last]+1]
    set i [$menu index active]
    if {$i == "none"} {
        set i 0
    } else {
        incr i $count
    }
    while 1 {
        while {$i < 0} {
            incr i $length
        }
        while {$i >= $length} {
            incr i -$length
        }
        if {[catch {$menu entryconfigure $i -state} state] == 0} {
            if {[lindex $state 4] != "disabled"} {
                break
            }
        }
        incr i $count
    }
    $menu activate $i
}

#------------------------------------------------------------------------------
# Menu constructor code, to make it easier for novices to specify a
# complicated menu.
# (I should make cascades part of the structural description here...)
#------------------------------------------------------------------------------
# Create a new menu as described by the description list:
# the format is:
# {{type label command}
#  {type label command}
#  ....}

proc tkwm_menu {path desc} {
    global menu_list
    if {[info commands $path] != ""} {
	destroy $path
    } else {
	lappend menu_list $path
    }
    menu $path -border 3
    $path config -disabledforeground [lindex [$path config -foreground] 4]
    foreach i $desc {
	set type [lindex $i 0]
	switch $type {
	    separator {$path add $type}
	    cascade {$path add $type -label [lindex $i 1] -menu [lindex $i 2]}
	    title {$path add command -label [lindex $i 1] -state disabled}
	    default {$path add $type -label [lindex $i 1] -command [lindex $i 2] -accelerator [lindex $i 3]}
	}
    }
}

set tkwm_priv(posted) {}
set tkwm_priv(focus) {}
set tkwm_priv(grab) {}
set tkwm_priv(window) {}
set tkwm_priv(button) {}