widget.tcl

Linux下的MSN聊天程序源码

	    set exports($option) $optionDbName
            set classopt($option) [list TkResource $value $ro \
		    [list $tkwidget $realopt]]
	    set optionClass($option) [lindex [$foo configure $realopt] 1]
	    ::destroy $foo
            continue
        }

	set optionDbName ".[lindex [_configure_option $option ""] 0]"
	option add *${class}${optionDbName} $value widgetDefault
	set exports($option) $optionDbName
        # for any other resource type, we keep original optdesc
        set classopt($option) [list $type $value $ro $arg]
    }
}


proc Widget::define { class filename args } {
    variable ::BWidget::use
    set use($class)      $args
    set use($class,file) $filename
    lappend use(classes) $class

    if {[set x [lsearch -exact $args "-classonly"]] > -1} {
	set args [lreplace $args $x $x]
    } else {
	interp alias {} ::${class} {} ${class}::create
	proc ::${class}::use {} {}

	bind $class <Destroy> [list Widget::destroy %W]
    }

    foreach class $args { ${class}::use }
}


proc Widget::create { class path {rename 1} } {
    if {$rename} { rename $path ::$path:cmd }
    proc ::$path { cmd args } \
    	[subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}]
    return $path
}


# ----------------------------------------------------------------------------
#  Command Widget::addmap
# ----------------------------------------------------------------------------
proc Widget::addmap { class subclass subpath options } {
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::optionExports exports
    upvar 0 ${class}::optionClass optionClass
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::map$subpath submap

    foreach {option realopt} $options {
        if { ![string length $realopt] } {
            set realopt $option
        }
	set val [lindex $classopt($option) 1]
	set optDb ".[lindex [_configure_option $realopt ""] 0]"
	if { ![string equal $subpath ":cmd"] } {
	    set optDb "$subpath$optDb"
	}
	option add *${class}${optDb} $val widgetDefault
	lappend exports($option) $optDb
	# Store the forward and backward mappings for this
	# option <-> realoption pair
        lappend classmap($option) $subpath $subclass $realopt
	set submap($realopt) $option
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::syncoptions
# ----------------------------------------------------------------------------
proc Widget::syncoptions { class subclass subpath options } {
    upvar 0 ${class}::sync classync

    foreach {option realopt} $options {
        if { ![string length $realopt] } {
            set realopt $option
        }
        set classync($option) [list $subpath $subclass $realopt]
    }
}


# ----------------------------------------------------------------------------
#  Command Widget::init
# ----------------------------------------------------------------------------
proc Widget::init { class path options } {
    variable _inuse

    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::$path:opt  pathopt
    upvar 0 ${class}::$path:mod  pathmod
    upvar 0 ${class}::map classmap
    upvar 0 ${class}::$path:init pathinit

    if { [info exists pathopt] } {
	unset pathopt
    }
    if { [info exists pathmod] } {
	unset pathmod
    }
    # We prefer to use the actual widget for option db queries, but if it
    # doesn't exist yet, do the next best thing:  create a widget of the
    # same class and use that.
    set fpath $path
    set rdbclass [string map [list :: ""] $class]
    if { ![winfo exists $path] } {
	set fpath ".#BWidgetClass#$class"
	if { ![winfo exists $fpath] } {
	    frame $fpath -class $rdbclass
	}
    }
    foreach {option optdesc} [array get classopt] {
        set pathmod($option) 0
	if { [info exists classmap($option)] } {
	    continue
	}
        set type [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
	    continue
        }
        if { [string equal $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set optdb [lindex [_configure_option $option $alt] 0]
        set def   [option get $fpath $optdb $rdbclass]
        if { [string length $def] } {
            set pathopt($option) $def
        } else {
            set pathopt($option) [lindex $optdesc 1]
        }
    }

    if {![info exists _inuse($class)]} { set _inuse($class) 0 }
    incr _inuse($class)

    set Widget::_class($path) $class
    foreach {option value} $options {
        if { ![info exists classopt($option)] } {
            unset pathopt
            unset pathmod
            return -code error "unknown option \"$option\""
        }
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
        set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
	set pathinit($option) $pathopt($option)
    }
}

# Bastien Chevreux ([e-mail])
#
# copyinit performs basically the same job as init, but it uses a
#  existing template to initialize its values. So, first a perferct copy
#  from the template is made just to be altered by any existing options
#  afterwards.
# But this still saves time as the first initialization parsing block is
#  skipped.
# As additional bonus, items that differ in just a few options can be
#  initialized faster by leaving out the options that are equal.

# This function is currently used only by ListBox::multipleinsert, but other
#  calls should follow :)

# ----------------------------------------------------------------------------
#  Command Widget::copyinit
# ----------------------------------------------------------------------------
proc Widget::copyinit { class templatepath path options } {
    upvar 0 ${class}::opt classopt \
	    ${class}::$path:opt	 pathopt \
	    ${class}::$path:mod	 pathmod \
	    ${class}::$path:init pathinit \
	    ${class}::$templatepath:opt	  templatepathopt \
	    ${class}::$templatepath:mod	  templatepathmod \
	    ${class}::$templatepath:init  templatepathinit

    if { [info exists pathopt] } {
	unset pathopt
    }
    if { [info exists pathmod] } {
	unset pathmod
    }

    # We use the template widget for option db copying, but it has to exist!
    array set pathmod  [array get templatepathmod]
    array set pathopt  [array get templatepathopt]
    array set pathinit [array get templatepathinit]

    set Widget::_class($path) $class
    foreach {option value} $options {
	if { ![info exists classopt($option)] } {
	    unset pathopt
	    unset pathmod
	    return -code error "unknown option \"$option\""
	}
	set optdesc $classopt($option)
	set type    [lindex $optdesc 0]
	if { [string equal $type "Synonym"] } {
	    set option	[lindex $optdesc 1]
	    set optdesc $classopt($option)
	    set type	[lindex $optdesc 0]
	}
	set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
	set pathinit($option) $pathopt($option)
    }
}

# Widget::parseArgs --
#
#	Given a widget class and a command-line spec, cannonize and validate
#	the given options, and return a keyed list consisting of the 
#	component widget and its masked portion of the command-line spec, and
#	one extra entry consisting of the portion corresponding to the 
#	megawidget itself.
#
# Arguments:
#	class	widget class to parse for.
#	options	command-line spec
#
# Results:
#	result	keyed list of portions of the megawidget and that segment of
#		the command line in which that portion is interested.

proc Widget::parseArgs {class options} {
    upvar 0 ${class}::opt classopt
    upvar 0 ${class}::map classmap
    
    foreach {option val} $options {
	if { ![info exists classopt($option)] } {
	    error "unknown option \"$option\""
	}
        set optdesc $classopt($option)
        set type    [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
            set option  [lindex $optdesc 1]
            set optdesc $classopt($option)
            set type    [lindex $optdesc 0]
        }
	if { [string equal $type "TkResource"] } {
	    # Make sure that the widget used for this TkResource exists
	    Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0]
	}
	set val [$Widget::_optiontype($type) $option $val [lindex $optdesc 3]]
		
	if { [info exists classmap($option)] } {
	    foreach {subpath subclass realopt} $classmap($option) {
		lappend maps($subpath) $realopt $val
	    }
	} else {
	    lappend maps($class) $option $val
	}
    }
    return [array get maps]
}

# Widget::initFromODB --
#
#	Initialize a megawidgets options with information from the option
#	database and from the command-line arguments given.
#
# Arguments:
#	class	class of the widget.
#	path	path of the widget -- should already exist.
#	options	command-line arguments.
#
# Results:
#	None.

proc Widget::initFromODB {class path options} {
    variable _inuse
    variable _class

    upvar 0 ${class}::$path:opt  pathopt
    upvar 0 ${class}::$path:mod  pathmod
    upvar 0 ${class}::map classmap

    if { [info exists pathopt] } {
	unset pathopt
    }
    if { [info exists pathmod] } {
	unset pathmod
    }
    # We prefer to use the actual widget for option db queries, but if it
    # doesn't exist yet, do the next best thing:  create a widget of the
    # same class and use that.
    set fpath [_get_window $class $path]
    set rdbclass [string map [list :: ""] $class]
    if { ![winfo exists $path] } {
	set fpath ".#BWidgetClass#$class"
	if { ![winfo exists $fpath] } {
	    frame $fpath -class $rdbclass
	}
    }

    foreach {option optdesc} [array get ${class}::opt] {
        set pathmod($option) 0
	if { [info exists classmap($option)] } {
	    continue
	}
        set type [lindex $optdesc 0]
        if { [string equal $type "Synonym"] } {
	    continue
        }
	if { [string equal $type "TkResource"] } {
            set alt [lindex [lindex $optdesc 3] 1]
        } else {
            set alt ""
        }
        set optdb [lindex [_configure_option $option $alt] 0]
        set def   [option get $fpath $optdb $rdbclass]
        if { [string length $def] } {
            set pathopt($option) $def
        } else {
            set pathopt($option) [lindex $optdesc 1]
        }
    }

    if {![info exists _inuse($class)]} { set _inuse($class) 0 }
    incr _inuse($class)

    set _class($path) $class
    array set pathopt $options
}



# ----------------------------------------------------------------------------
#  Command Widget::destroy
# ----------------------------------------------------------------------------
proc Widget::destroy { path } {
    variable _class
    variable _inuse

    if {![info exists _class($path)]} { return }

    set class $_class($path)
    upvar 0 ${class}::$path:opt pathopt
    upvar 0 ${class}::$path:mod pathmod
    upvar 0 ${class}::$path:init pathinit

    if {[info exists _inuse($class)]} { incr _inuse($class) -1 }

    if {[info exists pathopt]} {
        unset pathopt
    }
    if {[info exists pathmod]} {
        unset pathmod
    }
    if {[info exists pathinit]} {
        unset pathinit
    }

    if {![string equal [info commands $path] ""]} { rename $path "" }
    if {![string equal [info commands ::$path:cmd] ""]} { rename ::$path:cmd $path }

    ## Unset any variables used in this widget.
    foreach var [info vars ::${class}::$path:*] { unset $var }

    unset _class($path)
}


# ----------------------------------------------------------------------------
#  Command Widget::configure
# ----------------------------------------------------------------------------
proc Widget::configure { path options } {
    set len [llength $options]
    if { $len <= 1 } {
        return [_get_configure $path $options]
    } elseif { $len % 2 == 1 } {
        return -code error "incorrect number of arguments"
    }