nshelper.tcl

   1 # Implements script-based implementations of various namespace
   2 # subcommands
   3 #
   4 # (c) 2011 Steve Bennett <steveb@workware.net.au>
   5 #
   6
   7 proc {namespace delete} {args} {
   8         foreach name $args {
   9                 if {$name ni {:: ""}} {
  10                         set name [uplevel 1 [list ::namespace canon $name]]
  11                         foreach i [info commands ${name}::*] { rename $i "" }
  12                         uplevel #0 [list unset {*}[info globals ${name}::*]]
  13                 }
  14         }
  15 }
  16
  17 proc {namespace origin} {name} {
  18         set nscanon [uplevel 1 [list ::namespace canon $name]]
  19         if {[exists -alias $nscanon]} {
  20                 tailcall {namespace origin} [info alias $nscanon]
  21         }
  22         if {[exists -command $nscanon]} {
  23                 return ::$nscanon
  24         }
  25         if {[exists -command $name]} {
  26                 return ::$name
  27         }
  28
  29         return -code error "invalid command name \"$name\""
  30 }
  31
  32 proc {namespace which} {{type -command} name} {
  33         set nsname ::[uplevel 1 [list ::namespace canon $name]]
  34         if {$type eq "-variable"} {
  35                 return $nsname
  36         }
  37         if {$type eq "-command"} {
  38                 if {[exists -command $nsname]} {
  39                         return $nsname
  40                 } elseif {[exists -command ::$name]} {
  41                         return ::$name
  42                 }
  43                 return ""
  44         }
  45         return -code error {wrong # args: should be "namespace which ?-command? ?-variable? name"}
  46 }
  47
  48
  49 proc {namespace code} {arg} {
  50         if {[string first "::namespace inscope " $arg] == 0} {
  51                 # Already scoped
  52                 return $arg
  53         }
  54         list ::namespace inscope [uplevel 1 ::namespace current] $arg
  55 }
  56
  57 proc {namespace inscope} {name arg args} {
  58         tailcall namespace eval $name $arg $args
  59 }
  60
  61 proc {namespace import} {args} {
  62         set current [uplevel 1 ::namespace canon]
  63
  64         foreach pattern $args {
  65                 foreach cmd [info commands [namespace canon $current $pattern]] {
  66                         if {[namespace qualifiers $cmd] eq $current} {
  67                                 return -code error "import pattern \"$pattern\" tries to import from namespace \"$current\" into itself"
  68                         }
  69                         # What if this alias would create a loop?
  70                         # follow the target alias chain to see if we are creating a loop
  71                         set newcmd ${current}::[namespace tail $cmd]
  72
  73                         set alias $cmd
  74                         while {[exists -alias $alias]} {
  75                                 set alias [info alias $alias]
  76                                 if {$alias eq $newcmd} {
  77                                         return -code error "import pattern \"$pattern\" would create a loop"
  78                                 }
  79                         }
  80
  81                         alias $newcmd $cmd
  82                 }
  83         }
  84 }
  85
  86 # namespace-aware info commands: procs, channels, globals, locals, vars
  87 proc {namespace info} {cmd {pattern *}} {
  88         set current [uplevel 1 ::namespace canon]
  89         # Now we may need to strip $pattern
  90         if {[string first :: $pattern] == 0} {
  91                 set global 1
  92                 set prefix ::
  93         } else {
  94                 set global 0
  95                 set clen [string length $current]
  96                 incr clen 2
  97         }
  98         set fqp [namespace canon $current $pattern]
  99         switch -glob -- $cmd {
 100                 co* - p* {
 101                         if {$global} {
 102                                 set result [info $cmd $fqp]
 103                         } else {
 104                                 # Add commands in the current namespace
 105                                 set r {}
 106                                 foreach c [info $cmd $fqp] {
 107                                         dict set r [string range $c $clen end] 1
 108                                 }
 109                                 if {[string match co* $cmd]} {
 110                                         # Now in the global namespace
 111                                         foreach c [info -nons commands $pattern] {
 112                                                 dict set r $c 1
 113                                         }
 114                                 }
 115                                 set result [dict keys $r]
 116                         }
 117                 }
 118                 ch* {
 119                         set result [info channels $pattern]
 120                 }
 121                 v* {
 122                         #puts "uplevel #0 info gvars $fqp"
 123                         set result [uplevel #0 info -nons vars $fqp]
 124                 }
 125                 g* {
 126                         set result [info globals $fqp]
 127                 }
 128                 l* {
 129                         set result [uplevel 1 info -nons locals $pattern]
 130                 }
 131         }
 132         if {$global} {
 133                 set result [lmap p $result { string cat $prefix $p }]
 134         }
 135         return $result
 136 }
 137
 138 proc {namespace upvar} {ns args} {
 139         set nscanon ::[uplevel 1 [list ::namespace canon $ns]]
 140         set script [list upvar 0]
 141         foreach {other local} $args {
 142                 lappend script ${nscanon}::$other $local
 143         }
 144         tailcall {*}$script
 145 }