Tcl Source Code

2011-04-03  Donal K. Fellows  <[email protected]>

	* 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  <[email protected]>

	* generic/tclStrToD.c (QuickConversion): Replaced another couple
	of 'double' declarations with 'volatile double' to work around
	misrounding issues in mingw-gcc 3.4.5.

2011-04-02  Donal K. Fellows  <[email protected]>

	parentPtr = NULL;
	simpleName = "";
    } else if (*name == '\0') {
	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 {
	/*
	 * Find the parent for the new namespace.
	 */

	TclGetNamespaceForQualName(interp, name, NULL,

#else
	    parentPtr->childTablePtr != NULL &&
	    Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
	) {
	    Tcl_AppendResult(interp, "can't create namespace \"", name,
		    "\": already exists", NULL);
            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
                    "CREATEEXISTING", NULL);
	    return NULL;
	}
    }

    /*
     * Create the new namespace and root it in its parent. Increment the count
     * of namespaces created.

{
    do {
	if (objPtr->typePtr == &tclDoubleType) {
	    if (TclIsNaN(objPtr->internalRep.doubleValue)) {
		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;
	    }
	    *dblPtr = (double) objPtr->internalRep.doubleValue;
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclIntType) {

    if (pathPtr->typePtr != NULL) {
	if (pathPtr->bytes == NULL) {
	    if (pathPtr->typePtr->updateStringProc == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "can't find object"
			    "string representation", NULL);
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
			    NULL);
		}
		return TCL_ERROR;
	    }
	    pathPtr->typePtr->updateStringProc(pathPtr);
	}
	TclFreeIntRep(pathPtr);
    }

	    dir = TclGetEnv("HOME", &dirString);
	    if (dir == NULL) {
		if (interp) {
		    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;
	    }
	    Tcl_DStringInit(&temp);
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */

	    Tcl_DStringInit(&temp);
	    if (TclpGetUserHome(name+1, &temp) == NULL) {
		if (interp != NULL) {
		    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) {
		    name[split] = separator;
		}
		return TCL_ERROR;
	    }

	    Tcl_GetChannelError(chan, &msg);
	    if (msg) {
		Tcl_SetObjResult(interp, msg);
	    } else {
		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;
	}
	*releasePtr = 1;
	if (writing) {
	    /*
	     * Be sure to flush output to the file, so that anything written

	*closePtr = 1;
    }
    return file;

  badLastArg:
    Tcl_AppendResult(interp, "can't specify \"", arg,
	    "\" as last word in command", NULL);
    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachPids --

		    Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
			    Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
		    Tcl_AppendResult(interp, "child suspended: ", p, "\n",
			    NULL);
		} else {
		    Tcl_AppendResult(interp,
			    "child wait status didn't make sense\n", NULL);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
			    "ODDWAITRESULT", msg1, NULL);
		}
	    }
	}
    }

    /*
     * Read the standard error file. If there's anything there, then return an

	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		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;
		}
	    }
	    lastBar = i;
	    cmdCount++;
	    needCmd = 1;
	    break;

		inputLiteral = p + 1;
		skip = 1;
		if (*inputLiteral == '\0') {
		    inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
		    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;
		}
	    } else {
		nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
		inputLiteral = NULL;

		 * exec/open output pipe as well. This is meant for the end of
		 * the command string, otherwise use |& between commands.
		 */

		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;
		errorToOutput = 2;
		skip = 1;
	    } else {
		nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];

    if (needCmd) {
	/*
	 * We had a bar followed only by redirections.
	 */

	Tcl_SetResult(interp, "illegal use of | or |& in command",
		TCL_STATIC);
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
		NULL);
	goto error;
    }

    if (inputFile == NULL) {
	if (inputLiteral != NULL) {
	    /*
	     * The input for the first process is immediate data coming from

     * constraints.
     */

    if (flags & TCL_ENFORCE_MODE) {
	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;
	}
    }

    channel = TclpCreateCommandChannel(outPipe, inPipe, errFile,
	    numPids, pidPtr);

    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;

  error:
    if (numPids > 0) {
	Tcl_DetachPids(numPids, pidPtr);

	if (clientData != NULL) {
	    pkgPtr->clientData = clientData;
	}
	return TCL_OK;
    }
    Tcl_AppendResult(interp, "conflicting versions provided for package \"",
	    name, "\": ", pkgPtr->version, ", then ", version, NULL);
    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --

	 * behave when initialization is incomplete.
	 */

	tclEmptyStringRep = &tclEmptyString;
	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;
    }

    /*
     * Translate between old and new API, and defer to the new function.
     */

	 */

	if (pkgPtr->clientData != NULL) {
	    Tcl_AppendResult(interp, "circular package dependency: "
		    "attempt to provide ", name, " ",
		    (char *) pkgPtr->clientData, " requires ", name, NULL);
	    AddRequirementsToResult(interp, reqc, reqv);
	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
	    return NULL;
	}

	/*
	 * The package isn't yet present. Search the list of available
	 * versions and invoke the script for the best available version. We
	 * are actually locating the best, and the best stable version. One of

		    ckfree(availVersion);
		    availVersion = NULL;
		    continue;
		}
	    }

	    /*
	     * We have found a version which is better than our max.
	     */

	    if (reqc > 0) {
		/* Check satisfaction of requirements. */

		satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
		if (!satisfies) {
		    ckfree(availVersion);

		Tcl_ResetResult(interp);
		if (pkgPtr->version == NULL) {
		    code = TCL_ERROR;
		    Tcl_AppendResult(interp, "attempt to provide package ",
			    name, " ", versionToProvide,
			    " failed: no version of package ", name,
			    " provided", NULL);
		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
			    NULL);
		} else {
		    char *pvi, *vi;

		    if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
			    NULL) != TCL_OK) {
			code = TCL_ERROR;
		    } else if (CheckVersionAndConvert(interp,

			if (res != 0) {
			    code = TCL_ERROR;
			    Tcl_AppendResult(interp,
				    "attempt to provide package ", name, " ",
				    versionToProvide, " failed: package ",
				    name, " ", pkgPtr->version,
				    " provided instead", NULL);
			    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
				    "WRONGPROVIDE", NULL);
			}
		    }
		}
	    } else if (code != TCL_ERROR) {
		Tcl_Obj *codePtr = Tcl_NewIntObj(code);

		Tcl_ResetResult(interp);
		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;
	    }

	    if (code == TCL_ERROR) {
		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			"\n    (\"package ifneeded %s %s\" script)",

	    code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
		    Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
	    Tcl_DStringFree(&command);

	    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;
	    }
	    if (code == TCL_ERROR) {
		Tcl_AddErrorInfo(interp,
			"\n    (\"package unknown\" script)");
		return NULL;
	    }
	    Tcl_ResetResult(interp);
	}
    }

    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;
    }

    /*
     * At this point we know that the package is present. Make sure that the
     * provided version meets the current requirements.
     */

    if (reqc != 0) {


	CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);

	ckfree(pkgVersionI);

	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;
	}
    }

    if (clientDataPtr) {
	const void **ptr = (const void **) clientDataPtr;

	*ptr = pkgPtr->clientData;
    }
    return pkgPtr->version;






}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
 *

	return TCL_OK;
    }

  error:
    ckfree(ibuf);
    Tcl_AppendResult(interp, "expected version number but got \"", string,
	    "\"", NULL);
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * CompareVersions --

    if (strchr(dash+1, '-') != NULL) {
	/*
	 * More dashes found after the first. This is wrong.
	 */

	Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
		string, "\"", NULL);
	Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
	return TCL_ERROR;
    }

    /*
     * Exactly one dash is present. Copy the string, split at the location of
     * dash and check that both parts are versions. Note that the max part can
     * be empty. Also note that the string allocated with strdup() must be

    fullName = TclGetString(objv[1]);
    TclGetNamespaceForQualName(interp, fullName, NULL, 0,
	    &nsPtr, &altNsPtr, &cxtNsPtr, &procName);

    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)
	    && (procName != NULL) && (procName[0] == ':')) {
	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;
    }

    /*
     * Create the data structure to represent the procedure.
     */

    if (precompiled) {
	if (numArgs > procPtr->numArgs) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "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;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }

	    goto procError;
	}
	if (fieldCount > 2) {
	    ckfree(fieldValues);
	    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;
	}

	nameLength = strlen(fieldValues[0]);
	if (fieldCount == 2) {
	    valueLength = strlen(fieldValues[1]);
	} else {

		    q++;
		} while (*q != '\0');
		q--;
		if (*q == ')') {	/* We have an array element. */
		    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++;
	}

	if (precompiled) {
	    /*

		    || !(localPtr->flags & VAR_ARGUMENT)
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"procedure \"%s\": formal parameter %d is "
			"inconsistent with precompiled body", procName, i));
		ckfree(fieldValues);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"BYTECODELIES", NULL);
		goto procError;
	    }

	    /*
	     * Compare the default value if any.
	     */

	    if (localPtr->defValuePtr != NULL) {
		int tmpLength;
		const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
			&tmpLength);

		if ((valueLength != tmpLength) ||
			strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "procedure \"%s\": formal parameter \"%s\" has "
			    "default value inconsistent with precompiled body",
			    procName, fieldValues[0]));
		    ckfree(fieldValues);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }
	    if ((i == numArgs - 1)
		    && (localPtr->nameLength == 4)
		    && (localPtr->name[0] == 'a')
		    && (strcmp(localPtr->name, "args") == 0)) {

    *framePtrPtr = framePtr;
    return result;

  levelError:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjGetFrame --

    }
    *framePtrPtr = framePtr;
    return result;

  levelError:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
    Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UplevelObjCmd --

	 * transform to an error now.
	 */

	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "invoked \"",
		((result == TCL_BREAK) ? "break" : "continue"),
		"\" outside of a loop", NULL);
	Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
	result = TCL_ERROR;

	/*
	 * Fall through to the TCL_ERROR handling code.
	 */

    case TCL_ERROR:

	    return TCL_OK;
	}

	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	    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;
	    codePtr->nsPtr = nsPtr;
	} else {
	    bodyPtr->typePtr->freeIntRepProc(bodyPtr);
	    bodyPtr->typePtr = NULL;

    result = TclListObjGetElements(interp, objPtr, &objc, &objv);
    if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
	TclNewLiteralStringObj(errPtr, "can't interpret \"");
	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;
    }

    argsPtr = objv[0];
    bodyPtr = objv[1];

    /*

	codeObjPtr = procPtr->bodyPtr;
	break;
    }
    case DISAS_PROC:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "procName");
	    return TCL_ERROR;
	}

	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;
	}

	/*
	 * 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.
	 */

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "script");

	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
	if (oPtr == NULL) {
	    return TCL_ERROR;
	}
	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,
		(char *) objv[3]);
	goto methodBody;
    case DISAS_OBJECT_METHOD:
	if (objc != 4) {

	 */

    methodBody:
	if (hPtr == NULL) {
	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) {
	    Command cmd;

	    /*
	     * Yes, this is ugly, but we need to pass the namespace in to the

    /*
     * Do the actual disassembly.
     */

    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));
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

	if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) {
	    /*
	     * Value is not a list, which is illegal for -errorstack.
	     */
	    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);
	    goto error;
	}
        if (length % 2) {
            /*
             * 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);
	    goto error;
        }
    }

    /*
     * Convert [return -code return -level X] to [return -code ok -level X+1]
     */

    notXpg:
	gotSequential = 1;
	if (gotXpg) {
	mixedXPG:
	    Tcl_SetResult(interp,
		    "cannot mix \"%\" and \"%n$\" conversion specifiers",
		    TCL_STATIC);
	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
	    goto error;
	}

    xpgCheckDone:
	/*
	 * Parse any width specifier.
	 */

	switch (ch) {
	case 'c':
	    if (flags & SCAN_WIDTH) {
		Tcl_SetResult(interp,
			"field width may not be specified in %c conversion",
			TCL_STATIC);
		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'n':
	case 's':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
	    invalidFieldSize:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp,
			"field size modifier may not be specified in %", buf,
			" conversion", NULL);
		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'd':
	case 'e':
	case 'f':
	case 'g':
	case 'i':
	case 'o':
	case 'x':
	case 'b':
	    break;
	case 'u':
	    if (flags & SCAN_BIG) {
		Tcl_SetResult(interp,
			"unsigned bignum scans are invalid", TCL_STATIC);
		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
		goto error;
	    }
	    break;
	    /*
	     * Bracket terms need special checking
	     */
	case '[':

		}
		format += Tcl_UtfToUniChar(format, &ch);
	    }
	    break;
	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)) {
	    if (objIndex >= nspace) {
		/*
		 * Expand the nassign buffer. If we are using XPG specifiers,
		 * make sure that we grow to a large enough size. xpgSize is

	*totalSubs = numVars;
    }
    for (i = 0; i < numVars; i++) {
	if (nassign[i] > 1) {
	    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)) {
	    /*
	     * If the space is empty, and xpgSize is 0 (means XPG wasn't used,
	     * and/or numVars != 0), then too many vars were given
	     */

	    Tcl_SetResult(interp,
		    "variable is not assigned by any conversion specifiers",
		    TCL_STATIC);
	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
	    goto error;
	}
    }

    TclStackFree(interp, nassign);
    return TCL_OK;

  badIndex:
    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:
    TclStackFree(interp, nassign);
    return TCL_ERROR;
}


	 */

	for (i = 0; i < totalVars; i++) {
	    if (objs[i] == NULL) {
		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);
		code = TCL_ERROR;
	    }
	    Tcl_DecrRefCount(objs[i]);
	}

set path(test5) [makeFile {} test5]

file delete $path(test5)
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} {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} {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} {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}}}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    file delete $path(test1)
    set f [open $path(test1) w]