From 2205a28b9e00ec29977d2b21e2f2bda3b77aaaf4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 3 Apr 2011 06:05:13 +0000 Subject: More generation of error codes (namespace creation, path normalization, pipeline creation, package handling, procedures, [scan] formats) --- ChangeLog | 8 +++++++ generic/tclNamesp.c | 4 ++++ generic/tclObj.c | 2 ++ generic/tclPathObj.c | 6 +++++ generic/tclPipe.c | 18 ++++++++++++++ generic/tclPkg.c | 44 +++++++++++++++++++++++----------- generic/tclProc.c | 68 ++++++++++++++++++++++++++++++++++++++-------------- generic/tclResult.c | 15 +++++++----- generic/tclScan.c | 11 +++++++++ tests/ioCmd.test | 6 ++--- 10 files changed, 141 insertions(+), 41 deletions(-) diff --git a/ChangeLog b/ChangeLog index 23b3f1e..b734896 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2011-04-03 Donal K. Fellows + + * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: + * generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c: + * generic/tclScan.c: More generation of error codes (namespace + creation, path normalization, pipeline creation, package handling, + procedures, [scan] formats) + 2011-04-02 Kevin B. Kenny * generic/tclStrToD.c (QuickConversion): Replaced another couple diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3a08221..45b9f6d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -690,6 +690,8 @@ Tcl_CreateNamespace( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -725,6 +727,8 @@ Tcl_CreateNamespace( ) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index 321ed67..630226f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2265,6 +2265,8 @@ Tcl_GetDoubleFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + NULL); } return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 81007a2..01a297b 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1523,6 +1523,8 @@ TclFSMakePathFromNormalized( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object" "string representation", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", + NULL); } return TCL_ERROR; } @@ -2423,6 +2425,8 @@ SetFsPathFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment " "variable to expand path", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); } return TCL_ERROR; } @@ -2440,6 +2444,8 @@ SetFsPathFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", name+1, "\" doesn't exist", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); } Tcl_DStringFree(&temp); if (split != len) { diff --git a/generic/tclPipe.c b/generic/tclPipe.c index c24d136..5f59c38 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -109,6 +109,8 @@ FileForRedirect( Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), "\" wasn't opened for ", ((writing) ? "writing" : "reading"), NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADCHAN", NULL); } return NULL; } @@ -151,6 +153,7 @@ FileForRedirect( badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } @@ -342,6 +345,8 @@ TclCleanupChildren( } else { Tcl_AppendResult(interp, "child wait status didn't make sense\n", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "ODDWAITRESULT", msg1, NULL); } } } @@ -539,6 +544,8 @@ TclCreatePipeline( if ((i == (lastBar + 1)) || (i == (argc - 1))) { Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } } @@ -565,6 +572,8 @@ TclCreatePipeline( if (inputLiteral == NULL) { Tcl_AppendResult(interp, "can't specify \"", argv[i], "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } skip = 2; @@ -673,6 +682,8 @@ TclCreatePipeline( if (i != argc-1) { Tcl_AppendResult(interp, "must specify \"", argv[i], "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } errorFile = outputFile; @@ -713,6 +724,8 @@ TclCreatePipeline( Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", + NULL); goto error; } @@ -1063,11 +1076,15 @@ Tcl_OpenCommandChannel( if ((flags & TCL_STDOUT) && (outPipe == NULL)) { Tcl_AppendResult(interp, "can't read output from command:" " standard output was redirected", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { Tcl_AppendResult(interp, "can't write input to command:" " standard input was redirected", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } } @@ -1078,6 +1095,7 @@ Tcl_OpenCommandChannel( if (channel == NULL) { Tcl_AppendResult(interp, "pipe for command could not be created", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } return channel; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 53be4af..67503cb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -156,6 +156,7 @@ Tcl_PkgProvideEx( } Tcl_AppendResult(interp, "conflicting versions provided for package \"", name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -286,6 +287,7 @@ Tcl_PkgRequireEx( Tcl_AppendResult(interp, "Cannot load package \"", name, "\" in standalone executable: This package is not " "compiled with stub support", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -376,6 +378,7 @@ PkgRequireCore( "attempt to provide ", name, " ", (char *) pkgPtr->clientData, " requires ", name, NULL); AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; } @@ -422,7 +425,9 @@ PkgRequireCore( } } - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ if (reqc > 0) { /* Check satisfaction of requirements. */ @@ -493,6 +498,8 @@ PkgRequireCore( name, " ", versionToProvide, " failed: no version of package ", name, " provided", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); } else { char *pvi, *vi; @@ -515,6 +522,8 @@ PkgRequireCore( versionToProvide, " failed: package ", name, " ", pkgPtr->version, " provided instead", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); } } } @@ -525,6 +534,7 @@ PkgRequireCore( Tcl_AppendResult(interp, "attempt to provide package ", name, " ", versionToProvide, " failed: bad return code: ", TclGetString(codePtr), NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; } @@ -582,9 +592,11 @@ PkgRequireCore( if ((code != TCL_OK) && (code != TCL_ERROR)) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad return code: ", TclGetString(codePtr), NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } @@ -599,6 +611,7 @@ PkgRequireCore( if (pkgPtr->version == NULL) { Tcl_AppendResult(interp, "can't find package ", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; } @@ -608,27 +621,28 @@ PkgRequireCore( * provided version meets the current requirements. */ - if (reqc == 0) { - satisfies = 1; - } else { + if (reqc != 0) { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); - } - if (satisfies) { - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + if (!satisfies) { + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; } - return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; + + *ptr = pkgPtr->clientData; + } + return pkgPtr->version; } /* @@ -1328,6 +1342,7 @@ CheckVersionAndConvert( ckfree(ibuf); Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1590,6 +1605,7 @@ CheckRequirement( Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 6cd5bb2..9f4ba29 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -154,11 +154,13 @@ Tcl_ProcObjCmd( if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": unknown namespace", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": bad procedure name", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) @@ -166,6 +168,7 @@ Tcl_ProcObjCmd( Tcl_AppendResult(interp, "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -490,6 +493,8 @@ TclCreateProc( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -516,11 +521,15 @@ TclCreateProc( Tcl_AppendResult(interp, "too many fields in argument specifier \"", argArray[i], "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree(fieldValues); Tcl_AppendResult(interp, "argument with no name", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } @@ -547,12 +556,16 @@ TclCreateProc( Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is an array element", NULL); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is not a simple name", NULL); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; @@ -580,6 +593,8 @@ TclCreateProc( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } @@ -599,6 +614,8 @@ TclCreateProc( "default value inconsistent with precompiled body", procName, fieldValues[0])); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } } @@ -752,6 +769,7 @@ TclGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -884,7 +902,7 @@ TclObjGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -1863,6 +1881,7 @@ InterpProcNR2( Tcl_AppendResult(interp, "invoked \"", ((result == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; /* @@ -1980,6 +1999,8 @@ TclProcCompileProc( if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_AppendResult(interp, "a precompiled script jumped interps", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2468,6 +2489,7 @@ SetLambdaFromAny( Tcl_AppendObjToObj(errPtr, objPtr); Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); Tcl_SetObjResult(interp, errPtr); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } @@ -2893,26 +2915,28 @@ Tcl_DisassembleObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; - } else { - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); - return TCL_ERROR; - } + } - /* - * Compile (if uncompiled) and disassemble a procedure. - */ + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; case DISAS_SCRIPT: /* * Compile and disassemble a script. @@ -2947,6 +2971,8 @@ Tcl_DisassembleObjCmd( if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), "\" is not a class", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, @@ -2980,12 +3006,16 @@ Tcl_DisassembleObjCmd( unknownMethod: Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[3]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_AppendResult(interp, "body not available for this kind of method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { @@ -3019,6 +3049,8 @@ Tcl_DisassembleObjCmd( if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); diff --git a/generic/tclResult.c b/generic/tclResult.c index fad3b82..6a71ee2 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1487,9 +1487,10 @@ TclMergeReturnOptions( */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); + "expected a list but got \"", TclGetString(valuePtr), + "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", + NULL); goto error; } if (length % 2) { @@ -1497,9 +1498,11 @@ TclMergeReturnOptions( * Errorstack must always be an even-sized list */ Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); + Tcl_AppendResult(interp, + "forbidden odd-sized list for -errorstack: \"", + TclGetString(valuePtr), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", + "ODDSIZEDLIST_ERRORSTACK", NULL); goto error; } } diff --git a/generic/tclScan.c b/generic/tclScan.c index c862be4..68b8d21 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -331,6 +331,7 @@ ValidateFormat( Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); goto error; } @@ -377,6 +378,7 @@ ValidateFormat( Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } /* @@ -390,6 +392,7 @@ ValidateFormat( Tcl_AppendResult(interp, "field size modifier may not be specified in %", buf, " conversion", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); goto error; } /* @@ -408,6 +411,7 @@ ValidateFormat( if (flags & SCAN_BIG) { Tcl_SetResult(interp, "unsigned bignum scans are invalid", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); goto error; } break; @@ -444,11 +448,13 @@ ValidateFormat( badSet: Tcl_SetResult(interp, "unmatched [ in format string", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad scan conversion character \"", buf, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -495,6 +501,7 @@ ValidateFormat( Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* @@ -505,6 +512,7 @@ ValidateFormat( Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } } @@ -516,10 +524,12 @@ ValidateFormat( if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); } else { Tcl_SetResult(interp, "different numbers of variable names and field specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } error: @@ -991,6 +1001,7 @@ Tcl_ScanObjCmd( continue; } result++; +#warning Why make your own error message? Why? if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", TclGetString(objv[i+3]), "\"", NULL); diff --git a/tests/ioCmd.test b/tests/ioCmd.test index c83d174..82f83db 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -386,13 +386,13 @@ test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode -} {1 {can't write input to command: standard input was redirected} NONE} +} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.4 {I/O to command pipelines} unixOrPc { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} -- cgit v0.12