##############################################################################
# $Id: menus.tcl,v 1.16 2002/11/03 01:23:23 cgavin Exp $
#
# menus.tcl procedures to edit application menus
#
# Copyright (C) 2000 Christian Gavin
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
##############################################################################

namespace eval ::menu_edit {

    # this contains a list of currently open menu editors
    variable menu_edit_windows ""

    proc {::menu_edit::delete_item} {top} {
        global widget

        set ::${top}::current_menu ""
        set ::${top}::current_index ""

        # this proc deletes the currently selected menu item

        set indices [$top.MenuListbox curselection]
        set index [lindex $indices 0]

        if {$index == ""} return

        set listboxitems [set ::${top}::listboxitems]

        set reference [lindex $listboxitems $index]

        set menu [lindex $reference end-1]
        set pos  [lindex $reference end]

        if {$pos != -1} {
            set mtype [$menu type $pos]

            if {$mtype == "cascade"} {
                set submenu [$menu entrycget $pos -menu]
                ::menu_edit::delete_menu_recurse $submenu
            }

            $menu delete $pos
            vTcl:init_wtree
        }

        ::menu_edit::fill_menu_list $top [set ::${top}::menu]
        click_listbox $top
    }

    proc {::menu_edit::delete_menu_recurse} {menu} {
        global widget vTcl

        # unregister
        catch {namespace delete ::widgets::$menu} error

        set last [$menu index end]

        while {$last != "none"} {

            set mtype [$menu type $last]

            if {$mtype == "cascade"} {
                set submenu [$menu entrycget $last -menu]
                ::menu_edit::delete_menu_recurse $submenu
            }

            if {$mtype == "tearoff"} {
                $menu configure -tearoff 0
            } else {
                $menu delete $last
            }

            set last [$menu index end]
        }

        destroy $menu
    }

    proc {::menu_edit::enable_editor} {top enable} {

        global widget

        set ctrls "$top.NewMenu      $top.DeleteMenu
                   $top.MoveMenuUp   $top.MoveMenuDown"

        switch $enable {
            0 - false - no {
                set ::${top}::backup_bindings [bindtags $widget($top,MenuListbox)]
                bindtags $widget($top,MenuListbox) dummy
                bindtags $widget($top,NewMenu)     dummy
                $top.MenuListbox configure -background gray

                foreach ctrl $ctrls {
                    set ::${top}::$ctrl.state      [$ctrl cget -state]
                    set ::${top}::$ctrl.background [$ctrl cget -background]

                    $ctrl configure -state disabled
                }
                enableProperties $top 0
            }
            1 - true - yes {
                foreach ctrl $ctrls {
                    if {[info exists ::${top}::$ctrl.state]} {
                        $ctrl configure -state      [set ::${top}::$ctrl.state] \
                                        -background [set ::${top}::$ctrl.background]
                    }
                }

                if {[info exists ::${top}::backup_bindings]} {
                    bindtags $widget($top,MenuListbox) [set ::${top}::backup_bindings]
                }
                bindtags $widget($top,NewMenu) ""
                $top.MenuListbox configure -background white
                enableProperties $top 1
                ::menu_edit::click_listbox $top
            }
        }
    }

    proc {::menu_edit::enable_all_editors} {enable} {

        variable menu_edit_windows

        set wnds $menu_edit_windows

        foreach wnd $wnds {
            ::menu_edit::enable_editor $wnd $enable
        }
    }

    proc {::menu_edit::set_uistate} {top} {
        foreach name [array names ::${top}::uistate] {
            if {$name != "Tearoff"} {
                $top.$name configure -state [set ::${top}::uistate($name)]
            }
        }
    }

    proc {::menu_edit::enable_toolbar_buttons} {top} {
        set indices [$top.MenuListbox curselection]
        set index [lindex $indices 0]

        if {$index == "" || $index == 0} {
            array set ::${top}::uistate {
                DeleteMenu disabled  MoveMenuUp disabled MoveMenuDown disabled
                Tearoff disabled
            }
            ::menu_edit::set_uistate $top
            return
        }

        array set ::${top}::uistate { DeleteMenu normal Tearoff disabled }

        set m ""
        set i ""

        ::menu_edit::get_menu_index $top $index m i
        set j $i
        if {[$m cget -tearoff] == 1 && $i == 1} {
           set j [expr $i -1]
        }

        if {$j == 0} {
            array set ::${top}::uistate { MoveMenuUp disabled }
        } else {
            array set ::${top}::uistate { MoveMenuUp normal }
        }

        if {$i < [$m index end]} {
            array set ::${top}::uistate { MoveMenuDown normal }
        } else {
            array set ::${top}::uistate { MoveMenuDown disabled }
        }

        if {[$m type $i] == "cascade"} {
            array set ::${top}::uistate { Tearoff normal }
        }

        ::menu_edit::set_uistate $top
    }

