entry.tcl

是TCL的另外一个编译（解释）器

# ------------------------------------------------------------------------------
#  entry.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: entry.tcl,v 1.16 2001/06/11 23:58:40 hobbs Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - Entry::create
#     - Entry::configure
#     - Entry::cget
#     - Entry::_destroy
#     - Entry::_init_drag_cmd
#     - Entry::_end_drag_cmd
#     - Entry::_drop_cmd
#     - Entry::_over_cmd
#     - Entry::_auto_scroll
#     - Entry::_scroll
# ------------------------------------------------------------------------------

namespace eval Entry {

    # Note:  -textvariable is pulled off of the tk entry and put onto the
    # BW Entry so that we avoid the TkResource test for it, which screws up
    # the existance/non-existance bits of the -textvariable.
    set remove  [list -state -cursor -foreground -textvariable]
    set declare [list \
	    [list -foreground		TkResource	""	0 entry] \
	    [list -state	Enum	normal	0 [list normal disabled]] \
	    [list -text			String	""	0] \
	    [list -textvariable		String	""	0] \
	    [list -editable		Boolean	1	0] \
	    [list -command		String	""	0] \
	    [list -relief		TkResource	""	0 entry] \
	    [list -borderwidth		TkResource	""	0 entry] \
	    [list -fg		Synonym		-foreground] \
	    [list -bg		Synonym		-background] \
	    [list -bd		Synonym		-borderwidth] \
	    ]

    if {[package vcompare [package provide Tk] 8.4] >= 0} {
	#
	#   Tk 8.4 added -disabledforeground and -disabledbackground
	#   resources to the entry widget, but the BWidget Entry
	#   handles the 'disabled' state in a different way.
	#
	lappend remove -disabledforeground -disabledbackground
	lappend declare \
	    [list -disabledforeground	TkResource	""	0 entry]
    } else {
	lappend declare \
	    [list -disabledforeground	TkResource	""	0 button]
    }

    Widget::tkinclude Entry entry :cmd remove $remove
    Widget::declare Entry $declare
    Widget::addmap Entry "" :cmd {-textvariable {}}

    DynamicHelp::include Entry balloon
    DragSite::include    Entry "" 3
    DropSite::include    Entry {
        TEXT    {move {}}
        FGCOLOR {move {}}
        BGCOLOR {move {}}
        COLOR   {move {}}
    }

    foreach event [bind Entry] {
        bind BwEntry $event [bind Entry $event]
    }

    # Copy is kind of a special event.  It should be enabled when the
    # widget is editable but not disabled, and not when the widget is disabled.
    # To make this a bit easier to manage, we will handle it separately.

    bind BwEntry <<Copy>> {}
    bind BwEditableEntry <<Copy>> [bind Entry <<Copy>>]

    bind BwEntry <Return>  {Entry::invoke %W}
    bind BwEntry <Destroy> {Entry::_destroy %W}
    bind BwDisabledEntry <Destroy> {Entry::_destroy %W}

    interp alias {} ::Entry {} ::Entry::create
    proc use {} {}
}


