blob: 33acb51eadbb1262154f40314298f32fd5d24e70 (
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
|
# 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]] {
alias ${current}::[namespace tail $cmd] $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 { set p $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
}
|
