# $Id: labelframe.wgt,v 1.3 2005/11/14 07:10:58 kenparkerjr 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.

##############################################################################
#this is a merge of label and frame that actually works-glb 10/12/04
#

# Rozen. To get this to work I added TLabelframe to dontDumpChildren in
# vTcl:dump:widgets in dump.tcl.  Rationalized with tile.

Class           TLabelframe
Lib             ttk
CreateCmd   ttk::labelframe
CreateCmd   ::vTcl::widgets::ttk::labelframe::createCmd;# NEEDS WORK panedwindow

Icon            ../lib/Widgets/ttk/labelframe.gif
#DefaultOptions -bd 2 -relief groove -width 125 -height 75 -text
# "Labelframe" Below I made it a bit wider to reasonably display the
# text in a bit larger font.
DefaultOptions  -width 150 -height 75 -text "TLabelframe"
DefaultValues   -background -highlightbackground -highlightcolor
TtkOptions      -background
TtkWidget       yes


#TreeLabel       TLabelframe
TreeLabel   @vTcl::widgets::ttk::labelframe::getWidgetTreeLabel
DoubleClickCmd    vTcl:set_label
DeleteCmd       ::vTcl::widgets::ttk::labelframe::deleteCmd
SelectCmd       ::vTcl::widgets::ttk::labelframe::selectCmd
InsertChildCmd  ::vTcl::widgets::ttk::labelframe::insertChildCmd
DumpCmd         ::vTcl::widgets::ttk::labelframe::dumpCmd
DumpInfoCmd     ::vTcl::widgets::ttk::labelframe::dumpInfoCmd
Insertable

NewOption -class     "class"      type
NewOption -container "container"  boolean
NewOption -visual    "visual"     type
#NewOption -labelanchor "anchor"   choice "nw n ne e se s sw w"

## Right-click menu
Function        "Set Text"  vTcl::widgets::ttk::labelframe::setText
Function  "Set Multiline Text"  vTcl::widgets::ttk::labelframe::setMultilineText

#Function        "Create Compound..."     vTcl::widgets::ttk::frameframe::rightClickCmd

Function "Fill Container"  vTcl::widgets::ttk::labelframe::fill_container

namespace eval ::vTcl::widgets::ttk::labelframe {

	proc createCmd {args} {
		global vTcl
	# 	if {$vTcl(current_theme) eq "default"} {
    # ttk::style configure TLabelframe.Label -foreground $vTcl(actual_gui_fg)
	# ttk::style configure TLabelframe.Label -background $vTcl(actual_gui_bg)
    # ttk::style configure TLabelframe.Label \
	#     -font "$vTcl(actual_gui_font_dft_desc)"
	# 	} else {
			#set class_bg [ttk::style lookup TLabelframe -background]
			#ttk::style configure TLabelframe.Label -background "$class_bg"
			#ttk::style configure TLabelframe.Label \
				-font "$vTcl(actual_gui_font_dft_desc)"
	#	}
		ttk::labelframe {*}$args
	}		

    proc fill_container {} {
         # Rozen function to expand widget to fill container.
         set w $::vTcl(w,widget)
         vTcl:fill_container $w
    }

    proc setText {} {
        # vTcl:set_label $::vTcl(w,widget)
        vTcl:set_text $::vTcl(w,widget)
    }

    proc setMultilineText {} {
        vTcl:set_text $::vTcl(w,widget)
    }

    proc rightClickCmd {} {
        set w $::vTcl(w,widget)
        set newName [vTcl:name_compound $w]
    }

