comment here
This commit is contained in:
ton
Vendored
+151
@@ -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
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
+67
@@ -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.2.2'
|
||||
ITCL_VERSION='4.2.2'
|
||||
|
||||
# The name of the Itcl library (may be either a .a file or a shared library):
|
||||
itcl_LIB_FILE=libitcl4.2.2.so
|
||||
ITCL_LIB_FILE=libitcl4.2.2.so
|
||||
|
||||
# String to pass to linker to pick up the Itcl library from its
|
||||
# build directory.
|
||||
itcl_BUILD_LIB_SPEC='-L/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/unix/pkgs/itcl4.2.2 -litcl4.2.2'
|
||||
ITCL_BUILD_LIB_SPEC='-L/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/unix/pkgs/itcl4.2.2 -litcl4.2.2'
|
||||
|
||||
# String to pass to linker to pick up the Itcl library from its
|
||||
# installed directory.
|
||||
itcl_LIB_SPEC='-L/home/ton/.julia/dev/ImageUtils/.CondaPkg/env/lib/itcl4.2.2 -litcl4.2.2'
|
||||
ITCL_LIB_SPEC='-L/home/ton/.julia/dev/ImageUtils/.CondaPkg/env/lib/itcl4.2.2 -litcl4.2.2'
|
||||
|
||||
# The name of the Itcl stub library (a .a file):
|
||||
itcl_STUB_LIB_FILE=libitclstub4.2.2.a
|
||||
ITCL_STUB_LIB_FILE=libitclstub4.2.2.a
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# build directory.
|
||||
itcl_BUILD_STUB_LIB_SPEC='-L/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/unix/pkgs/itcl4.2.2 -litclstub4.2.2'
|
||||
ITCL_BUILD_STUB_LIB_SPEC='-L/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/unix/pkgs/itcl4.2.2 -litclstub4.2.2'
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# installed directory.
|
||||
itcl_STUB_LIB_SPEC='-L/home/ton/.julia/dev/ImageUtils/.CondaPkg/env/lib/itcl4.2.2 -litclstub4.2.2'
|
||||
ITCL_STUB_LIB_SPEC='-L/home/ton/.julia/dev/ImageUtils/.CondaPkg/env/lib/itcl4.2.2 -litclstub4.2.2'
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# build directory.
|
||||
itcl_BUILD_STUB_LIB_PATH='/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/unix/pkgs/itcl4.2.2/libitclstub4.2.2.a'
|
||||
ITCL_BUILD_STUB_LIB_PATH='/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/unix/pkgs/itcl4.2.2/libitclstub4.2.2.a'
|
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its
|
||||
# installed directory.
|
||||
itcl_STUB_LIB_PATH='/home/ton/.julia/dev/ImageUtils/.CondaPkg/env/lib/itcl4.2.2/libitclstub4.2.2.a'
|
||||
ITCL_STUB_LIB_PATH='/home/ton/.julia/dev/ImageUtils/.CondaPkg/env/lib/itcl4.2.2/libitclstub4.2.2.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='/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/pkgs/itcl4.2.2'
|
||||
ITCL_SRC_DIR='/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/pkgs/itcl4.2.2'
|
||||
|
||||
# String to pass to the compiler so that an extension can
|
||||
# find installed Itcl headers.
|
||||
itcl_INCLUDE_SPEC='-I/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/pkgs/itcl4.2.2/generic'
|
||||
ITCL_INCLUDE_SPEC='-I/home/conda/feedstock_root/build_artifacts/tk_1645033378611/work/tcl8.6.12/pkgs/itcl4.2.2/generic'
|
||||
+562
@@ -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
@@ -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
|
||||
BIN
Binary file not shown.
BIN
Binary file not shown.
+14
@@ -0,0 +1,14 @@
|
||||
# -*- tcl -*-
|
||||
# Tcl package index file, version 1.1
|
||||
#
|
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
|
||||
|
||||
if {[package vsatisfies [package provide Tcl] 9.0-]} {
|
||||
package ifneeded itcl 4.2.2 \
|
||||
[list load [file join $dir libtcl9itcl4.2.2.so] Itcl]
|
||||
} else {
|
||||
package ifneeded itcl 4.2.2 \
|
||||
[list load [file join $dir libitcl4.2.2.so] Itcl]
|
||||
}
|
||||
package ifneeded Itcl 4.2.2 [list package require -exact itcl 4.2.2]
|
||||
+1
@@ -0,0 +1 @@
|
||||
libatomic.so.1.2.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libatomic.so.1.2.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
Vendored
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libbz2.so.1.0.8
|
||||
+1
@@ -0,0 +1 @@
|
||||
libbz2.so.1.0.8
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
+1
@@ -0,0 +1 @@
|
||||
libcrypto.so.3
|
||||
BIN
Binary file not shown.
Vendored
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libffi.so.8.1.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libffi.so.8.1.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libform.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libform.so.6.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libformw.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libformw.so.6.3
|
||||
BIN
Binary file not shown.
Vendored
+4
@@ -0,0 +1,4 @@
|
||||
/* GNU ld script
|
||||
Use the shared library, but some functions are only in
|
||||
the static library. */
|
||||
GROUP ( libgcc_s.so.1 -lgcc )
|
||||
Vendored
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libgfortran.so.5.0.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libgfortran.so.5.0.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libgomp.so.1.0.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libgomp.so.1.0.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libhistory.so.8.1
|
||||
+1
@@ -0,0 +1 @@
|
||||
libhistory.so.8.1
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libitm.so.1.0.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libitm.so.1.0.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
+1
@@ -0,0 +1 @@
|
||||
liblzma.so.5.2.6
|
||||
+1
@@ -0,0 +1 @@
|
||||
liblzma.so.5.2.6
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libmenu.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libmenu.so.6.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libmenuw.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libmenuw.so.6.3
|
||||
BIN
Binary file not shown.
Vendored
BIN
Binary file not shown.
Vendored
BIN
Binary file not shown.
Vendored
+1
@@ -0,0 +1 @@
|
||||
INPUT(libncurses.so.6 -ltinfo)
|
||||
+1
@@ -0,0 +1 @@
|
||||
libncurses.so.6.3
|
||||
BIN
Binary file not shown.
Vendored
+1
@@ -0,0 +1 @@
|
||||
INPUT(libncursesw.so.6 -ltinfow)
|
||||
+1
@@ -0,0 +1 @@
|
||||
libncursesw.so.6.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libnsl.so.3.0.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libnsl.so.3.0.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libopenblasp-r0.3.21.so
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libpanel.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libpanel.so.6.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libpanelw.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libpanelw.so.6.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libpython3.11.so.1.0
|
||||
BIN
Binary file not shown.
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libquadmath.so.0.0.0
|
||||
+1
@@ -0,0 +1 @@
|
||||
libquadmath.so.0.0.0
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libreadline.so.8.1
|
||||
+1
@@ -0,0 +1 @@
|
||||
libreadline.so.8.1
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libsqlite3.so.0.8.6
|
||||
+1
@@ -0,0 +1 @@
|
||||
libsqlite3.so.0.8.6
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libssl.so.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libstdc++.so.6.0.30
|
||||
+1
@@ -0,0 +1 @@
|
||||
libstdc++.so.6.0.30
|
||||
BIN
Binary file not shown.
BIN
Binary file not shown.
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libtinfo.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libtinfo.so.6.3
|
||||
BIN
Binary file not shown.
+1
@@ -0,0 +1 @@
|
||||
libtinfow.so.6.3
|
||||
+1
@@ -0,0 +1 @@
|
||||
libtinfow.so.6.3
|
||||
BIN
Binary file not shown.
BIN
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user