# ------------------------------------------------------------------------------
#  Command Entry::create
# ------------------------------------------------------------------------------
proc Entry::create { path args } {
    variable $path
    upvar 0 $path data

    array set maps [list Entry {} :cmd {}]
    array set maps [Widget::parseArgs Entry $args]

    set data(afterid) ""
    eval entry $path $maps(:cmd)
    Widget::initFromODB Entry $path $maps(Entry)
    set state    [Widget::getMegawidgetOption $path -state]
    set editable [Widget::getMegawidgetOption $path -editable]
    set text     [Widget::getMegawidgetOption $path -text]
    if { $editable && ![string compare $state "normal"] } {
        bindtags $path [list $path BwEntry [winfo toplevel $path] all]
        $path configure -takefocus 1
    } else {
        bindtags $path [list $path BwDisabledEntry [winfo toplevel $path] all]
        $path configure -takefocus 0
    }
    if { $editable == 0 } {
        $path configure -cursor left_ptr
    }
    if { ![string compare $state "disabled"] } {
        $path configure -foreground \
		[Widget::getMegawidgetOption $path -disabledforeground]
    } else {
	$path configure -foreground \
		[Widget::getMegawidgetOption $path -foreground]
	bindtags $path [linsert [bindtags $path] 2 BwEditableEntry] 
    }
    if { [string length $text] } {
	set varName [$path cget -textvariable]
	if { ![string equal $varName ""] } {
	    uplevel \#0 [list set $varName [Widget::cget $path -text]]
	} else {
	    set validateState [$path cget -validate]
	    $path configure -validate none
	    $path delete 0 end
	    $path configure -validate $validateState
	    $path insert 0 [Widget::getMegawidgetOption $path -text]
	}
    }	

    DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd 1
    DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd 1
    DynamicHelp::sethelp $path $path 1

    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[Entry::_path_command $path \$cmd \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
#  Command Entry::configure
# ------------------------------------------------------------------------------
proc Entry::configure { path args } {
    # Cheat by setting the -text value to the current contents of the entry
    # This might be better hidden behind a function in ::Widget.
    set Widget::Entry::${path}:opt(-text) [$path:cmd get]

    set res [Widget::configure $path $args]

    # Extract the modified bits that we are interested in.
    foreach {chstate cheditable chfg chdfg chtext} [Widget::hasChangedX $path \
	    -state -editable -foreground -disabledforeground -text] break

    if { $chstate || $cheditable } {
	set state [Widget::getMegawidgetOption $path -state]
	set editable [Widget::getMegawidgetOption $path -editable]
        set btags [bindtags $path]
        if { $editable && ![string compare $state "normal"] } {
            set idx [lsearch $btags BwDisabledEntry]
            if { $idx != -1 } {
                bindtags $path [lreplace $btags $idx $idx BwEntry]
            }
            $path:cmd configure -takefocus 1
        } else {
            set idx [lsearch $btags BwEntry]
            if { $idx != -1 } {
                bindtags $path [lreplace $btags $idx $idx BwDisabledEntry]
            }
            $path:cmd configure -takefocus 0
            if { ![string compare [focus] $path] } {
                focus .
            }
        }
    }

    if { $chstate || $chfg || $chdfg } {
	set state [Widget::getMegawidgetOption $path -state]
        if { ![string compare $state "disabled"] } {
	    set dfg [Widget::cget $path -disabledforeground]
            $path:cmd configure -fg $dfg
        } else {
	    set fg [Widget::cget $path -foreground]
            $path:cmd configure -fg $fg
        }
    }
    if { $chstate } {
	if { ![string compare $state "disabled"] } {
	    set idx [lsearch -exact [bindtags $path] BwEditableEntry]
	    if { $idx != -1 } {
		bindtags $path [lreplace [bindtags $path] $idx $idx]
	    }
	} else {
	    set idx [expr {[lsearch [bindtags $path] Bw*Entry] + 1}]
	    bindtags $path [linsert [bindtags $path] $idx BwEditableEntry]
	}
    }

    if { $cheditable } {
        if { $editable } {
            $path:cmd configure -cursor xterm
        } else {
            $path:cmd configure -cursor left_ptr
        }
    }

    if { $chtext } {
	# Oh my lordee-ba-goordee
	# Do some magic to prevent multiple validation command firings.
	# If there is a textvariable, set that to the right value; if not,
	# disable validation, delete the old text, enable, then set the text.
	set varName [$path:cmd cget -textvariable]
	if { ![string equal $varName ""] } {
	    uplevel \#0 [list set $varName \
		    [Widget::getMegawidgetOption $path -text]]
	} else {
	    set validateState [$path:cmd cget -validate]
	    $path:cmd configure -validate none
	    $path:cmd delete 0 end
	    $path:cmd configure -validate $validateState
	    $path:cmd insert 0 [Widget::getMegawidgetOption $path -text]
	}
    }

    DragSite::setdrag $path $path Entry::_init_drag_cmd Entry::_end_drag_cmd
    DropSite::setdrop $path $path Entry::_over_cmd Entry::_drop_cmd
    DynamicHelp::sethelp $path $path

    return $res
}