bootstrap jimsh: pass all tests

In order to test bootstrap jimsh, it is very helpful
if it can pass all the unit tests.

- Set tcl_platform(bootstrap) to 1 for bootstrap jimsh or 0 otherwise
- Use getref to determine in we have references, not ref since we
  implement a poor-man's ref for bootstrap jimsh
- bootstrap jimsh package doesn't return a "Can't load package"
  message if loading the package fails
- exec tests using [open |command] need pipe
- bootstrap jimsh can't set file times with [file mtime]

Signed-off-by: Steve Bennett <[email protected]>

Author: msteveb

bootstrap.tcl

@@ -1,16 +1,16 @@
 # Minimal support for package require
-# No error on failure since C extensions aren't handled
-proc package {cmd pkg args} {
+proc package {cmd args} {
 	if {$cmd eq "require"} {
 		foreach path $::auto_path {
+			lassign $args pkg
 			set pkgpath $path/$pkg.tcl
 			if {$path eq "."} {
 				set pkgpath $pkg.tcl
 			}
 			if {[file exists $pkgpath]} {
-				uplevel #0 [list source $pkgpath]
-				return
+				tailcall uplevel #0 [list source $pkgpath]
 			}
 		}
 	}
 }
+set tcl_platform(bootstrap) 1

jim.c

@@ -5671,6 +5671,7 @@ Jim_Interp *Jim_CreateInterp(void)
     Jim_SetVariableStrWithStr(i, "tcl_platform(pathSeparator)", TCL_PLATFORM_PATH_SEPARATOR);
     Jim_SetVariableStrWithStr(i, "tcl_platform(byteOrder)", Jim_IsBigEndian() ? "bigEndian" : "littleEndian");
     Jim_SetVariableStrWithStr(i, "tcl_platform(threaded)", "0");
+    Jim_SetVariableStrWithStr(i, "tcl_platform(bootstrap)", "0");
     Jim_SetVariableStr(i, "tcl_platform(pointerSize)", Jim_NewIntObj(i, sizeof(void *)));
     Jim_SetVariableStr(i, "tcl_platform(wordSize)", Jim_NewIntObj(i, sizeof(jim_wide)));
 

tests/coverage.test

@@ -2,7 +2,7 @@
 
 source [file dirname [info script]]/testing.tcl
 
-testCmdConstraints ref rand namespace
+testCmdConstraints getref rand namespace
 
 testConstraint debug-invstr 0
 catch {
@@ -79,39 +79,39 @@ test script-1 {convert empty object to script} {
 	eval $empty
 } {}
 
-test ref-1 {treat something as a reference} ref {
+test ref-1 {treat something as a reference} getref {
 	set ref [ref abc tag]
 	append ref "  "
 	getref "  $ref "
 } {abc}
 
-test ref-2 {getref invalid reference} -constraints ref -body {
+test ref-2 {getref invalid reference} -constraints getref -body {
 	getref "<reference.<tag____>.99999999999999000000>"
 } -returnCodes error -match glob -result {invalid reference id *}
 
-test ref-3 {getref invalid reference tag} -constraints ref -body {
+test ref-3 {getref invalid reference tag} -constraints getref -body {
 	getref "<reference.<tag!%(*>.99999999999999000000>"
 } -returnCodes error -match glob -result {expected reference but got "<reference.<tag!%(*>.99999999999999000000>"}
 
-test ref-4 {finalize} ref {
+test ref-4 {finalize} getref {
 	finalize $ref
 } {}
 
-test ref-5 {finalize} ref {
+test ref-5 {finalize} getref {
 	finalize $ref cleanup
 	finalize $ref cleanup2
 	finalize $ref
 } {cleanup2}
 
-test ref-6 {finalize get invalid reference} -constraints ref -body {
+test ref-6 {finalize get invalid reference} -constraints getref -body {
 	finalize "<reference.<tag____>.99999999999999000000>"
 } -returnCodes error -match glob -result {invalid reference id *}
 
-test ref-7 {finalize set invalid reference} -constraints ref -body {
+test ref-7 {finalize set invalid reference} -constraints getref -body {
 	finalize "<reference.<tag____>.99999999999999000000>" cleanup
 } -returnCodes error -match glob -result {invalid reference id *}
 
-test collect-1 {recursive collect} ref {
+test collect-1 {recursive collect} getref {
 	set ref2 [ref dummy cleanup2]
 	unset ref2
 	proc cleanup2 {ref value} {
@@ -209,10 +209,6 @@ test divide-1 {expr} -constraints jim -body {
 	/ 2 0
 } -returnCodes error -result {Division by zero}
 
-test package-1 {package names} jim {
-	expr {"stdlib" in [package names]}
-} {1}
-
 test variable-1 {upvar, name with embedded null} -constraints jim -body {
 	proc a {} {
 		upvar var\0null abc

tests/error.test

@@ -49,7 +49,7 @@ test error-1.2 "Modify stacktrace" {
 
 # Package should be able to invoke exit, which should exit if not caught
 test error-2.1 "Exit from package" {
-	list [catch -exit {package require exitpackage} msg] $msg
-} {6 {Can't load package exitpackage}}
+	catch -exit {package require exitpackage} msg
+} 6
 
 testreport

tests/exec.test

@@ -18,6 +18,13 @@ source [file dirname [info script]]/testing.tcl
 needs cmd exec
 needs cmd flush
 
+# Jim needs [pipe] to implement [open |command]
+if {[testConstraint tcl]} {
+    testConstraint pipe 1
+} else {
+    testCmdConstraints pipe
+}
+
 testConstraint unix [expr {$tcl_platform(platform) eq {unix}}]
 
 # Sleep which supports fractions of a second
@@ -415,7 +422,7 @@ Third line}
 
 test exec-17.1 {redirecting from command pipeline} -setup {
     makeFile "abc\nghi\njkl" gorp.file
-} -body {
+} -constraints pipe -body {
     set f [open "|cat gorp.file | wc -l" r]
     set result [lindex [exec cat <@$f] 0]
     close $f
@@ -426,7 +433,7 @@ test exec-17.1 {redirecting from command pipeline} -setup {
 
 test exec-17.2 {redirecting to command pipeline} -setup {
     makeFile "abc\nghi\njkl" gorp.file
-} -body {
+} -constraints pipe -body {
     set f [open "|wc -l >gorp2.file" w]
     exec cat gorp.file >@$f
     flush $f

tests/exec2.test

@@ -5,7 +5,14 @@
 source [file dirname [info script]]/testing.tcl
 
 needs cmd exec
-testCmdConstraints pipe signal wait alarm
+testCmdConstraints signal wait alarm after
+
+# Jim needs [pipe] to implement [open |command]
+if {[testConstraint tcl]} {
+	testConstraint pipe 1
+} else {
+	testCmdConstraints pipe
+}
 
 # Some Windows platforms (e.g. AppVeyor) produce ENOSPC rather than killing
 # the child with SIGPIPE). So turn off this test for that platform
@@ -53,14 +60,14 @@ test exec2-2.4 "Remove all env var" {
 
 array set env [array get saveenv]
 
-test exec2-3.1 "close pipeline return value" {
+test exec2-3.1 "close pipeline return value" pipe {
 	set f [open |false]
 	set rc [catch {close $f} msg opts]
 	lassign [dict get $opts -errorcode] status pid exitcode
 	list $rc $msg $status $exitcode
 } {1 {child process exited abnormally} CHILDSTATUS 1}
 
-test exec2-3.2 "close pipeline return value" -constraints {pipe nomingw32} -body {
+test exec2-3.2 "close pipeline return value" -constraints {jim pipe nomingw32} -body {
 	# Create a pipe and immediately close the read end
 	lassign [pipe] r w
 	close $r
@@ -101,7 +108,7 @@ test exec2-3.4 "wait for background task" -constraints wait -body {
 
 test exec2-4.1 {redirect from invalid filehandle} -body {
 	exec cat <@bogus
-} -returnCodes error -result {invalid command name "bogus"}
+} -returnCodes error -match glob -result {*"bogus"}
 
 test exec2-4.2 {env is invalid dict} -constraints jim -body {
 	set saveenv $env
@@ -127,7 +134,7 @@ test exec2-4.5 {exec - consecutive | with &} -body {
 
 test exec2-4.6 {exec - illegal channel} -body {
 	exec echo hello >@nonexistent
-} -returnCodes error -result {invalid command name "nonexistent"}
+} -returnCodes error -match glob -result {*"nonexistent"}
 
 test exec2-5.1 {wait with invalid pid} wait {
 	wait 9999999
@@ -148,7 +155,7 @@ test exec2-5.4 {wait -nohang} -constraints wait -body {
 	wait $pid
 } -match glob -result {CHILDSTATUS * 0}
 
-test exec2-5.5 {wait for all children} -body {
+test exec2-5.5 {wait for all children} -constraints {after jim} -body {
 	# We want to have children finish at different times
 	# so that we test the handling of the wait table
 	foreach i {0.1 0.2 0.6 0.5 0.4 0.3} {

tests/file.test

@@ -6,6 +6,11 @@ testConstraint filelink [string match "wrong # args:*" $msg]
 catch {file lstat} msg
 testConstraint filelstat [string match "wrong # args:*" $msg]
 testConstraint unix [expr {$tcl_platform(platform) eq "unix"}]
+if {[testConstraint jim]} {
+	testConstraint mtimeset [expr {!$tcl_platform(bootstrap)}]
+} else {
+	testConstraint mtimeset 1
+}
 
 test join-1.1 "One name" {
 	file join abc
@@ -366,7 +371,7 @@ test mtime-1.4 {file mtime} {
 	}
 } {}
 
-test mtime-1.5 {file mtime} -constraints unix -body {
+test mtime-1.5 {file mtime} -constraints {mtimeset unix} -body {
 	set name tmp.[pid]
 	makeFile testing $name
 	set t [file mtime [info script]]

tests/package.test

@@ -3,6 +3,10 @@ source [file dirname [info script]]/testing.tcl
 needs constraint jim
 needs cmd package
 
+if {[exists -proc package]} {
+	skiptest " (bootstrap jimsh)"
+}
+
 test package-1.1 {provide} -body {
 	package provide new-package-name
 	expr {"new-package-name" in [package names]}
@@ -12,5 +16,9 @@ test package-1.2 {provide, duplicate} -body {
 	package provide new-package-name
 } -returnCodes error -result {package "new-package-name" was already provided}
 
+test package-1.3 {package names} -body {
+	expr {"stdlib" in [package names]}
+} -result 1
+
 testreport