Tcl Source Code

static int
CheckNamespaceQualifiers(
    Tcl_Interp* interp,		/* Tcl interpreter for error reporting */
    const char* name,		/* Variable name to check */
    int nameLen)		/* Length of the variable */
{
    Tcl_Obj* result;		/* Error message */
    const char* p;

    for (p = name; p+2 < name+nameLen;  p++) {
	if ((*p == ':') && (p[1] == ':')) {
	    result = Tcl_NewStringObj("variable \"", -1);
	    Tcl_AppendToObj(result, name, -1);
	    Tcl_AppendToObj(result, "\" is not local", -1);
	    Tcl_SetObjResult(interp, result);

	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL);
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}


    Tcl_DecrRefCount(cmdNameObj);

    /*
     * Report unknown functions.
     */

    if (cmdPtr == NULL) {
	Tcl_Obj *message;

	TclNewLiteralStringObj(message, "unknown math function \"");
	Tcl_AppendToObj(message, name, -1);
	Tcl_AppendToObj(message, "\"", 1);
	Tcl_SetObjResult(interp, message);

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL);
	*numArgsPtr = -1;
	*argTypesPtr = NULL;
	*procPtr = NULL;
	*clientDataPtr = NULL;
	return TCL_ERROR;
    }

    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int index, i, globFlags, length, join, dir, result;
    char *string;
    const char *separators;
    Tcl_Obj *typePtr, *resultPtr, *look;
    Tcl_Obj *pathOrDir = NULL;
    Tcl_DString prefix;
    static const char *const options[] = {
	"-directory", "-join", "-nocomplain", "-path", "-tails",
	"-types", "--", NULL
    };
    enum options {

		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);

	    } else {
		Tcl_Obj *item;

		if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
			(len == 3)) {
		    Tcl_ListObjIndex(interp, look, 0, &item);
		    if (!strcmp("macintosh", Tcl_GetString(item))) {
			Tcl_ListObjIndex(interp, look, 1, &item);
			if (!strcmp("type", Tcl_GetString(item))) {
			    Tcl_ListObjIndex(interp, look, 2, &item);
			    if (globTypes->macType != NULL) {
				goto badMacTypesArg;

		/*
		 * Error cases. We reset the 'join' flag to zero, since we
		 * haven't yet made use of it.
		 */

	    badTypesArg:
		TclNewObj(resultPtr);
		Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
		Tcl_AppendObjToObj(resultPtr, look);
		Tcl_SetObjResult(interp, resultPtr);


		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;

	    badMacTypesArg:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(

	if (length == 0) {
	    Tcl_AppendResult(interp, "no files matched glob pattern",
		    (join || (objc == 1)) ? " \"" : "s \"", NULL);
	    if (join) {
		Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL);
	    } else {
		const char *sep = "";

		for (i = 0; i < objc; i++) {
		    string = Tcl_GetString(objv[i]);
		    Tcl_AppendResult(interp, sep, string, NULL);
		    sep = " ";
		}
	    }
	    Tcl_AppendResult(interp, "\"", NULL);

{
    Channel *chanPtr;		/* The actual channel. */
    ClientData handle;
    int result;

    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    if (!chanPtr->typePtr->getHandleProc) {
	Tcl_Obj *err;

	TclNewLiteralStringObj(err, "channel \"");
	Tcl_AppendToObj(err, Tcl_GetChannelName(chan), -1);
	Tcl_AppendToObj(err, "\" does not support OS handles", -1);
	Tcl_SetChannelError(chan, err);
	return TCL_ERROR;
    }
    result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction,
	    &handle);
    if (handlePtr) {
	*handlePtr = handle;
    }

     * Verify the result.
     * - List, of method names. Convert to mask.
     *   Check for non-optionals through the mask.
     *   Compare open mode against optional r/w.
     */

    if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
	Tcl_AppendObjToObj(err, resObj);
	Tcl_SetObjResult(interp, err);


	Tcl_DecrRefCount(resObj);
	goto error;
    }

    methods = 0;
    while (listc > 0) {
	if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,

	methods |= FLAG(methIndex);
	listc--;
    }
    Tcl_DecrRefCount(resObj);

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" does not support all required methods", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" lacks a \"read\" method", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" lacks a \"write\" method", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" supports \"cget\" but not \"cgetall\"", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" supports \"cgetall\" but not \"cget\"", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.

    /*
     * Verify the result.
     * - List, of method names. Convert to mask. Check for non-optionals
     *   through the mask. Compare open mode against optional r/w.
     */

    if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
	Tcl_AppendObjToObj(err, resObj);
	Tcl_SetObjResult(interp, err);


	Tcl_DecrRefCount(resObj);
	goto error;
    }

    methods = 0;
    while (listc > 0) {
	if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,

	methods |= FLAG(methIndex);
	listc--;
    }
    Tcl_DecrRefCount(resObj);

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" does not support all required methods", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    /*
     * Mode tell us what the parent channel supports. The methods tell us what
     * the handler supports. We remove the non-supported bits from the mode
     * and check that the channel is not completely inacessible. Afterward the
     * mode tells us which methods are still required, and these methods will
     * also be supported by the handler, by design of the check.
     */

    if (!HAS(methods, METH_READ)) {
	mode &= ~TCL_READABLE;
    }
    if (!HAS(methods, METH_WRITE)) {
	mode &= ~TCL_WRITABLE;
    }

    if (!mode) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" makes the channel inacessible", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    /*
     * The mode and support for it is ok, now check the internal constraints.
     */

    if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
	TclNewLiteralStringObj(err, "chan handler \"");
	Tcl_AppendObjToObj(err, cmdObj);
	Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1);
	Tcl_SetObjResult(interp, err);


	goto error;
    }

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.

		return TCL_OK;
	    }
	    goto tooLarge;
	}
