Artifact 820ff759563a90d4b28648ba0993a387bb078dba:

• Executable file packages/ns/lib/ns.test.tcl — part of check-in [8e107fd0d0] at 2020-03-20 20:45:41 on branch trunk — accommodate new version of ego

  a few new routines and tests (user: pooryorick size: 13721)

#! /bin/env tclsh

package require {ycl test}

proc suite_main {} {
	global auto_path
	package require {ycl proc}
	[yclprefix] proc alias alias [yclprefix] proc alias
	alias aliases [yclprefix] proc aliases

	package require {ycl list}
	aliases {
		{ycl proc} {
			method 
			upmethod
		}
		{ycl list} {
			join
			sl
		}
		{ycl ns}
		{ycl ns local} {
			rename
		}
	}

	[yclprefix] test init
	rename test {}
	aliases {
		{ycl test} {
			cleanup1
			test
		}
	}

	lappend setup0 [list set auto_path $auto_path]

	lappend setup0 {
		package require {ycl proc}
		[yclprefix] proc alias aliases [yclprefix] proc aliases
		aliases {
			{ycl proc} {
				alias
			}
		}

		package require {ycl ns}
		package require {ycl ns ensemble}
		alias ns [yclprefix] ns
		aliases {
			{ycl list} {
				compare
				lmap
				lsort
				sl
			}
			{ycl ns} {
				cleanly 
				dupcmds
				duplicate
				nsjoin join
				nscall
				object
				powerimport
				unique
				vars
				which
			}
		}
	}

	join setup0 \n 

	lappend setup1 $setup0
	lappend setup1 {

		namespace eval ns1 {
			namespace export *
			namespace ensemble create -prefixes 0 -parameters name
			variable var1 val1
			variable arr1
			array set arr1 {var1 aval1 var2 aval2 var3 aval3}
			proc greet args {
				list [namespace current] $args
			}

			namespace ensemble create -command ns1a -prefixes 0 \
				-parameters name

			namespace eval ns2 {
				namespace export *
				namespace ensemble create -parameters name
				proc greet2 name {
					return [list howdy $name]
				}
			}
		}
		nscall ns1 [which alias] lreverse lreverse
		namespace ensemble configure ns1 -unknown [
			list ::apply {{ensemble ensemble2 args} {
				list ::apply [list args {
					return [list {unknown command in namespace} [
						namespace tail [namespace current]] $args]
				} [namespace ensemble configure $ensemble -namespace]]
			}} [namespace which ns1]]
	}

	join setup1 \n


	lappend setup2 $setup0
	lappend setup2 {
		namespace eval type1 {
			namespace export *
			proc init _ {
				namespace upvar [$_ .namespace] speed speed
				set speed 8
			}
			proc run _ {
				namespace upvar [$_ .namespace] speed speed
				return $speed 
			}
		}
	}
	join setup2 \n


	test ascall {} -setup $setup0 -body {
		namespace eval space1 {
			proc greet varname {
				upvar $varname var
				list hello $var
			}
		}
		set call [namespace eval space1 [
			list [ns which ns] ascall greet a]]
		set a Madis
		{*}$call
	} -cleanup [cleanup1] -result {hello Madis}


	test cleanly {} -setup $setup1 -body {
		variable var1
		set var1 a
		lassign [cleanly {
			list [namespace current] $var1
		}] ns var2
		lappend res [namespace exists $ns]
		lappend res [expr {
			[namespace qualifiers [namespace current]] eq [
				namespace qualifiers $ns]
			&&
			$ns ne [namespace current]
		}]
		return $res
	} -cleanup [cleanup1] -result [sl {
		0 1
	}]


	test dupcmds {} -setup $setup1 -body {
		set expected {
			greet
			lreverse
			ns1a
			ns2
		}
		lappend res [namespace exists ns3]
		lappend res [dupcmds ns1 ns3]
		set inns 1
		set cmds [info commands ns3::*]
		lsort cmds
		lmap cmd cmds {
			namespace tail $cmd
		}
		lappend res [compare ::tcl::mathop::eq cmds expected]
		return $res
	} -cleanup [cleanup1] -result [sl {
		0 {} -1
	}]


	test duplicate_proc_linked {
		A procecure imported into a namespace should also be imported , not
		copied , when the namespace is duplicated .
	} -setup $setup1 -body {
		namespace export *
		proc p1 {} {
			return [uplevel 1 {list hello from [
				namespace tail [namespace current]]}]
		}
		namespace eval ns1 [list namespace import [
			list [namespace current]::p1]]
		lappend res [namespace eval ns1 p1]
		namespace eval ns1 {namespace export p1}
		duplicate ns1 ns2
		lappend res [namespace eval ns2 p1]
		lappend res [expr {
			[namespace eval ns2 {namespace origin p1}]
			eq
			[namespace origin p1]
		}]
		return $res
	} -cleanup [cleanup1] -result [sl {
		{hello from ns1}
		{hello from ns2}
		1
	}]


	test ensemble_duplicate {} -setup $setup1 -body {
		namespace eval ns1 {
			namespace import [yclprefix]::ns
		}

		#check that -prefixes are off 
		lappend res [ns1 Boyet gre]

		ns ensemble duplicate ns1 ns3
		lappend res $ns3::var1
		lappend res $ns3::arr1(var3)

		#check that -prefixes are still off
		lappend res [ns3 Boyet gre]

		namespace eval ns3 [
			list namespace upvar [namespace current]::ns1 var1 var2] 
		ns ensemble duplicate ns3 ns4 tons ns4 
		lappend res $ns4::var2

		#check upvar'ed variables
		namespace eval ns4 {unset var2}
		lappend res [catch {set ns3::var2} cres copts]
		lappend res [dict get [dict merge {-errorcode {}} $copts] -errorcode]

		#check child namespaces
		lappend res [ns3 Rosaline ns2 greet2]

		#imported ensembles should be imported, not duplicated
		lappend res [namespace origin ns3::ns]

		# [ensemble duplicate] should replace occurrences of original namespace in map
		set map [namespace ensemble configure ns1 -map]
		dict set map p1 [list ::apply [list {ns args} {
			::tailcall ::apply [list args {
				variable var1
				lindex $var1
			} $ns] {*}$args
		}] [namespace ensemble configure ns1 -namespace]]

		dict set map p2 greet 

		# check for proper quoting of switch statement
		dict set map p3 [list ::fake -something fake]

		# evaluate in the namespace for ns1 so that map targets get resolved
		# relative to that namespace
		namespace eval [namespace ensemble configure ns1 -namespace] [
		list ::namespace ensemble configure [namespace which ns1] -map $map]
		ns ensemble duplicate ns1 ns5
		set ns5::var1 val4
		lappend res [ns5 Jim p1]

		lassign [ns5 {arg one} p2 {arg two}] namespace arg1 arg2
		lappend res {p2 in ns5 namespace} [expr {$namespace eq [namespace which ns5]}]

		lappend res [ns5 Ferdinand bananas]

		namespace eval ns6 {
			namespace ensemble create
		}
		namespace ensemble configure ns6 -map [list cmd1 [
			list ::apply {{ensemble args} {
				return [list {the args} [namespace tail $ensemble] {*}$args]
			}} [namespace which ns6]]]
		ns ensemble duplicate ns6 ns7
		lappend res [ns7 cmd1 greetings]
		set res
	} -cleanup [cleanup1] -result [sl {
		{{unknown command in namespace} ns1 Boyet}
		val1 aval3
		{{unknown command in namespace} ns3 Boyet}
		val1 1 {TCL READ VARNAME} {howdy Rosaline}
		[yclprefix]::ns
		val4
		{p2 in ns5 namespace} 1
		{{unknown command in namespace} ns5 Ferdinand}
		{{the args} ns7 greetings}
	}]


	test ensemble_duplicate_embedded_ensemble {
		a duplicated ensemble
			containing a command
				that is an ensemble
					whose namespace is within the namespace of the outer
					ensemble

			namespace is duplicated

	} -setup $setup1 -body {
		ns ensemble duplicate ns1 ns3
		lappend res [ns3 Ardo ns2 greet2]
		set ns3ns [namespace ensemble configure ns3 -namespace] 
		set ns3ns2ns [namespace eval $ns3ns {
			namespace ensemble configure ns2 -namespace
		}]
		set expected [namespace eval $ns3ns [list namespace eval ns2 {
			namespace current
		}]]
		lappend res [expr {$ns3ns2ns eq $expected}]
		return $res
	} -cleanup [cleanup1] -result [sl {
		{howdy Ardo} 1
	}]


	test duplicate {} -setup $setup1 -body {
		duplicate ns1 ns1::0
		set ns1::0::var1 val1
		lappend res {$ns1::0::var1} $ns1::0::var1
		duplicate ns1 ns2
		lappend res {$ns2::var1} $ns2::var1
		#does 0 get properly pruned?
		lappend res [namespace exists ns2::0]
		lappend res {lreverse in ns2} [namespace eval ns2 {
			expr {[namespace qualifiers [
				namespace which lreverse]] eq [namespace current]}
		}]
		return $res
	} -cleanup [cleanup1] -result [sl {
		{$ns1::0::var1} val1 
		{$ns2::var1} val1 0
		{lreverse in ns2} 1
	}]


	test info_vars {} -setup $setup1 -body {
		set var1 one
		set var2 two
		ns info vars
	} -cleanup [cleanup1] -result [sl {
		var1 var2
	}]


	test join {} -setup $setup1 -body {
		if 0 {
			to do
				these results would depend on the namesapce delimiting scheme
		}
	    lappend res [nsjoin {}]
		lappend res [nsjoin one]
	    lappend res [nsjoin ::]
	    lappend res [nsjoin :::]
	    lappend res [nsjoin one two]
	} -cleanup [cleanup1] -result [sl {
	    {}
		one
		::
		::
	    one::two
	}]


	test move {} -setup $setup0 -body {
		namespace eval ns0 {
			namespace export *
			proc p1 {} {
				list hello from p1
			}
		}
		namespace eval ns1 {
			namespace path [list [namespace qualifiers [namespace current]]::ns0]
			namespace eval ns1a {
				proc p3 {} {
					list hello from p3
				}
			}
			namespace eval ns1b {
				namespace export *
				namespace ensemble create
				proc p4 {} {
					list hello from p4
				}
			}
			proc p2 {} {
				list hello from p2
			}
			set var1 val1
		}
		ns move ns1 ns2
		lappend res [namespace eval ns2 p1]
		lappend res [ns2::p2]
		lappend res [ns2::ns1a::p3]
		lappend res [ns2::ns1b p4]
		return $res
	} -cleanup [cleanup1] -result [sl {
		{hello from p1}
		{hello from p2}
		{hello from p3}
		{hello from p4}
	}]


	test normalize_null {} -setup $setup1 -body {
		ns normalize {}
	} -cleanup [cleanup1] -result {::}


	test object {} -setup $setup2 -body {
		object obj1
		obj1 .extend type1 
		obj1 init
		lappend res [obj1 run]
		lappend res [namespace tail [obj1 .namespace]]
		return $res
	} -cleanup [cleanup1] -result [sl {
		8 obj1
	}]


	test object_method {} -setup $setup2 -body {
		namespace eval type2 {
			proc p1 _ {
				list hello from $_
			}
		}
		object obj1
		obj1 .extend type2
		set res1 [obj1 p1]
		# {to do} {finish {ycl list lvar}}
		#lvar var1 res1 3 
		lassign $res1 hello from name
		set name [namespace tail $name]
		lappend res $hello $from $name
		return $res
	} -cleanup [cleanup1] -result [sl {
		hello from obj1
	}]


	test object_next {} -setup $setup0 -body {
		set obj [object]

		namespace eval ext1 {
			proc p1 _ {
				return goodbye
			}
		}

		namespace eval ext2 {
			namespace eval system {
				namespace export *

				package require {ycl proc}
				[yclprefix] proc alias alias [yclprefix] proc alias
				alias aliases [yclprefix] proc aliases

				aliases {
					{ycl proc} {
						imports
					}
				}

				proc p1 _ {
					set routine [$_ .next p1]
					list hello [$routine $_]
				}

				imports [namespace parent] [namespace current] {
					p1
				}
			}
		}

		$obj .extend ext1
		$obj .extend ext2
		catch {$obj p1} cres copts
		lappend res $cres
	} -cleanup [cleanup1] -result [sl {
		{hello goodbye}
	}]


	test object_noname {} -setup $setup2 -body {
		set obj [object]
		$obj .extend type1
		$obj init
		$obj run
	} -cleanup [cleanup1] -result 8


	test object_globalroutine {
		a global routine is found instead of any routine in the path of the
		object
	} -setup $setup1 -body {
		object obj1
		catch {obj1 puts hello} cres copts
		set res1 $cres 
		if {[string is list $cres]} {
			if {
				[lindex $cres 0] eq {no such routine}
				&&
				[lindex $cres 1 0] eq [namespace which obj1]
				&&
				[lindex $cres 1 1] eq {puts}
			} {
					set res1 yes
			}
		}
		lappend res {correct error message?} $res1
		return $res
	} -cleanup [cleanup1] -result [sl {
		{correct error message?} yes
	}]


	test object_routine_loop {} -setup $setup2 -body {
		namespace eval type2 {
			proc p1 _ {
				list hello from $_
			}
		}
		object obj1
		object [obj1 .namespace]::obj2
		catch {obj1 obj2} cres copts
		set res {}
		if {[string is list $cres]} {
			lappend res [lindex $cres 0]
		} else {
			return -options $copts $res
		}
		return $res
	} -cleanup [cleanup1] -result [sl {
		{self-referential routine}
	}]


	test powerimport {} -setup $setup1 -body {
		namespace eval ns1 {
			proc p1 {} {
				return 7
			}
		}
		alias [nsjoin ns2 nsjoin] nsjoin
		alias [nsjoin ns2 powerimport] powerimport
		lappend res [namespace eval ns2 {
			powerimport [nsjoin [namespace parent] ns1 p1]
			p1
		}]
		return $res
	} -cleanup [cleanup1] -result [sl {
		7
	}]


	test split {} -setup $setup0 -body {
		foreach ns [sl {
			:
			::
			::one
			::one::
			::one::two
			:one
			one:
			:one:
			one
			one::
			one:::two
			one::two
			one:two
			{one two:::three}
		}] {
			ns split ns
			lappend res $ns
		}
		return $res
	} -cleanup [cleanup1] -result [sl {
		:
		{{} {}}
		{{} one}
		{{} one {}}
		{{} one two}
		:one
		one:
		:one:
		one
		{one {}}
		{one two}
		{one two}
		one:two
		{{one two} three}
	}]


	test subcommands_map {} -setup $setup0 -body {
		namespace eval ns1 {
			namespace ensemble create -map {
				one one
				two two
				three three
			}
		}
		set res [ns ensemble subcommands ns1]
		lsort res
		return $res
	} -cleanup [cleanup1] -result [sl {
		one three two
	}]


	test subcommands_exports {} -setup $setup0 -body {
		namespace eval ns2 {
			proc p1 {} {}
			proc q1 {} {}
			proc quarp {} {}
			namespace export q*
			namespace ensemble create -command [namespace parent]::ensemble1
		}
		set res [ns ensemble subcommands ensemble1]
		lsort res
		return $res
	} -cleanup [cleanup1] -result [sl {
		q1 quarp
	}]


	test subcommands_subcommands {} -setup $setup0 -body {
		namespace eval ns2 {
			proc p1 {} {}
			proc q1 {} {}
			proc quarp {} {}
			namespace export q*
			namespace ensemble create -command [namespace parent]::ensemble1 \
				-subcommands {q1 p1}
		}
		set res [ns ensemble subcommands ensemble1]
		lsort res
		return $res
	} -cleanup [cleanup1] -result [sl {
		p1 q1
	}]


	test unique {} -setup $setup0 -body {
		set unique [unique]
		set unique2 [unique]
		lappend res [expr {$unique eq $unique2}]
	} -cleanup [cleanup1] -result [sl {
		0
	}]


	test vars {} -setup $setup1 -body {
		alias [nsjoin ns1 vars] vars
		namespace eval ns1 {
			set one 1 
			set two 2
			set four 4
			proc p1 {} {
				vars [namespace current] one {two three} four
				list $one $three $four
			}
		}
		lappend res [ns1::p1]
	} -cleanup [cleanup1] -result [sl {
		{1 2 4}
	}]

	cleanupTests
}