# $Id: menu.wgt,v 1.13 2002/11/03 08:19:37 cgavin Exp $

##############################################################################
#
# Visual TCL - A cross-platform application development environment
#
# Copyright (C) 2001 Damon Courtney
#
# Description file for Tk Widget
#
# 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.

##############################################################################

# Menu edit code is located in menus.tcl

Class       Menu
Lib         core

Icon        icon_menu.gif
TreeLabel   @vTcl::widgets::core::menu::getWidgetTreeLabel
# DefaultOptions -background \$vTcl(actual_gui_menu_bg) -compound left
DefaultOptions -compound left -activeforeground black -activebackground #d9d9d9 \
            -background red
NewOption -menuspecial      "menu"          menuspecial
NewOption -tearoff          "tearoff"       boolean "0 1"
NewOption -postcommand      "post cmd"      command
NewOption -tearoffcommand   "tearoff cmd"   command
NewOption -title            "title"         type

DumpCmd       vTcl::widgets::core::menu::dumpCmd
DumpInfoCmd   vTcl::widgets::core::menu::dumpInfoCmd
DeleteCmd     vTcl::widgets::core::menu::deleteMenu
GetImagesCmd  vTcl::widgets::core::menu::getImagesCmd
GetFontsCmd   vTcl::widgets::core::menu::getFontsCmd

DoubleClickCmd  vTcl::widgets::core::menu::dblClkCmd

Function        "Edit Menu..."     vTcl::widgets::core::menu::editMenu

namespace eval vTcl::widgets::core::menu {

    proc editMenu {} {
        # Menu editing has code in three files. The menu editor itself
        # vTclWindow.vTclMenuEdit and most of the code is in
        # menus.tcl. The attribute stuff ::ui:attributes is located in
        # misc.tcl. The starting point seems to be in
        # vTcl:edit_target_menu located in lib_core.tcl.
        dblClkCmd $::vTcl(w,widget)
    }

    proc dblClkCmd {target} {
        global vTcl
        set class $vTcl(w,class)
        if {$class == "Menu"} {
            #if {[string first "pop" $target] > -1} {}
            #set base ".vTcl.menu_popup"
            #set menu  "new"  ;# NOT CORRECT
            set base $vTcl(w,insert)
            #vTclWindow.vTclMenuEdit $base $target  ;# In menus.tcl
            vTcl:edit_menu $target
        } else {
            set vTcl(w,opt,-menu) [$target cget -menu]
            vTcl:edit_target_menu $target
        }

        # this is necessary for the -menu option to be set right now
        update

        vTcl:prop:save_opt $target -menu vTcl(w,opt,-menu)
    }


    proc getWidgetTreeLabel {target} {
        global vTcl
        global widget
        # Special case - a real hack - for popup menus.  Rozen
        if {[string first "pop" $target] > -1} {
            return "Context Menu - $widget(rev,$target)"
            global widname
        }
        set components [split $target .]
        # let's see if the parent is a menu
        set size [llength $components]
        # parent is at least a toplevel
        if {$size <= 3} {
            return "Menubar"
        }
        set parent [lrange $components 0 [expr $size - 2] ]
        set parent [join $parent .]
        if { [vTcl:get_class $parent 1] != "menu" } {
			return "Menu"
        }
        for {set i 0} {$i <= [$parent index end]} {incr i} {
            if { [$parent type $i] != "cascade" } {
                continue
            }
            set menuwindow [$parent entrycget $i -menu]
            if {$menuwindow == $target} {
                return [$parent entrycget $i -label]
            }
        }
        return "Menubar"
    }

