16 changed files with 1716 additions and 0 deletions
@ -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 add variable itcl-local-$ptr unset \ |
||||
"::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 -encoding utf-8 \[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 -encoding utf-8 \[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 -encoding utf-8 \[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 -encoding utf-8 \[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 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
Binary file not shown.
@ -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.3.4' |
||||
ITCL_VERSION='4.3.4' |
||||
|
||||
# The name of the Itcl library (may be either a .a file or a shared library): |
||||
itcl_LIB_FILE=itcl434.dll |
||||
ITCL_LIB_FILE=itcl434.dll |
||||
|
||||
# String to pass to linker to pick up the Itcl library from its |
||||
# build directory. |
||||
itcl_BUILD_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4 -litcl434' |
||||
ITCL_BUILD_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4 -litcl434' |
||||
|
||||
# String to pass to linker to pick up the Itcl library from its |
||||
# installed directory. |
||||
itcl_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/itcl4.3.4 -litcl434' |
||||
ITCL_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/itcl4.3.4 -litcl434' |
||||
|
||||
# The name of the Itcl stub library (a .a file): |
||||
itcl_STUB_LIB_FILE=libitclstub434.a |
||||
ITCL_STUB_LIB_FILE=libitclstub434.a |
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its |
||||
# build directory. |
||||
itcl_BUILD_STUB_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4 -litclstub434' |
||||
ITCL_BUILD_STUB_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4 -litclstub434' |
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its |
||||
# installed directory. |
||||
itcl_STUB_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/itcl4.3.4 -litclstub434' |
||||
ITCL_STUB_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/itcl4.3.4 -litclstub434' |
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its |
||||
# build directory. |
||||
itcl_BUILD_STUB_LIB_PATH='C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4/libitclstub434.a' |
||||
ITCL_BUILD_STUB_LIB_PATH='C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4/libitclstub434.a' |
||||
|
||||
# String to pass to linker to pick up the Itcl stub library from its |
||||
# installed directory. |
||||
itcl_STUB_LIB_PATH='C:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/itcl4.3.4/libitclstub434.a' |
||||
ITCL_STUB_LIB_PATH='C:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/itcl4.3.4/libitclstub434.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='/c/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4' |
||||
ITCL_SRC_DIR='/c/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4' |
||||
|
||||
# String to pass to the compiler so that an extension can |
||||
# find installed Itcl headers. |
||||
itcl_INCLUDE_SPEC='"-I/c/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4/generic"' |
||||
ITCL_INCLUDE_SPEC='"-I/c/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.4/generic"' |
||||
@ -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 9 |
||||
|
||||
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 |
||||
} |
||||
|
||||
} |
||||
@ -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 9 |
||||
# 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 |
||||
Binary file not shown.
@ -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.3.4 \ |
||||
[list load [file join $dir tcl9itcl434.dll] Itcl] |
||||
} else { |
||||
package ifneeded itcl 4.3.4 \ |
||||
[list load [file join $dir itcl434.dll] Itcl] |
||||
} |
||||
package ifneeded Itcl 4.3.4 [list package require -exact itcl 4.3.4] |
||||
@ -0,0 +1,93 @@
|
||||
# |
||||
# itk::Archetype |
||||
# ---------------------------------------------------------------------- |
||||
# Base class for all widgets in the [incr Tk] Toolkit. Provides |
||||
# facilities to merge widget options into a composite list of options |
||||
# for the overall widget. Derived classes add widgets and methods to |
||||
# specialize behavior. |
||||
# |
||||
# METHODS: |
||||
# configure |
||||
# configure -option |
||||
# configure -option value ?-option value?... |
||||
# Used to set/query configuration options |
||||
# |
||||
# component |
||||
# component <name> <command> ?<arg> <arg>...? |
||||
# Invokes the given <command> as a method on the component |
||||
# called <name>. |
||||
# |
||||
# itk_component add <name> <create-cmd> <option-cmds> |
||||
# Creates a component widget and merges its options into |
||||
# the composite option list for the overall widget |
||||
# |
||||
# itk_component delete <name> ?<name>...? |
||||
# Destroys a component widget and removes its options from |
||||
# the composite option list |
||||
# |
||||
# itk_option add <name> ?<name>...? |
||||
# Adds the option <name> belonging to a class or component |
||||
# widget into the option list. Options can be added even |
||||
# if they were not originally kept when the component was |
||||
# created. |
||||
# |
||||
# itk_option remove <name> ?<name>...? |
||||
# Removes the option <name> belonging to a class or component |
||||
# widget from the option list. This allows a derived class |
||||
# to turn off or redefine undesirable options inherited from |
||||
# a base class. |
||||
# |
||||
# WIDGET ATTRIBUTES: |
||||
# none |
||||
# |
||||
# ---------------------------------------------------------------------- |
||||
# 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. |
||||
|
||||
itcl::class itk::Archetype { |
||||
|
||||
constructor {args} { |
||||
::itcl::builtin::Archetype init |
||||
eval itk_initialize $args |
||||
} |
||||
|
||||
destructor { |
||||
::itcl::builtin::Archetype delete |
||||
} |
||||
|
||||
method cget {option} @Archetype-cget |
||||
|
||||
method configure {{option ""} args} @Archetype-configure |
||||
|
||||
method config {{option ""} args} @Archetype-configure |
||||
|
||||
method component {{name ""} args} @Archetype-component |
||||
|
||||
protected method itk_component {option args} @Archetype-itk_component |
||||
|
||||
protected method itk_option {option args} @Archetype-itk_option |
||||
|
||||
protected method itk_initialize {args} @Archetype-itk_initialize |
||||
|
||||
protected variable itk_option |
||||
protected variable itk_component |
||||
protected variable itk_interior "" |
||||
|
||||
# ------------------------------------------------------------------ |
||||
# Options common to all widgets |
||||
# ------------------------------------------------------------------ |
||||
itk_option define -clientdata clientData ClientData "" |
||||
|
||||
# ------------------------------------------------------------------ |
||||
# Private methods needed for option management |
||||
# ------------------------------------------------------------------ |
||||
private method _initOptionInfo {} @Archetype-init |
||||
private method _deleteOptionInfo {} @Archetype-delete |
||||
} |
||||
@ -0,0 +1,82 @@
|
||||
# |
||||
# itk::Toplevel |
||||
# ---------------------------------------------------------------------- |
||||
# Base class for toplevel windows in the [incr Tk] Toolkit. Creates |
||||
# a new toplevel window to contain the widget. Derived classes add |
||||
# widgets and methods to specialize behavior. |
||||
# |
||||
# WIDGET ATTRIBUTES: |
||||
# switch: -background .... normal background color for widget |
||||
# name: background |
||||
# class: Background |
||||
# |
||||
# switch: -cursor ........ cursor for widget |
||||
# name: cursor |
||||
# class: Cursor |
||||
# |
||||
# switch: -title ......... title given to window manager |
||||
# name: title |
||||
# class: Title |
||||
# |
||||
# ---------------------------------------------------------------------- |
||||
# 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. |
||||
|
||||
itcl::class itk::Toplevel { |
||||
inherit itk::Archetype |
||||
|
||||
constructor {args} { |
||||
# |
||||
# Create a toplevel window with the same name as this object |
||||
# |
||||
set itk_hull [namespace tail $this] |
||||
set itk_interior $itk_hull |
||||
|
||||
itk_component add hull { |
||||
toplevel $itk_hull -class [namespace tail [info class]] |
||||
} { |
||||
keep -menu -background -cursor -takefocus |
||||
} |
||||
bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this] |
||||
|
||||
set tags [bindtags $itk_hull] |
||||
bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull] |
||||
|
||||
eval itk_initialize $args |
||||
} |
||||
|
||||
destructor { |
||||
if {[winfo exists $itk_hull]} { |
||||
set tags [bindtags $itk_hull] |
||||
set i [lsearch $tags itk-delete-$itk_hull] |
||||
if {$i >= 0} { |
||||
bindtags $itk_hull [lreplace $tags $i $i] |
||||
} |
||||
destroy $itk_hull |
||||
} |
||||
itk_component delete hull |
||||
|
||||
set components [component] |
||||
foreach component $components { |
||||
set path($component) [component $component] |
||||
} |
||||
foreach component $components { |
||||
if {[winfo exists $path($component)]} { |
||||
destroy $path($component) |
||||
} |
||||
} |
||||
} |
||||
|
||||
itk_option define -title title Title "" { |
||||
wm title $itk_hull $itk_option(-title) |
||||
} |
||||
|
||||
private variable itk_hull "" |
||||
} |
||||
@ -0,0 +1,79 @@
|
||||
# |
||||
# itk::Widget |
||||
# ---------------------------------------------------------------------- |
||||
# Base class for ordinary widgets in the [incr Tk] Toolkit. Creates |
||||
# a frame to contain the widget. Derived classes add widgets and |
||||
# methods to specialize behavior. |
||||
# |
||||
# METHODS: |
||||
# |
||||
# WIDGET ATTRIBUTES: |
||||
# switch: -background .... normal background color for widget |
||||
# name: background |
||||
# class: Background |
||||
# |
||||
# switch: -cursor ........ cursor used when pointer is inside |
||||
# name: cursur widget |
||||
# class: Cursur |
||||
# |
||||
# ---------------------------------------------------------------------- |
||||
# 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. |
||||
|
||||
itcl::class itk::Widget { |
||||
inherit itk::Archetype |
||||
|
||||
# ------------------------------------------------------------------ |
||||
# CONSTRUCTOR |
||||
# ------------------------------------------------------------------ |
||||
constructor {args} { |
||||
# |
||||
# Create a window with the same name as this object |
||||
# |
||||
set itk_hull [namespace tail $this] |
||||
set itk_interior $itk_hull |
||||
|
||||
itk_component add hull { |
||||
frame $itk_hull -class [namespace tail [info class]] |
||||
} { |
||||
keep -background -cursor |
||||
} |
||||
bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this] |
||||
|
||||
set tags [bindtags $itk_hull] |
||||
bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull] |
||||
|
||||
eval itk_initialize $args |
||||
} |
||||
|
||||
destructor { |
||||
if {[winfo exists $itk_hull]} { |
||||
set tags [bindtags $itk_hull] |
||||
set i [lsearch $tags itk-delete-$itk_hull] |
||||
if {$i >= 0} { |
||||
bindtags $itk_hull [lreplace $tags $i $i] |
||||
} |
||||
destroy $itk_hull |
||||
} |
||||
itk_component delete hull |
||||
|
||||
set components [component] |
||||
foreach component $components { |
||||
set path($component) [component $component] |
||||
} |
||||
foreach component $components { |
||||
if {[winfo exists $path($component)]} { |
||||
destroy $path($component) |
||||
} |
||||
} |
||||
} |
||||
|
||||
private variable itk_hull "" |
||||
} |
||||
@ -0,0 +1,149 @@
|
||||
# |
||||
# itk.tcl |
||||
# ---------------------------------------------------------------------- |
||||
# Invoked automatically upon startup to customize the interpreter |
||||
# for [incr Tk]. |
||||
# ---------------------------------------------------------------------- |
||||
# 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. |
||||
|
||||
package require -exact Itk 4.2.5 |
||||
# |
||||
# Provide transparent access to all [incr Tk] commands |
||||
# |
||||
lappend auto_path ${itk::library} |
||||
|
||||
# ---------------------------------------------------------------------- |
||||
# USAGE: itk::remove_destroy_hook <widget> |
||||
# |
||||
# Used internally via "itk_component delete" when disconnecting a |
||||
# component <widget> from the mega-widget that contains it. |
||||
# Each component has a special binding for the <Destroy> event |
||||
# that causes it to disconnect itself from its parent when destroyed. |
||||
# This procedure removes the binding from the binding tag list and |
||||
# deletes the binding. It is much easier to implement this in |
||||
# Tcl than C. |
||||
# ---------------------------------------------------------------------- |
||||
proc ::itk::remove_destroy_hook {widget} { |
||||
if {![winfo exists $widget]} {return} |
||||
set tags [bindtags $widget] |
||||
set i [lsearch $tags "itk-destroy-$widget"] |
||||
if {$i >= 0} { |
||||
bindtags $widget [lreplace $tags $i $i] |
||||
} |
||||
bind itk-destroy-$widget <Destroy> {} |
||||
} |
||||
|
||||
# |
||||
# Define "usual" option-handling code for the Tk widgets: |
||||
# |
||||
itk::usual Button { |
||||
keep -background -cursor -foreground -font |
||||
keep -activebackground -activeforeground -disabledforeground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Canvas { |
||||
keep -background -cursor |
||||
keep -insertbackground -insertborderwidth -insertwidth |
||||
keep -insertontime -insertofftime |
||||
keep -selectbackground -selectborderwidth -selectforeground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Checkbutton { |
||||
keep -background -cursor -foreground -font |
||||
keep -activebackground -activeforeground -disabledforeground |
||||
keep -selectcolor |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Entry { |
||||
keep -background -cursor -foreground -font |
||||
keep -insertbackground -insertborderwidth -insertwidth |
||||
keep -insertontime -insertofftime |
||||
keep -selectbackground -selectborderwidth -selectforeground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Frame { |
||||
keep -background -cursor |
||||
} |
||||
|
||||
itk::usual Label { |
||||
keep -background -cursor -foreground -font |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Listbox { |
||||
keep -background -cursor -foreground -font |
||||
keep -selectbackground -selectborderwidth -selectforeground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Menu { |
||||
keep -background -cursor -foreground -font |
||||
keep -activebackground -activeforeground -disabledforeground |
||||
keep -selectcolor -tearoff |
||||
} |
||||
|
||||
itk::usual Menubutton { |
||||
keep -background -cursor -foreground -font |
||||
keep -activebackground -activeforeground -disabledforeground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Message { |
||||
keep -background -cursor -foreground -font |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Radiobutton { |
||||
keep -background -cursor -foreground -font |
||||
keep -activebackground -activeforeground -disabledforeground |
||||
keep -selectcolor |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Scale { |
||||
keep -background -cursor -foreground -font -troughcolor |
||||
keep -activebackground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Scrollbar { |
||||
keep -background -cursor -troughcolor |
||||
keep -activebackground -activerelief |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Text { |
||||
keep -background -cursor -foreground -font |
||||
keep -insertbackground -insertborderwidth -insertwidth |
||||
keep -insertontime -insertofftime |
||||
keep -selectbackground -selectborderwidth -selectforeground |
||||
keep -highlightcolor -highlightthickness |
||||
rename -highlightbackground -background background Background |
||||
} |
||||
|
||||
itk::usual Toplevel { |
||||
keep -background -cursor |
||||
} |
||||
Binary file not shown.
@ -0,0 +1,45 @@
|
||||
# itkConfig.sh -- |
||||
# |
||||
# This shell script (for sh) is generated automatically by Itk'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 Itk 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, tkConfig.sh or itclConfig.sh, |
||||
# so you may need to use those files in addition to this one. |
||||
# |
||||
# The information in this file is specific to a single platform. |
||||
|
||||
# Itcl's version number. |
||||
ITCL_VERSION='4.3.4' |
||||
|
||||
# The name of the Itk library (may be either a .a file or a shared library): |
||||
ITK_LIB_FILE=itk425.dll |
||||
|
||||
# String to pass to linker to pick up the Itk library from its |
||||
# build directory. |
||||
ITK_BUILD_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Build/itk -litk425' |
||||
|
||||
# String to pass to linker to pick up the Itk library from its |
||||
# installed directory. |
||||
ITK_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Install/itk/lib/itk4.2.5 -litk425' |
||||
|
||||
# The name of the Itk stub library (a .a file): |
||||
ITK_STUB_LIB_FILE=libitkstub425.a |
||||
|
||||
# String to pass to linker to pick up the Itk stub library from its |
||||
# build directory. |
||||
ITK_BUILD_STUB_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Build/itk -litkstub425' |
||||
|
||||
# String to pass to linker to pick up the Itk stub library from its |
||||
# installed directory. |
||||
ITK_STUB_LIB_SPEC='-LC:/bawt/BawtBuild/Windows/x64/Release/Install/itk/lib/itk4.2.5 -litkstub425' |
||||
|
||||
# Location of the top-level source directories from which [incr Tk] |
||||
# was built. This is the directory that contains a README file as well |
||||
# as subdirectories such as generic, unix, etc. If [incr Tk] 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 Tk] was compiled. |
||||
ITK_SRC_DIR='/C/bawt/BawtBuild/Windows/x64/Release/Build/itk' |
||||
Binary file not shown.
@ -0,0 +1,16 @@
|
||||
# -*- tcl -*- |
||||
# Tcl package index file, version 1.1 |
||||
# |
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.6-]} {return} |
||||
if {[string length [package provide Itcl]] && ![package vsatisfies [package provide Itcl] 4.1]} return |
||||
if {[package vsatisfies [package provide Tcl] 9.0-]} { |
||||
package ifneeded itk 4.2.5 \ |
||||
[list load [file join $dir tcl9itk425.dll] Itk] |
||||
} else { |
||||
package ifneeded itk 4.2.5 \ |
||||
[list load [file join $dir itk425.dll] Itk] |
||||
} |
||||
|
||||
package ifneeded Itk 4.2.5 \ |
||||
[list package require -exact itk 4.2.5] |
||||
@ -0,0 +1,11 @@
|
||||
# Tcl autoload index file, version 2.0 |
||||
# This file is generated by the "auto_mkindex" command |
||||
# and sourced to set up indexing information for one or |
||||
# more commands. Typically each line is a command that |
||||
# sets an element in the auto_index array, where the |
||||
# element name is the name of a command and the value is |
||||
# a script that loads the command. |
||||
|
||||
set auto_index(::itk::Archetype) [list source [file join $dir Archetype.itk]] |
||||
set auto_index(::itk::Toplevel) [list source [file join $dir Toplevel.itk]] |
||||
set auto_index(::itk::Widget) [list source [file join $dir Widget.itk]] |
||||
Loading…
Reference in new issue