#endif
	if (objPtr->typePtr == &tclDoubleType) {
	    if (interp != NULL) {
		Tcl_Obj *msg;

		TclNewLiteralStringObj(msg, "expected integer but got \"");
		Tcl_AppendObjToObj(msg, objPtr);
		Tcl_AppendToObj(msg, "\"", -1);
		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
	    }
	    return TCL_ERROR;
	}
	if (objPtr->typePtr == &tclBignumType) {
	    /*
	     * Must check for those bignum values that can fit in a long, even

#endif
	if (objPtr->typePtr == &tclIntType) {
	    *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclDoubleType) {
	    if (interp != NULL) {
		Tcl_Obj *msg;

		TclNewLiteralStringObj(msg, "expected integer but got \"");
		Tcl_AppendObjToObj(msg, objPtr);
		Tcl_AppendToObj(msg, "\"", -1);
		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
	    }
	    return TCL_ERROR;
	}
	if (objPtr->typePtr == &tclBignumType) {
	    /*
	     * Must check for those bignum values that can fit in a

	    TclBNInitBignumFromWideInt(bignumValue,
		    objPtr->internalRep.wideValue);
	    return TCL_OK;
	}
#endif
	if (objPtr->typePtr == &tclDoubleType) {
	    if (interp != NULL) {
		Tcl_Obj *msg;

		TclNewLiteralStringObj(msg, "expected integer but got \"");
		Tcl_AppendObjToObj(msg, objPtr);
		Tcl_AppendToObj(msg, "\"", -1);
		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;

static int
SetLambdaFromAny(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr)	/* The object to convert. */
{
    Interp *iPtr = (Interp *) interp;
    const char *name;
    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
    int objc, result;
    Proc *procPtr;

    if (interp == NULL) {
	return TCL_ERROR;
    }

    /*
     * Convert objPtr to list type first; if it cannot be converted, or if its
     * length is not 2, then it cannot be converted to lambdaType.
     */

    result = TclListObjGetElements(NULL, 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];

    /*
     * Format an error message when an invalid number is encountered.
     */

    if (status != TCL_OK) {
	if (interp != NULL) {
	    Tcl_Obj *msg;


	    TclNewLiteralStringObj(msg, "expected ");
	    Tcl_AppendToObj(msg, expected, -1);
	    Tcl_AppendToObj(msg, " but got \"", -1);
	    Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
	    Tcl_AppendToObj(msg, "\"", -1);
	    if (state == BAD_OCTAL) {
		Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1);
	    }
	    Tcl_SetObjResult(interp, msg);
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);

} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write}
test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body {
    proc foo {args} {return {initialize finalize}}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone
    rename foo {}
} -match glob -result {*makes the channel inacessible}
# iortrans-2.15 event/watch methods elimimated, removed these tests.
# iortrans-2.16
test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body {
    proc foo {args} {return {initialize finalize drain write}}
    chan push [tempchan] foo
} -returnCodes error -cleanup {
    tempdone