blob: 3a8e54c3b22490023970e1ca31c4fa8fb061014e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
#
# 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
#
# RCS: $Id$
# ----------------------------------------------------------------------
# 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.
# ----------------------------------------------------------------------
# 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 object $cmd; list"]
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 itcl_class} {
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.
#
auto_mkindex_parser::command itcl::body {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.
#
auto_mkindex_parser::command itcl::configbody {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.
#
auto_mkindex_parser::command itcl::ensemble {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
}
}
# CYGNUS LOCAL
# This version of auto_import does not work, because it relies
# WHOLLY on the tclIndex files, but the tclIndex files have no
# notion of what the export list for a namespace is. So at the
# time you do "namespace import" the export list is empty, and
# so nothing is imported.
# Until that is fixed, it is best just to go back to the original
# Tcl version of auto_import...
# ----------------------------------------------------------------------
# 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
# }
# }
# }
# }
|