    proc {::menu_edit::fill_command} {top command} {
        global widget

        ## if the command is in the form "vTcl:DoCmdOption target cmd",
        ## then extracts the command, otherwise use the command as is
        if {[regexp {vTcl:DoCmdOption [^ ]+ (.*)} $command matchAll realCmd]} {
            lassign $command dummy1 dummy2 command
        }

        $top.MenuText delete 0.0 end
        $top.MenuText insert end $command

        vTcl:syntax_color $widget($top,MenuText)
    }

    proc {::menu_edit::fill_menu} {top m {level 0} {path {}}} {

        set size [$m index end]

        if {$path == ""} {
            set path $m
        } else {
            lappend path $m
        }

        if {$size == "none"} {return}

        for {set i 0} {$i <= $size} {incr i} {

            set mtype [$m type $i]
            if {$mtype == "tearoff"} continue

            lappend ::${top}::listboxitems [concat $path $i]

            set indent "    "
            for {set j 0} {$j < $level} {incr j} {
                append indent "    "
            }

            switch -exact $mtype {
                "cascade" {
                    set tearoff ""
                    set mlabel [$m entrycget $i -label]
                    set maccel [$m entrycget $i -accel]
                    set submenu [$m entrycget $i -menu]
                    if {$submenu != ""} {
                        if {[$submenu cget -tearoff] == 1} {
                            set tearoff " ---X---"}}
                    if {$maccel != ""} {
                        $top.MenuListbox insert end \
                            "$indent${mlabel}   ($maccel)$tearoff"
                    } else {
                        $top.MenuListbox insert end "$indent${mlabel}$tearoff"
                    }
                    if {$submenu != ""} {
                        ::menu_edit::fill_menu \
                            $top $submenu [expr $level + 1] [concat $path $i]
                    }
                }
                "command" {
                    set mlabel   [$m entrycget $i -label]
                    set maccel   [$m entrycget $i -accel]

                    if {$maccel != ""} {
                        $top.MenuListbox insert end \
                            "$indent${mlabel}   ($maccel)"
                    } else {
                        $top.MenuListbox insert end \
                            "$indent${mlabel}"
                    }
                }
                "separator" {
                    $top.MenuListbox insert end "$indent<separator>"
                }
                "radiobutton" -
                "checkbutton" {
                    set mlabel [$m entrycget $i -label]
                    set maccel [$m entrycget $i -accel]
                    if {$mtype == "radiobutton"} {
                        set prefix "o "
                    } else {
                        set prefix "x "}
                    if {$maccel != ""} {
                        $top.MenuListbox insert end \
                            "$indent$prefix${mlabel}   ($maccel)"
                    } else {
                        $top.MenuListbox insert end \
                            "$indent$prefix${mlabel}"
                    }
                }
            }
        }
    }

    proc {::menu_edit::fill_menu_list} {top m} {
        global widget

        # let's try to save the context
        set indices [$top.MenuListbox curselection]
        set index [lindex $indices 0]
        if {$index == ""} {
            set index [set ::${top}::listbox_index]
        }

        set yview [lindex [$top.MenuListbox yview] 0]

        set ::${top}::listboxitems ""
        $top.MenuListbox delete 0 end

        lappend ::${top}::listboxitems [list $m -1]
        $top.MenuListbox insert end "<Menu>"

        ::menu_edit::fill_menu $top $m
        set ::${top}::menu $m

        if {$index != ""} {
            $top.MenuListbox selection clear 0 end
            $top.MenuListbox selection set $index
        }

        $top.MenuListbox yview moveto $yview
    }

    proc {::menu_edit::get_menu_index} {top index ref_m ref_i} {
        upvar $ref_m m
        upvar $ref_i i

        set reference [set ::${top}::listboxitems]
        set reference [lindex $reference $index]
        set m [lindex $reference end-1]
        set i [lindex $reference end]
    }