    proc deleteMenu {m} {
        # this will be used later
        set editor [::menu_edit::is_open_existing_editor $m]
        ::menu_edit::delete_menu_recurse $m
        # well, this is not enough to destroy the menu itself,
        # we better tell its parent that it's not there as well
        set items [split $m .]
        set items [lrange $items 0 [expr [llength $items] - 2] ]
        set parent [join $items .]
        # now, let's see if the parent contains the child menu (should)
 # 								append result \
# 					   	"$vTcl(tab)set $sitevariable [vTcl:base_name $target]\n"
       set class [vTcl:get_class $parent]
        if {$class == "Toplevel"} then {
                # it's a toplevel, just removes its menu
                $parent configure -menu ""
                # closes any open menu editor for this menu
                if {$editor != ""} {
					destroy $editor}
                return
        }
        if {$class != "Menu"} then return
        set last [$parent index end]
        for {set i 0} {$i <= $last} {incr i} {
                set mtype [$parent type $i]
                if {$mtype != "cascade"} then continue

                set submenu [$parent entrycget $i -menu]
                if {$submenu == $m} then {
                # this is the one
                $parent delete $i
                break
                }
        }
        # now, we will refresh any possibly open menu editor
        if {$editor != ""} {
                ::menu_edit::refreshes_existing_editor $editor
        }
    }

    proc getOption {target option} {
        set result {}
        set size [$target index end]
        if {[vTcl:streq $size "none"]} { return {} }
        for {set i 0} {$i <= $size} {incr i} {
        if {![catch {$target entrycget $i $option} value]} {
                lappend result $value
            }
        }
        return $result
    }

    proc getImagesCmd {target} {
        return [getOption $target -image]
    }

    proc getFontsCmd {target} {
        return [getOption $target -font]
    }

