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