Mercurial > repos > rliterman > csp2

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