    proc dumpCmd {target basename} {
        global vTcl basenames
        ## discard temporary items
        if {[string first .# $target] >= 0} {
            return ""
        }
		set result ""
        ## first dump the menu widget
        set len [llength [split $target .]]
append result "# add aa target = $target, basename = $basename\n"
        append result [vTcl:dump_widget_opt $target $basename]
append result "# add first menu widget\n"					
		## any entries in the menu?
        set entries [$target index end]
        if {$entries == "none"} {return $result}
        ## then all its submenus
        for {set index 0} {$index <= $entries} {incr index} {
            set conf [$target entryconf $index]
            set type [$target type $index]
            set len [llength [split $target .]]
			switch $type {
                tearoff {}
				separator -
				radiobutton -
				checkbutton -
				command {					
					if {$vTcl(copy)} {
						append result "$vTcl(tab)$basename add $type \\\n"
					} else {
						append result "$vTcl(tab)$basename add $type \\\n"
					}
                    set pairs [vTcl:get_subopts_special $conf $target]
					append result "[vTcl:clean_pairs $pairs]\n"					
					append result "# add 5a\n"					
				}
                cascade {
                    set pairs [vTcl:get_subopts_special $conf $target]
					append result "$vTcl(tab)$basename add $type \\\n" 
					set vTcl(last_widget_name) [vTcl:new_widget_name  "mnu" ""]
					append result \
						[vTcl:new_clean_pairs $pairs "" $basename]\n
append result "# add 1 target = $target\n"
					set base_name \${base}$vTcl(last_widget_name)
					set sitevariable "menusite_[llength [split $target .]]_0"
					append result "$vTcl(tab)\n"
append result "# add 10 base_name = $base_name\n"
					if {$vTcl(copy) && $vTcl(copy_class) eq "Toplevel"} {
						append result "# target = $target\n"
						regexp {^\.top\d+} $target top
						regexp {^\.bor\d+} $target top
						set source_menu [$top cget -menu]
						regsub $top $source_menu "" x
						set vTcl(mbar_name) \${top}${x}
						append result "# add 2\n"
					} elseif {$vTcl(copy) && $vTcl(copy_class) eq "Menu"} {
						regsub {^\.top\d+|^\.bor\d+} $target "" menu
						set vTcl(copy_menu) $menu
						if {$len == 3} {
							append result \
						  "$vTcl(tab)set $sitevariable \$\{target\}\$\{menu\}\n"
						} else {
							append result \
								"$vTcl(tab)set $sitevariable $vTcl(copy_name)\n"
						}
						set vTcl(old_sitevariable) $sitevariable
						set b $sitevariable
						append result "# add 3\n"			
					} elseif {$vTcl(copy) && \
							   $vTcl(copy_class) in "TMenubutton Menubutton"} {
						# ######################################################
						# set base_name \${base}$vTcl(last_widget_name)
						set base_name \${base}$vTcl(last_widget_name)

					} elseif {$vTcl(copy) && $vTcl(copy_class) eq "Popupmenu"} {
						set base_name \${base}$vTcl(last_widget_name)
					}
					if {$vTcl(copy)} {
						# append result \
						# 	"set $sitevariable  \$top\n"
						append result \
						    "set $sitevariable  \$target\n"
append result "# add first target = $target\n"
						# append result \
							"set $sitevariable [vTcl:base_name $target]\n"
					} else {
						append result \
							"set $sitevariable [vTcl:base_name $target]\n"
append result  "# add second sitevariable = $sitevariable\n"
					}
append result "# add 4.1\n"					
					set copy_name \$$sitevariable$vTcl(last_widget_name)
					set vTcl(copy_name) $copy_name
					set basenames($target) \$$sitevariable

					## dump menu recursively
					set childMenu [$target entrycget $index -menu]
					set childBasename [vTcl:base_name $childMenu]

                    if {$vTcl(copy)} {
						set childBasename $copy_name
					}
append result "# add 4.2 childMenu = $childMenu, childBasename = "\
						"childBasename\n"	
					append result [dumpCmd $childMenu $childBasename]
					catch {unset basenames($target)}
				} ;# end of cascade
				default {						
					if {![info exists vTcl(last_widget_name)] } {
						set vTcl(last_widget_name) \
							[vTcl:next_widget_name Mnu ""]
					} 	
					set base_name \${base}$vTcl(last_widget_name)
					if {[regexp {(\.pop\d+)} $vTcl(last_widget_name) chunk]} {
						set base_name \${base}$chunk
					}				
					if {$len == 3 && $vTcl(copy) && \
							$vTcl(copy_class) eq "Menu"} {
						regsub {^\.top\d+|^\.bor\d+} $target "" menu
						set vTcl(copy_menu) $menu
						# set basename \${target}\${menu}
						set basename \${top}\${menu}
					}
					set pairs [vTcl:get_subopts_special $conf $target]
					# append result "$vTcl(tab)$basename add $type \\\n"
					# append result "$vTcl(tab)$base_name add $type \\\n"
					append result "$vTcl(tab)$target add $type \\\n"
					append result "# add 5\n"					
					append result "[vTcl:clean_pairs $pairs]\n"
				} ;# End of default
			}
		}	   
		return $result
    }

    proc dumpInfoCmd {target basename} {
        global vTcl basenames classes
		if {[string first .# $target] >= 0} {
            return ""
        }
        if {$vTcl(copy)} {
            return
        }
        ## first dump the menu widget info
        set result [vTcl:dump:widget_info $target $basename]
        ## any entries in the menu?
        set entries [$target index end]
        if {$entries == "none"} {return $result}
        ## then all its submenus
        for {set index 0} {$index <= $entries} {incr index} {
            set conf [$target entryconf $index]
            set type [$target type $index]
            switch $type {
                cascade {
                    # set sitevariable "site_[llength [split $target .]]_0"
                    set sitevariable \
                     	"menusite_[llength [split $target .]]_$vTcl(mb_count)"
incr vTcl(mb_count)
                    append result "$vTcl(tab)"
                    append result "set $sitevariable [vTcl:base_name $target]\n"
append result "# add third\n"					
                    set basenames($target) \$$sitevariable
                    ## dump menu recursively
                    set childMenu [$target entrycget $index -menu]
                    set childBasename [vTcl:base_name $childMenu]
                    set childClass [vTcl:get_class $childMenu]
                    append result [$classes($childClass,dumpInfoCmd) \
                                       $childMenu $childBasename]
                    catch {unset basenames($target)}
                }
                default {
                }
            }
        }
        return $result
    }
}

