1 |
578 |
markom |
#
|
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 |
|
|
# RCS: $Id: itcl.tcl,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
13 |
|
|
# ----------------------------------------------------------------------
|
14 |
|
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
15 |
|
|
# ======================================================================
|
16 |
|
|
# See the file "license.terms" for information on usage and
|
17 |
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
18 |
|
|
|
19 |
|
|
# ----------------------------------------------------------------------
|
20 |
|
|
# USAGE: local <className> <objName> ?<arg> <arg>...?
|
21 |
|
|
#
|
22 |
|
|
# Creates a new object called <objName> in class <className>, passing
|
23 |
|
|
# the remaining <arg>'s to the constructor. Unlike the usual
|
24 |
|
|
# [incr Tcl] objects, however, an object created by this procedure
|
25 |
|
|
# will be automatically deleted when the local call frame is destroyed.
|
26 |
|
|
# This command is useful for creating objects that should only remain
|
27 |
|
|
# alive until a procedure exits.
|
28 |
|
|
# ----------------------------------------------------------------------
|
29 |
|
|
proc ::itcl::local {class name args} {
|
30 |
|
|
set ptr [uplevel eval [list $class $name] $args]
|
31 |
|
|
uplevel [list set itcl-local-$ptr $ptr]
|
32 |
|
|
set cmd [uplevel namespace which -command $ptr]
|
33 |
|
|
uplevel [list trace variable itcl-local-$ptr u \
|
34 |
|
|
"itcl::delete object $cmd; list"]
|
35 |
|
|
return $ptr
|
36 |
|
|
}
|
37 |
|
|
|
38 |
|
|
# ----------------------------------------------------------------------
|
39 |
|
|
# auto_mkindex
|
40 |
|
|
# ----------------------------------------------------------------------
|
41 |
|
|
# Define Itcl commands that will be recognized by the auto_mkindex
|
42 |
|
|
# parser in Tcl...
|
43 |
|
|
#
|
44 |
|
|
|
45 |
|
|
#
|
46 |
|
|
# USAGE: itcl::class name body
|
47 |
|
|
# Adds an entry for the given class declaration.
|
48 |
|
|
#
|
49 |
|
|
foreach cmd {itcl::class itcl_class} {
|
50 |
|
|
auto_mkindex_parser::command $cmd {name body} {
|
51 |
|
|
variable index
|
52 |
|
|
variable scriptFile
|
53 |
|
|
append index "set [list auto_index([fullname $name])]"
|
54 |
|
|
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
55 |
|
|
|
56 |
|
|
variable parser
|
57 |
|
|
variable contextStack
|
58 |
|
|
set contextStack [linsert $contextStack 0 $name]
|
59 |
|
|
$parser eval $body
|
60 |
|
|
set contextStack [lrange $contextStack 1 end]
|
61 |
|
|
}
|
62 |
|
|
}
|
63 |
|
|
|
64 |
|
|
#
|
65 |
|
|
# USAGE: itcl::body name arglist body
|
66 |
|
|
# Adds an entry for the given method/proc body.
|
67 |
|
|
#
|
68 |
|
|
auto_mkindex_parser::command itcl::body {name arglist body} {
|
69 |
|
|
variable index
|
70 |
|
|
variable scriptFile
|
71 |
|
|
append index "set [list auto_index([fullname $name])]"
|
72 |
|
|
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
73 |
|
|
}
|
74 |
|
|
|
75 |
|
|
#
|
76 |
|
|
# USAGE: itcl::configbody name arglist body
|
77 |
|
|
# Adds an entry for the given method/proc body.
|
78 |
|
|
#
|
79 |
|
|
auto_mkindex_parser::command itcl::configbody {name body} {
|
80 |
|
|
variable index
|
81 |
|
|
variable scriptFile
|
82 |
|
|
append index "set [list auto_index([fullname $name])]"
|
83 |
|
|
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
84 |
|
|
}
|
85 |
|
|
|
86 |
|
|
#
|
87 |
|
|
# USAGE: ensemble name ?body?
|
88 |
|
|
# Adds an entry to the auto index list for the given ensemble name.
|
89 |
|
|
#
|
90 |
|
|
auto_mkindex_parser::command itcl::ensemble {name {body ""}} {
|
91 |
|
|
variable index
|
92 |
|
|
variable scriptFile
|
93 |
|
|
append index "set [list auto_index([fullname $name])]"
|
94 |
|
|
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
|
95 |
|
|
}
|
96 |
|
|
|
97 |
|
|
#
|
98 |
|
|
# USAGE: public arg ?arg arg...?
|
99 |
|
|
# protected arg ?arg arg...?
|
100 |
|
|
# private arg ?arg arg...?
|
101 |
|
|
#
|
102 |
|
|
# Evaluates the arguments as commands, so we can recognize proc
|
103 |
|
|
# declarations within classes.
|
104 |
|
|
#
|
105 |
|
|
foreach cmd {public protected private} {
|
106 |
|
|
auto_mkindex_parser::command $cmd {args} {
|
107 |
|
|
variable parser
|
108 |
|
|
$parser eval $args
|
109 |
|
|
}
|
110 |
|
|
}
|
111 |
|
|
|
112 |
|
|
# CYGNUS LOCAL
|
113 |
|
|
# This version of auto_import does not work, because it relies
|
114 |
|
|
# WHOLLY on the tclIndex files, but the tclIndex files have no
|
115 |
|
|
# notion of what the export list for a namespace is. So at the
|
116 |
|
|
# time you do "namespace import" the export list is empty, and
|
117 |
|
|
# so nothing is imported.
|
118 |
|
|
# Until that is fixed, it is best just to go back to the original
|
119 |
|
|
# Tcl version of auto_import...
|
120 |
|
|
|
121 |
|
|
# ----------------------------------------------------------------------
|
122 |
|
|
# auto_import
|
123 |
|
|
# ----------------------------------------------------------------------
|
124 |
|
|
# This procedure overrides the usual "auto_import" function in the
|
125 |
|
|
# Tcl library. It is invoked during "namespace import" to make see
|
126 |
|
|
# if the imported commands reside in an autoloaded library. If so,
|
127 |
|
|
# stubs are created to represent the commands. Executing a stub
|
128 |
|
|
# later on causes the real implementation to be autoloaded.
|
129 |
|
|
#
|
130 |
|
|
# Arguments -
|
131 |
|
|
# pattern The pattern of commands being imported (like "foo::*")
|
132 |
|
|
# a canonical namespace as returned by [namespace current]
|
133 |
|
|
|
134 |
|
|
#proc auto_import {pattern} {
|
135 |
|
|
# global auto_index
|
136 |
|
|
|
137 |
|
|
# set ns [uplevel namespace current]
|
138 |
|
|
# set patternList [auto_qualify $pattern $ns]
|
139 |
|
|
|
140 |
|
|
# auto_load_index
|
141 |
|
|
|
142 |
|
|
# foreach pattern $patternList {
|
143 |
|
|
# foreach name [array names auto_index $pattern] {
|
144 |
|
|
# if {"" == [info commands $name]} {
|
145 |
|
|
# ::itcl::import::stub create $name
|
146 |
|
|
# }
|
147 |
|
|
# }
|
148 |
|
|
# }
|
149 |
|
|
# }
|