# $Id: toplevel.wgt,v 1.25 2003/04/13 05:48:44 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.

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

Class       Toplevel
Lib     core

Icon        icon_toplevel.gif
#CreateCmd       vTcl:toplevel
CreateCmd       vTcl::widgets::core::toplevel::createCmd
DoubleClickCmd  vTcl::widgets::core::toplevel::dblClkCmd

TreeLabel   @vTcl::widgets::core::toplevel::getWidgetTreeLabel
DumpCmd         vTcl::widgets::core::toplevel::dumpCmd
DumpInfoCmd     vTcl::widgets::core::toplevel::dumpInfoCmd
InsertCmd   vTcl::widgets::core::toplevel::insertCmd
DeleteCmd       vTcl::widgets::core::toplevel::deleteCmd
WidgetProc  vTcl:Toplevel:WidgetProc

global vTcl
# if {$vTcl(pr,chosen_theme) eq "default"} {
# 	DefaultOptions -background \$vTcl(actual_gui_bg)
#     # DefaultValues   -background -highlightbackground -highlightcolor
#     DefaultValues   -background 
# }

#NewOption -title Title type
ClassOption -toptitle
NewOption -toptitle title type              ;# NEEDS WORK toplevel

OptionConfigCmd -toptitle  get    vTcl::widgets::core::toplevel::get_load_cmd
OptionConfigCmd -toptitle update vTcl::widgets::core::toplevel::update_load_cmd
OptionConfigCmd -toptitle config vTcl::widgets::core::toplevel::config_load_cmd

Function        "Edit Menu Bar ..."     vTcl::widgets::core::toplevel::editMenu
# Rozen Since I don't know what these two accomplish I am removing them.
#Function  "Set New Toplevel Geometry" vTcl::widgets::core::toplevel::setNewGeom
#Function   Adjust Size To Children"   vTcl::widgets::core::toplevel::adjustSize

#Function  "Import toplevel widget" vTcl::widgets::core::toplevel::import_toplevel

Export          vTcl:DefineAlias
Export          vTcl:toplevel
Export          vTcl:DoCmdOption
Export          vTcl:FireEvent

proc vTcl:DoCmdOption {target cmd} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## menus are considered toplevel windows
    set parent $target
    while {[winfo class $parent] == "Menu"} {
        set parent [winfo parent $parent]
    }
    regsub -all {\%widget} $cmd $target cmd
    regsub -all {\%top} $cmd [winfo toplevel $parent] cmd

    uplevel #0 [list eval $cmd]
}

proc vTcl:toplevel {args} {
    global vTcl
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.
    uplevel #0 eval toplevel $args
    set target [lindex $args 0]
    namespace eval ::$target {set _modal 0}
}

proc vTcl:Toplevel:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.
    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }
    set command [lindex $args 0]
    set args [lrange $args 1 end]
    switch -- [string tolower $command] {
        "setvar" {
            foreach {varname value} $args {}
            if {$value == ""} {
                return [set ::${w}::${varname}]

            } else {
                return [set ::${w}::${varname} $value]
            }
        }
        "hide" - "show" {
            Window [string tolower $command] $w
        }
        "showmodal" {
            ## modal dialog ends when window is destroyed
            Window show $w; raise $w
            grab $w; tkwait window $w; grab release $w
        }
        "startmodal" {
            ## ends when endmodal called
            Window show $w; raise $w
            set ::${w}::_modal 1
            grab $w; tkwait variable ::${w}::_modal; grab release $w
        }
        "endmodal" {
            ## ends modal dialog started with startmodal, argument is var name
            set ::${w}::_modal 0
            Window hide $w
        }
        default {
            uplevel $w $command $args
        }
    }
}

namespace eval vTcl::widgets::core::toplevel {

    proc createCmd {args} {
        # Function created so that I can set the global
        # vTcl(top_geometry) when I am actually creating the toplevel
        # window of the GUI.
        global rel
        vTcl:toplevel $args  ;# Function in this file.
        set target [lindex $args 0]
        namespace eval ::widgets::${target}::toptitle {}
        namespace eval ::widgets::${target}::options {}
        namespace eval ::widgets::${target}::save    {}
        namespace eval ::widgets::${target}::ClassOption    {}
        set ::vTcl(top_geometry) "new"
        set rel(relx) 0.0
        set rel(rely) 0.0
        set rel(relw) 0.0
        set rel(relh) 0.0
    }

    proc getWidgetTreeLabel {target} {
        # Returns the label which is probably easier for the user to
        # correlate with the actual toplevel.
        global widget
        set label  [wm title $target]
        if {$label == ""} {
            # return  alias
            set label $widget(rev,$target)
        }
        return $label
    }

    proc editMenu {} {
        dblClkCmd $::vTcl(w,widget)
    }