    proc {::menu_edit::move_item} {top direction} {
        set indices [$top.MenuListbox curselection]
        set index   [lindex $indices 0]

        if {$index == ""} return

        set m ""
        set i ""

        ::menu_edit::get_menu_index $top $index m i

        # what is the new index ?
        switch $direction {
            up {
                set new_i [expr $i - 1]
            }
            down {
                set new_i [expr $i + 1]
            }
        }

        # let's save the old menu
        set old_config [$m entryconfigure $i]
        set mtype      [$m type $i]

        set optval ""

        # build a list of option/value pairs
        foreach option $old_config {
            lappend optval [list [lindex $option 0] [lindex $option 4]]
        }

        # delete the old menu
        $m delete $i

        # insert menu at the new place
        eval $m insert $new_i $mtype [join $optval]

        ::menu_edit::fill_menu_list $top [set ::${top}::menu]

        # let's select the same menu at its new location
        set size [$top.MenuListbox index end]

        for {set ii 0} {$ii < $size} {incr ii} {

            set mm ""
            set mi ""

            ::menu_edit::get_menu_index $top $ii mm mi
            if {$mm == $m && $new_i == $mi} {
                $top.MenuListbox selection clear 0 end
                $top.MenuListbox selection set $ii
                $top.MenuListbox activate $ii
                ::menu_edit::show_menu $top $ii
                break
            }
        }
    }

    proc {::menu_edit::new_item} {top type} {
        global widget

        set indices [$top.MenuListbox curselection]
        set index [lindex $indices 0]

        if {$index == ""} return

        set listboxitems [set ::${top}::listboxitems]

        set reference [lindex $listboxitems $index]

        set menu [lindex $reference end-1]
        set pos  [lindex $reference end]

        if {$pos != -1} {
            set mtype [$menu type $pos]
            if {$mtype == "cascade"} {
                set menu [$menu entrycget $pos -menu]
            }
        }

        switch $type {
            "cascade" {
                set nmenu [vTcl:new_widget_name menu $menu]
                menu $nmenu -tearoff 0
                vTcl:widget:register_widget $nmenu -tearoff
                vTcl:setup_vTcl:bind $nmenu
                $menu add $type -label "New cascade" -menu $nmenu
                vTcl:init_wtree
                vTcl:active_widget $nmenu
                foreach def {-activebackground -activeforeground
                             -background -foreground -font} {
                    vTcl:prop:default_opt $nmenu $def vTcl(w,opt,$def)
                }
                vTcl::widgets::saveSubOptions $menu -label -menu
            }
            "command" {
                $menu add $type -label "New command"  \
                    -command "\# TODO: Your menu handler here"
                vTcl::widgets::saveSubOptions $menu -label -command
            }
            "radiobutton" {
                set toplevel [findToplevel $menu]
                $menu add $type -label "New radio"  \
                    -command "\# TODO: Your menu handler here" \
                    -variable ::${toplevel}::menuSelectedButton
                vTcl::widgets::saveSubOptions $menu -label -command -variable
            }
            "checkbutton" {
                set num 1
                set toplevel [findToplevel $menu]
                while {[info exists ::${toplevel}::check${num}]} {incr num}

                $menu add $type -label "New check"  \
                    -command "\# TODO: Your menu handler here" \
                    -variable ::${toplevel}::check${num}
                set ::${toplevel}::check${num} 1
                vTcl::widgets::saveSubOptions $menu -label -command -variable
            }
            "separator" {
                $menu add $type
            }
        }

        ::menu_edit::fill_menu_list $top [set ::${top}::menu]
    }

    proc findToplevel {menu} {
        set toplevel [winfo toplevel $menu]
        while {[winfo class $toplevel] != "Toplevel"} {
            set toplevel [winfo parent $toplevel]}
        return $toplevel
    }

    proc {::menu_edit::post_context_new_menu} {top X Y} {
        global widget

        tk_popup $widget($top,NewMenuContextPopup) $X $Y
    }


    proc {::menu_edit::post_new_menu} {top} {
        global widget

        set x [winfo rootx  $widget($top,NewMenu)]
        set y [winfo rooty  $widget($top,NewMenu)]
        set h [winfo height $widget($top,NewMenu)]

        tk_popup $widget($top,NewMenuToolbarPopup)  $x [expr $y + $h]
    }

    ## get initial values for the checkboxes
    proc initBoxes {top m} {
        variable target

        set nm ::widgets::${m}::subOptions
        namespace eval $nm {}

        ## first time ? if so, check values that are not the default
        if {![info exists ${nm}::save]} {
            ## how many subitems ?
            set size [$m index end]
            if {$size == "none"} {
                return
            }

            for {set i 0} {$i <= $size} {incr i} {
                set conf [$m entryconfigure $i]
                foreach opt $conf {
		        set option  [lindex $opt 0]
                    set default [lindex $opt 3]
		        set value   [lindex $opt 4]
		        if {$value != $default} {
		            set ${nm}::save($option) 1
                    }
                }
            }
	  }
    }

