# $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, Donald Rozenberg 2020
#
# 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.

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

Class       Popupmenu
Lib         core

Icon        icon_menubutton.gif
TreeLabel   @vTcl::widgets::core::popup::getWidgetTreeLabel

DefaultOptions  -font \$vTcl(actual_gui_font_menu_desc)\
  -background \$vTcl(actual_gui_menu_bg) -foreground \$vTcl(actual_gui_menu_fg) \
    -activebackground \$vTcl(analog_color_m) \
    -activeforeground \$vTcl(active_fg) -tearoff 0

NewOption -menuspecial      "menu"          menuspecial
NewOption -tearoff          "tearoff"       boolean "0 1"
NewOption -postcommand      "post cmd"      command
NewOption -tearoffcommand   "tearoff cmd"   command
NewOption -title            "title"         type

ClassOption    -proc
NewOption      -proc "function name" type

# Since popup menus are special cases of menu widgets the Create
# Command can be simply menu,
CreateCmd       vTcl::widgets::core::popup::createCmd
DoubleClickCmd  vTcl::widgets::core::popup::dblClkCmd
DumpCmd       vTcl::widgets::core::popup::dumpCmd
DumpInfoCmd   vTcl::widgets::core::popup::dumpInfoCmd
DeleteCmd     vTcl::widgets::core::popup::deletePopup
GetImagesCmd  vTcl::widgets::core::popup::getImagesCmd
GetFontsCmd   vTcl::widgets::core::popup::getFontsCmd

# The following 3 commands added for to allow  a new attribute "-proc".
OptionConfigCmd -proc get    vTcl::widgets::core::popup::get_load_cmd
OptionConfigCmd -proc update vTcl::widgets::core::popup::update_load_cmd
OptionConfigCmd -proc config vTcl::widgets::core::popup::config_load_cmd

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

namespace eval vTcl::widgets::core::popup {

    proc createCmd {target args} {
        # Rozen. My attempt to support popup menus.
		# The widget prefix "pmu" is assigned in autoPlaceCompound
		# locted in compound.tcl,
        #uplevel #0 eval menu $args
        global vTcl
		namespace eval ::widgets::${target}::proc {}
        namespace eval ::widgets::${target}::options {}
        namespace eval ::widgets::${target}::save    {}
        namespace eval ::widgets::${target}::ClassOption    {}
		regexp {^\.top\d+} $target top
		regexp {^\.bor\d+} $target top
		regexp {^\.pop\d+} $target top
		set vTcl($top,no_popups) [vTcl:count_all_popups $top]
        set var popup$vTcl($top,no_popups)
		set ::widgets::${target}::ClassOption(-proc) $var
		set ::widgets::${target}::save(-proc) 1
		set vTcl($target,-proc) $var
		menu $target {*}$args
	}

    proc getWidgetTreeLabel {target} {
        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 "Context memu"
        }
        set parent [lrange $components 0 [expr $size - 2] ]
        set parent [join $parent .]
        if { [vTcl:get_class $parent 1] != "popup" } {
        return "Context 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 "Pop Menu"
    }

    proc editMenu {} {
        dblClkCmd $::vTcl(w,widget)
    }
    proc dblClkCmd {target} {
        global vTcl
		set vTcl(menubar) 0
        #set vTcl(w,opt,-menu) [$target cget -menu]
        vTcl:edit_target_menu $target
		# this is necessary in order for the -menu option to be set right now
        update
        vTcl:prop:save_opt $target -menu vTcl(w,opt,-menu)
    }

    proc deletePopup {m} {
        # this will be used later
        set editor [::popup_edit::is_open_existing_editor $m]

        ::popup_edit::delete_popup_recurse $m

        # well, this is not enough to destroy the popup 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)

        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 != "Popupmenu"} 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 != ""} {
                ::popup_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]
    }


