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