Improve stack trace handling

*: Get rid of JIM_ERR_ADDSTACK and use interp->addStackTrace instead
*: 'return -code error' doesn't add a stack frame
*: Rename _file_copy to {file copy} for better error messages
*: Use 'return -code' to prevent excessive levels in the stack trace
Also rename info_nameofexecutable to {info nameofexecutable}

4 files changed, 146 insertions, 23 deletions

diff --git a/tests/errors.tcl b/tests/errors.tcl
index a544faf..7f5cdc8 100644
--- a/tests/errors.tcl
+++ b/tests/errors.tcl
@@ -26,6 +26,9 @@ proc error_generator {type} {
 		badpackage {
 			package require bogus
 		} \
+		returncode {
+			return -code error failure
+		} \
 		default {
 			puts "Unknown type=$type"
 		}
@@ -34,9 +37,6 @@ proc error_generator {type} {
 
 
 
-
-
-
 # line 40: Some empty lines above so that line numbers don't change
 proc error_caller {type {method call}} {
 	switch $method \
diff --git a/tests/filecopy.test b/tests/filecopy.test
new file mode 100644
index 0000000..3bc1570
--- /dev/null
+++ b/tests/filecopy.test
@@ -0,0 +1,124 @@
+source testing.tcl
+
+file mkdir tempdir
+
+test filecopy-1.1 "Simple case" {
+	file copy testio.in tempfile
+} {}
+
+test filecopy-1.2 "Target exists" {
+	list [catch {file copy testio.in tempfile} msg] $msg
+} {1 {error copying "testio.in" to "tempfile": file already exists}}
+
+test filecopy-1.3 "Source doesn't exist" {
+	list [catch {file copy missing tempfile} msg] $msg
+} {1 {missing: No such file or directory}}
+
+test filecopy-1.4 "Can't write to target" {
+	list [catch {file copy testio.in tempdir} msg] $msg
+} {1 {error copying "testio.in" to "tempdir": file already exists}}
+
+test filecopy-1.5 "Source doesn't exist and can't write to target" {
+	list [catch {file copy missing tempdir} msg] $msg
+} {1 {missing: No such file or directory}}
+
+test filecopy-1.6 "Wrong args" {
+	list [catch {file copy onearg} msg] $msg
+} {1 {wrong # args: must be "file copy ?-force? source dest"}}
+
+test filecopy-1.7 "Wrong args" {
+	list [catch {file copy too many args here} msg] $msg
+} {1 {wrong # args: must be "file copy ?-force? source dest"}}
+
+test filecopy-1.8 "Wrong args" {
+	list [catch {file copy -blah testio.in tempfile} msg] $msg
+} {1 {bad option "-blah": should be -force}}
+
+file delete tempfile
+
+test filecopy-2.1 "Simple case (-force)" {
+	file copy -force testio.in tempfile
+} {}
+
+test filecopy-2.2 "Target exists (-force)" {
+	file copy -force testio.in tempfile
+} {}
+
+test filecopy-2.3 "Source doesn't exist (-force)" {
+	list [catch {file copy -force missing tempfile} msg] $msg
+} {1 {missing: No such file or directory}}
+
+test filecopy-2.4 "Can't write to target (-force)" {
+	list [catch {file copy -force testio.in tempdir} msg] $msg
+} {1 {tempdir: Is a directory}}
+
+test filecopy-2.5 "Source doesn't exist and can't write to target (-force)" {
+	list [catch {file copy -force missing tempdir} msg] $msg
+} {1 {missing: No such file or directory}}
+
+file delete tempfile
+exec rmdir tempdir
+
+testreport
+source testing.tcl
+
+file mkdir tempdir
+
+test filecopy-1.1 "Simple case" {
+	file copy testio.in tempfile
+} {}
+
+test filecopy-1.2 "Target exists" {
+	list [catch {file copy testio.in tempfile} msg] $msg
+} {1 {error copying "testio.in" to "tempfile": file already exists}}
+
+test filecopy-1.3 "Source doesn't exist" {
+	list [catch {file copy missing tempfile} msg] $msg
+} {1 {missing: No such file or directory}}
+
+test filecopy-1.4 "Can't write to target" {
+	list [catch {file copy testio.in tempdir} msg] $msg
+} {1 {error copying "testio.in" to "tempdir": file already exists}}
+
+test filecopy-1.5 "Source doesn't exist and can't write to target" {
+	list [catch {file copy missing tempdir} msg] $msg
+} {1 {missing: No such file or directory}}
+
+test filecopy-1.6 "Wrong args" {
+	list [catch {file copy onearg} msg] $msg
+} {1 {wrong # args: must be "file copy ?-force? source dest"}}
+
+test filecopy-1.7 "Wrong args" {
+	list [catch {file copy too many args here} msg] $msg
+} {1 {wrong # args: must be "file copy ?-force? source dest"}}
+
+test filecopy-1.8 "Wrong args" {
+	list [catch {file copy -blah testio.in tempfile} msg] $msg
+} {1 {bad option "-blah": should be -force}}
+
+file delete tempfile
+
+test filecopy-2.1 "Simple case (-force)" {
+	file copy -force testio.in tempfile
+} {}
+
+test filecopy-2.2 "Target exists (-force)" {
+	file copy -force testio.in tempfile
+} {}
+
+test filecopy-2.3 "Source doesn't exist (-force)" {
+	list [catch {file copy -force missing tempfile} msg] $msg
+} {1 {missing: No such file or directory}}
+
+test filecopy-2.4 "Can't write to target (-force)" {
+	list [catch {file copy -force testio.in tempdir} msg] $msg
+} {1 {tempdir: Is a directory}}
+
+test filecopy-2.5 "Source doesn't exist and can't write to target (-force)" {
+	list [catch {file copy -force missing tempdir} msg] $msg
+} {1 {missing: No such file or directory}}
+
+file delete tempfile
+exec rmdir tempdir
+
+testreport
diff --git a/tests/stacktrace.test b/tests/stacktrace.test
index 7be8ab9..5a1ce0a 100644
--- a/tests/stacktrace.test
+++ b/tests/stacktrace.test
@@ -4,7 +4,7 @@ package require errors
 # Make this a proc so that the line numbers don't have to change
 proc main {} {
 	set id1 0
-	foreach type {badcmd badvar error interpbadvar interpbadcmd package source badpackage} {
+	foreach type {badcmd badvar error interpbadvar interpbadcmd package source badpackage returncode} {
 		set id2 0
 		incr id1
 		foreach method {call uplevel eval evalstr} {
@@ -16,7 +16,7 @@ proc main {} {
 			test err-$id1.$id2 "Stacktrace on error type $type, method $method" {
 				set rc [catch {error_caller $type $method} msg]
 				#puts stderr "err-$id1.$id2 $type, $method\n[errorInfo $msg]\n"
-				#puts stderr "\terr-$id1.$id2 {[list $rc $msg [info stacktrace]]}"
+				if {$::SHOW_EXPECTED} { puts stderr "\terr-$id1.$id2 {[list $rc $msg [info stacktrace]]}" }
 
 				list $rc $msg [info stacktrace]
 			} $exp
@@ -102,8 +102,16 @@ Can't load package dummy} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21
 	err-8.2 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
 	err-8.3 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
 	err-8.4 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-9.1 {1 failure {{} errors.tcl 44 error_caller stacktrace.test 17}}
+	err-9.2 {1 failure {{} errors.tcl 47 error_caller stacktrace.test 17}}
+	err-9.3 {1 failure {{} errors.tcl 50 error_caller stacktrace.test 17}}
+	err-9.4 {1 failure {{} errors.tcl 53 error_caller stacktrace.test 17}}
 }
 
+# Set this to output expected results to stderr
+# in a form which can be pasted into 'expected' below
+set SHOW_EXPECTED 0
+
 main
 
 testreport
diff --git a/tests/testing.tcl b/tests/testing.tcl
index a675c5e..3142c72 100644
--- a/tests/testing.tcl
+++ b/tests/testing.tcl
@@ -1,32 +1,22 @@
-# Uses references to automatically close files when the handle
-# can no longer be accessed.
-#
-# e.g. bio copy [autoopen infile] [autoopen outfile w]; collect
-#
-proc autoopen {filename {mode r}} {
-	set ref [ref [open $filename $mode] aio lambdaFinalizer]
-	rename [getref $ref] $ref
-	return $ref
-}
-
-# Hardly needed
-proc filecopy {read write} {
-	bio copy [autoopen $read] [autoopen $write w]
-	collect
-}
-
 proc makeFile {contents name} {
 	set f [open $name w]
 	puts $f $contents
 	close $f
 }
 
+proc info_source {script} {
+	join [info source $script] :
+}
+
 catch {
 	# Tcl-only things
 	info tclversion
 	proc errorInfo {msg} {
 		return $::errorInfo
 	}
+	proc info_source {script} {
+		return ""
+	}
 }
 
 proc section {name} {
@@ -53,6 +43,7 @@ proc test {id descr script expected} {
 			puts -nonewline "$id "
 		}
 		puts "ERR $descr"
+		puts "At      : [info_source $script]"
 		puts "Expected: '$expected'"
 		puts "Got     : '$result'"
 		incr ::testresults(numfail)
@@ -65,7 +56,7 @@ proc testreport {} {
 	puts "FAILED: $::testresults(numfail)"
 	foreach failed $::testresults(failed) {
 		foreach {id descr script expected result} $failed {}
-		puts "\t$id"
+		puts "\t[info_source $script]\t$id"
 	}
 	puts "PASSED: $::testresults(numpass)"
 	puts "----------------------------------------------------------------------\n"