From 7f383c6726fd71c23d622753152faf749124ca22 Mon Sep 17 00:00:00 2001
From: Steve Bennett <steveb@workware.net.au>
Date: Thu, 1 Dec 2011 17:25:36 +1000
Subject: Add support for lightweight namespaces

See README.namespaces

Signed-off-by: Steve Bennett <steveb@workware.net.au>
---
 nshelper.tcl | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 124 insertions(+)
 create mode 100644 nshelper.tcl

(limited to 'nshelper.tcl')

diff --git a/nshelper.tcl b/nshelper.tcl
new file mode 100644
index 0000000..c91973f
--- /dev/null
+++ b/nshelper.tcl
@@ -0,0 +1,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
+}
-- 
cgit v1.1