    proc dblClkCmd {target} {
        global vTcl		
		set vTcl(menubar) 1
        vTcl:edit_target_menu $target  ;# In lib_core.tcl

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

        update
#        set vTcl(w,opt,-menu) [$target cget -menu]

        vTcl:prop:save_opt $target -menu vTcl(w,opt,-menu)
#		set vTcl(menubar) 0
    }

    proc setBindings {} {

          bind _TopLevel <<Create>> {
        if {![info exists _topcount]} {set _topcount 0}; incr _topcount
        }

        bind _TopLevel <Destroy> {
            if {[winfo toplevel %W] == "%W"} {incr _topcount -1}
        }

        bind _TopLevel <<DeleteWindow>> {
            if {[set ::%W::_modal]} {
                vTcl:Toplevel:WidgetProc %W endmodal
            } else {
                destroy %W; if {$_topcount == 0} {exit}
            }
        }

        ::widgets_bindings::add_tag_to_tagslist _TopLevel
    }

    proc insertCmd {target} {
        global vTcl
        set count 0
        foreach top $vTcl(tops) {
            if {![regexp {^\.bor} $top]} {
                incr count
            }
        }
        foreach {W H X Y} [split $vTcl(geom_center) "x+"] {}
        set X [expr {$X - (50 * ($count))}]
        set Y [expr {$Y + (50 * ($count))}]
        set location ${W}x${H}+${X}+${Y}
        wm  geometry $target $location
        set vTcl($target,x) $X
        set vTcl($target,y) $Y
        wm protocol $target WM_DELETE_WINDOW "vTcl:hide_top $target"
        if {$vTcl(pr,winfocus) == 1} {
            wm protocol $target WM_TAKE_FOCUS "vTcl:wm_take_focus $target"
        }
        wm title $target "Toplevel $count"
        set ::widgets::${target}::ClassOption(-toptitle) "Toplevel $count"
        set vTcl($target,-toptitle) "Toplevel $count"
        incr vTcl(newtops)
        set vTcl(w,insert) $target
        lappend vTcl(tops) $target
        vTcl:update_top_list
        setBindings
        bindtags $target [concat [bindtags $target] _TopLevel]
        vTcl:FireEvent $target <<Create>>
    }

    proc deleteCmd {target} {
        global vTcl
        set vTcl(tops) [lremove $vTcl(tops) $target]
        destroy $target
        namespace delete ::$target
        vTcl:update_top_list
    }

    proc dumpTop {target} {
        global vTcl
        set output ""
        if {$target == "."} {
            return
        }
        set proc_base $vTcl(winname)$target
        if {![winfo exists $target]} {
            if {[info procs $proc_base] == ""} {
                return ""
            }
            append output [vTcl:dump_proc $proc_base]
            return $output
        }
        if {[winfo class $target] != "Toplevel" && $target != "."} {
            return
        }
        ## vTcl:update_widget_info $target
        append output "\nproc $proc_base \{base\} \{\n"
        append output "$vTcl(tab)global vTcl\n"
        append output "$vTcl(tab)if {\$base == \"\"} {\n"
        append output "$vTcl(tab2)set base $target\n$vTcl(tab)}\n"
        if { $target != "." } {
            append output "$vTcl(tab)if \{\[winfo exists \$base\]\} \{\n"
            append output "$vTcl(tab2)wm deiconify \$base; return\n"
            append output "$vTcl(tab)\}\n"
            append output "$vTcl(tab)set top \$base\n"
            #append output "$vTcl(tab)set site_3_0 \$base\n"
            append output "$vTcl(tab)set target \$base\n"
        }
        if {[wm state $target] == "normal" ||
            [wm state $target] == "iconic" ||
            $target == "."} {
            lappend vTcl(showtops) $target
        }
        incr vTcl(num,index)
	    vTcl:statbar [expr {($vTcl(num,index) * 100) / $vTcl(num,total)}]
	append output "\n############ toplevel.wgt #############################\n"	
        append output [vTcl:dump:widgets $target]
	append output "\n############# Spot ttt ##############################\n"	
        append output "\n$vTcl(tab)vTcl:FireEvent \$base <<Ready>>\n"
        append output "\}\n"
        return $output
    }