    proc {::menu_edit::show_menu} {top index} {
        global widget

        set name ::${top}::listboxitems
        eval set reference $\{$name\}

        set reference [lindex $reference $index]
        set m [lindex $reference end-1]
        set i [lindex $reference end]

        if {$i == -1} {
            enableProperties $top 0
            set ::${top}::current_menu  $m
            set ::${top}::current_index $i
            ::menu_edit::enable_toolbar_buttons $top
            return
        }

        set mtype  [$m type $i]

        set ::${top}::current_menu  $m
        set ::${top}::current_index $i
        set ::${top}::listbox_index $index

        initBoxes $top $m
        fillProperties $top $m $i

        ::menu_edit::enable_toolbar_buttons $top
    }

    proc setGetBox {top option {var {}}} {
        set m [set ::${top}::current_menu]
        set i [set ::${top}::current_index]
        if {$m == "" || $i == ""} {return}

        set nm ::widgets::${m}::subOptions
        if {$var != ""} {
            set ${nm}::save($option) [set $var]
        } else {
            if {[info exists ${nm}::save($option)]} {
                return [set ${nm}::save($option)]
            } else {
                return 0
            }
        }
    }

    proc keyRelease {top option var boxvar} {
        set m [set ::${top}::current_menu]
        set i [set ::${top}::current_index]
        if {$m == "" || $i == ""} {return}

	  set conf [$m entryconfigure $i $option]
        set default [lindex $conf 3]
        set value [set $var]

        if {$value != $default} {
	      set $boxvar 1
            setGetBox $top $option $boxvar
        }
    }

    proc discoverOptions {} {
        menu .m -tearoff 0
        .m add cascade -menu ".m.cascade" -label "test"
        menu .m.cascade -tearoff 0
        set options [.m entryconfigure 0]

        .m.cascade add command -label "command"
        set options [concat $options [.m.cascade entryconfigure 0]]

        .m.cascade add radiobutton -label "command"
        set options [concat $options [.m.cascade entryconfigure 1]]

        .m.cascade add checkbutton -label "command"
        set options [concat $options [.m.cascade entryconfigure 2]]

        .m.cascade add separator
        set options [concat $options [.m.cascade entryconfigure 3]]

        destroy .m.cascade
        destroy .m

        set optionsList ""
        foreach option $options {
            lappend optionsList [lindex $option 0]
        }
        return [lsort -unique $optionsList]
    }

    proc checkAttribute {m option checkVar} {
        set nm ::widgets::${m}::subOptions
        if {[info exists ${nm}::save($option)]} {
            set $checkVar [set ${nm}::save($option)]
        } else {
            set $checkVar 0
        }
    }

    proc fillProperties {top m i} {
        upvar ::${top}::enableData enableData
        upvar ::${top}::allOptions allOptions

        set properties [$m entryconfigure $i]
        set currentOptions ""

        foreach property $properties {
            set option [lindex $property 0]
            set value  [lindex $property 4]
            set variable ::${top}::optionsValues($option)
            set $variable $value
            lappend currentOptions $option
        }

        foreach option $allOptions($top) {
            set variable ::${top}::optionsValues($option)
            set f [$top.MenuCanvas].f.$option

            # first uncheck the box, then check it if needed
            set checkVar [::vTcl::ui::attributes::getCheckVariable $f $option]
            set $checkVar 0

            # enable/disable option if it does/does not apply to subitem
            if {[lsearch -exact $currentOptions $option] == -1} {
                ::vTcl::ui::attributes::enableAttribute $enableData($top,$option) 0
            } else {
                ::vTcl::ui::attributes::enableAttribute $enableData($top,$option) 1

                checkAttribute $m $option $checkVar
            }
        }

        ## make sure the -command option substitutes %widget and %top with the
        ## correct value
        set f [$top.MenuCanvas].f.-command
        ::vTcl::ui::attributes::setCommandTarget $f -command $m
    }

    proc enableProperties {top enable} {
        upvar ::${top}::enableData enableData
        upvar ::${top}::allOptions allOptions

        foreach option $allOptions($top) {
            ::vTcl::ui::attributes::enableAttribute $enableData($top,$option) $enable
        }
    }

    proc configCmd {top option variable} {
        set m [set ::${top}::current_menu]
        set i [set ::${top}::current_index]
        if {$m == "" || $i == ""} {return}

        $m entryconfigure $i $option [set $variable]

        if {$option == "-label" || $option == "-accelerator"} {
            ::menu_edit::fill_menu_list $top [set ::${top}::menu]
        }
    }

