source testing.tcl

section "Regression Testing"

test regr-1.1 "Double dereference arrays" {
	array set a {one ONE two TWO three THREE}
	array set b {ONE 1 TWO 2 THREE 3}
	set chan two
	set b($a($chan))
} {2}

# Will assert on exit if the bug exists
test regr-1.2 "Reference count shared literals" {
	proc a {} {
		while {1} {break}
	}
	a
	rename a ""
	return 1
} {1}

test regr-1.3 "Invalid for expression" {
	# Crashes with invalid expression
	catch {
		for {set i 0} {$i < n} {incr i} {
			set a(b) $i
			set a(c) $i
			break
		}
	}
} 1

test regr-1.4 "format double percent" {
	format (%d%%) 12
} {(12%)}

test regr-1.5 "lassign with empty list" {
	unset -nocomplain a b c
	lassign {} a b c
	info exists c
} {1}

section "I/O Testing"

test io-1.1 "Read last line with no newline" {
	set lines 0
	set f [open testio.in]
	while {[gets $f buf] >= 0} {
		incr lines
	}
	close $f
	list $lines
} {2}

section "unset"

set g1 1
set g2 2
array set g3 {4 5 6 7}

proc test_unset {} {
	test unset-1.1 "Simple var" {
		set g4 4
		list [catch {unset g4; info exists g4} msg] $msg
	} {0 0}

	test unset-1.2 "Simple var" {
		list [catch {unset g4; info exists g4} msg] $msg
	} {1 {can't unset "g4": no such variable}}

	test unset-1.3 "Simple var" {
		list [catch {unset g2; info exists g2} msg] $msg
	} {1 {can't unset "g2": no such variable}}

	test unset-1.4 "Global via global" {
		global g1
		list [catch {unset g1; info exists g1} msg] $msg
	} {0 0}

	test unset-1.5 "Global error" {
		list [catch {unset ::g2; info exists ::g2} msg] $msg
	} {0 0}

	test unset-1.6 "Global array" {
		list [catch {unset ::g3; info exists ::g3} msg] $msg
	} {0 0}

	test unset-1.7 "Simple var -nocomplain" {
		list [catch {unset -nocomplain g2; info exists g2} msg] $msg
	} {0 0}

	test unset-1.8 "Simple var --" {
		list [catch {unset -- g2; info exists g2} msg] $msg
	} {1 {can't unset "g2": no such variable}}

	test unset-1.9 "Simple var -nocomplain --" {
		set g2 1
		list [catch {unset -nocomplain -- g2; info exists g2} msg] $msg
	} {0 0}

	test unset-1.10 "Var named -nocomplain with --" {
		set -nocomplain 1
		list [catch {unset -- -nocomplain; info exists -nocomplain} msg] $msg
	} {0 0}

	test unset-1.11 "Unset no args" {
		list [catch {unset} msg] $msg
	} {0 {}}
}

test_unset

section "lrepeat"

test lrepeat-1.1 "Basic tests" {
	lrepeat 1 a
} {a}

test lrepeat-1.2 "Basic tests" {
	lrepeat 1 a b
} {a b}

test lrepeat-1.3 "Basic tests" {
	lrepeat 2 a b
} {a b a b}

test lrepeat-1.4 "Basic tests" {
	lrepeat 2 a
} {a a}

test lrepeat-1.5 "Errors" {
	catch {lrepeat}
} {1}

test lrepeat-1.6 "Errors" {
	catch {lrepeat 1}
} {1}

test lrepeat-1.7 "Errors" {
	catch {lrepeat 0 a b}
} {1}

test lrepeat-1.8 "Errors" {
	catch {lrepeat -10 a}
} {1}

section "string/list index"

test lindex-1.1 "Integer" {
	lindex {a b c} 0
} a

test lindex-1.2 "Integer" {
	lindex {a b c} 2
} c

test lindex-1.3 "Integer" {
	lindex {a b c} -1
} {}

test lindex-1.4 "Integer" {
	lindex {a b c} 4
} {}

test lindex-1.5 "end" {
	lindex {a b c} end
} c

test lindex-1.6 "end" {
	lindex {a b c} end-1
} b

test lindex-1.7 "end" {
	lindex {a b c} end-4
} {}

test lindex-1.8 "end + " {
	lindex {a b c} end+1
} {}

test lindex-1.9 "end + " {
	lindex {a b c} end+-1
} b

test lindex-1.10 "end - errors" {
	catch {lindex {a b c} end-}
} 1

test lindex-1.11 "end - errors" {
	catch {lindex {a b c} end-blah}
} 1

test lindex-1.12 "int+int, int-int" {
	lindex {a b c} 0+4
} {}

test lindex-1.13 "int+int, int-int" {
	lindex {a b c} 3-1
} c

test lindex-1.14 "int+int, int-int" {
	lindex {a b c} 1--1
} c

test lindex-1.15 "int+int, int-int" {
	set l {a b c}
	lindex $l [lsearch $l b]-1
} a

test lindex-1.16 "int+int, int-int" {
	lindex {a b c} 0+1
} b

test lindex-1.17 "int+int - errors" {
	catch {lindex {a b c} 5-blah}
} 1

test lindex-1.18 "int+int - errors" {
	catch {lindex {a b c} blah-2}
} 1

test lindex-1.19 "int+int - errors" {
	catch {lindex {a b c} 5+blah}
} 1

test lindex-1.20 "unary plus" {
	lindex {a b c} +2
} c

test incr-1.1 "incr unset" {
	unset -nocomplain a
	incr a
	set a
} 1

test incr-1.2 "incr, incr unset" {
	incr a
} 2

test incr-1.3 "incr unset array element" {
	unset -nocomplain a
	incr a(2)
	set a(2)
} 1

test incr-1.4 "incr array element - shimmering" {
	set b "$a(2)-test"
	incr a(2)
} 2

test catch-1.1 "catch ok" {
	list [catch {set abc 2} result] $result
} {0 2}

test catch-1.2 "catch error" {
	list [catch {error 3} result] $result
} {1 3}

test catch-1.3 "catch break" {
	list [catch {break} result] $result
} {3 {}}

test catch-1.4 "catch -nobreak" {
	set result {}
	foreach x {a b c} {
		lappend result $x
		# This acts just like break since it won't be caught by catch
		catch -nobreak {break} tmp
	}
	set result
} {a}

test catch-1.5 "catch -no3" {
	set result {}
	foreach x {a b c} {
		lappend result $x
		# Same as above, but specify as an integer
		catch -no3 {break} tmp
	}
	set result
} {a}

test catch-1.6 "catch break" {
	set result {}
	foreach x {a b c} {
		lappend result $x
		# This does nothing since the break is caught
		catch {break} tmp
	}
	set result
} {a b c}


test catch-1.7 "catch exit" {
	# Normally exit would not be caught
	dict get [info returncodes] [catch -exit {exit 5} result]
} {exit}

test catch-1.8 "catch error has -errorinfo" {
	set rc [catch {set undefined} msg opts]
	list $rc [info exists opts(-errorinfo)]
} {1 1}

test catch-1.9 "catch no error has no -errorinfo" {
	set rc [catch {set x 1} msg opts]
	list $rc [info exists opts(-errorinfo)]
} {0 0}

test return-1.1 "return can rethrow an error" {
	proc a {} { error "from a" }
	proc b {} { catch {a} msg opts; return {*}$opts $msg }
	set rc [catch {b} msg opts]
	list $rc $msg [llength $opts(-errorinfo)]
} {1 {from a} 6}

test return-1.2 "error can rethrow an error" {
	proc a {} { error "from a" }
	proc b {} { catch {a} msg; error $msg [info stacktrace] }
	set rc [catch {b} msg opts]
	list $rc $msg [llength $opts(-errorinfo)]
} {1 {from a} 9}

test return-1.3 "return can rethrow no error" {
	proc a {} { return "from a" }
	proc b {} { catch {a} msg opts; return {*}$opts $msg }
	set rc [catch {b} msg opts]
	#list $rc $msg [llength $opts(-errorinfo)]
	list $rc $msg [info exists opts(-errorinfo)]
} {0 {from a} 0}


testreport