diff options
| -rw-r--r-- | jim-aio.c | 12 | ||||
| -rw-r--r-- | jim-file.c | 55 | ||||
| -rw-r--r-- | jim-package.c | 57 | ||||
| -rw-r--r-- | jim-regexp.c | 72 | ||||
| -rw-r--r-- | jim.c | 40 | ||||
| -rw-r--r-- | jim.h | 7 | ||||
| -rw-r--r-- | tcl6.tcl | 13 | ||||
| -rw-r--r-- | tests/Makefile | 2 | ||||
| -rw-r--r-- | tests/case.test | 80 | ||||
| -rw-r--r-- | tests/error.test | 53 | ||||
| -rw-r--r-- | tests/exitpackage.tcl | 3 | ||||
| -rw-r--r-- | tests/expr.test | 17 | ||||
| -rw-r--r-- | tests/filejoin.test | 62 | ||||
| -rw-r--r-- | tests/lsortcmd.test | 2 | ||||
| -rw-r--r-- | tests/regexp.test | 35 | ||||
| -rw-r--r-- | tests/stacktrace.test | 41 | ||||
| -rw-r--r-- | tests/testing.tcl | 2 |
17 files changed, 478 insertions, 75 deletions
@@ -326,7 +326,7 @@ static int aio_cmd_ndelay(Jim_Interp *interp, int argc, Jim_Obj *const *argv) if (argc) { long nb; - if (Jim_GetLong(interp, argv[2], &nb) != JIM_OK) { + if (Jim_GetLong(interp, argv[0], &nb) != JIM_OK) { return JIM_ERR; } if (nb) { @@ -675,7 +675,7 @@ static int JimAioSockCommand(Jim_Interp *interp, int argc, int on = 1; if (argc <= 2 ) { - Jim_WrongNumArgs(interp, 1, argv, "sockspec ?script?"); + Jim_WrongNumArgs(interp, 1, argv, "type address"); return JIM_ERR; } @@ -695,9 +695,7 @@ static int JimAioSockCommand(Jim_Interp *interp, int argc, srcport = atol(stsrcport); port = atol(stport); he = gethostbyname(sthost); - /* FIX!!!! this still results in null pointer exception here. - FIXED!!!! debug output but no JIM_ERR done UK. - */ + if (!he) { Jim_SetResultString(interp,hstrerror(h_errno),-1); return JIM_ERR; @@ -710,7 +708,7 @@ static int JimAioSockCommand(Jim_Interp *interp, int argc, break; case SOCK_STREAM_CL: sa.sin_family= he->h_addrtype; - bcopy(he->h_addr,(char *)&sa.sin_addr,he->h_length); /* set address */ + memcpy((char *)&sa.sin_addr,he->h_addr,he->h_length); /* set address */ sa.sin_port = htons(port); res = connect(sock,(struct sockaddr*)&sa,sizeof(sa)); if (res) { @@ -722,7 +720,7 @@ static int JimAioSockCommand(Jim_Interp *interp, int argc, break; case SOCK_STREAM_SERV: sa.sin_family= he->h_addrtype; - bcopy(he->h_addr,(char *)&sa.sin_addr,he->h_length); /* set address */ + memcpy((char *)&sa.sin_addr,he->h_addr,he->h_length); /* set address */ sa.sin_port = htons(port); /* Enable address reuse */ @@ -236,6 +236,54 @@ static int file_cmd_normalize(Jim_Interp *interp, int argc, Jim_Obj *const *argv return JIM_OK; } +static int file_cmd_join(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + int i; + char *newname = Jim_Alloc(MAXPATHLEN + 1); + char *last = newname; + + *newname = 0; + + /* Simple implementation for now */ + for (i = 0; i < argc; i++) { + int len; + const char *part = Jim_GetString(argv[i], &len); + + if (*part == '/') { + /* Absolute component, so go back to the start */ + last = newname; + } + + /* Add a slash if needed */ + if (last != newname) { + *last++ = '/'; + } + + if (len) { + if (last + len - newname >= MAXPATHLEN) { + Jim_Free(newname); + Jim_SetResultString(interp, "Path too long", -1); + return JIM_ERR; + } + memcpy(last, part, len); + last += len; + } + + /* Remove a slash if needed */ + if (last != newname && last[-1] == '/') { + *--last = 0; + } + } + + *last = 0; + + /* Probably need to handle some special cases ...*/ + + Jim_SetResult(interp, Jim_NewStringObjNoAlloc(interp, newname, last - newname)); + + return JIM_OK; +} + static int file_access(Jim_Interp *interp, Jim_Obj *filename, int mode) { const char *path = Jim_GetString(filename, NULL); @@ -516,6 +564,13 @@ static const jim_subcmd_type command_table[] = { .maxargs = 1, .description = "Normalized path of name" }, + { .cmd = "join", + .args = "name ?name ...?", + .function = file_cmd_join, + .minargs = 1, + .maxargs = -1, + .description = "Join multiple path components" + }, { .cmd = "readable", .args = "name", .function = file_cmd_readable, diff --git a/jim-package.c b/jim-package.c index f5450b5..5cdba85 100644 --- a/jim-package.c +++ b/jim-package.c @@ -108,9 +108,11 @@ static int JimLoadPackage(Jim_Interp *interp, const char *name, int flags) return retCode; } -const char *Jim_PackageRequire(Jim_Interp *interp, const char *name, int flags) +int Jim_PackageRequire(Jim_Interp *interp, const char *name, int flags) { Jim_HashEntry *he; + int retcode = 0; + const char *version; /* Start with an empty error string */ Jim_SetResultString(interp, "", 0); @@ -118,33 +120,39 @@ const char *Jim_PackageRequire(Jim_Interp *interp, const char *name, int flags) he = Jim_FindHashEntry(&interp->packages, name); if (he == NULL) { /* Try to load the package. */ - if (JimLoadPackage(interp, name, flags) == JIM_OK) { + retcode = JimLoadPackage(interp, name, flags); + if (retcode != JIM_OK) { + if (flags & JIM_ERRMSG) { + int len; + Jim_Obj *resultObj = Jim_GetResult(interp); + if (Jim_IsShared(resultObj)) { + resultObj = Jim_DuplicateObj(interp, resultObj); + } + Jim_GetString(resultObj, &len); + Jim_AppendStrings(interp, resultObj, len ? "\n" : "", + "Can't find package '", name, "'", NULL); + Jim_SetResult(interp, resultObj); + } + return retcode; + } + else { he = Jim_FindHashEntry(&interp->packages, name); if (he == NULL) { /* Did not call package provide, so we do it for them */ Jim_PackageProvide(interp, name, "1.0", 0); - return "1.0"; + version = "1.0"; } - return he->val; - } - - /* No way... return an error. */ - if (flags & JIM_ERRMSG) { - int len; - Jim_Obj *resultObj = Jim_GetResult(interp); - if (Jim_IsShared(resultObj)) { - resultObj = Jim_DuplicateObj(interp, resultObj); + else { + version = he->val; } - Jim_GetString(resultObj, &len); - Jim_AppendStrings(interp, resultObj, len ? "\n" : "", - "Can't find package '", name, "'", NULL); - Jim_SetResult(interp, resultObj); } - return NULL; - } else { - return he->val; } + else { + version = he->val; + } + Jim_SetResultString(interp, version, -1); + return retcode; } /* @@ -187,14 +195,13 @@ 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) { - const char *ver = Jim_PackageRequire(interp, Jim_GetString(argv[0], NULL), JIM_ERRMSG); + int retcode = Jim_PackageRequire(interp, Jim_GetString(argv[0], NULL), JIM_ERRMSG); - if (ver == NULL) { - /* package require failing is important enough to add to the stack */ - return JIM_ERR_ADDSTACK; + /* package require failing is important enough to add to the stack */ + if (retcode == JIM_ERR) { + retcode = JIM_ERR_ADDSTACK; } - Jim_SetResultString(interp, ver, -1); - return JIM_OK; + return retcode; } /* diff --git a/jim-regexp.c b/jim-regexp.c index 736813d..b8a7585 100644 --- a/jim-regexp.c +++ b/jim-regexp.c @@ -53,25 +53,59 @@ #define JIM_EXTENSION #include "jim.h" -/** - * REVISIT: Should cache a number of compiled regexps for performance reasons. - */ -static regex_t * -compile_regexp(Jim_Interp *interp, const char *pattern, int flags) +void FreeRegexpInternalRep(Jim_Interp *interp, Jim_Obj *objPtr) +{ + regfree(objPtr->internalRep.regexpValue.compre); + Jim_Free(objPtr->internalRep.regexpValue.compre); +} + +static Jim_ObjType regexpObjType = { + "regexp", + FreeRegexpInternalRep, + NULL, + NULL, + JIM_TYPE_NONE +}; + +static regex_t *SetRegexpFromAny(Jim_Interp *interp, Jim_Obj *objPtr, unsigned flags) { + regex_t *compre; + const char *pattern; int ret; - regex_t *result = (regex_t *)Jim_Alloc(sizeof(*result)); + /* Check if the object is already an uptodate variable */ + if (objPtr->typePtr == ®expObjType && + objPtr->internalRep.regexpValue.compre && + objPtr->internalRep.regexpValue.flags == flags) { + /* nothing to do */ + return objPtr->internalRep.regexpValue.compre; + } + + /* Not a regexp or the flags do not match */ + if (objPtr->typePtr == ®expObjType) { + FreeRegexpInternalRep(interp, objPtr); + objPtr->typePtr = NULL; + } - if ((ret = regcomp(result, pattern, REG_EXTENDED | flags)) != 0) { + /* Get the string representation */ + pattern = Jim_GetString(objPtr, NULL); + compre = Jim_Alloc(sizeof(regex_t)); + + if ((ret = regcomp(compre, pattern, REG_EXTENDED | flags)) != 0) { char buf[100]; - regerror(ret, result, buf, sizeof(buf)); + regerror(ret, compre, buf, sizeof(buf)); Jim_SetResult(interp, Jim_NewEmptyStringObj(interp)); Jim_AppendStrings(interp, Jim_GetResult(interp), "couldn't compile regular expression pattern: ", buf, NULL); - Jim_Free(result); + regfree(compre); + Jim_Free(compre); return NULL; } - return result; + + objPtr->typePtr = ®expObjType; + objPtr->internalRep.regexpValue.flags = flags; + objPtr->internalRep.regexpValue.compre = compre; + + return compre; } int Jim_RegexpCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) @@ -139,12 +173,12 @@ int Jim_RegexpCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) goto wrongNumArgs; } - pattern = Jim_GetString(argv[i], NULL); - regex = compile_regexp(interp, pattern, regcomp_flags); - if (regex == NULL) { + regex = SetRegexpFromAny(interp, argv[i], regcomp_flags); + if (!regex) { return JIM_ERR; } + pattern = Jim_GetString(argv[i], NULL); source_str = Jim_GetString(argv[i + 1], &source_len); num_vars = argc - i - 2; @@ -271,12 +305,10 @@ int Jim_RegexpCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) } Jim_Free(pmatch); - regfree(regex); - Jim_Free(regex); return result; } -#define MAX_SUB_MATCHES 10 +#define MAX_SUB_MATCHES 50 int Jim_RegsubCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { @@ -338,11 +370,11 @@ int Jim_RegsubCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) goto wrongNumArgs; } - pattern = Jim_GetString(argv[i], NULL); - regex = compile_regexp(interp, pattern, regcomp_flags); - if (regex == NULL) { + regex = SetRegexpFromAny(interp, argv[i], regcomp_flags); + if (!regex) { return JIM_ERR; } + pattern = Jim_GetString(argv[i], NULL); source_str = Jim_GetString(argv[i + 1], &source_len); replace_str = Jim_GetString(argv[i + 2], NULL); @@ -459,8 +491,6 @@ int Jim_RegsubCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) } done: - regfree(regex); - Jim_Free(regex); return result; } @@ -1300,6 +1300,8 @@ int JimParseCmd(struct JimParserCtx *pc) if (!level) break; } else if (*pc->p == '\\') { pc->p++; pc->len--; + if (*pc->p == '\n') + pc->linenr++; } else if (*pc->p == '{') { blevel++; } else if (*pc->p == '}') { @@ -1439,6 +1441,9 @@ int JimParseStr(struct JimParserCtx *pc) return JIM_OK; } if (pc->len >= 2) { + if (*(pc->p+1) == '\n') { + pc->linenr++; + } pc->p++; pc->len--; } break; @@ -4657,9 +4662,9 @@ static void JimResetStackTrace(Jim_Interp *interp) static void JimAppendStackTrace(Jim_Interp *interp, const char *procname, const char *filename, int linenr) { - /* No need to add this dummy entry to the stack trace */ + /* XXX Omit "unknown" for now since it can be confusing (but it may help too!) */ if (strcmp(procname, "unknown") == 0) { - return; + procname = ""; } if (!*procname && !*filename) { /* No useful info here */ @@ -7946,10 +7951,10 @@ static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv) Jim_Obj **v, *sv[JIM_EVAL_SARGV_LEN]; int retCode; - /* If JimUnknown() is recursively called (e.g. error in the unknown proc, + /* If JimUnknown() is recursively called too many times... * done here */ - if (interp->unknown_called) { + if (interp->unknown_called > 50) { return JIM_ERR; } @@ -8141,15 +8146,13 @@ void Jim_ExpandArgument(Jim_Interp *interp, Jim_Obj ***argv, static int JimAddErrorToStack(Jim_Interp *interp, int retcode, const char *filename, int line) { if (retcode == JIM_ERR || retcode == JIM_ERR_ADDSTACK) { - /*fprintf(stderr, "JimAddErrorToStack(retcode=%d, procname=%s, filename=%s, line=%d, errorFlag=%d\n", - retcode, Jim_GetString(interp->errorProc, NULL), filename, line, interp->errorFlag); - */ 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); /* Always add a stack frame at this level */ @@ -8157,14 +8160,10 @@ static int JimAddErrorToStack(Jim_Interp *interp, int retcode, const char *filen } if (retcode == JIM_ERR_ADDSTACK) { - //fprintf(stderr, " JimAddErrorToStack()\n"); /* Add the stack info for the current level */ JimAppendStackTrace(interp, Jim_GetString(interp->errorProc, NULL), filename, line); retcode = JIM_ERR; } - else { - //fprintf(stderr, " JimAddErrorToStack() ignoring error info\n"); - } Jim_DecrRefCount(interp, interp->errorProc); interp->errorProc = interp->emptyObj; @@ -8598,6 +8597,10 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename) " err: ", strerror(errno), NULL); return JIM_ERR_ADDSTACK; } + if (sb.st_size == 0) { + fclose(fp); + return JIM_OK; + } buf = Jim_Alloc(sb.st_size + 1); if (buf == 0 || fread(buf, sb.st_size, 1, fp) != 1) { @@ -11541,7 +11544,8 @@ static int Jim_ScanCoreCommand(Jim_Interp *interp, int argc, int len = 0; if (listPtr != 0 && listPtr != (Jim_Obj*)EOF) Jim_ListLength(interp, listPtr, &len); - if (listPtr == (Jim_Obj*)EOF || len == 0) { // XXX + if (listPtr == (Jim_Obj*)EOF || len == 0) { + /* XXX */ Jim_SetResult(interp, Jim_NewIntObj(interp, -1)); return JIM_OK; } @@ -11572,11 +11576,19 @@ err: static int Jim_ErrorCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { - if (argc != 2) { - Jim_WrongNumArgs(interp, 1, argv, "message"); + if (argc != 2 && argc != 3) { + Jim_WrongNumArgs(interp, 1, argv, "message ?stacktrace?"); return JIM_ERR; } Jim_SetResult(interp, argv[1]); + if (argc == 3) { + /* Increment reference first in case these are the same object */ + Jim_IncrRefCount(argv[2]); + Jim_DecrRefCount(interp, interp->stackTrace); + interp->stackTrace = argv[2]; + interp->errorFlag = 1; + return JIM_ERR; + } return JIM_ERR_ADDSTACK; } @@ -345,6 +345,11 @@ typedef struct Jim_Obj { unsigned char *data; size_t len; } binaryValue; + /* Regular expression pattern */ + struct { + unsigned flags; + void *compre; /* really an allocated (regex_t *) */ + } regexpValue; } internalRep; /* This are 8 or 16 bytes more for every object * but this is required for efficient garbage collection @@ -817,7 +822,7 @@ JIM_EXPORT int Jim_DeleteAssocData(Jim_Interp *interp, const char *key); /* jim-package.c */ JIM_EXPORT int Jim_PackageProvide (Jim_Interp *interp, const char *name, const char *ver, int flags); -JIM_EXPORT const char * Jim_PackageRequire (Jim_Interp *interp, +JIM_EXPORT int Jim_PackageRequire (Jim_Interp *interp, const char *name, int flags); /* error messages */ @@ -63,7 +63,8 @@ proc case {var args} { } if {[info exists do_action]} { - return [uplevel 1 $do_action] + set rc [catch [list uplevel 1 $do_action] result] + return -code $rc $result } } @@ -80,14 +81,18 @@ proc parray {arrayname {pattern *}} { incr max [string length $arrayname] incr max 2 foreach name [lsort [array names a $pattern]] { - puts [format "%-${max}s = $a($name)" $arrayname\($name\)] + puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)] } } # Sort of replacement for $::errorInfo -proc errorInfo {error} { +# Usage: errorInfo error ?stacktrace? +proc errorInfo {error {stacktrace ""}} { + if {$stacktrace eq ""} { + set stacktrace [info stacktrace] + } set result "Runtime Error: $error" - foreach {l f p} [lreverse [info stacktrace]] { + foreach {l f p} [lreverse $stacktrace] { append result \n if {$p ne ""} { append result "in procedure '$p' " diff --git a/tests/Makefile b/tests/Makefile index 1e04cdb..a97f183 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,5 +1,5 @@ test: ../jimsh @for i in *.test; do ../jimsh $$i; done -../jimsh: ../jim.c +../jimsh: ../*.c make -C .. all diff --git a/tests/case.test b/tests/case.test new file mode 100644 index 0000000..1973477 --- /dev/null +++ b/tests/case.test @@ -0,0 +1,80 @@ +source testing.tcl + +# Test that control structures can be implemented in a proc + +proc control {cond code} { + set iscond [uplevel 1 expr $cond] + #puts "$cond -> $iscond" + if {$iscond} { + set rc [catch [list uplevel 1 $code] error] + #puts "$code -> rc=$rc, error=$error" + return -code $rc $error + } +} + +test control-1.1 "False case" { + control 0 bogus +} {} + +test control-1.2 "Simple case" { + control 1 {return result} +} {result} + +test control-1.3 "Break from proc" { + set result {} + foreach i {1 2 3 4 5} { + control {$i == 4} {break} + lappend result $i + } + set result +} {1 2 3} + +test control-1.4 "Return from proc" { + foreach i {1 2 3 4 5} { + control {$i == 3} {return $i} + } +} {3} + +test control-1.5 "Continue from proc" { + set result {} + foreach i {1 2 3 4 5} { + control {$i == 2} {continue} + lappend result $i + } + set result +} {1 3 4 5} + +# case is a proc, but it should be able +# to cause a return in do_case +proc do_case {var} { + case $var in { + 1 { + return one + } + 2 { + return two + } + 3 { + return 33 + } + 4 { + continue + } + 5 { + break + } + 6 { + return six + } + } + return zero +} + +test control-2.1 "Return from case" { + set result {} + foreach i {0 1 2 3 4 5 6} { + lappend result [do_case $i] + } + set result +} {zero one two 33} + diff --git a/tests/error.test b/tests/error.test new file mode 100644 index 0000000..0bcd0da --- /dev/null +++ b/tests/error.test @@ -0,0 +1,53 @@ +package require testing + +proc a {} { + error "error thrown from a" +} + +proc b {} { + set rc [catch {a} msg] + if {$rc} { + error $msg [info stacktrace] + } +} + +test error-1.1 "Rethrow caught error" { + set rc [catch {b} msg] + #puts stderr "error-1.1\n[errorInfo $msg]\n" + + list $rc $msg [info stacktrace] +} {1 {error thrown from a} {{} error.test 4 a error.test 8 b error.test 15}} + +proc c {} { + a +} + +proc d {} { + c +} + +proc e {} { + d +} + +test error-1.2 "Modify stacktrace" { + set rc [catch {e} msg] + set st [info stacktrace] + # Now elide one entry from the stacktrace + #puts [errorInfo $msg] + set newst {} + foreach {p f l} $st { + if {$p ne "d"} { + lappend newst $p $f $l + } + } + # Now rethrow with the new stack + set rc [catch {error $msg $newst} msg] + #puts [errorInfo $msg] + info stacktrace +} {{} error.test 4 a error.test 22 c error.test 26 e error.test 34} + +# Package should be able to invoke exit, which should exit if not caught +test error-2.1 "Exit from package" { + list [catch {package require exitpackage} msg] $msg +} {7 {Can't find package 'exitpackage'}} diff --git a/tests/exitpackage.tcl b/tests/exitpackage.tcl new file mode 100644 index 0000000..c292557 --- /dev/null +++ b/tests/exitpackage.tcl @@ -0,0 +1,3 @@ +# This package just exits + +exit 1 diff --git a/tests/expr.test b/tests/expr.test new file mode 100644 index 0000000..99ef609 --- /dev/null +++ b/tests/expr.test @@ -0,0 +1,17 @@ +source testing.tcl + +section "String comparison" + +test expr-1.1 "Compare strings lt" { + expr {"V000500" < "V000405"} +} {0} + +test expr-1.2 "Compare strings with embedded nulls" { + set s1 [format abc%cdef 0] + set s2 [format abc%cghi 0] + expr {$s1 < $s2} +} {1} + +test expr-1.3 "Hex values" { + set mask1 [expr 0x4050 & 0x0CCC] +} {64} diff --git a/tests/filejoin.test b/tests/filejoin.test new file mode 100644 index 0000000..56fe661 --- /dev/null +++ b/tests/filejoin.test @@ -0,0 +1,62 @@ +source testing.tcl + +test join-1.1 "One name" { + file join abc +} {abc} + +test join-1.2 "One name with trailing slash" { + file join abc/ +} {abc} + +test join-1.3 "One name with leading slash" { + file join /abc +} {/abc} + +test join-1.4 "One name with leading and trailing slash" { + file join /abc/ +} {/abc} + +test join-1.5 "Two names" { + file join abc def +} {abc/def} + +test join-1.6 "Two names with dir trailing slash" { + file join abc/ def +} {abc/def} + +test join-1.7 "Two names with dir leading slash" { + file join /abc def +} {/abc/def} + +test join-1.8 "Two names with dir leading and trailing slash" { + file join /abc/ def +} {/abc/def} + +test join-1.9 "Two names with file trailing slash" { + file join abc def/ +} {abc/def} + +test join-1.10 "Two names with file leading slash" { + file join abc /def +} {/def} + +test join-1.11 "Two names with file leading and trailing slash" { + file join abc /def/ +} {/def} + +test join-1.12 "Two names with double slashes" { + file join abc/ /def +} {/def} + +test join-2.1 "Dir is empty string" { + file join "" def +} {def} + +test join-2.2 "File is empty string" { + file join abc "" +} {abc} + +test join-2.3 "Path too long" { + set components [string repeat {abcdefghi } 500] + list [catch [concat file join $components] msg] $msg +} {1 {Path too long}} diff --git a/tests/lsortcmd.test b/tests/lsortcmd.test index 3631855..fc6726b 100644 --- a/tests/lsortcmd.test +++ b/tests/lsortcmd.test @@ -1,4 +1,4 @@ -package require testing +source testing.tcl section "lsort -command" diff --git a/tests/regexp.test b/tests/regexp.test new file mode 100644 index 0000000..86ba17a --- /dev/null +++ b/tests/regexp.test @@ -0,0 +1,35 @@ +source testing.tcl + +test regexp-1.1 {effect of caching} { + + set filedata {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE} + + # Note: use 2 REs because often libc will cache a single regcomp() result + + # t1 should be faster because the compiled re can be cached. + set re1 "END_TABLE" + set re2 "BEGIN_TABLE" + + set t1 [time { + regexp -inline -all $re1 $filedata + regexp -inline -all $re2 $filedata + } 10000] + + # t2 should be slower since the re's need to be recompiled every time + set t2 [time { + set re1 END + append re1 _TABLE + regexp -inline -all $re1 $filedata + set re2 BEGIN + append re2 _TABLE + regexp -inline -all $re2 $filedata + } 10000] + + set t1 [lindex $t1 0] + set t2 [lindex $t2 0] + + #puts "t1=$t1, t2=$t2" + + # If these two times are within 20% of each other, caching isn't working + expr {$t2 / $t1 < 1.2 && $t1 / $t2 < 1.2} +} {0} diff --git a/tests/stacktrace.test b/tests/stacktrace.test index f7d131c..328dd49 100644 --- a/tests/stacktrace.test +++ b/tests/stacktrace.test @@ -22,6 +22,47 @@ proc main {} { } $exp } } + proc unknown {args} { + error "from unknown" + } + + test err-10.1 "Stacktrace on error from unknown (badcmd, call)" { + set rc [catch {error_caller badcmd call} msg] + #puts stderr "err-10.1\n[errorInfo $msg]\n" + #puts stderr "\terr-10.1 {[list $rc $msg [info stacktrace]]}" + + list $rc $msg [info stacktrace] + } {1 {from unknown} {{} stacktrace.test 26 {} errors.tcl 6 error_generator errors.tcl 44 error_caller stacktrace.test 30}} + + rename unknown "" + + set a {one} + set b [list 1 \ + 2 \ + 3] + set c {two} + set d "list 1 + 2 + 3" + set e {three} + set f "list 1 \ + 2 \ + 3" + set g {four} + + test source-1.1 "Basic line numbers" { + info source $a + } {stacktrace.test 39} + + test source-1.2 "Line numbers after command with escaped newlines" { + info source $c + } {stacktrace.test 43} + test source-1.3 "Line numbers after string with newlines" { + info source $e + } {stacktrace.test 47} + test source-1.4 "Line numbers after string with escaped newlines" { + info source $g + } {stacktrace.test 51} } set expected { diff --git a/tests/testing.tcl b/tests/testing.tcl index ab25575..18bc8db 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -22,7 +22,7 @@ proc section {name} { puts "-- $name ----------------" } -set testresults {numfail 0 numpass 0 failed {}} +array set testresults {numfail 0 numpass 0 failed {}} proc test {id descr script expected} { puts -nonewline "$id " |