    proc initProperties {top m} {
        upvar ::${top}::enableData enableData
        upvar ::${top}::allOptions allOptions

        set options [discoverOptions]
        set allOptions($top) $options

        set target($top) $m

        foreach option $options {
            set variable ::${top}::optionsValues($option)
            set $variable ""
            set f [$top.MenuCanvas].f.$option
            if {[winfo exists $f]} {destroy $f}
            frame $f
            set config_cmd "::menu_edit::configCmd $top $option $variable"
            set enableData($top,$option) \
                [::vTcl::ui::attributes::newAttribute  $target($top) $f \
                 $option $variable $config_cmd  \
                 "::menu_edit::setGetBox $top"  \
                 "::menu_edit::keyRelease $top"]
            pack $f -side top -fill x -expand 0
            ::vTcl::ui::attributes::enableAttribute $enableData($top,$option) 0
        }

        ## calculate the scrolling region
        update idletasks
        set w [winfo width  [$top.MenuCanvas].f]
        set h [winfo height [$top.MenuCanvas].f]
        ${top}.MenuCanvas configure -scrollregion [list 0 0 $w $h]
    }

    proc {::menu_edit::toggle_tearoff} {top} {
        set indices [$top.MenuListbox curselection]
        set index   [lindex $indices 0]

        if {$index == ""} return

        set m ""
        set i ""

        ::menu_edit::get_menu_index $top $index m i

        set mtype [$m type $i]
        if {$mtype != "cascade"} return

        set submenu [$m entrycget $i -menu]
        if {$submenu == ""} return

        set tearoff [$submenu cget -tearoff]
        set tearoff [expr 1-$tearoff]
        $submenu configure -tearoff $tearoff

        ::menu_edit::fill_menu_list $top [set ::${top}::menu]
        ::menu_edit::show_menu $top $index
    }

    proc {::menu_edit::update_current} {top} {
        ::vTcl::ui::attributes::setPending
    }

    proc {::menu_edit::close_all_editors} {} {

        variable menu_edit_windows

        set wnds $menu_edit_windows

        foreach wnd $wnds {
            destroy $wnd
        }

        set menu_edit_windows ""
    }

    proc {::menu_edit::browse_image} {top} {
        set image [set ::${top}::entry_image]
        set r [vTcl:prompt_user_image2 $image]
        set ::${top}::entry_image $r
    }

    proc {::menu_edit::browse_font} {top} {
        set font [set ::${top}::entry_font]
        set r [vTcl:font:prompt_noborder_fontlist $font]
        if {$r != ""} {
            set ::${top}::entry_font $r
        }
    }

    proc {::menu_edit::click_listbox} {top} {

        ::menu_edit::update_current $top

        set indices [$top.MenuListbox curselection]
        set index [lindex $indices 0]

        if {$index != ""} {
            ::menu_edit::show_menu $top $index
        }
    }

    proc {::menu_edit::ask_delete_menu} {top} {

        if {[::vTcl::MessageBox -message {Delete menu ?} \
                           -title {Menu editor} -type yesno] == "yes"} {
            ::menu_edit::delete_item $top
        }
    }

    proc {::menu_edit::includes_menu} {top m} {

        # is it the root menu?
        if {[set ::${top}::menu] == $m} {
            return 0}

        set size [$top.MenuListbox index end]

        for {set i 0} {$i < $size} {incr i} {

            set mm ""
            set mi ""

            ::menu_edit::get_menu_index $top $i mm mi

            if {$mm != "" && $mi != -1 &&
                [$mm type $mi] == "cascade" &&
                [$mm entrycget $mi -menu] == $m} then {
                return $i
            }
        }

        # oh well
        return -1
    }

    ## check if the menu to edit is a submenu in an already open
    ## menu editor, and if so, open that menu editor
    proc {::menu_edit::open_existing_editor} {m} {

        # let's check each menu editor
        variable menu_edit_windows

        foreach top $menu_edit_windows {

            set index [::menu_edit::includes_menu $top $m]

            if {$index != -1} {
                Window show $top
                raise $top
                $top.MenuListbox selection clear 0 end
                $top.MenuListbox selection set $index
                $top.MenuListbox activate $index
                ::menu_edit::show_menu $top $index
                return 1
            }
        }

        return 0
    }

    proc {::menu_edit::is_open_existing_editor} {m} {
        # let's check each menu editor
        variable menu_edit_windows

        foreach top $menu_edit_windows {

            if {[::menu_edit::includes_menu $top $m] != -1} then {
                return $top
            }
        }

        return ""
    }

