nshelper.tcl

   1 proc {namespace delete} {args} {
   2         foreach name $args {
   3                 if {$name ni {:: ""}} {
   4                         set name [uplevel 1 [list ::namespace canon $name]]
   5                         foreach i [info commands ${name}::*] { rename $i "" }
   6                         uplevel #0 [list unset {*}[info globals ${name}::*]]
   7                 }
   8         }
   9 }
  10
  11 proc {namespace origin} {name} {
  12         set nscanon [uplevel 1 [list ::namespace canon $name]]
  13         if {[exists -alias $nscanon]} {
  14                 tailcall {namespace origin} [info alias $nscanon]
  15         }
  16         if {[exists -command $nscanon]} {
  17                 return ::$nscanon
  18         }
  19         if {[exists -command $name]} {
  20                 return ::$name
  21         }
  22
  23         return -code error "invalid command name \"$name\""
  24 }
  25
  26 proc {namespace which} {{type -command} name} {
  27         set nsname ::[uplevel 1 [list ::namespace canon $name]]
  28         if {$type eq "-variable"} {
  29                 return $nsname
  30         }
  31         if {$type eq "-command"} {
  32                 if {[exists -command $nsname]} {
  33                         return $nsname
  34                 } elseif {[exists -command ::$name]} {
  35                         return ::$name
  36                 }
  37                 return ""
  38         }
  39         return -code error {wrong # args: should be "namespace which ?-command? ?-variable? name"}
  40 }
  41
  42
  43 proc {namespace code} {arg} {
  44         if {[string first "::namespace inscope " $arg] == 0} {
  45                 # Already scoped
  46                 return $arg
  47         }
  48         list ::namespace inscope [uplevel 1 ::namespace current] $arg
  49 }
  50
  51 proc {namespace inscope} {name arg args} {
  52         tailcall namespace eval $name $arg $args
  53 }
  54
  55 proc {namespace import} {args} {
  56         set current [uplevel 1 ::namespace canon]
  57
  58         foreach pattern $args {
  59                 foreach cmd [info commands [namespace canon $current $pattern]] {
  60                         alias ${current}::[namespace tail $cmd] $cmd
  61                 }
  62         }
  63 }
  64
  65 # namespace-aware info commands: procs, channels, globals, locals, vars
  66 proc {namespace info} {cmd {pattern *}} {
  67         set current [uplevel 1 ::namespace canon]
  68         # Now we may need to strip $pattern
  69         if {[string first :: $pattern] == 0} {
  70                 set global 1
  71                 set prefix ::
  72         } else {
  73                 set global 0
  74                 set clen [string length $current]
  75                 incr clen 2
  76         }
  77         set fqp [namespace canon $current $pattern]
  78         switch -glob -- $cmd {
  79                 co* - p* {
  80                         if {$global} {
  81                                 set result [info $cmd $fqp]
  82                         } else {
  83                                 # Add commands in the current namespace
  84                                 set r {}
  85                                 foreach c [info $cmd $fqp] {
  86                                         dict set r [string range $c $clen end] 1
  87                                 }
  88                                 if {[string match co* $cmd]} {
  89                                         # Now in the global namespace
  90                                         foreach c [info -nons commands $pattern] {
  91                                                 dict set r $c 1
  92                                         }
  93                                 }
  94                                 set result [dict keys $r]
  95                         }
  96                 }
  97                 ch* {
  98                         set result [info channels $pattern]
  99                 }
 100                 v* {
 101                         #puts "uplevel #0 info gvars $fqp"
 102                         set result [uplevel #0 info -nons vars $fqp]
 103                 }
 104                 g* {
 105                         set result [info globals $fqp]
 106                 }
 107                 l* {
 108                         set result [uplevel 1 info -nons locals $pattern]
 109                 }
 110         }
 111         if {$global} {
 112                 set result [lmap p $result { set p $prefix$p }]
 113         }
 114         return $result
 115 }
 116
 117 proc {namespace upvar} {ns args} {
 118         set nscanon ::[uplevel 1 [list ::namespace canon $ns]]
 119         set script [list upvar 0]
 120         foreach {other local} $args {
 121                 lappend script ${nscanon}::$other $local
 122         }
 123         tailcall {*}$script
 124 }