source [file dirname [info script]]/testing.tcl

needs constraint jim
needs cmd array
needs cmd ref

test alias-1.1 "One word alias" {
	set x 2
	alias newincr incr
	newincr x 
} {3}

test alias-1.4 "Two word alias" {
	alias infoexists info exists
	infoexists x
} {1}

test alias-1.5 "Replace alias" {
	alias newincr infoexists
	newincr x
} {1}

test alias-1.6 "Delete alias" {
	rename newincr ""
	catch {newincr x}
} {1}

test alias-1.7 "Replace alias with proc" {
	proc infoexists {n} {
		return yes
	}
	infoexists any
} {yes}

test alias-1.8 "Replace proc with alias" {
	alias infoexists info exists
	infoexists any
} {0}

test alias-1.9 "error message from alias" -body {
	alias newstring string
	newstring match
} -returnCodes error -result {wrong # args: should be "string match ?-nocase? pattern string"}

test alias-1.10 "info alias" {
	alias x info exists
	info alias x
} {info exists}

test alias-1.10 "info alias on non-alias" -body {
	info alias format
} -returnCodes error -result {command "format" is not an alias}

test curry-1.1 "One word curry" {
	set x 2
	set one [curry incr]
	$one x 
} {3}

test curry-1.4 "Two word curry" {
	set two [curry info exists]
	list [$two x] [$two y]
} {1 0}

test curry-1.5 "Delete curry" references {
	collect
	$one abc
	unset one two
	collect
} {2}

test local-1.2 "local curry in proc" {
	proc a {} {
		local set p [curry info exists]
		set x 1
		list $p [$p x] [$p y]
	}
	lassign [a] p exists_x exists_y
	list [info procs $p] $exists_x $exists_y
} {{} 1 0}

test local-1.2 "set local curry in proc" {
	proc a {} {
		set p [local curry info exists]
		set x 1
		list $p [$p x] [$p y]
	}
	lassign [a] p exists_x exists_y
	list [info procs $p] $exists_x $exists_y
} {{} 1 0}

test local-1.3 "local alias in proc" {
	proc a {} {
		local alias p info exists
		set x 1
		list [p x] [p y]
	}
	lassign [a] exists_x exists_y
	list [info commands p] $exists_x $exists_y
} {{} 1 0}

test local-1.5 "local proc in proc" {
	set ::x 1
	proc a {} {
		local proc b {} { incr ::x }
		b
		set ::x
	}
	a
	list [info procs b] $::x
} {{} 2}

test local-1.6 "local lambda in lsort" {
	proc a {} {
		lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
	}
	a
} {a d f g}

test local-1.7 "check no reference procs" {
	info procs "<reference*"
} {}

test local-1.8 "local on non-existent command" {
	list [catch {local set x blah} msg] $msg
} {1 {invalid command name "blah"}}

test local-1.9 "local on existing proc" {
	proc x {} {
		proc a {b} {incr b}
		local function a
		set c [lambda b {incr b -1}]
		local function $c
		lappend result [a 1] [$c 2]
	}
	set result [x]
	list [info procs a] $result 
} {{} {2 1}}

test statics-1.1 "missing static variable init" {
	unset -nocomplain c
	catch {
		proc a {b} {c} {
			# No initialiser for c
		}
	}
} 1

test statics-1.2 "static variable with name containing null" {
	proc a {b} "{c\0d 4}" {
		return [set c\0d]
	}
	a 5
} 4

test statics-1.3 "duplicate static variable" {
	catch {
		proc a {b} {{c 1} {c 2}} {
		}
	}
} 1

test statics-1.4 "bad static variable init" {
	catch {
		proc a {b} {{c 1 2}} {
		}
	}
} 1

test local-2.1 "proc over existing proc" {
	proc a {b} {incr b}
	proc t {x} {
		proc a {b} {incr b -1}
		a $x
	}
	unset -nocomplain x
	lappend x [a 5]
	lappend x [t 5]
	lappend x [a 5]
} {6 4 4}

test local-2.2 "local proc over existing proc" {
	proc a {b} {incr b}
	proc t {x} {
		local proc a {b} {incr b -1}
		a $x
	}
	unset -nocomplain x
	lappend x [a 5]
	lappend x [t 5]
	lappend x [a 5]
} {6 4 6}

test local-2.3 "local proc over existing proc" {
	proc a {b} {incr b}
	proc t {x} {
		local proc a {b} {incr b -1}
		a $x
	}
	unset -nocomplain x
	lappend x [a 5]
	lappend x [t 5]
	lappend x [a 5]
} {6 4 6}

test upcall-1.1 "upcall pushed proc" {
	proc a {b} {incr b}
	local proc a {b} {
		incr b 10
		# invoke the original defn via upcall
		return [upcall a $b]
	}
	# Should call the new defn which will call the original defn
	a 3
} 14

test upcall-1.2 "upcall in proc" {
	proc a {b} {incr b}
	proc t {c} {
		local proc a {b} {
			incr b 10
			return [upcall a $b]
		}
		a $c
	}
	unset -nocomplain x
	lappend x [t 5]
	lappend x [a 5]
	set x
} {16 6}

test upcall-1.3 "double upcall" {
	proc a {} {return 1}
	local proc a {} {list 2 {*}[upcall a]}
	local proc a {} {list 3 {*}[upcall a]}
	a
} {3 2 1}

test upcall-1.4 "upcall errors" {
	proc a {} {return 1}
	list [catch {upcall a} msg] $msg
} {1 {no previous command: "a"}}

test upcall-1.5 "upcall errors" {
	proc a {} {upcall a}
	list [catch a msg] $msg
} {1 {no previous command: "a"}}

test upcall-1.6 "delete local command" -setup {
	# First make sure a is gone
	rename a ""
} -body {
	local proc a {x} {list 2 $x}
	# It is OK to rename this local proc
	rename a b
	b 5
} -result {2 5} -cleanup {
	rename b ""
}

test upcall-1.6 {delete local command with upcall} -body {
	local proc a {x} {list 2 $x}
	local proc a {x} {list 3 $x}
	# Can't rename a because it would invalide upcalls from a
	rename a c
} -returnCodes error -result {can't rename local command "a"}

testreport