    ## refreshes the menu editor
    proc {::menu_edit::refreshes_existing_editor} {top} {

        ::menu_edit::fill_menu_list $top [set ::${top}::menu]

        $top.MenuListbox selection clear 0 end
        $top.MenuListbox selection set 0
        $top.MenuListbox activate 0
        ::menu_edit::show_menu $top 0
    }

    ## finds the root menu of the given menu
    proc {::menu_edit::find_root_menu} {m} {

        # go up until we find something that is not a menu
        set parent $m
        set lastparent $m

        while {[vTcl:get_class $parent] == "Menu"} {
            set lastparent $parent

            set items [split $parent .]
            set parent [join [lrange $items 0 [expr [llength $items] - 2] ] . ]
        }

        return $lastparent
    }

} ; # namespace eval

proc vTclWindow.vTclMenuEdit {base menu} {

    ##################################
    # OPEN EXISTING EDITOR IF POSSIBLE
    ##################################
    if {[::menu_edit::open_existing_editor $menu]} then {
        return }

    # always open a menu editor with root menu
    set original_menu $menu
    set menu [::menu_edit::find_root_menu $menu]

    global widget vTcl

    if {[winfo exists $base]} {
        wm deiconify $base; return
    }

    namespace eval $base {
        variable listboxitems  ""
        variable current_menu  ""
        variable current_index ""
        variable listbox_index ""
        variable enableData
        variable allOptions
        array set enableData {}
        array set allOptions {}
    }

    ###################
    # DEFINING ALIASES
    ###################
    vTcl:DefineAlias $base.cpd24.01.cpd25.01 MenuListbox vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.cpd24.01.cpd25.01.m24 NewMenuToolbarPopup vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.cpd24.01.cpd25.01.m25 NewMenuContextPopup vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.fra21.but21 NewMenu vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.fra21.but22 DeleteMenu vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.fra21.but23 MoveMenuUp vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.fra21.but24 MoveMenuDown vTcl:WidgetProc $base 1
    vTcl:DefineAlias $base.fra21.but22 MenuOK vTcl:WidgetProc $base 1

    ###################
    # CREATING WIDGETS
    ###################
    toplevel $base -class Toplevel -menu $base.m22
    wm overrideredirect $base 0
    wm focusmodel $base passive
    wm geometry $base 550x450+323+138
    wm withdraw $base
    wm maxsize $base 1284 1010
    wm minsize $base 100 1
    wm resizable $base 1 1
    wm title $base "Menu editor"
    wm transient $base .vTcl

    menu $base.m22 -tearoff 0 -relief flat
    $base.m22 add cascade \
        -menu "$base.m22.men23" -label Insert
    $base.m22 add cascade \
        -menu "$base.m22.men24" -label Delete
    $base.m22 add cascade \
        -menu "$base.m22.men36" -label Move
    menu $base.m22.men23 -tearoff 0
    $base.m22.men23 add command \
        -command "::menu_edit::new_item $base command" \
        -label {New command}
    $base.m22.men23 add command \
        -command "::menu_edit::new_item $base cascade" \
        -label {New cascade}
    $base.m22.men23 add command \
        -command "::menu_edit::new_item $base separator" \
        -label {New separator}
    $base.m22.men23 add command \
        -command "::menu_edit::new_item $base radiobutton" \
        -label {New radio}
    $base.m22.men23 add command \
        -command "::menu_edit::new_item $base checkbutton" \
        -label {New check}
    menu $base.m22.men24 -tearoff 0  \
        -postcommand "$base.m22.men24 entryconfigure 0 -state \
            \[set ::${base}::uistate(DeleteMenu)\]"
    $base.m22.men24 add command \
        -command "::menu_edit::ask_delete_menu $base" \
        -label {Selected item...}
    menu $base.m22.men36 -tearoff 0 \
        -postcommand "$base.m22.men36 entryconfigure 0 -state \
            \[set ::${base}::uistate(MoveMenuUp)\]
            $base.m22.men36 entryconfigure 1 -state \
            \[set ::${base}::uistate(MoveMenuDown)\]"
    $base.m22.men36 add command \
        -command "::menu_edit::move_item $base up" \
        -label Up
    $base.m22.men36 add command \
        -command "::menu_edit::move_item $base down" \
        -label Down

    frame $base.fra21 \
        -borderwidth 2 -height 75 -width 125
    ::vTcl::OkButton $base.fra21.but32 \
	-command "::menu_edit::update_current $base; destroy $base"
    frame $base.cpd24 \
        -background #000000 -height 100 -width 200
    frame $base.cpd24.01 \
        -background #9900991B99FE
    vTcl:toolbar_label $base.fra21.but21 \
        -image [vTcl:image:get_image "add.gif"]
    bind $base.fra21.but21 <ButtonPress-1> {
        ::menu_edit::post_new_menu [winfo toplevel %W]
    }
    ::vTcl::CancelButton $base.fra21.but22 \
	-command "::menu_edit::ask_delete_menu $base"
    vTcl:toolbar_button $base.fra21.but23 \
        -command "::menu_edit::move_item $base up" -image up
    vTcl:toolbar_button $base.fra21.but24 \
        -command "::menu_edit::move_item $base down" -image down

    ScrolledWindow $base.cpd24.01.cpd25
    listbox $base.cpd24.01.cpd25.01 -background white
    $base.cpd24.01.cpd25 setwidget $base.cpd24.01.cpd25.01

    bindtags $base.cpd24.01.cpd25.01 \
        "Listbox $base.cpd24.01.cpd25.01 $base all"
    bind $base.cpd24.01.cpd25.01 <Button-1> {
        focus %W
    }
    bind $base.cpd24.01.cpd25.01 <<ListboxSelect>> {
        ::menu_edit::click_listbox [winfo toplevel %W]
        after idle {focus %W}
    }
    bind $base.cpd24.01.cpd25.01 <ButtonRelease-3> {
        ::menu_edit::update_current [winfo toplevel %W]

        set index [%W index @%x,%y]
        %W selection clear 0 end
        %W selection set $index
        %W activate $index

        if {$index != ""} {
            ::menu_edit::show_menu [winfo toplevel %W] $index
        }

        ::menu_edit::post_context_new_menu [winfo toplevel %W] %X %Y
    }
    menu $base.cpd24.01.cpd25.01.m24 \
        -activeborderwidth 1 -tearoff 0
    $base.cpd24.01.cpd25.01.m24 add command \
        -accelerator {} -command "::menu_edit::new_item $base command" \
        -label {New command}
    $base.cpd24.01.cpd25.01.m24 add command \
        -accelerator {} -command "::menu_edit::new_item $base cascade" \
        -label {New cascade}
    $base.cpd24.01.cpd25.01.m24 add command \
        -accelerator {} -command "::menu_edit::new_item $base separator" \
        -label {New separator}
    $base.cpd24.01.cpd25.01.m24 add command \
        -accelerator {} \
        -command "::menu_edit::new_item $base radiobutton" \
        -label {New radio}
    $base.cpd24.01.cpd25.01.m24 add command \
        -accelerator {} \
        -command "::menu_edit::new_item $base checkbutton" \
        -label {New check}
    menu $base.cpd24.01.cpd25.01.m25 \
        -activeborderwidth 1 -tearoff 0 \
        -postcommand "$base.cpd24.01.cpd25.01.m25 entryconfigure 8 -state \
            \[set ::${base}::uistate(Tearoff)\]"
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} -command "::menu_edit::new_item $base command" \
        -label {New command}
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} -command "::menu_edit::new_item $base cascade" \
        -label {New cascade}
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} -command "::menu_edit::new_item $base separator" \
        -label {New separator}
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} \
        -command "::menu_edit::new_item $base radiobutton" \
        -label {New radio}
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} \
        -command "::menu_edit::new_item $base checkbutton" \
        -label {New check}
    $base.cpd24.01.cpd25.01.m25 add separator
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} \
        -command "::menu_edit::ask_delete_menu $base" \
        -label Delete...
    $base.cpd24.01.cpd25.01.m25 add separator
    $base.cpd24.01.cpd25.01.m25 add command \
        -accelerator {} -command "::menu_edit::toggle_tearoff $base" \
        -label Tearoff
    frame $base.cpd24.02

    ScrolledWindow $base.cpd24.02.scr84
    canvas $base.cpd24.02.scr84._grid.f.can85 \
        -highlightthickness 0 -yscrollincrement 20 -closeenough 1.0 
    vTcl:DefineAlias "$base.cpd24.02.scr84._grid.f.can85" "MenuCanvas" vTcl:WidgetProc $base 1
    $base.cpd24.02.scr84 setwidget $base.cpd24.02.scr84._grid.f.can85

    frame $base.cpd24.03 \
        -background #ff0000 -borderwidth 2 -relief raised
    bind $base.cpd24.03 <B1-Motion> {
        set root [ split %W . ]
        set nb [ llength $root ]
        incr nb -1
        set root [ lreplace $root $nb $nb ]
        set root [ join $root . ]
        set width [ winfo width $root ].0

        set val [ expr (%X - [winfo rootx $root]) /$width ]

        if { $val >= 0 && $val <= 1.0 } {

            place $root.01 -relwidth $val
            place $root.03 -relx $val
            place $root.02 -relwidth [ expr 1.0 - $val ]
        }
    }
    ###################
    # SETTING GEOMETRY
    ###################
    pack $base.fra21 \
        -in $base -anchor center -expand 0 -fill x -side top
    pack $base.fra21.but32 \
        -in $base.fra21 -anchor center -expand 0 -fill none -side right
    pack $base.cpd24 \
        -in $base -anchor center -expand 1 -fill both -side top
    place $base.cpd24.01 \
        -x 0 -y 0 -width -1 -relwidth 0.6 -relheight 1 -anchor nw \
        -bordermode ignore
    pack $base.fra21.but21 \
        -in $base.fra21 -anchor center -expand 0 -fill none \
        -side left
    pack $base.fra21.but22 \
        -in $base.fra21 -anchor center -expand 0 -fill none \
        -side left
    pack $base.fra21.but23 \
        -in $base.fra21 -anchor center -expand 0 -fill none \
        -side left
    pack $base.fra21.but24 \
        -in $base.fra21 -anchor center -expand 0 -fill none \
        -side left
    pack $base.cpd24.01.cpd25 \
        -in $base.cpd24.01 -anchor center -expand 1 -fill both -side top
    pack $base.cpd24.01.cpd25.01
    place $base.cpd24.02 \
        -x 0 -relx 1 -y 0 -width -1 -relwidth 0.4 -relheight 1 -anchor ne \
        -bordermode ignore
    pack $base.cpd24.02.scr84 \
        -in $base.cpd24.02 -anchor center -expand 1 -fill both -side top 
    place $base.cpd24.03 \
        -x 0 -relx 0.6 -y 0 -rely 0.9 -width 10 -height 10 -anchor s \
        -bordermode ignore

    vTcl:set_balloon $widget($base,NewMenu) \
        "Create a new menu item or a new submenu"
    vTcl:set_balloon $widget($base,DeleteMenu) \
        "Delete an existing menu item or submenu"
    vTcl:set_balloon $widget($base,MoveMenuUp) \
        "Move menu up"
    vTcl:set_balloon $widget($base,MoveMenuDown) \
        "Move menu down"

    frame [$base.MenuCanvas].f
    $base.MenuCanvas create window 0 0 -window [$base.MenuCanvas].f -anchor nw -tag properties

    array set ::${base}::uistate {
        DeleteMenu disabled  MoveMenuUp disabled MoveMenuDown disabled
        Tearoff disabled
    }

    #############################
    # FILL IN MENU EDITOR WIDGETS
    #############################

    # initializes menu editor
    ::menu_edit::initProperties $base $menu
    ::menu_edit::fill_menu_list $base $menu

    # keep a record of open menu editors
    lappend ::menu_edit::menu_edit_windows $base

    # initial selection
    set initial_index [::menu_edit::includes_menu $base $original_menu]
    if {$initial_index == -1} {
        set initial_index 0
    }

    $base.MenuListbox selection clear 0 end
    $base.MenuListbox selection set $initial_index
    $base.MenuListbox activate $initial_index
    ::menu_edit::click_listbox $base

    # when a menu editor is closed, should be removed from the list
    bind $base <Destroy> {

        set ::menu_edit::index \
            [lsearch -exact ${::menu_edit::menu_edit_windows} %W]

        if {${::menu_edit::index} != -1} {
            set ::menu_edit::menu_edit_windows \
                [lreplace ${::menu_edit::menu_edit_windows} \
                    ${::menu_edit::index} ${::menu_edit::index}]

            # clean up after ourselves
            namespace delete %W
        }
    }

    #######################
    # KEYBOARD ACCELERATORS
    #######################

    vTcl:setup_vTcl:bind $base

    # ok, let's add a special tag to override the <KeyPress-Delete> mechanism
    bindtags $widget($base,MenuListbox) \
        "_vTclMenuDelete [bindtags $widget($base,MenuListbox)]"

    bind _vTclMenuDelete <KeyPress-Delete> {

        ::menu_edit::ask_delete_menu [winfo toplevel %W]

        # we stop processing here so that Delete does not get processed
        # by further binding tags, which would have the quite undesirable
        # effect of deleting the current toplevel...

        break
    }

    wm deiconify $base
}




