blob: 9e617b731a95cd37d9a332129b1a6d33d154b070 (
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
|
# Implements script-based implementations of various namespace
# subcommands
#
# (c) 2011 Steve Bennett <steveb@workware.net.au>
#
proc {namespace delete} {args} {
foreach name $args {
if {$name ni {:: ""}} {
set name [uplevel 1 [list ::namespace canon $name]]
foreach i [info commands ${name}::*] { rename $i "" }
uplevel #0 [list unset {*}[info globals ${name}::*]]
}
}
}
proc {namespace origin} {name} {
set nscanon [uplevel 1 [list ::namespace canon $name]]
if {[exists -alias $nscanon]} {
tailcall {namespace origin} [info alias $nscanon]
}
if {[exists -command $nscanon]} {
return ::$nscanon
}
if {[exists -command $name]} {
return ::$name
}
return -code error "invalid command name \"$name\""
}
proc {namespace which} {{type -command} name} {
set nsname ::[uplevel 1 [list ::namespace canon $name]]
if {$type eq "-variable"} {
return $nsname
}
if {$type eq "-command"} {
if {[exists -command $nsname]} {
return $nsname
} elseif {[exists -command ::$name]} {
return ::$name
}
return ""
}
return -code error {wrong # args: should be "namespace which ?-command? ?-variable? name"}
}
proc {namespace code} {arg} {
if {[string first "::namespace inscope " $arg] == 0} {
# Already scoped
return $arg
}
list ::namespace inscope [uplevel 1 ::namespace current] $arg
}
proc {namespace inscope} {name arg args} {
tailcall namespace eval $name $arg $args
}
proc {namespace import} {args} {
set current [uplevel 1 ::namespace canon]
foreach pattern $args {
foreach cmd [info commands [namespace canon $current $pattern]] {
if {[namespace qualifiers $cmd] eq $current} {
return -code error "import pattern \"$pattern\" tries to import from namespace \"$current\" into itself"
}
# What if this alias would create a loop?
# follow the target alias chain to see if we are creating a loop
set newcmd ${current}::[namespace tail $cmd]
set alias $cmd
while {[exists -alias $alias]} {
set alias [info alias $alias]
if {$alias eq $newcmd} {
return -code error "import pattern \"$pattern\" would create a loop"
}
}
alias $newcmd $cmd
}
}
}
# namespace-aware info commands: procs, channels, globals, locals, vars
proc {namespace info} {cmd {pattern *}} {
set current [uplevel 1 ::namespace canon]
# Now we may need to strip $pattern
if {[string first :: $pattern] == 0} {
set global 1
set prefix ::
} else {
set global 0
set clen [string length $current]
incr clen 2
}
set fqp [namespace canon $current $pattern]
switch -glob -- $cmd {
co* - p* {
if {$global} {
set result [info $cmd $fqp]
} else {
# Add commands in the current namespace
set r {}
foreach c [info $cmd $fqp] {
dict set r [string range $c $clen end] 1
}
if {[string match co* $cmd]} {
# Now in the global namespace
foreach c [info -nons commands $pattern] {
dict set r $c 1
}
}
set result [dict keys $r]
}
}
ch* {
set result [info channels $pattern]
}
v* {
#puts "uplevel #0 info gvars $fqp"
set result [uplevel #0 info -nons vars $fqp]
}
g* {
set result [info globals $fqp]
}
l* {
set result [uplevel 1 info -nons locals $pattern]
}
}
if {$global} {
set result [lmap p $result { string cat $prefix $p }]
}
return $result
}
proc {namespace upvar} {ns args} {
set nscanon ::[uplevel 1 [list ::namespace canon $ns]]
set script [list upvar 0]
foreach {other local} $args {
lappend script ${nscanon}::$other $local
}
tailcall {*}$script
}
|
