Add some tests from tinytcl

11 files changed, 268 insertions, 0 deletions

diff --git a/tcltests/Makefile b/tcltests/Makefile
new file mode 100644
index 0000000..6fc1e54
--- /dev/null
+++ b/tcltests/Makefile
@@ -0,0 +1,5 @@
+test:
+	../jimsh runtests
+
+verbose:
+	../jimsh runtests -v
diff --git a/tcltests/runtests b/tcltests/runtests
new file mode 100755
index 0000000..df0faba
--- /dev/null
+++ b/tcltests/runtests
@@ -0,0 +1,32 @@
+#!/bin/sh
+
+# \
+exec ../tclsh $0
+
+#package require tcl6
+
+proc check {test got exp} {
+	if {$got != $exp} {
+		error "Failed: $test\nExp: {$exp}\nGot: {$got}"
+	}
+}
+proc verbose {msg} {
+	if {$::verbose} {
+		puts $msg
+	}
+}
+
+set verbose [string equal [lindex $argv 0] "-v"]
+
+foreach i [glob test_*.tcl] {
+	puts -nonewline "$i..."
+	flush stdout
+	if {[catch {source $i} error]} {
+		puts "failed"
+		if {$verbose} {
+			puts $error
+		}
+	} else {
+		puts "ok"
+	}
+}
diff --git a/tcltests/test.bin b/tcltests/test.bin
new file mode 100644
index 0000000..82f43cd
--- /dev/null
+++ b/tcltests/test.bin
diff --git a/tcltests/test_bio.tcl b/tcltests/test_bio.tcl
new file mode 100644
index 0000000..addcbeb
--- /dev/null
+++ b/tcltests/test_bio.tcl
@@ -0,0 +1,97 @@
+proc copy_binary_file {infile outfile} {
+	set in [open $infile r]
+	set out [open $outfile w]
+	while {[bio read $in buf 200] > 0} {
+		bio write $out $buf
+	}
+	close $in
+	close $out
+}
+
+proc copy_file {infile outfile} {
+	set in [open $infile r]
+	set out [open $outfile w]
+	while {1} {
+		set buf [read $in 200]
+		if {[string length $buf] == 0} {
+			break
+		}
+		puts -nonewline $out $buf
+	}
+	close $in
+	close $out
+}
+
+proc copy_binary_file_hex {infile outfile} {
+	set in [open $infile r]
+	set out [open $outfile w]
+	while {[bio read -hex $in buf 200] > 0} {
+		bio write -hex $out $buf
+	}
+	close $in
+	close $out
+}
+
+proc check_file {message filename} {
+	set expected {
+		000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d
+		1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b
+		3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556575859
+		5a5b5c5d5e5f606162636465666768696a6b6c6d6e6f7071727374757677
+		78797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495
+		969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3
+		b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1
+		d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeef
+		f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff000102
+	}
+
+	# Does it look OK?
+	set line 0
+	exec xxd -p $filename >tmp.1
+	set f [open "tmp.1" r]
+	while {[gets $f buf] >= 0} {
+		if {[lindex $expected $line] != $buf} {
+			incr line
+			puts $message
+			puts "=========================================="
+			puts "Failed match on line $line"
+			puts "Exp: {[lindex $expected $line]}"
+			puts "Got: {$buf}"
+			error failed
+		}
+		incr line
+	}
+	close $f
+	verbose "$message -- ok"
+}
+
+# First create a binary file with the chars 0 - 255
+set f [open bio.test w]
+bio write $f "\0010"
+bio write $f "\0011"
+for {set i 2} {$i < 256} {incr i} {
+	puts -nonewline $f [format %c $i]
+}
+bio write $f "\0010\0011\002"
+close $f
+check_file "Create binary file from std encoding" bio.test
+
+# Now the same using hex mode
+set hex ""
+for {set i 0} {$i < 256} {incr i} {
+	append hex [format %02x $i]
+}
+append hex 000102
+set f [open bio.test w]
+bio write -hex $f $hex
+close $f
+check_file "Create binary file from hex encoding" bio.test
+
+copy_binary_file bio.test bio.copy
+check_file "Copy binary file with std encoding" bio.copy
+copy_binary_file_hex bio.test bio.copy
+check_file "Copy binary file with hex encoding" bio.copy
+copy_file bio.test bio.copy
+check_file "Copy file with stdio" bio.copy
+file delete bio.test
+file delete bio.copy
diff --git a/tcltests/test_lsort_cmd.tcl b/tcltests/test_lsort_cmd.tcl
new file mode 100644
index 0000000..cf20ed7
--- /dev/null
+++ b/tcltests/test_lsort_cmd.tcl
@@ -0,0 +1,16 @@
+set list {b d a c z}
+
+proc sorter {a v1 v2} {
+	set ::arg $a
+	return [string compare $v1 $v2]
+}
+
+proc test_lsort_cmd {test cmd list exp} {
+	lsort -command $cmd $list
+	if {$::arg != $exp} {
+		error "$test: Failed"
+	}
+}
+test_lsort_cmd lsort.cmd.1 "sorter arg1" $list "arg1"
+test_lsort_cmd lsort.cmd.2 {sorter "arg with space"} $list "arg with space"
+test_lsort_cmd lsort.cmd.3 [list sorter [list arg with list "last with spaces"]] $list [list arg with list "last with spaces"]
diff --git a/tcltests/test_package.tcl b/tcltests/test_package.tcl
new file mode 100644
index 0000000..439bfa3
--- /dev/null
+++ b/tcltests/test_package.tcl
@@ -0,0 +1,7 @@
+lappend ::auto_path [pwd]
+
+set v [package require testmod]
+
+check "package version" $v 2.0
+check "testmod #1" [testmod 1] 1
+check "testmod #2" [testmod 2] 2
diff --git a/tcltests/test_read.tcl b/tcltests/test_read.tcl
new file mode 100644
index 0000000..a142128
--- /dev/null
+++ b/tcltests/test_read.tcl
@@ -0,0 +1,20 @@
+set f [open "/dev/urandom" r]
+
+set count 0
+set error NONE
+
+signal handle SIGALRM
+catch -signal {
+	alarm 0.5
+	while {1} {
+		incr count [bio read -hex $f buf 1]
+	}
+	alarm 0
+	signal default SIGALRM
+} error
+
+verbose "Read $count bytes in 0.5 seconds: Got $error"
+
+# Kill it off
+#kill -TERM [pid $f]
+catch {close $f}
diff --git a/tcltests/test_signal.tcl b/tcltests/test_signal.tcl
new file mode 100644
index 0000000..e04b7fb
--- /dev/null
+++ b/tcltests/test_signal.tcl
@@ -0,0 +1,32 @@
+set ret2 ""
+set res2 ""
+
+set progress ""
+
+set ret1 [catch -signal {
+	append progress a
+	set ret2 [catch {
+		append progress b
+		signal handle TERM
+		signal throw -TERM
+		append progress c
+	} res2]
+	append progress d
+} res1]
+
+check signal.1 $progress ab
+check signal.2 $ret1 5
+check signal.3 $ret2 ""
+check signal.4 $res1 SIGTERM
+check signal.5 $res2 ""
+
+set result 0
+catch -signal {
+	signal handle ALRM
+	alarm 1
+	sleep 2
+	set result 1
+} ret
+
+check signal.7 $result 0
+check signal.6 $ret SIGALRM
diff --git a/tcltests/test_stdio.tcl b/tcltests/test_stdio.tcl
new file mode 100644
index 0000000..1e2e3fb
--- /dev/null
+++ b/tcltests/test_stdio.tcl
@@ -0,0 +1,31 @@
+proc copy_file {infile outfile} {
+	set in [open $infile r]
+	set out [open $outfile w]
+	while {1} {
+		set buf [read $in 200]
+		if {[string length $buf] == 0} {
+			break
+		}
+		puts -nonewline $out $buf
+	}
+	close $in
+	close $out
+}
+
+proc check_file {message filename} {
+	# Does it look OK?
+	set line 0
+	if {[catch {exec cmp -s test.bin $filename} err]} {
+		puts "$message"
+		puts "=========================================="
+		puts "$filename did not match test.bin"
+		error failed
+	}
+	verbose "$message -- ok"
+}
+
+check_file "Initial test.bin" test.bin
+
+copy_file test.bin stdio.copy
+check_file "Copy file with stdio" stdio.copy
+file delete stdio.copy
diff --git a/tcltests/test_upvararray.tcl b/tcltests/test_upvararray.tcl
new file mode 100644
index 0000000..a83b484
--- /dev/null
+++ b/tcltests/test_upvararray.tcl
@@ -0,0 +1,23 @@
+proc t {an v} {
+	upvar $an a
+	return $a($v)
+}
+
+proc t2 {anv} {
+	upvar $anv av
+	return $av
+}
+
+array set a {b B c C}
+
+set res [t a b]
+check upvar.array.1 $res B
+
+set res [t a c]
+check upvar.array.2 $res C
+
+set res [t2 a(b)]
+check upvar.array.3 $res B
+
+set res [t2 a(c)]
+check upvar.array.4 $res C
diff --git a/tcltests/testmod.tcl b/tcltests/testmod.tcl
new file mode 100644
index 0000000..dbc469b
--- /dev/null
+++ b/tcltests/testmod.tcl
@@ -0,0 +1,5 @@
+package provide testmod 2.0
+
+proc testmod {msg} {
+	return $msg
+}