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                         alias ${current}::[namespace tail $cmd] $cmd
  67                 }
  68         }
  69 }
  70
  71 # namespace-aware info commands: procs, channels, globals, locals, vars
  72 proc {namespace info} {cmd {pattern *}} {
  73         set current [uplevel 1 ::namespace canon]
  74         # Now we may need to strip $pattern
  75         if {[string first :: $pattern] == 0} {
  76                 set global 1
  77                 set prefix ::
  78         } else {
  79                 set global 0
  80                 set clen [string length $current]
  81                 incr clen 2
  82         }
  83         set fqp [namespace canon $current $pattern]
  84         switch -glob -- $cmd {
  85                 co* - p* {
  86                         if {$global} {
  87                                 set result [info $cmd $fqp]
  88                         } else {
  89                                 # Add commands in the current namespace
  90                                 set r {}
  91                                 foreach c [info $cmd $fqp] {
  92                                         dict set r [string range $c $clen end] 1
  93                                 }
  94                                 if {[string match co* $cmd]} {
  95                                         # Now in the global namespace
  96                                         foreach c [info -nons commands $pattern] {
  97                                                 dict set r $c 1
  98                                         }
  99                                 }
 100                                 set result [dict keys $r]
 101                         }
 102                 }
 103                 ch* {
 104                         set result [info channels $pattern]
 105                 }
 106                 v* {
 107                         #puts "uplevel #0 info gvars $fqp"
 108                         set result [uplevel #0 info -nons vars $fqp]
 109                 }
 110                 g* {
 111                         set result [info globals $fqp]
 112                 }
 113                 l* {
 114                         set result [uplevel 1 info -nons locals $pattern]
 115                 }
 116         }
 117         if {$global} {
 118                 set result [lmap p $result { set p $prefix$p }]
 119         }
 120         return $result
 121 }
 122
 123 proc {namespace upvar} {ns args} {
 124         set nscanon ::[uplevel 1 [list ::namespace canon $ns]]
 125         set script [list upvar 0]
 126         foreach {other local} $args {
 127                 lappend script ${nscanon}::$other $local
 128         }
 129         tailcall {*}$script
 130 }