    proc dumpCmd {target basename} {
        global vTcl basenames classes
        set result [vTcl:dump_widget_opt $target $basename]
        set children [vTcl:get_children $target]
        if {$children == ""} {
        ## the frame is empty, don't bother
            return $result
        }

        append result "$::vTcl(tab)"
        set sitevariable "site_[llength [split $target .]]_$vTcl(mb_count)"
        # set sitevariable "site_[llength [split $target .]]_0"
        append result "set $sitevariable $basename\n"
        set basenames($target) \$$sitevariable
        set geometry ""

        foreach i $children {
            set basename [vTcl:base_name $i]
            set basenames($i) $basename
            set class [vTcl:get_class $i]
            append result [$classes($class,dumpCmd) $i $basename]
        if {[info exists ::widgets::${i}::locked] &&
            [set ::widgets::${i}::locked]} {
            append result "$vTcl(tab)vTcl:copy_lock $basename\n"
        }
            append geometry [vTcl:dump_widget_geom $i $basename]
            catch {unset basenames($i)}
            incr vTcl(num,index)
        }
        catch {unset basenames($target)}
        append result $geometry
        return $result
    }

    proc dumpInfoCmd {target basename} {
        global vTcl basenames classes
        set result [vTcl:dump:widget_info $target $basename]

        set children [vTcl:get_children $target]
    if {$children == ""} {
        ## the frame is empty, don't bother
        return $result
    }

        append result "$::vTcl(tab)"
        set sitevariable "site_[llength [split $target .]]_0"
        append result "set $sitevariable $basename\n"
    set basenames($target) \$$sitevariable

    foreach i $children {
            set basename [vTcl:base_name $i]
            set basenames($i) $basename
            set class [vTcl:get_class $i]
            append result [$classes($class,dumpInfoCmd) $i $basename]
            catch {unset basenames($i)}
        }
        catch {unset basenames($target)}
        return $result
    }

    proc containing_megawidget {target} {
        global classes

        set path ""
        if {[vTcl:WidgetVar [winfo parent $target] parent tmp]} {
            set path $tmp
        }

        if {$path == ""} {return ""}

        set class [vTcl:get_class $path]
        if {[info exists classes($class,megaWidget)] &&
            $classes($class,megaWidget)} {

            # it is a megawidget, ask for its childsites
            set childsiteCmd [lindex $classes($class,treeChildrenCmd) 1]

            # no childsites in megawidget ? shouldn't happen at this point but...
            if {$childsiteCmd == ""} {return ""}

            set sites [$childsiteCmd $path]

            # is it a child site of this megawidget ?
            if {[lsearch -exact $sites $target] != -1} {return $path}
        }

        # wasn't a megawidget's childsite
        return ""
    }

    proc deleteCmd {target} {
        global classes

        # Let's go up levels until we find a megawidget. If we
        # find one, we ask for its childsites, and if the frame is
        # one of them, we ask the megawidget to delete it's childsite

        set megawidget [containing_megawidget $target]

        if {$megawidget == ""} {
            destroy $target
            return
        }

        # yes it is a childsite, ask to delete
        set class [vTcl:get_class $megawidget]
        if {$classes($class,deleteSiteCmd) != ""} {

            ## before deleting, get the index
            set childsiteCmd [lindex $classes($class,treeChildrenCmd) 1]
            set sites [$childsiteCmd $megawidget]
            set index [lsearch -exact $sites $target]

            $classes($class,deleteSiteCmd) $megawidget $target
            ::vTcl::notify::publish deleted_childsite $target $index
        }
    }

    proc selectCmd {target} {
        global classes

        set megawidget [containing_megawidget $target]

        if {$megawidget == ""} {
            return
        }

        set class [vTcl:get_class $megawidget]
        if {$classes($class,selectSiteCmd) != ""} {
            $classes($class,selectSiteCmd) $megawidget $target
        }
    }

    proc insertChildCmd {target child} {
        global classes

        set megawidget [containing_megawidget $target]

        if {$megawidget == ""} {
            return
        }

        set class [vTcl:get_class $megawidget]
        if {[info exists classes($class,insertChildCmd)] &&
            ![lempty $classes($class,insertChildCmd)]} {
            $classes($class,insertChildCmd) $megawidget $child
        }
    }
    proc getWidgetTreeLabel {target} {
        set ttt1 [$target cget -text]
        return "TLabelframe: $ttt1"
    }
}


