Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/itcl4.2.3/itcl.tcl @ 68:5028fdace37b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author jpayne
date Tue, 18 Mar 2025 16:23:26 -0400
parents
children
rev   line source
jpayne@68 1 #
jpayne@68 2 # itcl.tcl
jpayne@68 3 # ----------------------------------------------------------------------
jpayne@68 4 # Invoked automatically upon startup to customize the interpreter
jpayne@68 5 # for [incr Tcl].
jpayne@68 6 # ----------------------------------------------------------------------
jpayne@68 7 # AUTHOR: Michael J. McLennan
jpayne@68 8 # Bell Labs Innovations for Lucent Technologies
jpayne@68 9 # mmclennan@lucent.com
jpayne@68 10 # http://www.tcltk.com/itcl
jpayne@68 11 # ----------------------------------------------------------------------
jpayne@68 12 # Copyright (c) 1993-1998 Lucent Technologies, Inc.
jpayne@68 13 # ======================================================================
jpayne@68 14 # See the file "license.terms" for information on usage and
jpayne@68 15 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@68 16
jpayne@68 17 proc ::itcl::delete_helper { name args } {
jpayne@68 18 ::itcl::delete object $name
jpayne@68 19 }
jpayne@68 20
jpayne@68 21 # ----------------------------------------------------------------------
jpayne@68 22 # USAGE: local <className> <objName> ?<arg> <arg>...?
jpayne@68 23 #
jpayne@68 24 # Creates a new object called <objName> in class <className>, passing
jpayne@68 25 # the remaining <arg>'s to the constructor. Unlike the usual
jpayne@68 26 # [incr Tcl] objects, however, an object created by this procedure
jpayne@68 27 # will be automatically deleted when the local call frame is destroyed.
jpayne@68 28 # This command is useful for creating objects that should only remain
jpayne@68 29 # alive until a procedure exits.
jpayne@68 30 # ----------------------------------------------------------------------
jpayne@68 31 proc ::itcl::local {class name args} {
jpayne@68 32 set ptr [uplevel [list $class $name] $args]
jpayne@68 33 uplevel [list set itcl-local-$ptr $ptr]
jpayne@68 34 set cmd [uplevel namespace which -command $ptr]
jpayne@68 35 uplevel [list trace variable itcl-local-$ptr u \
jpayne@68 36 "::itcl::delete_helper $cmd"]
jpayne@68 37 return $ptr
jpayne@68 38 }
jpayne@68 39
jpayne@68 40 # ----------------------------------------------------------------------
jpayne@68 41 # auto_mkindex
jpayne@68 42 # ----------------------------------------------------------------------
jpayne@68 43 # Define Itcl commands that will be recognized by the auto_mkindex
jpayne@68 44 # parser in Tcl...
jpayne@68 45 #
jpayne@68 46
jpayne@68 47 #
jpayne@68 48 # USAGE: itcl::class name body
jpayne@68 49 # Adds an entry for the given class declaration.
jpayne@68 50 #
jpayne@68 51 foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} {
jpayne@68 52 auto_mkindex_parser::command $__cmd {name body} {
jpayne@68 53 variable index
jpayne@68 54 variable scriptFile
jpayne@68 55 append index "set [list auto_index([fullname $name])]"
jpayne@68 56 append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
jpayne@68 57
jpayne@68 58 variable parser
jpayne@68 59 variable contextStack
jpayne@68 60 set contextStack [linsert $contextStack 0 $name]
jpayne@68 61 $parser eval $body
jpayne@68 62 set contextStack [lrange $contextStack 1 end]
jpayne@68 63 }
jpayne@68 64 }
jpayne@68 65
jpayne@68 66 #
jpayne@68 67 # USAGE: itcl::body name arglist body
jpayne@68 68 # Adds an entry for the given method/proc body.
jpayne@68 69 #
jpayne@68 70 foreach __cmd {itcl::body body} {
jpayne@68 71 auto_mkindex_parser::command $__cmd {name arglist body} {
jpayne@68 72 variable index
jpayne@68 73 variable scriptFile
jpayne@68 74 append index "set [list auto_index([fullname $name])]"
jpayne@68 75 append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
jpayne@68 76 }
jpayne@68 77 }
jpayne@68 78
jpayne@68 79 #
jpayne@68 80 # USAGE: itcl::configbody name arglist body
jpayne@68 81 # Adds an entry for the given method/proc body.
jpayne@68 82 #
jpayne@68 83 foreach __cmd {itcl::configbody configbody} {
jpayne@68 84 auto_mkindex_parser::command $__cmd {name body} {
jpayne@68 85 variable index
jpayne@68 86 variable scriptFile
jpayne@68 87 append index "set [list auto_index([fullname $name])]"
jpayne@68 88 append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
jpayne@68 89 }
jpayne@68 90 }
jpayne@68 91
jpayne@68 92 #
jpayne@68 93 # USAGE: ensemble name ?body?
jpayne@68 94 # Adds an entry to the auto index list for the given ensemble name.
jpayne@68 95 #
jpayne@68 96 foreach __cmd {itcl::ensemble ensemble} {
jpayne@68 97 auto_mkindex_parser::command $__cmd {name {body ""}} {
jpayne@68 98 variable index
jpayne@68 99 variable scriptFile
jpayne@68 100 append index "set [list auto_index([fullname $name])]"
jpayne@68 101 append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
jpayne@68 102 }
jpayne@68 103 }
jpayne@68 104
jpayne@68 105 #
jpayne@68 106 # USAGE: public arg ?arg arg...?
jpayne@68 107 # protected arg ?arg arg...?
jpayne@68 108 # private arg ?arg arg...?
jpayne@68 109 #
jpayne@68 110 # Evaluates the arguments as commands, so we can recognize proc
jpayne@68 111 # declarations within classes.
jpayne@68 112 #
jpayne@68 113 foreach __cmd {public protected private} {
jpayne@68 114 auto_mkindex_parser::command $__cmd {args} {
jpayne@68 115 variable parser
jpayne@68 116 $parser eval $args
jpayne@68 117 }
jpayne@68 118 }
jpayne@68 119
jpayne@68 120 # SF bug #246 unset variable __cmd to avoid problems in user programs!!
jpayne@68 121 unset __cmd
jpayne@68 122
jpayne@68 123 # ----------------------------------------------------------------------
jpayne@68 124 # auto_import
jpayne@68 125 # ----------------------------------------------------------------------
jpayne@68 126 # This procedure overrides the usual "auto_import" function in the
jpayne@68 127 # Tcl library. It is invoked during "namespace import" to make see
jpayne@68 128 # if the imported commands reside in an autoloaded library. If so,
jpayne@68 129 # stubs are created to represent the commands. Executing a stub
jpayne@68 130 # later on causes the real implementation to be autoloaded.
jpayne@68 131 #
jpayne@68 132 # Arguments -
jpayne@68 133 # pattern The pattern of commands being imported (like "foo::*")
jpayne@68 134 # a canonical namespace as returned by [namespace current]
jpayne@68 135
jpayne@68 136 proc auto_import {pattern} {
jpayne@68 137 global auto_index
jpayne@68 138
jpayne@68 139 set ns [uplevel namespace current]
jpayne@68 140 set patternList [auto_qualify $pattern $ns]
jpayne@68 141
jpayne@68 142 auto_load_index
jpayne@68 143
jpayne@68 144 foreach pattern $patternList {
jpayne@68 145 foreach name [array names auto_index $pattern] {
jpayne@68 146 if {"" == [info commands $name]} {
jpayne@68 147 ::itcl::import::stub create $name
jpayne@68 148 }
jpayne@68 149 }
jpayne@68 150 }
jpayne@68 151 }