    proc dumpProperties {target basename} {
        global vTcl
        set result ""
        foreach i $vTcl(attr,tops) {
            switch $i {
                class {}
                title {
                    append result "$vTcl(tab)wm $i $basename"
                    append result " \"[wm title $target]\"\n"
                }
                toptitle {
                    # I want to put out a block of code that looks like:
#    set toptitle "Toplevel 1"
#    wm title $top $toptitle
#    namespace eval ::widgets::${top}::ClassOption {}
#    set ::widgets::${top}::ClassOption(-toptitle) $toptitle
                    set j title
                    if {[info exists \
							 ::widgets::${target}::ClassOption(-toptitle)]} {
                        set tt [set ::widgets::${target}::ClassOption(-toptitle)]
                        append result \
                        "$vTcl(tab)set toptitle \"[set ::widgets::${target}::ClassOption(-toptitle)]\"\n"
                    } else {
						append result \
                            "$vTcl(tab)set toptitle \"[wm title $target]\"\n"
                            # "$vTcl(tab)set toptitle \"[wm title $target]\"\n"
                    }
                    append result "$vTcl(tab)wm $j \$top \$toptitle\n"
                    append result \
                  "$vTcl(tab)namespace eval ::widgets::\${top}::ClassOption {}\n"
                    append result \
         "$vTcl(tab)set ::widgets::\${top}::ClassOption(-toptitle) \$toptitle\n"
                }
                state {
                    switch [wm state $target] {
                        iconic {
                            append result "$vTcl(tab)wm iconify $basename\n"
                        }
                        normal {
                            append result "$vTcl(tab)wm deiconify $basename\n"
                        }
                        withdrawn {
                            if {$target == "."} {
                                append result "$vTcl(tab)wm withdraw $basename\n"
                            }
                        }
                    }
                }
                geometry {
                    set geom_dump [wm $i $target]
                     # Detemine if I am saving default origin or set origin
                     set dflt_origin $vTcl(w,wm,dflt,origin)
                     if {[info exists ::widgets::${target}::dflt,origin]} {
                         set dflt_origin \
                             [vTcl:at ::widgets::${target}::dflt,origin]
                     }
                    append result "$vTcl(tab)wm $i $basename $geom_dump\n"
                    append result "$vTcl(tab)update\n"
                    # new stuff to save my new geometry settings.
                    # Determine relative position.
                    append result "$vTcl(tab)# set in toplevel.wgt.\n"
                    append result "$vTcl(tab)global vTcl\n"
                    append result "$vTcl(tab)global img_list\n" ;# Rozen 12/20/17
                    append result \
                        "$vTcl(tab)" "set vTcl(save,dflt,origin) $dflt_origin\n"
                }
                default {
                    ## Let's get the current values of the target.
                    set value [wm $i $target]
                    if {$value != ""} {
                        append result "$vTcl(tab)wm $i $basename $value\n"
                    }
                }
            } ; ## switch ...d
        } ; ## foreach ...

        return $result
    }

    proc dumpCmd {target basename} {
        global vTcl classes 
        ## Let's be safe and force wm for toplevel windows.  Just in case...
        set mgr wm
        set opt [$target configure]
		set class [vTcl:get_class $target]
        if {$target != "."} {
            set result "$vTcl(tab)$classes($class,createCmd) "
            append result "$basename"
            append result " -class [winfo class $target]"
            set p [vTcl:get_opts_special $opt $target]
            if {$p != ""} {
				set copy_name ""
				if {$vTcl(copy)} {
					# set copy_name [$target cget -menu]
					# set copy_name ""
					foreach {i var} $p {
						if {$i eq "-menu"} {
							set copy_name $var
							break
						} 
							
					}
				 # append result " \\\n[vTcl:new_clean_pairs $p \"\" $copy_name]\n"
				 append result " \\\n[vTcl:new_clean_pairs $p $target $copy_name]\n"
				} else {
					append result " \\\n[vTcl:clean_pairs $p $target]\n"
				}
            } else {
                append result "\n"
            }
            if {![lempty [wm transient $target]]} {
                append result $vTcl(tab)
                append result "wm transient $basename [wm transient $target]"
                append result "\; update\n"
            }

            if {[wm state $target] == "withdrawn"} {
                append result $vTcl(tab)
                append result "wm withdraw $basename\n"
            }
        }
        append result [dumpProperties $target $basename]
        append result [vTcl:dump_widget_alias $target $basename]
        append result [vTcl:dump_widget_bind $target $basename]
        return $result
    }

    proc dumpInfoCmd {target basename} {
        global vTcl basenames classes
        set basenames($target) $basename
        append out [vTcl:wm:dump_info $target $basename]

        set children [vTcl:get_children $target]
        foreach widget $children {
            set class [vTcl:get_class $widget]
        }
    catch {unset basenames($target)}
    return $out
    }

    # The following 3 procs added for to allow  a new attribute "-toptitle".
    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,-toptitle)]} {
            set v $vTcl($target,-toptitle)
        } else {
            set v ""
        }
        set vTcl(w,opt,-toptitle) $v

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

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

    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 appropriate vTcl variable.
        #regsub {\.bor[1-9]+} $target "\$top" target
        set vTcl($target,-toptitle) $var
        set ::widgets::${target}::ClassOption(-toptitle) $var
        set ::widgets::${target}::options(-toptitle) $var
        set ::widgets::${target}::save(-toptitle) [expr {$var != ""}]
        set ::widgets::${target}::toptitle $var
        wm title $target $var
    }

    proc import_toplevel {} {
        # New command for importing a borrowed toplevel.
        global vTcl
        set toplevel vTcl(w,widget)
        set ret [regexp {\.bor} $toplevel]
        if {!$ret} {
            ::vTcl::MessageBox -icon error \
                -message "Can only import borrowed toplevel widget." \
                -title "Import error"
        }
    }

}





