path: root/tests/misc.test

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

needs constraint jim
needs cmd gets tclcompat
needs cmd array

catch {unset a b}
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" jim {
	# 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}

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

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

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" {
	lrepeat 1
} {}

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

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

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}

test stringreverse-1.1 "Containing nulls" {
	string reverse abc\0def
} "fed\0cba"

test split-1.1 "Split with leading null" {
	split "\0abc\0def\0" \0
} {{} abc def {}}

test parsevar-1.1 "Variables should include double colons" {
	set ::a::b 2
	set x $::a::b
	unset ::a::b
	set x
} 2

test sharing-1.1 "Problems with ref sharing in arrays: lappend" {
	set a {a 1 c 2}
	set b $a
	lappend b(c) 3
	set a(c)
} 2

test sharing-1.2 "Problems with ref sharing in arrays: append" {
	set a {a 1 c 2}
	set b $a
	append b(c) 3
	set a(c)
} 2

test sharing-1.3 "Problems with ref sharing in arrays: incr" {
	set a {a 1 c 2}
	set b $a
	incr b(c)
	set a(c)
} 2

test sharing-1.4 "Problems with ref sharing in arrays: lset" {
	set a {a 1 c {2 3}}
	set b $a
	lset b(c) 1 x
	set a(c)
} {2 3}

test jimexpr-1.1 "integer ** operator" {
    expr {2 ** 3}
} 8

test jimexpr-1.2 "integer ** operator" {
    expr {0 ** 3}
} 0

test jimexpr-1.3 "integer ** operator" {
    expr {2 ** 0}
} 1

test jimexpr-1.4 "integer ** operator" {
    expr {-2 ** 1}
} -2

test jimexpr-1.5 "integer ** operator" {
    expr {3 ** -2}
} 0

test jimexpr-1.6 "+ command" {
    + 1
} 1

test jimexpr-1.7 "+ command" {
    + 2 3.5
} 5.5

test jimexpr-1.8 "+ command" {
    + 2 3 4 -6
} 3

test jimexpr-1.9 "* command" {
    * 4
} 4

test jimexpr-1.10 "* command" {
    * 4 2
} 8

test jimexpr-1.11 "* command" {
    * 4 2 -0.5
} -4.0

test jimexpr-1.12 "/ command" {
    / 2
} 0.5

test jimexpr-1.12 "/ command" {
    / 0.5
} 2.0

test jimexpr-1.13 "/ command" {
    / 12 3
} 4

test jimexpr-1.14 "/ command" {
    / 12 3 2.0
} 2.0

test jimexpr-1.15 "- command" {
    - 6
} -6

test jimexpr-1.15 "- command" {
    - 6.5
} -6.5

test jimexpr-1.16 "- command" {
    - 6 3
} 3

test jimexpr-1.17 "- command" {
    - 6 3 1.5
} 1.5

test jimexpr-1.17 "- command" {
    - 6.5 3
} 3.5

test jimexpr-2.1 "errors in math commands" {
    list [catch /] [catch {/ x}] [catch -] [catch {- blah blah}] [catch {- 2.0 blah}] [catch {+ x y}] [catch {* x}]
} {1 1 1 1 1 1 1}

test jimexpr-2.2 "not var optimisation" {
	set x [expr 1]
	set y [expr 0]
	set z [expr 2.0]
	list [expr {!$x}] [expr {!$y}] [expr {!$z}]
} {0 1 0}

test jimexpr-2.3 "expr access unset var" {
	unset -nocomplain a
	catch {expr {3 * $a}}
} 1

test jimexpr-2.4 "expr double as bool" {
	set x 2
	if {1.0} {
		set x 3
	}
} 3

# May be supported if support compiled in
test jimexpr-2.5 "double ** operator" {
    catch {expr {2.0 ** 3}} result
    expr {$result in {unsupported 8.0}}
} 1

# This one is for test coverage of an unusual case
test jimobj-1.1 "duplicate obj with no dupIntRepProc" {
	proc "x x" {} { return 2 }
	set a "x x"
	# force it to be a command object
	set b [$a]
	# A second reference
	set c $a
	# Now force it to be duplicated
	lset a 1 x
	# force the duplicate object it to be a command object again
	set b [$a]
	# And get the string rep
	set x "y $a"
} "y x x"

test jimobj-1.2 "cooerced double to int" {
	set x 3
	# cooerce to a double
	expr {4.5 + $x}
	# Now get the int rep
	incr x
} 4

test jimobj-1.3 "cooerced double to double" {
	set x 3
	# cooerce to a double
	expr {4.5 + $x}
	# Now use as a double
	expr {1.5 + $x}
} 4.5

test jimobj-1.4 "incr dict sugar" {
	unset -nocomplain a
	set a(3) 3
	incr a(3)
	list $a(3) $a
} {4 {3 4}}

test jim-badvar-1.1 "invalid variable name" {
	set x b\0c
	catch {set $x 5}
} 1

test jim-badvar-1.2 "incr invalid variable name" {
	set x b\0c
	catch {incr $x}
} 1

test lset-1.1 "lset with bad var" {
	catch {lset badvar 1 x}
} 1

test dict-1.1 "dict to string" {
	set a [dict create abc \\ def \"]
	set x x$a
	# The order of keys in the dictionary is random
	if {$x eq "xabc \\\\ def {\"}" || $x eq "xdef {\"} abc \\\\"} {
		return ok
	} else {
		return "failed: \"$x\""
	}
} ok

test channels-1.1 {info channels} {
	lsort [info channels]
} {stderr stdin stdout}

test lmap-1.1 {lmap} {
	lmap p {1 2 3} {incr p}
} {2 3 4}

test exprerr-1.1 {Error message with bad expr} {
	catch {expr {5 ||}} msg
	set msg
} {Expression has bad operands to ||}

test eval-list-1.1 {Lost string rep with list} {
	set x {set y 1; incr y}
	# Convert to list rep internally
	lindex $x 4
	# But make sure we don't lost the original string rep
	list [catch $x] $y
} {0 2}

test info-statics-1.1 {info statics commands} {
	set x 1
	proc a {} {x {y 2}} {}
	lsort [info statics a]
} {1 2 x y}

testreport