Mercurial > repos > rliterman > csp2
diff CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/itcl4.2.3/itcl.tcl @ 68:5028fdace37b
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author | jpayne |
---|---|
date | Tue, 18 Mar 2025 16:23:26 -0400 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/itcl4.2.3/itcl.tcl Tue Mar 18 16:23:26 2025 -0400 @@ -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 + } + } + } +}