Initial class construction
This commit is contained in:
João Narciso
151
Git/mingw64/lib/itcl4.1.2/itcl.tcl
Normal file
151
Git/mingw64/lib/itcl4.1.2/itcl.tcl
Normal file
@ -0,0 +1,151 @@
|
||||
#
|
||||
# itcl.tcl
|
||||
# ----------------------------------------------------------------------
|
||||
# Invoked automatically upon startup to customize the interpreter
|
||||
# for [incr Tcl].
|
||||
# ----------------------------------------------------------------------
|
||||
# AUTHOR: Michael J. McLennan
|
||||
# Bell Labs Innovations for Lucent Technologies
|
||||
# mmclennan@lucent.com
|
||||
# http://www.tcltk.com/itcl
|
||||
# ----------------------------------------------------------------------
|
||||
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
||||
# ======================================================================
|
||||
# See the file "license.terms" for information on usage and
|
||||
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
proc ::itcl::delete_helper { name args } {
|
||||
::itcl::delete object $name
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# USAGE: local <className> <objName> ?<arg> <arg>...?
|
||||
#
|
||||
# Creates a new object called <objName> in class <className>, passing
|
||||
# the remaining <arg>'s to the constructor. Unlike the usual
|
||||
# [incr Tcl] objects, however, an object created by this procedure
|
||||
# will be automatically deleted when the local call frame is destroyed.
|
||||
# This command is useful for creating objects that should only remain
|
||||
# alive until a procedure exits.
|
||||
# ----------------------------------------------------------------------
|
||||
proc ::itcl::local {class name args} {
|
||||
set ptr [uplevel [list $class $name] $args]
|
||||
uplevel [list set itcl-local-$ptr $ptr]
|
||||
set cmd [uplevel namespace which -command $ptr]
|
||||
uplevel [list trace variable itcl-local-$ptr u \
|
||||
"::itcl::delete_helper $cmd"]
|
||||
return $ptr
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# auto_mkindex
|
||||
# ----------------------------------------------------------------------
|
||||
# Define Itcl commands that will be recognized by the auto_mkindex
|
||||
# parser in Tcl...
|
||||
#
|
||||
|
||||
#
|
||||
# USAGE: itcl::class name body
|
||||
# Adds an entry for the given class declaration.
|
||||
#
|
||||
foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} {
|
||||
auto_mkindex_parser::command $__cmd {name body} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
append index "set [list auto_index([fullname $name])]"
|
||||
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
||||
|
||||
variable parser
|
||||
variable contextStack
|
||||
set contextStack [linsert $contextStack 0 $name]
|
||||
$parser eval $body
|
||||
set contextStack [lrange $contextStack 1 end]
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# USAGE: itcl::body name arglist body
|
||||
# Adds an entry for the given method/proc body.
|
||||
#
|
||||
foreach __cmd {itcl::body body} {
|
||||
auto_mkindex_parser::command $__cmd {name arglist body} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
append index "set [list auto_index([fullname $name])]"
|
||||
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# USAGE: itcl::configbody name arglist body
|
||||
# Adds an entry for the given method/proc body.
|
||||
#
|
||||
foreach __cmd {itcl::configbody configbody} {
|
||||
auto_mkindex_parser::command $__cmd {name body} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
append index "set [list auto_index([fullname $name])]"
|
||||
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# USAGE: ensemble name ?body?
|
||||
# Adds an entry to the auto index list for the given ensemble name.
|
||||
#
|
||||
foreach __cmd {itcl::ensemble ensemble} {
|
||||
auto_mkindex_parser::command $__cmd {name {body ""}} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
append index "set [list auto_index([fullname $name])]"
|
||||
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# USAGE: public arg ?arg arg...?
|
||||
# protected arg ?arg arg...?
|
||||
# private arg ?arg arg...?
|
||||
#
|
||||
# Evaluates the arguments as commands, so we can recognize proc
|
||||
# declarations within classes.
|
||||
#
|
||||
foreach __cmd {public protected private} {
|
||||
auto_mkindex_parser::command $__cmd {args} {
|
||||
variable parser
|
||||
$parser eval $args
|
||||
}
|
||||
}
|
||||
|
||||
# SF bug #246 unset variable __cmd to avoid problems in user programs!!
|
||||
unset __cmd
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# auto_import
|
||||
# ----------------------------------------------------------------------
|
||||
# This procedure overrides the usual "auto_import" function in the
|
||||
# Tcl library. It is invoked during "namespace import" to make see
|
||||
# if the imported commands reside in an autoloaded library. If so,
|
||||
# stubs are created to represent the commands. Executing a stub
|
||||
# later on causes the real implementation to be autoloaded.
|
||||
#
|
||||
# Arguments -
|
||||
# pattern The pattern of commands being imported (like "foo::*")
|
||||
# a canonical namespace as returned by [namespace current]
|
||||
|
||||
proc auto_import {pattern} {
|
||||
global auto_index
|
||||
|
||||
set ns [uplevel namespace current]
|
||||
set patternList [auto_qualify $pattern $ns]
|
||||
|
||||
auto_load_index
|
||||
|
||||
foreach pattern $patternList {
|
||||
foreach name [array names auto_index $pattern] {
|
||||
if {"" == [info commands $name]} {
|
||||
::itcl::import::stub create $name
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
BIN
Git/mingw64/lib/itcl4.1.2/itcl412.dll
Normal file
BIN
Git/mingw64/lib/itcl4.1.2/itcl412.dll
Normal file
Binary file not shown.
67
Git/mingw64/lib/itcl4.1.2/itclConfig.sh
Normal file
67
Git/mingw64/lib/itcl4.1.2/itclConfig.sh
Normal file
@ -0,0 +1,67 @@
|
||||
# itclConfig.sh --
|
||||
#
|
||||
# This shell script (for sh) is generated automatically by Itcl's
|
||||
# configure script. It will create shell variables for most of
|
||||
# the configuration options discovered by the configure script.
|
||||
# This script is intended to be included by the configure scripts
|
||||
# for Itcl extensions so that they don't have to figure this all
|
||||
# out for themselves. This file does not duplicate information
|
||||
# already provided by tclConfig.sh, so you may need to use that
|
||||
# file in addition to this one.
|
||||
#
|
||||
# The information in this file is specific to a single platform.
|
||||
|
||||
# Itcl's version number.
|
||||
itcl_VERSION='4.1.2'
|
||||
ITCL_VERSION='4.1.2'
|
||||
|
||||
# The name of the Itcl library (may be either a .a file or a shared library):
|
||||
itcl_LIB_FILE=itcl412.dll
|
||||
ITCL_LIB_FILE=itcl412.dll
|
||||
|
||||
# String to pass to linker to pick up the Itcl library from its
|
||||
# build directory.
|
||||
itcl_BUILD_LIB_SPEC='-L/mingw64/lib/itcl4.1.2 -litcl412'
|
||||
ITCL_BUILD_LIB_SPEC='-L/mingw64/lib/itcl4.1.2 -litcl412'
|
||||
|
||||
# String to pass to linker to pick up the Itcl library from its
|
||||
# installed directory.
|
||||
itcl_LIB_SPEC='-LC:/building/msys64/mingw64/lib/itcl4.1.2 -litcl412'
|
||||
ITCL_LIB_SPEC='-LC:/building/msys64/mingw64/lib/itcl4.1.2 -litcl412'
|
||||
|
||||
# The name of the Itcl stub library (a .a file):
|
||||
itcl_STUB_LIB_FILE=libitclstub412.a
|
||||
ITCL_STUB_LIB_FILE=libitclstub412.a
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# build directory.
|
||||
itcl_BUILD_STUB_LIB_SPEC='-L/mingw64/lib/itcl4.1.2 -litclstub412'
|
||||
ITCL_BUILD_STUB_LIB_SPEC='-L/mingw64/lib/itcl4.1.2 -litclstub412'
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# installed directory.
|
||||
itcl_STUB_LIB_SPEC='-LC:/building/msys64/mingw64/lib/itcl4.1.2 -litclstub412'
|
||||
ITCL_STUB_LIB_SPEC='-LC:/building/msys64/mingw64/lib/itcl4.1.2 -litclstub412'
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# build directory.
|
||||
itcl_BUILD_STUB_LIB_PATH='/mingw64/lib/itcl4.1.2/libitclstub412.a'
|
||||
ITCL_BUILD_STUB_LIB_PATH='/mingw64/lib/itcl4.1.2/libitclstub412.a'
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# installed directory.
|
||||
itcl_STUB_LIB_PATH='C:/building/msys64/mingw64/lib/itcl4.1.2/libitclstub412.a'
|
||||
ITCL_STUB_LIB_PATH='C:/building/msys64/mingw64/lib/itcl4.1.2/libitclstub412.a'
|
||||
|
||||
# Location of the top-level source directories from which [incr Tcl]
|
||||
# was built. This is the directory that contains generic, unix, etc.
|
||||
# If [incr Tcl] was compiled in a different place than the directory
|
||||
# containing the source files, this points to the location of the sources,
|
||||
# not the location where [incr Tcl] was compiled.
|
||||
itcl_SRC_DIR='/scripts/mingw-w64-tcl/src/tcl8.6.9/pkgs/itcl4.1.2'
|
||||
ITCL_SRC_DIR='/scripts/mingw-w64-tcl/src/tcl8.6.9/pkgs/itcl4.1.2'
|
||||
|
||||
# String to pass to the compiler so that an extension can
|
||||
# find installed Itcl headers.
|
||||
itcl_INCLUDE_SPEC='-I/scripts/mingw-w64-tcl/src/tcl8.6.9/pkgs/itcl4.1.2/generic'
|
||||
ITCL_INCLUDE_SPEC='-I/scripts/mingw-w64-tcl/src/tcl8.6.9/pkgs/itcl4.1.2/generic'
|
||||
562
Git/mingw64/lib/itcl4.1.2/itclHullCmds.tcl
Normal file
562
Git/mingw64/lib/itcl4.1.2/itclHullCmds.tcl
Normal file
@ -0,0 +1,562 @@
|
||||
#
|
||||
# itclHullCmds.tcl
|
||||
# ----------------------------------------------------------------------
|
||||
# Invoked automatically upon startup to customize the interpreter
|
||||
# for [incr Tcl] when one of setupcomponent or createhull is called.
|
||||
# ----------------------------------------------------------------------
|
||||
# AUTHOR: Arnulf P. Wiedemann
|
||||
#
|
||||
# ----------------------------------------------------------------------
|
||||
# Copyright (c) 2008 Arnulf P. Wiedemann
|
||||
# ======================================================================
|
||||
# See the file "license.terms" for information on usage and
|
||||
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require Tk 8.6
|
||||
|
||||
namespace eval ::itcl::internal::commands {
|
||||
|
||||
# ======================= widgetDeleted ===========================
|
||||
|
||||
proc widgetDeleted {oldName newName op} {
|
||||
# The widget is beeing deleted, so we have to delete the object
|
||||
# which had the widget as itcl_hull too!
|
||||
# We have to get the real name from for example
|
||||
# ::itcl::internal::widgets::hull1.lw
|
||||
# we need only .lw here
|
||||
|
||||
#puts stderr "widgetDeleted!$oldName!$newName!$op!"
|
||||
set cmdName [namespace tail $oldName]
|
||||
set flds [split $cmdName {.}]
|
||||
set cmdName .[join [lrange $flds 1 end] {.}]
|
||||
#puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
|
||||
rename $cmdName {}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
namespace eval ::itcl::builtin {
|
||||
|
||||
# ======================= createhull ===========================
|
||||
# the hull widget is a tk widget which is the (mega) widget handled behind the itcl
|
||||
# extendedclass/itcl widget.
|
||||
# It is created be renaming the itcl class object to a temporary name <itcl object name>_
|
||||
# creating the widget with the
|
||||
# appropriate options and the installing that as the "hull" widget (the container)
|
||||
# All the options in args and the options delegated to component itcl_hull are used
|
||||
# Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
|
||||
# ::itcl::internal::widgets::hull<unique number><namespace tail path>
|
||||
# and widget is renamed to that name
|
||||
# Finally the <itcl object name>_ is renamed to the original <itcl object name> again
|
||||
# Component itcl_hull is created if not existent
|
||||
# itcl_hull is set to the hull_widget_name and the <itcl object name>
|
||||
# is returned to the caller
|
||||
# ==============================================================
|
||||
|
||||
proc createhull {widget_type path args} {
|
||||
variable hullCount
|
||||
upvar this this
|
||||
upvar win win
|
||||
|
||||
|
||||
#puts stderr "il-1![::info level -1]!$this!"
|
||||
#puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
|
||||
#puts stderr "ns1![uplevel 1 namespace current]!"
|
||||
#puts stderr "ns2![uplevel 2 namespace current]!"
|
||||
#puts stderr "ns3![uplevel 3 namespace current]!"
|
||||
#puts stderr "level-1![::info level -1]!"
|
||||
#puts stderr "level-2![::info level -2]!"
|
||||
# set my_this [namespace tail $this]
|
||||
set my_this $this
|
||||
set tmp $my_this
|
||||
#puts stderr "II![::info command $this]![::info command $tmp]!"
|
||||
#puts stderr "rename1!rename $my_this ${tmp}_!"
|
||||
rename ::$my_this ${tmp}_
|
||||
set options [list]
|
||||
foreach {option_name value} $args {
|
||||
switch -glob -- $option_name {
|
||||
-class {
|
||||
lappend options $option_name [namespace tail $value]
|
||||
}
|
||||
-* {
|
||||
lappend options $option_name $value
|
||||
}
|
||||
default {
|
||||
return -code error "bad option name\"$option_name\" options must start with a \"-\""
|
||||
}
|
||||
}
|
||||
}
|
||||
set my_win [namespace tail $path]
|
||||
set cmd [list $widget_type $my_win]
|
||||
#puts stderr "my_win!$my_win!cmd!$cmd!$path!"
|
||||
if {[llength $options] > 0} {
|
||||
lappend cmd {*}$options
|
||||
}
|
||||
set widget [uplevel 1 $cmd]
|
||||
#puts stderr "widget!$widget!"
|
||||
trace add command $widget delete ::itcl::internal::commands::widgetDeleted
|
||||
set opts [uplevel 1 info delegated options]
|
||||
foreach entry $opts {
|
||||
foreach {optName compName} $entry break
|
||||
if {$compName eq "itcl_hull"} {
|
||||
set optInfos [uplevel 1 info delegated option $optName]
|
||||
set realOptName [lindex $optInfos 4]
|
||||
# strip off the "-" at the beginning
|
||||
set myOptName [string range $realOptName 1 end]
|
||||
set my_opt_val [option get $my_win $myOptName *]
|
||||
if {$my_opt_val ne ""} {
|
||||
$my_win configure -$myOptName $my_opt_val
|
||||
}
|
||||
}
|
||||
}
|
||||
set idx 1
|
||||
while {1} {
|
||||
set widgetName ::itcl::internal::widgets::hull${idx}$my_win
|
||||
#puts stderr "widgetName!$widgetName!"
|
||||
if {[string length [::info command $widgetName]] == 0} {
|
||||
break
|
||||
}
|
||||
incr idx
|
||||
}
|
||||
#puts stderr "rename2!rename $widget $widgetName!"
|
||||
set dorename 0
|
||||
rename $widget $widgetName
|
||||
#puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
|
||||
rename ${tmp}_ ::$tmp
|
||||
set exists [uplevel 1 ::info exists itcl_hull]
|
||||
if {!$exists} {
|
||||
# that does not yet work, beacause of problems with resolving
|
||||
::itcl::addcomponent $my_this itcl_hull
|
||||
}
|
||||
upvar itcl_hull itcl_hull
|
||||
::itcl::setcomponent $my_this itcl_hull $widgetName
|
||||
#puts stderr "IC![::info command $my_win]!"
|
||||
set exists [uplevel 1 ::info exists itcl_interior]
|
||||
if {!$exists} {
|
||||
# that does not yet work, beacause of problems with resolving
|
||||
::itcl::addcomponent $this itcl_interior
|
||||
}
|
||||
upvar itcl_interior itcl_interior
|
||||
set itcl_interior $my_win
|
||||
#puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
|
||||
return $my_win
|
||||
}
|
||||
|
||||
# ======================= addToItclOptions ===========================
|
||||
|
||||
proc addToItclOptions {my_class my_win myOptions argsDict} {
|
||||
upvar win win
|
||||
upvar itcl_hull itcl_hull
|
||||
|
||||
set opt_lst [list configure]
|
||||
foreach opt [lsort $myOptions] {
|
||||
#puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
|
||||
set isClass [::itcl::is class $my_class]
|
||||
set found 0
|
||||
if {$isClass} {
|
||||
if {[catch {
|
||||
set resource [namespace eval $my_class info option $opt -resource]
|
||||
set class [namespace eval $my_class info option $opt -class]
|
||||
set default_val [uplevel 2 info option $opt -default]
|
||||
set found 1
|
||||
} msg]} {
|
||||
# puts stderr "MSG!$opt!$my_class!$msg!"
|
||||
}
|
||||
} else {
|
||||
set tmp_win [uplevel #0 $my_class .___xx]
|
||||
|
||||
set my_info [$tmp_win configure $opt]
|
||||
set resource [lindex $my_info 1]
|
||||
set class [lindex $my_info 2]
|
||||
set default_val [lindex $my_info 3]
|
||||
uplevel #0 destroy $tmp_win
|
||||
set found 1
|
||||
}
|
||||
if {$found} {
|
||||
if {[catch {
|
||||
set val [uplevel #0 ::option get $win $resource $class]
|
||||
} msg]} {
|
||||
set val ""
|
||||
}
|
||||
if {[::dict exists $argsDict $opt]} {
|
||||
# we have an explicitly set option
|
||||
set val [::dict get $argsDict $opt]
|
||||
} else {
|
||||
if {[string length $val] == 0} {
|
||||
set val $default_val
|
||||
}
|
||||
}
|
||||
set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
|
||||
set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
|
||||
#puts stderr "OPT1!$opt!$val!"
|
||||
# uplevel 1 [list set itcl_options($opt) [list $val]]
|
||||
if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
|
||||
#puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ======================= setupcomponent ===========================
|
||||
|
||||
proc setupcomponent {comp using widget_type path args} {
|
||||
upvar this this
|
||||
upvar win win
|
||||
upvar itcl_hull itcl_hull
|
||||
|
||||
#puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
|
||||
#puts stderr "CONT![uplevel 1 info context]!"
|
||||
#puts stderr "ns1![uplevel 1 namespace current]!"
|
||||
#puts stderr "ns2![uplevel 2 namespace current]!"
|
||||
#puts stderr "ns3![uplevel 3 namespace current]!"
|
||||
set my_comp_object [lindex [uplevel 1 info context] 1]
|
||||
if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
|
||||
set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
|
||||
} else {
|
||||
set ::itcl::internal::component_objects($path) $my_comp_object
|
||||
}
|
||||
set options [list]
|
||||
foreach {option_name value} $args {
|
||||
switch -glob -- $option_name {
|
||||
-* {
|
||||
lappend options $option_name $value
|
||||
}
|
||||
default {
|
||||
return -code error "bad option name\"$option_name\" options must start with a \"-\""
|
||||
}
|
||||
}
|
||||
}
|
||||
if {[llength $args]} {
|
||||
set argsDict [dict create {*}$args]
|
||||
} else {
|
||||
set argsDict [dict create]
|
||||
}
|
||||
set cmd [list $widget_type $path]
|
||||
if {[llength $options] > 0} {
|
||||
lappend cmd {*}$options
|
||||
}
|
||||
#puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
|
||||
#puts stderr "cmd1!$cmd!"
|
||||
# set my_comp [uplevel 3 $cmd]
|
||||
set my_comp [uplevel #0 $cmd]
|
||||
#puts stderr 111![::info command $path]!
|
||||
::itcl::setcomponent $this $comp $my_comp
|
||||
set opts [uplevel 1 info delegated options]
|
||||
foreach entry $opts {
|
||||
foreach {optName compName} $entry break
|
||||
if {$compName eq $my_comp} {
|
||||
set optInfos [uplevel 1 info delegated option $optName]
|
||||
set realOptName [lindex $optInfos 4]
|
||||
# strip off the "-" at the beginning
|
||||
set myOptName [string range $realOptName 1 end]
|
||||
set my_opt_val [option get $my_win $myOptName *]
|
||||
if {$my_opt_val ne ""} {
|
||||
$my_comp configure -$myOptName $my_opt_val
|
||||
}
|
||||
}
|
||||
}
|
||||
set my_class $widget_type
|
||||
set my_parent_class [uplevel 1 namespace current]
|
||||
if {[catch {
|
||||
set myOptions [namespace eval $my_class {info classoptions}]
|
||||
} msg]} {
|
||||
set myOptions [list]
|
||||
}
|
||||
foreach entry [$path configure] {
|
||||
foreach {opt dummy1 dummy2 dummy3} $entry break
|
||||
lappend myOptions $opt
|
||||
}
|
||||
#puts stderr "OPTS!$myOptions!"
|
||||
addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
|
||||
#puts stderr END!$path![::info command $path]!
|
||||
}
|
||||
|
||||
proc itcl_initoptions {args} {
|
||||
puts stderr "ITCL_INITOPT!$args!"
|
||||
}
|
||||
|
||||
# ======================= initoptions ===========================
|
||||
|
||||
proc initoptions {args} {
|
||||
upvar win win
|
||||
upvar itcl_hull itcl_hull
|
||||
upvar itcl_option_components itcl_option_components
|
||||
|
||||
#puts stderr "INITOPT!!$win!"
|
||||
if {[llength $args]} {
|
||||
set argsDict [dict create {*}$args]
|
||||
} else {
|
||||
set argsDict [dict create]
|
||||
}
|
||||
set my_class [uplevel 1 namespace current]
|
||||
set myOptions [namespace eval $my_class {info classoptions}]
|
||||
if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
|
||||
set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
|
||||
# set myOptions [lsort -unique [namespace eval $my_class {info options}]]
|
||||
foreach comp [uplevel 1 info components] {
|
||||
if {[dict exists $class_info_dict $comp -keptoptions]} {
|
||||
foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
|
||||
if {[lsearch $myOptions $my_opt] < 0} {
|
||||
#puts stderr "KEOPT!$my_opt!"
|
||||
lappend myOptions $my_opt
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
set class_info_dict [list]
|
||||
}
|
||||
#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
|
||||
set opt_lst [list configure]
|
||||
set my_win $win
|
||||
foreach opt [lsort $myOptions] {
|
||||
set found 0
|
||||
if {[catch {
|
||||
set resource [uplevel 1 info option $opt -resource]
|
||||
set class [uplevel 1 info option $opt -class]
|
||||
set default_val [uplevel 1 info option $opt -default]
|
||||
set found 1
|
||||
} msg]} {
|
||||
# puts stderr "MSG!$opt!$msg!"
|
||||
}
|
||||
#puts stderr "OPT!$opt!$found!"
|
||||
if {$found} {
|
||||
if {[catch {
|
||||
set val [uplevel #0 ::option get $my_win $resource $class]
|
||||
} msg]} {
|
||||
set val ""
|
||||
}
|
||||
if {[::dict exists $argsDict $opt]} {
|
||||
# we have an explicitly set option
|
||||
set val [::dict get $argsDict $opt]
|
||||
} else {
|
||||
if {[string length $val] == 0} {
|
||||
set val $default_val
|
||||
}
|
||||
}
|
||||
set ::itcl::internal::variables::${win}::itcl_options($opt) $val
|
||||
set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
|
||||
#puts stderr "OPT1!$opt!$val!"
|
||||
# uplevel 1 [list set itcl_options($opt) [list $val]]
|
||||
if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
|
||||
puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
|
||||
}
|
||||
}
|
||||
foreach comp [dict keys $class_info_dict] {
|
||||
#puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
|
||||
if {[dict exists $class_info_dict $comp -keptoptions]} {
|
||||
if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
|
||||
if {$found == 0} {
|
||||
# we use the option value of the first component for setting
|
||||
# the option, as the components are traversed in the dict
|
||||
# depending on the ordering of the component creation!!
|
||||
set my_info [uplevel 1 \[set $comp\] configure $opt]
|
||||
set resource [lindex $my_info 1]
|
||||
set class [lindex $my_info 2]
|
||||
set default_val [lindex $my_info 3]
|
||||
set found 2
|
||||
set val [uplevel #0 ::option get $my_win $resource $class]
|
||||
if {[::dict exists $argsDict $opt]} {
|
||||
# we have an explicitly set option
|
||||
set val [::dict get $argsDict $opt]
|
||||
} else {
|
||||
if {[string length $val] == 0} {
|
||||
set val $default_val
|
||||
}
|
||||
}
|
||||
#puts stderr "OPT2!$opt!$val!"
|
||||
set ::itcl::internal::variables::${win}::itcl_options($opt) $val
|
||||
set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
|
||||
# uplevel 1 [list set itcl_options($opt) [list $val]]
|
||||
}
|
||||
if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
|
||||
puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
|
||||
}
|
||||
if {![uplevel 1 info exists itcl_option_components($opt)]} {
|
||||
set itcl_option_components($opt) [list]
|
||||
}
|
||||
if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
|
||||
if {![catch {
|
||||
set optval [uplevel 1 [list set itcl_options($opt)]]
|
||||
} msg3]} {
|
||||
uplevel 1 \[set $comp\] configure $opt $optval
|
||||
}
|
||||
lappend itcl_option_components($opt) $comp
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
# uplevel 1 $opt_lst
|
||||
}
|
||||
|
||||
# ======================= setoptions ===========================
|
||||
|
||||
proc setoptions {args} {
|
||||
|
||||
#puts stderr "setOPT!!$args!"
|
||||
if {[llength $args]} {
|
||||
set argsDict [dict create {*}$args]
|
||||
} else {
|
||||
set argsDict [dict create]
|
||||
}
|
||||
set my_class [uplevel 1 namespace current]
|
||||
set myOptions [namespace eval $my_class {info options}]
|
||||
#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
|
||||
set opt_lst [list configure]
|
||||
foreach opt [lsort $myOptions] {
|
||||
set found 0
|
||||
if {[catch {
|
||||
set resource [uplevel 1 info option $opt -resource]
|
||||
set class [uplevel 1 info option $opt -class]
|
||||
set default_val [uplevel 1 info option $opt -default]
|
||||
set found 1
|
||||
} msg]} {
|
||||
# puts stderr "MSG!$opt!$msg!"
|
||||
}
|
||||
#puts stderr "OPT!$opt!$found!"
|
||||
if {$found} {
|
||||
set val ""
|
||||
if {[::dict exists $argsDict $opt]} {
|
||||
# we have an explicitly set option
|
||||
set val [::dict get $argsDict $opt]
|
||||
} else {
|
||||
if {[string length $val] == 0} {
|
||||
set val $default_val
|
||||
}
|
||||
}
|
||||
set myObj [uplevel 1 set this]
|
||||
#puts stderr "myObj!$myObj!"
|
||||
set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
|
||||
set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
|
||||
#puts stderr "OPT1!$opt!$val!"
|
||||
uplevel 1 [list set itcl_options($opt) [list $val]]
|
||||
# if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
|
||||
#puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
|
||||
# }
|
||||
}
|
||||
}
|
||||
# uplevel 1 $opt_lst
|
||||
}
|
||||
|
||||
# ========================= keepcomponentoption ======================
|
||||
# Invoked by Tcl during evaluating constructor whenever
|
||||
# the "keepcomponentoption" command is invoked to list the options
|
||||
# to be kept when an ::itcl::extendedclass component has been setup
|
||||
# for an object.
|
||||
#
|
||||
# It checks, for all arguments, if the opt is an option of that class
|
||||
# and of that component. If that is the case it adds the component name
|
||||
# to the list of components for that option.
|
||||
# The variable is the object variable: itcl_option_components($opt)
|
||||
#
|
||||
# Handles the following syntax:
|
||||
#
|
||||
# keepcomponentoption <componentName> <optionName> ?<optionName> ...?
|
||||
#
|
||||
# ======================================================================
|
||||
|
||||
|
||||
proc keepcomponentoption {args} {
|
||||
upvar win win
|
||||
upvar itcl_hull itcl_hull
|
||||
|
||||
set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
|
||||
|
||||
#puts stderr "KEEP!$args![uplevel 1 namespace current]!"
|
||||
if {[llength $args] < 2} {
|
||||
puts stderr $usage
|
||||
return -code error
|
||||
}
|
||||
set my_hull [uplevel 1 set itcl_hull]
|
||||
set my_class [uplevel 1 namespace current]
|
||||
set comp [lindex $args 0]
|
||||
set args [lrange $args 1 end]
|
||||
set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
|
||||
if {![dict exists $class_info_dict $comp]} {
|
||||
puts stderr "keepcomponentoption cannot find component \"$comp\""
|
||||
return -code error
|
||||
}
|
||||
set class_comp_dict [dict get $class_info_dict $comp]
|
||||
if {![dict exists $class_comp_dict -keptoptions]} {
|
||||
dict set class_comp_dict -keptoptions [list]
|
||||
}
|
||||
foreach opt $args {
|
||||
#puts stderr "KEEP!$opt!"
|
||||
if {[string range $opt 0 0] ne "-"} {
|
||||
puts stderr "keepcomponentoption: option must begin with a \"-\"!"
|
||||
return -code error
|
||||
}
|
||||
if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
|
||||
dict lappend class_comp_dict -keptoptions $opt
|
||||
}
|
||||
}
|
||||
if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
|
||||
set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
|
||||
} else {
|
||||
set comp_object "unknown_comp_obj_$comp!"
|
||||
}
|
||||
dict set class_info_dict $comp $class_comp_dict
|
||||
dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
|
||||
puts stderr "CLDI!$class_comp_dict!"
|
||||
addToItclOptions $my_class $comp_object $args [list]
|
||||
}
|
||||
|
||||
proc ignorecomponentoption {args} {
|
||||
puts stderr "IGNORE_COMPONENT_OPTION!$args!"
|
||||
}
|
||||
|
||||
proc renamecomponentoption {args} {
|
||||
puts stderr "rename_COMPONENT_OPTION!$args!"
|
||||
}
|
||||
|
||||
proc addoptioncomponent {args} {
|
||||
puts stderr "ADD_OPTION_COMPONENT!$args!"
|
||||
}
|
||||
|
||||
proc ignoreoptioncomponent {args} {
|
||||
puts stderr "IGNORE_OPTION_COMPONENT!$args!"
|
||||
}
|
||||
|
||||
proc renameoptioncomponent {args} {
|
||||
puts stderr "RENAME_OPTION_COMPONENT!$args!"
|
||||
}
|
||||
|
||||
proc getEclassOptions {args} {
|
||||
upvar win win
|
||||
|
||||
#puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
|
||||
#parray ::itcl::internal::variables::${win}::itcl_options
|
||||
set result [list]
|
||||
foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
|
||||
if {[catch {
|
||||
foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
|
||||
lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
|
||||
} msg]} {
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
proc eclassConfigure {args} {
|
||||
upvar win win
|
||||
|
||||
#puts stderr "+++ eclassConfigure!$args!"
|
||||
if {[llength $args] > 1} {
|
||||
foreach {opt val} $args break
|
||||
if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
|
||||
set ::itcl::internal::variables::${win}::itcl_options($opt) $val
|
||||
return
|
||||
}
|
||||
} else {
|
||||
foreach {opt} $args break
|
||||
if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
|
||||
#puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
|
||||
foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
|
||||
return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
|
||||
}
|
||||
}
|
||||
return -code error
|
||||
}
|
||||
|
||||
}
|
||||
447
Git/mingw64/lib/itcl4.1.2/itclWidget.tcl
Normal file
447
Git/mingw64/lib/itcl4.1.2/itclWidget.tcl
Normal file
@ -0,0 +1,447 @@
|
||||
#
|
||||
# itclWidget.tcl
|
||||
# ----------------------------------------------------------------------
|
||||
# Invoked automatically upon startup to customize the interpreter
|
||||
# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
|
||||
# ----------------------------------------------------------------------
|
||||
# AUTHOR: Arnulf P. Wiedemann
|
||||
#
|
||||
# ----------------------------------------------------------------------
|
||||
# Copyright (c) 2008 Arnulf P. Wiedemann
|
||||
# ======================================================================
|
||||
# See the file "license.terms" for information on usage and
|
||||
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require Tk 8.6
|
||||
# package require itclwidget [set ::itcl::version]
|
||||
|
||||
namespace eval ::itcl {
|
||||
|
||||
proc widget {name args} {
|
||||
set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
|
||||
# we handle create by owerselfs !! allow classunknown to handle that
|
||||
oo::objdefine $result unexport create
|
||||
return $result
|
||||
}
|
||||
|
||||
proc widgetadaptor {name args} {
|
||||
set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
|
||||
# we handle create by owerselfs !! allow classunknown to handle that
|
||||
oo::objdefine $result unexport create
|
||||
return $result
|
||||
}
|
||||
|
||||
} ; # end ::itcl
|
||||
|
||||
|
||||
namespace eval ::itcl::internal::commands {
|
||||
|
||||
proc initWidgetOptions {varNsName widgetName className} {
|
||||
set myDict [set ::itcl::internal::dicts::classOptions]
|
||||
if {$myDict eq ""} {
|
||||
return
|
||||
}
|
||||
if {![dict exists $myDict $className]} {
|
||||
return
|
||||
}
|
||||
set myDict [dict get $myDict $className]
|
||||
foreach option [dict keys $myDict] {
|
||||
set infos [dict get $myDict $option]
|
||||
set resource [dict get $infos -resource]
|
||||
set class [dict get $infos -class]
|
||||
set value [::option get $widgetName $resource $class]
|
||||
if {$value eq ""} {
|
||||
if {[dict exists $infos -default]} {
|
||||
set defaultValue [dict get $infos -default]
|
||||
uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
|
||||
}
|
||||
} else {
|
||||
uplevel 1 set ${varNsName}::itcl_options($option) $value
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc initWidgetDelegatedOptions {varNsName widgetName className args} {
|
||||
set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
|
||||
if {$myDict eq ""} {
|
||||
return
|
||||
}
|
||||
if {![dict exists $myDict $className]} {
|
||||
return
|
||||
}
|
||||
set myDict [dict get $myDict $className]
|
||||
foreach option [dict keys $myDict] {
|
||||
set infos [dict get $myDict $option]
|
||||
if {![dict exists $infos -resource]} {
|
||||
# this is the case when delegating "*"
|
||||
continue
|
||||
}
|
||||
if {![dict exists $infos -component]} {
|
||||
# nothing to do
|
||||
continue
|
||||
}
|
||||
# check if not in the command line options
|
||||
# these have higher priority
|
||||
set myOption $option
|
||||
if {[dict exists $infos -as]} {
|
||||
set myOption [dict get $infos -as]
|
||||
}
|
||||
set noOptionSet 0
|
||||
foreach {optName optVal} $args {
|
||||
if {$optName eq $myOption} {
|
||||
set noOptionSet 1
|
||||
break
|
||||
}
|
||||
}
|
||||
if {$noOptionSet} {
|
||||
continue
|
||||
}
|
||||
set resource [dict get $infos -resource]
|
||||
set class [dict get $infos -class]
|
||||
set component [dict get $infos -component]
|
||||
set value [::option get $widgetName $resource $class]
|
||||
if {$component ne ""} {
|
||||
if {$value ne ""} {
|
||||
set compVar [namespace eval ${varNsName}${className} "set $component"]
|
||||
if {$compVar ne ""} {
|
||||
uplevel 1 $compVar configure $myOption $value
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc widgetinitobjectoptions {varNsName widgetName className} {
|
||||
#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
|
||||
}
|
||||
|
||||
proc deletehull {newName oldName what} {
|
||||
if {$what eq "delete"} {
|
||||
set name [namespace tail $newName]
|
||||
regsub {hull[0-9]+} $name {} name
|
||||
rename $name {}
|
||||
}
|
||||
if {$what eq "rename"} {
|
||||
set name [namespace tail $newName]
|
||||
regsub {hull[0-9]+} $name {} name
|
||||
rename $name {}
|
||||
}
|
||||
}
|
||||
|
||||
proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
|
||||
if {$hulltype eq ""} {
|
||||
set hulltype frame
|
||||
}
|
||||
set idx 0
|
||||
set found 0
|
||||
foreach {optName optValue} $args {
|
||||
if {$optName eq "-class"} {
|
||||
set found 1
|
||||
set widgetClass $optValue
|
||||
break
|
||||
}
|
||||
incr idx
|
||||
}
|
||||
if {$found} {
|
||||
set args [lreplace $args $idx [expr {$idx + 1}]]
|
||||
}
|
||||
if {$widgetClass eq ""} {
|
||||
set widgetClass $className
|
||||
set widgetClass [string totitle $widgetClass]
|
||||
}
|
||||
set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
|
||||
uplevel 2 $cmd
|
||||
}
|
||||
|
||||
} ; # end ::itcl::internal::commands
|
||||
|
||||
namespace eval ::itcl::builtin {
|
||||
|
||||
proc installhull {args} {
|
||||
set cmdPath ::itcl::internal::commands
|
||||
set className [uplevel 1 info class]
|
||||
|
||||
set replace 0
|
||||
switch -- [llength $args] {
|
||||
0 {
|
||||
return -code error\
|
||||
"wrong # args: should be \"[lindex [info level 0] 0]\
|
||||
name|using <widgetType> ?arg ...?\""
|
||||
}
|
||||
1 {
|
||||
set widgetName [lindex $args 0]
|
||||
set varNsName $::itcl::internal::varNsName($widgetName)
|
||||
}
|
||||
default {
|
||||
upvar win win
|
||||
set widgetName $win
|
||||
|
||||
set varNsName $::itcl::internal::varNsName($widgetName)
|
||||
set widgetType [lindex $args 1]
|
||||
incr replace
|
||||
if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
|
||||
set classNam [lindex $args 3]
|
||||
incr replace 2
|
||||
} else {
|
||||
set classNam [string totitle $widgetType]
|
||||
}
|
||||
uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
|
||||
uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
|
||||
}
|
||||
}
|
||||
|
||||
# initialize the itcl_hull variable
|
||||
set i 0
|
||||
set nam ::itcl::internal::widgets::hull
|
||||
while {1} {
|
||||
incr i
|
||||
set hullNam ${nam}${i}$widgetName
|
||||
if {[::info command $hullNam] eq ""} {
|
||||
break
|
||||
}
|
||||
}
|
||||
uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
|
||||
uplevel 1 [list ::rename $widgetName $hullNam]
|
||||
uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
|
||||
catch {${cmdPath}::checksetitclhull [list] 0}
|
||||
namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
|
||||
catch {${cmdPath}::checksetitclhull [list] 2}
|
||||
uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
|
||||
}
|
||||
|
||||
proc installcomponent {args} {
|
||||
upvar win win
|
||||
|
||||
set className [uplevel 1 info class]
|
||||
set myType [${className}::info types [namespace tail $className]]
|
||||
set isType 0
|
||||
if {$myType ne ""} {
|
||||
set isType 1
|
||||
}
|
||||
set numArgs [llength $args]
|
||||
set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
|
||||
if {$numArgs < 4} {
|
||||
error $usage
|
||||
}
|
||||
foreach {componentName using widgetType widgetPath} $args break
|
||||
set opts [lrange $args 4 end]
|
||||
if {$using ne "using"} {
|
||||
error $usage
|
||||
}
|
||||
if {!$isType} {
|
||||
set hullExists [uplevel 1 ::info exists itcl_hull]
|
||||
if {!$hullExists} {
|
||||
error "cannot install \"$componentName\" before \"itcl_hull\" exists"
|
||||
}
|
||||
set hullVal [uplevel 1 set itcl_hull]
|
||||
if {$hullVal eq ""} {
|
||||
error "cannot install \"$componentName\" before \"itcl_hull\" exists"
|
||||
}
|
||||
}
|
||||
# check for delegated option and ask the option database for the values
|
||||
# first check for number of delegated options
|
||||
set numOpts 0
|
||||
set starOption 0
|
||||
set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
|
||||
if {[dict exists $myDict $className]} {
|
||||
set myDict [dict get $myDict $className]
|
||||
foreach option [dict keys $myDict] {
|
||||
if {$option eq "*"} {
|
||||
set starOption 1
|
||||
}
|
||||
incr numOpts
|
||||
}
|
||||
}
|
||||
set myOptionDict [set ::itcl::internal::dicts::classOptions]
|
||||
if {[dict exists $myOptionDict $className]} {
|
||||
set myOptionDict [dict get $myOptionDict $className]
|
||||
}
|
||||
set cmd [list $widgetPath configure]
|
||||
set cmd1 "set $componentName \[$widgetType $widgetPath\]"
|
||||
uplevel 1 $cmd1
|
||||
if {$starOption} {
|
||||
upvar $componentName compName
|
||||
set cmd1 [list $compName configure]
|
||||
set configInfos [uplevel 1 $cmd1]
|
||||
foreach entry $configInfos {
|
||||
if {[llength $entry] > 2} {
|
||||
foreach {optName resource class defaultValue} $entry break
|
||||
set val ""
|
||||
catch {
|
||||
set val [::option get $win $resource $class]
|
||||
}
|
||||
if {$val ne ""} {
|
||||
set addOpt 1
|
||||
if {[dict exists $myDict $$optName]} {
|
||||
set addOpt 0
|
||||
} else {
|
||||
set starDict [dict get $myDict "*"]
|
||||
if {[dict exists $starDict -except]} {
|
||||
set exceptions [dict get $starDict -except]
|
||||
if {[lsearch $exceptions $optName] >= 0} {
|
||||
set addOpt 0
|
||||
}
|
||||
|
||||
}
|
||||
if {[dict exists $myOptionDict $optName]} {
|
||||
set addOpt 0
|
||||
}
|
||||
}
|
||||
if {$addOpt} {
|
||||
lappend cmd $optName $val
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach optName [dict keys $myDict] {
|
||||
set optInfos [dict get $myDict $optName]
|
||||
set resource [dict get $optInfos -resource]
|
||||
set class [namespace tail $className]
|
||||
set class [string totitle $class]
|
||||
set val ""
|
||||
catch {
|
||||
set val [::option get $win $resource $class]
|
||||
}
|
||||
if {$val ne ""} {
|
||||
if {[dict exists $optInfos -as] } {
|
||||
set optName [dict get $optInfos -as]
|
||||
}
|
||||
lappend cmd $optName $val
|
||||
}
|
||||
}
|
||||
}
|
||||
lappend cmd {*}$opts
|
||||
uplevel 1 $cmd
|
||||
}
|
||||
|
||||
} ; # end ::itcl::builtin
|
||||
|
||||
set ::itcl::internal::dicts::hullTypes [list \
|
||||
frame \
|
||||
toplevel \
|
||||
labelframe \
|
||||
ttk:frame \
|
||||
ttk:toplevel \
|
||||
ttk:labelframe \
|
||||
]
|
||||
|
||||
namespace eval ::itcl::builtin::Info {
|
||||
|
||||
proc hulltypes {args} {
|
||||
namespace upvar ::itcl::internal::dicts hullTypes hullTypes
|
||||
|
||||
set numArgs [llength $args]
|
||||
if {$numArgs > 1} {
|
||||
error "wrong # args should be: info hulltypes ?<pattern>?"
|
||||
}
|
||||
set pattern ""
|
||||
if {$numArgs > 0} {
|
||||
set pattern [lindex $args 0]
|
||||
}
|
||||
if {$pattern ne ""} {
|
||||
return [lsearch -all -inline -glob $hullTypes $pattern]
|
||||
}
|
||||
return $hullTypes
|
||||
|
||||
}
|
||||
|
||||
proc widgetclasses {args} {
|
||||
set numArgs [llength $args]
|
||||
if {$numArgs > 1} {
|
||||
error "wrong # args should be: info widgetclasses ?<pattern>?"
|
||||
}
|
||||
set pattern ""
|
||||
if {$numArgs > 0} {
|
||||
set pattern [lindex $args 0]
|
||||
}
|
||||
set myDict [set ::itcl::internal::dicts::classes]
|
||||
if {![dict exists $myDict widget]} {
|
||||
return [list]
|
||||
}
|
||||
set myDict [dict get $myDict widget]
|
||||
set result [list]
|
||||
if {$pattern ne ""} {
|
||||
foreach key [dict keys $myDict] {
|
||||
set myInfo [dict get $myDict $key]
|
||||
set value [dict get $myInfo -widget]
|
||||
if {[string match $pattern $value]} {
|
||||
lappend result $value
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach key [dict keys $myDict] {
|
||||
set myInfo [dict get $myDict $key]
|
||||
lappend result [dict get $myInfo -widget]
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
proc widgets {args} {
|
||||
set numArgs [llength $args]
|
||||
if {$numArgs > 1} {
|
||||
error "wrong # args should be: info widgets ?<pattern>?"
|
||||
}
|
||||
set pattern ""
|
||||
if {$numArgs > 0} {
|
||||
set pattern [lindex $args 0]
|
||||
}
|
||||
set myDict [set ::itcl::internal::dicts::classes]
|
||||
if {![dict exists $myDict widget]} {
|
||||
return [list]
|
||||
}
|
||||
set myDict [dict get $myDict widget]
|
||||
set result [list]
|
||||
if {$pattern ne ""} {
|
||||
foreach key [dict keys $myDict] {
|
||||
set myInfo [dict get $myDict $key]
|
||||
set value [dict get $myInfo -name]
|
||||
if {[string match $pattern $value]} {
|
||||
lappend result $value
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach key [dict keys $myDict] {
|
||||
set myInfo [dict get $myDict $key]
|
||||
lappend result [dict get $myInfo -name]
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
proc widgetadaptors {args} {
|
||||
set numArgs [llength $args]
|
||||
if {$numArgs > 1} {
|
||||
error "wrong # args should be: info widgetadaptors ?<pattern>?"
|
||||
}
|
||||
set pattern ""
|
||||
if {$numArgs > 0} {
|
||||
set pattern [lindex $args 0]
|
||||
}
|
||||
set myDict [set ::itcl::internal::dicts::classes]
|
||||
if {![dict exists $myDict widgetadaptor]} {
|
||||
return [list]
|
||||
}
|
||||
set myDict [dict get $myDict widgetadaptor]
|
||||
set result [list]
|
||||
if {$pattern ne ""} {
|
||||
foreach key [dict keys $myDict] {
|
||||
set myInfo [dict get $myDict $key]
|
||||
set value [dict get $myInfo -name]
|
||||
if {[string match $pattern $value]} {
|
||||
lappend result $value
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach key [dict keys $myDict] {
|
||||
set myInfo [dict get $myDict $key]
|
||||
lappend result [dict get $myInfo -name]
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
} ; # end ::itcl::builtin::Info
|
||||
6
Git/mingw64/lib/itcl4.1.2/pkgIndex.tcl
Normal file
6
Git/mingw64/lib/itcl4.1.2/pkgIndex.tcl
Normal file
@ -0,0 +1,6 @@
|
||||
# Tcl package index file, version 1.0
|
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
|
||||
|
||||
package ifneeded itcl 4.1.2 [list load [file join $dir "itcl412.dll"] itcl]
|
||||
package ifneeded Itcl 4.1.2 [list load [file join $dir "itcl412.dll"] itcl]
|
||||
Reference in New Issue
Block a user