blob: c91973f8f13c3a1b2db7d4c18725a5fd9e1c0bd2 (
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
|
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
}
|