# New version of dumpCmd. Started as a copy of dumpCmd from menu.wgt.
    proc dumpCmd {target basename} {
        global vTcl basenames
        ## discard temporary items
		if {[string first .# $target] >= 0} {
            return ""
        }
		if {$vTcl(copy)} {
            set vTcl(secondary_copy) 1
			set result [dumpCmd_copy_top $target $basename]
            unset vTcl(secondary_copy) 
			
			return $result
		}
		set result ""
        ## first dump the menu widget
        set len [llength [split $target .]]
append result "# add pa len = $len\n"
append result "# add pa target = $target, basename = $basename\n"
		# if {$len == 4 && $vTcl(copy)} { }
		if {$len == 3 && $vTcl(copy)} {
append result "# add pa3 target = $target, basename = $basename\n"
			append result [dump_popup_menu $basename] "\n"
			# append result [dump_popup_menu $target] "\n"
			# Put out vTcl:DefineAlias statement
			append result [vTcl:dump_widget_alias $target $basename]
		} elseif {$len == 4 && $vTcl(copy)} {
append result "# add pa4 target = $target, basename = $basename\n"
			# append result [dump_popup_menu $basename] "\n"
			# append result [dump_popup_menu $target] "\n"
			append result [vTcl:dump_widget_opt $target $basename]			
		} else {
			append result [vTcl:dump_widget_opt $target $basename]
		}
		
append result "# add first pop\n"
		# 		if {$vTcl(copy)} {
		# append result "\$top configure -menu \${target}\${menu}\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 {}
                cascade {
                    ## to allow option translation
                    set pairs [vTcl:get_subopts_special $conf $target]
                    set sitevariable "site_[llength [split $target .]]_0"
                    append result "$vTcl(tab)\n"
					# ---------------------------------------------------
					if {$vTcl(copy)} {
						if {$vTcl(copy_class) eq "Toplevel"} {
					   # 		if {$len == 3} {
					   # 			append result \
					   # "$vTcl(tab)set $sitevariable [vTcl:base_name $target]\n"
					   # 		} else {
					   # 			append result \
					   # 		   "$vTcl(tab)set $sitevariable $vTcl(copy_name)\n"
					   # 		}
					   # 		set vTcl(old_sitevariable) $sitevariable
					   # 		set b $sitevariable
					   # 		append result "$vTcl(tab)\$$b add $type \\\n" 
					   # 	} elseif {$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 \$\{top\}${menu}
					   # 		set b $sitevariable
					   # 		append result "$vTcl(tab)\$$b add $type \\\n"
					   # 	} elseif {$vTcl(copy_class) eq "Menubutton"} {

						} elseif {$vTcl(copy_class) eq "Popupmenu"} {
####################################################							
							# New stuff added for popup menus starting 10/9/22.
							if {$len == 3} {
								# append result "set $sitevariable \$target\n"

								#append result \
						  "$vTcl(tab)set $sitevariable $vTcl(last_widget_name)\n"
								append result \
						  "$vTcl(tab)set $sitevariable $basename\n"
					        } else {
								# New stuff here. ##########################
								append result \
							   "$vTcl(tab)set $sitevariable $vTcl(copy_name)\n"
							}
							set m [vTcl:new_widget_name Menu ""]
							#append result "$vTcl(tab)set $sitevariable \
								\${target}.$m\n"						
						   # append result "$vTcl(tab)$basename add $type \\\n"
                           append result \
								"$vTcl(tab)\$$sitevariable add $type \\\n"
#####################################################							
						} 

					  set copy_name \$$sitevariable.men[incr vTcl(menu_number)]
						set vTcl(copy_name) $copy_name
						set cleaned_pairs \
							[vTcl:new_clean_pairs $pairs "" $copy_name]
						append result $cleaned_pairs "\n"
						#append result \
							"[vTcl:new_clean_pairs $pairs "" $copy_name]\n"
				    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 "# spot x childMenu = $childMenu 	childBasename = $childBasename\n"
					append result [dumpCmd $childMenu $childBasename]
					catch {unset basenames($target)}
##################################################### End of cascade branch
				} else {
					# Not a copy just a save.
                    set pairs [vTcl:get_subopts_special $conf $target]
                    append result "$vTcl(tab)$basename add $type \\\n"
                    append result "[vTcl:clean_pairs $pairs]\n"
                    set sitevariable "site_[llength [split $target .]]_0"
                    append result "$vTcl(tab)"
                   append result "set $sitevariable [vTcl:base_name $target]\n"
                    set basenames($target) \$$sitevariable
                    ## dump menu recursively
                    set childMenu [$target entrycget $index -menu]
                    set childBasename [vTcl:base_name $childMenu]
					
append result "# spot z childMenu = $childMenu 	childBasename = $childBasename\n"
                    append result [dumpCmd $childMenu $childBasename]
                    catch {unset basenames($target)}
				}					
			} 
			default {
				if {$len == 3 && $vTcl(copy)} {
					regsub {^\.top\d+|^\.bor\d+} $target "" menu
					set vTcl(copy_menu) $menu
					if {$vTcl(copy_class) eq "Toplevel"} {
						set basename \${top}${menu}
					} else {
						if {![info exists vTcl(last_widget_name)] } {
							set vTcl(last_widget_name) \
	                                  [vTcl:next_widget_name Mnu ""]
						}
						# set basename $vTcl(last_widget_name)
						# set basename \${top}${menu}
						set basename \${target}
					}
				}	   		
				set pairs [vTcl:get_subopts_special $conf $target]
				append result "$vTcl(tab)$basename add $type \\\n"
				append result "[vTcl:clean_pairs $pairs]\n"
			}			
		}
	}
	return $result
}

    proc dumpCmd_copy_top {target basename} {
		# We come here to include a popup within a toplevel copy.
        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 pd len = $len\n"
append result "# add pd target = $target, basename = $basename\n"
		if {$len == 3 && $vTcl(copy)} {
			# append result [dump_popup_menu $basename] "\n"
			# append result [dump_popup_menu $target] "\n"
			# Put out vTcl:DefineAlias statement
			# append result [vTcl:dump_widget_alias $target $basename]
			append result \
"
   vTcl::widgets::core::popup::createCmd $basename \\
        -activebackground beige -activeforeground black \\
        -background \$vTcl(actual_gui_menu_bg) \\
        -font \$vTcl(actual_gui_font_menu_desc) \\
        -foreground \$vTcl(actual_gui_menu_fg) -tearoff 0 \n"

			append result \
			"
    set val \$vTcl($basename,-proc)
    set vTcl($basename,-proc) popup1
    regexp {^\.top\d+} $basename top
    regexp {^\.bor\d+} $basename top
    vTcl:context_function_name \$top
    set proc popup\$vTcl(\$top,no_popups)
    namespace eval ::widgets::\${target}::ClassOption    {}
    set ::widgets::\${target}::ClassOption(-proc) \$proc
    set ::widget(rev,$basename) $::widget(rev,$target)
    set vTcl(w,opt,-proc) \$proc
"
append result "# add pt3 target = $target, basename = $basename\n"
		} else {
append result "# add pt4 target = $target, basename = $basename\n"
			set opts ""
			append result \
"
##################

    [vTcl:dump_widget_opt $target $basename] 
##################
"
#    append result [vTcl:dump_widget_opt $target $basename]
			#set sitevariable $basename
			# append result "$vTcl(tab)\$$sitevariable add $type \\\n"
			#append result "$vTcl(tab) $basename add $type \\\n"
		}
			# Put out vTcl:DefineAlias statement
			append result [vTcl:dump_widget_alias $target $basename]			

        ## then all its submenus
		## any entries in the menu?
        set entries [$target index end]
		if {$entries == "none"} {return $result}
		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 {
					append result "$vTcl(tab)$basename add $type \\\n"
                    set pairs [vTcl:get_subopts_special $conf $target]
					append result "[vTcl:clean_pairs $pairs]\n"					
				}
				cascade {
                    set pairs [vTcl:get_subopts_special $conf $target]
                    set sitevariable "site_[llength [split $target .]]_0"
					append result "$vTcl(tab)\n"
					append result \
						"$vTcl(tab)set $sitevariable $basename\n"
					# append result  "$vTcl(tab)\$$sitevariable add $type \\\n"
					append result  "$vTcl(tab)\$$sitevariable add cascade \\\n"
					set copy_name \$$sitevariable.men$vTcl(menu_number)
					incr vTcl(menu_number)
					set vTcl(copy_name) $copy_name
					set  vTcl(last_widget_name)  $copy_name
					set cleaned_pairs \
						[vTcl:new_clean_pairs $pairs "" $copy_name]
					append result $cleaned_pairs "\n"
					## dump menu recursively
				    set childMenu [$target entrycget $index -menu]
				    set childBasename [vTcl:base_name $childMenu]
                    if {$vTcl(copy)} {
				     	set childBasename $copy_name
					}					
append result "# spot x childMenu = $childMenu 	childBasename = $childBasename\n"
					append result [dumpCmd_copy_top $childMenu $childBasename]
				}
				
			} ;# end of switch
		} ;# end of for loop
		
		return $result
		
}

    proc dumpInfoCmd {target basename} {
        ## discard temporary items
        if {[string first .# $target] >= 0} {
            return ""
        }
        global vTcl basenames classes
        ## 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 $isitevariablendex]
            set type [$target type $index]
            switch $type {
                cascade {
                    set sitevariable "site_[llength [split $target .]]_0"
                    append result "$vTcl(tab)"
                    append result "set $sitevariable [vTcl:base_name $target]\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
    }

    # The following 3 procs added for to allow  a new attribute "-proc".
    proc get_load_cmd {target} { ;# NEEDS WORK popup
        # Called by vTcl:widget:register_widget_custom in widget.tcl
        # At this point I don't know what it should return.
        global vTcl
        if {[info exists vTcl($target,-proc)]} {
            set v $vTcl($target,-proc)
        } else {
            set v ""
        }
        set vTcl(w,opt,-proc) $v

        if {![info exists ::widgets::${target}::proc]} {
            # namespace eval ::widgets::${target} {
            #     variable proc
            #     set proc $var
            # }  ;# 8/26/18
            namespace eval ::widgets::${target}:proc {}
        }
        set ::widgets::${target}::proc $v
        return [set ::widgets::${target}::proc]
    }

    proc update_load_cmd {target var} {
        global vTcl
        # Called to load the current vdump_cascade_menualue into the
        # prop manager (propmgr.tcl) What actually get stuffed in the
        # Attribute Editor is vTcl(w,opt,-proc)
        if {[info exists vTcl($target,-proc)]} {
            set [set var] $vTcl($target,-proc)
        } else {
            set [set $var]  ""
        }
        #set ::widgets::${target}::proc $var
        set ::widgets::${target}::proc [set $var]
    }

    proc config_load_cmd {target var} {
        # Called when the value is changed by the prop manager.
        global vTcl
        # I should just store the var in the appropiate vTcl variable.
        regsub {\.bor[1-9]+} $target "\$top" target
        set vTcl($target,-proc) $var
        set ::widgets::${target}::ClassOption(-proc) $var
        set ::widgets::${target}::options(-proc) $var
        set ::widgets::${target}::save(-proc) [expr {$var != ""}]
        # set ::widgets::vTcl(\$top,no_popups)${target}::proc $var
        #set ::widgets::vTcl(\$target,no_popups)${target}::proc $var
        wm title $target $var
        update
    }

    proc dump_popup_menu {target} {
        # Called from dumpCmd above when processing the top of the
        # menu. This is a variation of vTcl:dump_widget_opt. This
        # variation is needed to preserve the popup function name for
        # the Python code generation.
        global vTcl
		#$append str "   menu $target \\\n"
		append str \
"
   vTcl::widgets::core::popup::createCmd \$target \\
        -activebackground beige -activeforeground black \\
        -background \$vTcl(actual_gui_menu_bg) \\
        -font \$vTcl(actual_gui_font_menu_desc) \\
        -foreground \$vTcl(actual_gui_menu_fg) -tearoff 0 \n"

        append str \
"   set val \$vTcl(\$target,-proc)
    set vTcl(\$target,-proc) popup1
		regexp {^\.top\d+} \$target top
		regexp {^\.bor\d+} \$target top
        vTcl:context_function_name \$top
        set proc popup\$vTcl(\$top,no_popups)
	set ::widgets::\${target}::ClassOption(-proc) \$proc
    set vTcl(w,opt,-proc) \$proc"
		return $str
	}

}
