diff options
| -rw-r--r-- | doc/jim_tcl.txt | 2 | ||||
| -rw-r--r-- | glob.tcl | 2 | ||||
| -rw-r--r-- | jim-file.c | 2 | ||||
| -rw-r--r-- | jim-package.c | 9 | ||||
| -rw-r--r-- | jim.c | 94 | ||||
| -rw-r--r-- | jim.h | 3 | ||||
| -rw-r--r-- | jimsh.c | 2 | ||||
| -rw-r--r-- | tclcompat.tcl | 25 | ||||
| -rw-r--r-- | tests/errors.tcl | 6 | ||||
| -rw-r--r-- | tests/filecopy.test | 124 | ||||
| -rw-r--r-- | tests/stacktrace.test | 12 | ||||
| -rw-r--r-- | tests/testing.tcl | 27 |
12 files changed, 219 insertions, 89 deletions
diff --git a/doc/jim_tcl.txt b/doc/jim_tcl.txt index a5722ea..4950c6f 100644 --- a/doc/jim_tcl.txt +++ b/doc/jim_tcl.txt @@ -75,7 +75,7 @@ Since v0.61: 13. Allow 'catch' to determine what return codes are caught 14. Allow 'incr' to increment an unset variable by first setting to 0 15. Allow 'args' and optional arguments to the left or required arguments in 'proc' -15. Add 'file copy' +16. Add 'file copy' TCL INTRODUCTION ----------------- @@ -117,7 +117,7 @@ proc glob {args} { } if {$nocomplain == 0 && [llength $result] == 0} { - error "no files matched glob patterns" + return -code error "no files matched glob patterns" } return $result @@ -441,7 +441,7 @@ static int file_cmd_copy(Jim_Interp *interp, int argc, Jim_Obj *const *argv) Jim_Obj *new_argv[4]; int i; - new_argv[0] = Jim_NewStringObj(interp, "_file_copy", -1); + new_argv[0] = Jim_NewStringObj(interp, "file copy", -1); for (i = 0; i < argc; i++) { new_argv[i + 1] = argv[i]; } diff --git a/jim-package.c b/jim-package.c index 6796cb0..12a63be 100644 --- a/jim-package.c +++ b/jim-package.c @@ -188,13 +188,10 @@ static int package_cmd_provide(Jim_Interp *interp, int argc, Jim_Obj *const *arg */ static int package_cmd_require(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { - int retcode = Jim_PackageRequire(interp, Jim_GetString(argv[0], NULL), JIM_ERRMSG); - /* package require failing is important enough to add to the stack */ - if (retcode == JIM_ERR) { - retcode = JIM_ERR_ADDSTACK; - } - return retcode; + interp->addStackTrace++; + + return Jim_PackageRequire(interp, Jim_GetString(argv[0], NULL), JIM_ERRMSG); } /* @@ -112,7 +112,6 @@ static char *JimEmptyStringRep = (char*) ""; static void JimChangeCallFrameId(Jim_Interp *interp, Jim_CallFrame *cf); static void JimFreeCallFrame(Jim_Interp *interp, Jim_CallFrame *cf, int flags); static int ListSetIndex(Jim_Interp *interp, Jim_Obj *listPtr, int index, Jim_Obj *newObjPtr, int flags); -static int JimAddErrorToStack(Jim_Interp *interp, int retcode, const char *filename, int line); static Jim_Obj *Jim_ExpandDictSugar(Jim_Interp *interp, Jim_Obj *objPtr); static void SetDictSubstFromAny(Jim_Interp *interp, Jim_Obj *objPtr); static void JimSetFailedEnumResult(Jim_Interp *interp, const char *arg, const char *badtype, const char *prefix, const char * const *tablePtr, const char *name); @@ -4378,6 +4377,7 @@ Jim_Interp *Jim_CreateInterp(void) i->errorLine = 0; i->errorFileName = Jim_StrDup(""); + i->addStackTrace = 0; i->numLevels = 0; i->maxNestingDepth = JIM_MAX_NESTING_DEPTH; i->returnCode = JIM_OK; @@ -4621,6 +4621,8 @@ static void JimResetStackTrace(Jim_Interp *interp) static void JimAppendStackTrace(Jim_Interp *interp, const char *procname, const char *filename, int linenr) { + /*printf("AppendStackTrace: %s:%d (%s)\n", filename, linenr, procname);*/ + /* XXX Omit "unknown" for now since it can be confusing (but it may help too!) */ if (strcmp(procname, "unknown") == 0) { procname = ""; @@ -8787,33 +8789,42 @@ static int JimAddErrorToStack(Jim_Interp *interp, int retcode, const char *filen { int rc = retcode; +#if 0 + /* XXX: Don't create a stack frame for 'return -code error' */ + /* Pick up 'return -code error' too */ if (retcode == JIM_RETURN) { rc = interp->returnCode; } - if (rc == JIM_ERR || rc == JIM_ERR_ADDSTACK) { - if (!interp->errorFlag) { - /* This is the first error, so save the file/line information and reset the stack */ - interp->errorFlag = 1; - JimSetErrorFileName(interp, filename); - JimSetErrorLineNumber(interp, line); - JimResetStackTrace(interp); + printf("JimAddErrorToStack: retcode=%s, %s:%d, ast=%d, errorFlag=%d\n", + Jim_ReturnCode(retcode), filename, line, interp->addStackTrace, interp->errorFlag); +#endif - /* Always add a stack frame at this level */ - rc = JIM_ERR_ADDSTACK; - } + if (rc == JIM_ERR && !interp->errorFlag) { + /* This is the first error, so save the file/line information and reset the stack */ + interp->errorFlag = 1; + JimSetErrorFileName(interp, filename); + JimSetErrorLineNumber(interp, line); - if (rc == JIM_ERR_ADDSTACK) { - /* Add the stack info for the current level */ - JimAppendStackTrace(interp, Jim_GetString(interp->errorProc, NULL), filename, line); - } + JimResetStackTrace(interp); + /* Always add a level where the error first occurs */ + interp->addStackTrace++; + } + + /* Now if this is an "interesting" level, add it to the stack trace */ + if (rc == JIM_ERR && interp->addStackTrace > 0) { + /* Add the stack info for the current level */ + JimAppendStackTrace(interp, Jim_GetString(interp->errorProc, NULL), filename, line); Jim_DecrRefCount(interp, interp->errorProc); interp->errorProc = interp->emptyObj; Jim_IncrRefCount(interp->errorProc); } - return retcode == JIM_ERR_ADDSTACK ? JIM_ERR : retcode; + + interp->addStackTrace = 0; + + return JIM_OK; } int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) @@ -9032,7 +9043,7 @@ int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) j = 0; /* on normal termination, the argv array is already Jim_DecrRefCount-ed. */ err: - retcode = JimAddErrorToStack(interp, retcode, script->fileName, cmdtoken ? cmdtoken->linenr : 0); + JimAddErrorToStack(interp, retcode, script->fileName, cmdtoken ? cmdtoken->linenr : 0); Jim_FreeIntRep(interp, scriptObjPtr); scriptObjPtr->typePtr = &scriptObjType; Jim_SetIntRepPtr(scriptObjPtr, script); @@ -9180,8 +9191,8 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, retcode = interp->returnCode; interp->returnCode = JIM_OK; } - if (retcode == JIM_ERR) { - retcode = JIM_ERR_ADDSTACK; + else if (retcode == JIM_ERR) { + interp->addStackTrace++; Jim_DecrRefCount(interp, interp->errorProc); interp->errorProc = procname; Jim_IncrRefCount(interp->errorProc); @@ -9277,7 +9288,7 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename) if (stat(filename, &sb) != 0 || (fp = fopen(filename, "r")) == NULL) { Jim_SetResultFormatted(interp, "couldn't read file \"%s\": %s", filename, strerror(errno)); - return JIM_ERR_ADDSTACK; + return JIM_ERR; } if (sb.st_size == 0) { fclose(fp); @@ -9289,7 +9300,7 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename) fclose(fp); if (readlen != 1) { Jim_Free(buf); - return JIM_ERR_ADDSTACK; + return JIM_ERR; } buf[sb.st_size] = 0; @@ -9307,16 +9318,15 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename) retcode = interp->returnCode; interp->returnCode = JIM_OK; } + if (retcode == JIM_ERR) { + /* EvalFile changes context, so add a stack frame here */ + interp->addStackTrace++; + } interp->currentScriptObj = prevScriptObj; Jim_DecrRefCount(interp, scriptObjPtr); - if (retcode == JIM_ERR) { - /* EvalFile changes context, so add a stack frame here */ - retcode = JIM_ERR_ADDSTACK; - } - return retcode; } @@ -11053,24 +11063,23 @@ static int Jim_DebugCoreCommand(Jim_Interp *interp, int argc, static int Jim_EvalCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { - if (argc == 2) { - return Jim_EvalObj(interp, argv[1]); - } else if (argc > 2) { - Jim_Obj *objPtr; - int retcode; + int rc; - objPtr = Jim_ConcatObj(interp, argc-1, argv+1); - Jim_IncrRefCount(objPtr); - retcode = Jim_EvalObj(interp, objPtr); - Jim_DecrRefCount(interp, objPtr); - if (retcode == JIM_ERR) { - retcode = JIM_ERR_ADDSTACK; - } - return retcode; - } else { + if (argc < 2) { Jim_WrongNumArgs(interp, 1, argv, "script ?...?"); return JIM_ERR; } + if (argc == 2) { + rc = Jim_EvalObj(interp, argv[1]); + } + else { + rc = Jim_EvalObj(interp, Jim_ConcatObj(interp, argc-1, argv+1)); + } + if (rc == JIM_ERR) { + /* eval is "interesting", so add a stack frame here */ + interp->addStackTrace++; + } + return rc; } /* [uplevel] */ @@ -12168,7 +12177,7 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, case INFO_NAMEOFEXECUTABLE: /* Redirect to Tcl proc */ - return Jim_Eval(interp, "info_nameofexecutable"); + return Jim_Eval(interp, "{info nameofexecutable}"); case INFO_RETURNCODES: { int i; @@ -12389,7 +12398,8 @@ static int Jim_ErrorCoreCommand(Jim_Interp *interp, int argc, interp->errorFlag = 1; return JIM_ERR; } - return JIM_ERR_ADDSTACK; + interp->addStackTrace++; + return JIM_ERR; } /* [lrange] */ @@ -134,7 +134,7 @@ extern "C" { #define JIM_EXIT 6 /* The following are internal codes and should never been seen/used */ #define JIM_EVAL 7 -#define JIM_ERR_ADDSTACK 8 + #define JIM_MAX_NESTING_DEPTH 10000 /* default max nesting depth */ /* Some function get an integer argument with flags to change @@ -483,6 +483,7 @@ typedef struct Jim_Interp { Jim_Obj *result; /* object returned by the last command called. */ int errorLine; /* Error line where an error occurred. */ char *errorFileName; /* Error file where an error occurred. */ + int addStackTrace; /* > 0 If a level should be added to the stack trace */ int numLevels; /* Number of current nested calls. */ int maxNestingDepth; /* Used for infinite loop detection. */ int returnCode; /* Completion code to return on JIM_RETURN. */ @@ -153,7 +153,7 @@ int main(int argc, char *const argv[]) JimSetArgv(interp, argc - 2, argv + 2); retcode = Jim_EvalFile(interp, argv[1]); } - if (retcode == JIM_ERR || retcode == JIM_ERR_ADDSTACK) { + if (retcode == JIM_ERR) { Jim_PrintErrorMessage(interp); } } diff --git a/tclcompat.tcl b/tclcompat.tcl index 266f0d9..a8cbefb 100644 --- a/tclcompat.tcl +++ b/tclcompat.tcl @@ -94,7 +94,7 @@ proc errorInfo {error {stacktrace ""}} { return $result } -proc info_nameofexecutable {} { +proc {info nameofexecutable} {} { if {[info exists ::jim_argv0]} { if {[string first "/" $::jim_argv0] >= 0} { return $::jim_argv0 @@ -110,18 +110,17 @@ proc info_nameofexecutable {} { } # Implements 'file copy' - single file mode only -proc _file_copy {{force {}} source target} { - switch -- $force \ - -force {} \ - {} { - if {[file exists $target]} { - error "error copying \"$source\" to \"$target\": file already exists" - } - } \ - default { - error "bad option \"$force\": should be -force" - } - set in [open $source] +proc {file copy} {{force {}} source target} { + if {$force ni {{} -force}} { + return -code error "bad option \"$force\": should be -force" + } + if {[catch {open $source} in]} { + return -code error $in + } + if {$force eq "" && [file exists $target]} { + $in close + return -code error "error copying \"$source\" to \"$target\": file already exists" + } set rc [catch { set out [open $target w] bio copy $in $out 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" |