ycl

Artifact [0c13120faf]
Login

Artifact [0c13120faf]

Check-ins Using Download Hex

Artifact 0c13120faf07e2988fd0b214108e0c2460a55cd2:

#! /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
				nseval
				nscall
				object
				powerimport
				unique
				vars
				which
			}
		}


		proc creatensobjects {} {
			for {set i 0} {$i < 10000} {incr i} {
				#::namespace ensemble create -command [namespace current]::obj1
				object obj1
				rename obj1 {}
			}
		}


		proc callnsobjectmethods {} {
			object obj1
			obj1 .extend type1
			for {set i 0} {$i < 10000} {incr i} {
				obj1 accelerate
			}
			set speed [obj1 $ speed]
			rename obj1 {}
			return $speed
		}


		proc createooobjects {} {
			for {set i 0} {$i < 10000} {incr i} {
				oo::object create obj1
				rename obj1 {}
			}
		}


		proc callooobjectmethods {} {
			oo::object create obj1
			oo::objdefine obj1 {
				variable speed
				method accelerate {} {
					incr speed
				}

				method speed {} {
					return $speed
				}
			}
			for {set i 0} {$i < 10000} {incr i} {
				obj1 accelerate
			}
			set speed [obj1 speed]
			rename obj1 {}
			return $speed
		}


		proc timeit script {
			set res [uplevel 1 [list time $script 1]]
			lindex $res 0
		}


	}

	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 
			}

			proc accelerate _ {
				$_ .vars speed
				incr 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 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 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 eval {} -setup $setup1 -body {
		set res [ns eval one two {three four} five {
			namespace current
		}]
		if {$res eq [nsjoin [namespace current] one two {three four} five]} {
			return passed
		} else {
			return $res
		}
	} -cleanup [cleanup1] -result passed


	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 nscall {} -setup $setup0 -body {
		proc p1 {} {
			upvar 1 {var one} var
			set var
		}
		namespace eval ns1 {
			variable {var one} 5
		}
		nscall ns1 p1
	} -cleanup [cleanup1] -result 5


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


	test nseval {} -setup $setup0 -body {
		namespace eval ns1 {
			variable {var one} 5
		}
		set one set
		set two {var one}
		nseval ns1 $one $two
	} -cleanup [cleanup1] -result 5


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


	test {object call} {} -setup $setup2 -body {
		set obj [object]
		$obj .eval {
			proc p1 varname {
				upvar $varname var
				set var 5
			}
		}
		$obj .call p1 count
		return $count
	} -cleanup [cleanup1] -result 5


	test {object facade} {} -setup $setup0 -body {
		package require {ycl ns facade}
		namespace eval ns2 {
			proc m1 {_ args} {
				$_ m2 hello {*}$args
			}

			proc m2 {_ args} {
				list goodbye {*}$args
			}

			proc cleanup args {
				puts [list hack! $args]
			}
		}
		object o1
		trace add command o1 delete [list [which o1] cleanup]
		o1 .extend ns2
		lappend res [o1 m1 now]

		ns facade .new o2 o1
		catch {
			o2 m1
		} cres copts
		if {[regexp {^unknown subcommand.*m1.*$} $cres]} {
			lappend res 1
		} else {
			return -options $copts $cres
		}
		o1 facade add m1 
		lappend res [o2 m1 there]

		lappend res [namespace tail [o1 facade name]]
		catch {
			o2 m2
		} cres copts
		if {[regexp {^unknown or ambiguous subcommand.*m1.*$} $cres]} {
			lappend res 1
		} else {
			return -options $copts $cres
		}

		o1 facade remove m1 

		rename o1 o3
		lappend res [expr {[namespace which o3] ne {}}]
		rename o2 {}
		lappend res [expr {[namespace which o3] eq {}}]
		return $res
	} -cleanup [cleanup1] -result [sl {
		{goodbye hello now} 1 {goodbye hello there} o2 1 1 1
	}]


	test {object method} {} -setup $setup2 -body {
		namespace eval type2 {
			proc p1 _ {
				list hello from [$_ .name]
			}
		}
		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 match {unknown subcommand*puts*} $cres]} {
			set res1 yes
		}
		lappend res {correct error message?} $res1
		return $res
	} -cleanup [cleanup1] -result [sl {
		{correct error message?} yes
	}]


	test {object namespace local} {
		a routine in the namespace of an object is not part of its interface
	} -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 match {unknown subcommand *} $cres]} {
			lappend res 1
		} else {
			return -options $copts $res
		}
		return $res
	} -cleanup [cleanup1] -result [sl {
		1
	}]


	test {object call} {} -setup $setup2 -body {
		set obj [object]
		$obj .eval {
			proc p1 varname {
				upvar $varname var
				set var 5
			}
		}
		$obj .call p1 count
		return $count
	} -cleanup [cleanup1] -result 5


	test {object performance creation} {} -setup $setup2 -body {
		set time1 [timeit {
			createooobjects
		}]
		set time2 [timeit {
			creatensobjects
		}]
		set ratio [expr {double($time1) / $time2}] 
		
		lappend res {oo object dispatch speed} $ratio 

		return $res
	} -cleanup [cleanup1] -result 5


	test {object performance invocation} {} -setup $setup2 -body {
		set time1 [timeit {
			callooobjectmethods
		}]

		set time2 [timeit {
			callnsobjectmethods
		}]

		set ratio [expr {double($time1) / $time2}]

		lappend res {oo object dispatch speed} $ratio 

		return $res
	} -cleanup [cleanup1] -result 5



	test {object routine} {
		a routine does not receive the name of the object as its first argument
	} -setup $setup2 -body {
		namespace eval type2 {
			proc p1 {} {
				list just a routine
			}
		}
		object obj1
		obj1 .extend type2
		obj1 .routine p1
		obj1 p1
	} -cleanup [cleanup1] -result [sl {
		just a 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
}