tclobj.c

tcl是工具命令语言

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewBooleanObj(boolValue)
    register int boolValue;	/* Boolean used to initialize new object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;
    
    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclBooleanType;
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewBooleanObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
 *	same as the Tcl_NewBooleanObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command	will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewBooleanObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG

Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
    register int boolValue;	/* Boolean used to initialize new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;
    
    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclBooleanType;
    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
    register int boolValue;	/* Boolean used to initialize new object. */
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
				 * for debugging. */
{
    return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetBooleanObj --
 *
 *	Modify an object to be a boolean object and to have the specified
 *	boolean value. A nonzero "boolValue" is coerced to 1.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's old string rep, if any, is freed. Also, any old
 *	internal rep is freed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetBooleanObj(objPtr, boolValue)
    register Tcl_Obj *objPtr;	/* Object whose internal rep to init. */
    register int boolValue;	/* Boolean used to set object's value. */
{
    register Tcl_ObjType *oldTypePtr = objPtr->typePtr;

    if (Tcl_IsShared(objPtr)) {
	panic("Tcl_SetBooleanObj called with shared object");
    }
    
    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
	oldTypePtr->freeIntRepProc(objPtr);
    }
    
    objPtr->internalRep.longValue = (boolValue? 1 : 0);
    objPtr->typePtr = &tclBooleanType;
    Tcl_InvalidateStringRep(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetBooleanFromObj --
 *
 *	Attempt to return a boolean from the Tcl object "objPtr". If the
 *	object is not already a boolean, an attempt will be made to convert
 *	it to one.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already a boolean, the conversion will free
 *	any old internal representation. 
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get boolean. */
    register int *boolPtr;	/* Place to store resulting boolean. */
{
    register int result;

    if (objPtr->typePtr == &tclBooleanType) {
	result = TCL_OK;
    } else {
	result = SetBooleanFromAny(interp, objPtr);
    }

    if (result == TCL_OK) {
	*boolPtr = (int) objPtr->internalRep.longValue;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SetBooleanFromAny --
 *
 *	Attempt to generate a boolean internal form for the Tcl object
 *	"objPtr".
 *
 * Results:
 *	The return value is a standard Tcl result. If an error occurs during
 *	conversion, an error message is left in the interpreter's result
 *	unless "interp" is NULL.
 *
 * Side effects:
 *	If no error occurs, an integer 1 or 0 is stored as "objPtr"s
 *	internal representation and the type of "objPtr" is set to boolean.
 *
 *----------------------------------------------------------------------
 */

static int
SetBooleanFromAny(interp, objPtr)
    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object to convert. */
{
    Tcl_ObjType *oldTypePtr = objPtr->typePtr;
    char *string, *end;
    register char c;
    char lowerCase[10];
    int newBool, length;
    register int i;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */
    
    string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Use the obvious shortcuts for numerical values; if objPtr is not
     * of numerical type, parse its string rep.
     */
	
    if (objPtr->typePtr == &tclIntType) {
	newBool = (objPtr->internalRep.longValue != 0);
    } else if (objPtr->typePtr == &tclDoubleType) {
	newBool = (objPtr->internalRep.doubleValue != 0.0);
#ifndef TCL_WIDE_INT_IS_LONG
    } else if (objPtr->typePtr == &tclWideIntType) {
	newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0));
#endif /* TCL_WIDE_INT_IS_LONG */
    } else {
	/*
	 * Copy the string converting its characters to lower case.
	 */
	
	for (i = 0;  (i < 9) && (i < length);  i++) {
	    c = string[i];
	    /*
	     * Weed out international characters so we can safely operate
	     * on single bytes.
	     */
	    
	    if (c & 0x80) {
		goto badBoolean;
	    }
	    if (Tcl_UniCharIsUpper(UCHAR(c))) {
		c = (char) Tcl_UniCharToLower(UCHAR(c));
	    }
	    lowerCase[i] = c;
	}
	lowerCase[i] = 0;
	
	/*
	 * Parse the string as a boolean. We use an implementation here that
	 * doesn't report errors in interp if interp is NULL.
	 */
	
	c = lowerCase[0];
	if ((c == '0') && (lowerCase[1] == '\0')) {
	    newBool = 0;
	} else if ((c == '1') && (lowerCase[1] == '\0')) {
	    newBool = 1;
	} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
	    newBool = 1;
	} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
	    newBool = 0;
	} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
	    newBool = 1;
	} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
	    newBool = 0;
	} else if ((c == 'o') && (length >= 2)) {
	    if (strncmp(lowerCase, "on", (size_t) length) == 0) {
		newBool = 1;
	    } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
		newBool = 0;
	    } else {
		goto badBoolean;
	    }
	} else {
	    double dbl;
	    /*
	     * Boolean values can be extracted from ints or doubles.  Note
	     * that we don't use strtoul or strtoull here because we don't
	     * care about what the value is, just whether it is equal to
	     * zero or not.
	     */
#ifdef TCL_WIDE_INT_IS_LONG
	    newBool = strtol(string, &end, 0);
	    if (end != string) {
		/*
		 * Make sure the string has no garbage after the end of
		 * the int.
		 */
		while ((end < (string+length))
		       && isspace(UCHAR(*end))) { /* INTL: ISO only */
		    end++;
		}
		if (end == (string+length)) {
		    newBool = (newBool != 0);
		    goto goodBoolean;
		}
	    }
#else /* !TCL_WIDE_INT_IS_LONG */
	    Tcl_WideInt wide = strtoll(string, &end, 0);
	    if (end != string) {
		/*
		 * Make sure the string has no garbage after the end of
		 * the wide int.
		 */
		while ((end < (string+length))
		       && isspace(UCHAR(*end))) { /* INTL: ISO only */
		    end++;
		}
		if (end == (string+length)) {
		    newBool = (wide != Tcl_LongAsWide(0));
		    goto goodBoolean;
		}
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    /*
	     * Still might be a string containing the characters representing an
	     * int or double that wasn't handled above. This would be a string
	     * like "27" or "1.0" that is non-zero and not "1". Such a string
	     * would result in the boolean value true. We try converting to
	     * double. If that succeeds and the resulting double is non-zero, we
	     * have a "true". Note that numbers can't have embedded NULLs.
	     */
	    
	    dbl = strtod(string, &end);
	    if (end == string) {
		goto badBoolean;
	    }
	    
	    /*
	     * Make sure the string has no garbage after the end of the double.
	     */
	    
	    while ((end < (string+length))
		   && isspace(UCHAR(*end))) { /* INTL: ISO only */
		end++;
	    }
	    if (end != (string+length)) {
		goto badBoolean;
	    }
	    newBool = (dbl != 0.0);
	}
    }

    /*
     * Free the old internalRep before setting the new one. We do this as
     * late as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

    goodBoolean:
    if ((oldTypePtr != NULL) &&	(oldTypePtr->freeIntRepProc != NULL)) {
	oldTypePtr->freeIntRepProc(objPtr);
    }

    objPtr->internalRep.longValue = newBool;
    objPtr->typePtr = &tclBooleanType;
    return TCL_OK;

    badBoolean:
    if (interp != NULL) {
	/*
	 * Must copy string before resetting the result in case a caller
	 * is trying to convert the interpreter's result to a boolean.
	 */
	
	char buf[100];
	sprintf(buf, "expected boolean value but got \"%.50s\"", string);
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfBoolean --
 *
 *	Update the string representation for a boolean object.
 *	Note: This procedure does not free an existing old string rep
 *	so storage will be lost if this has not already been done. 
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The object's string is set to a valid string that results from
 *	the boolean-to-string conversion.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfBoolean(objPtr)
    register Tcl_Obj *objPtr;	/* Int object whose string rep to update. */
{
    char *s = ckalloc((unsigned) 2);
    
    s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
    s[1] = '\0';
    objPtr->bytes = s;
    objPtr->length = 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_NewDoubleObj --
 *
 *	This procedure is normally called when not debugging: i.e., when
 *	TCL_MEM_DEBUG is not defined. It creates a new double object and
 *	initializes it from the argument double value.
 *
 *	When TCL_MEM_DEBUG is defined, this procedure just returns the
 *	result of calling the debugging version Tcl_DbNewDoubleObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an
 *	invalid string representation. The returned object has ref count 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef TCL_MEM_DEBUG
#undef Tcl_NewDoubleObj

Tcl_Obj *
Tcl_NewDoubleObj(dblValue)
    register double dblValue;	/* Double used to initialize the object. */
{
    return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_NewDoubleObj(dblValue)
    register double dblValue;	/* Double used to initialize the object. */
{
    register Tcl_Obj *objPtr;

    TclNewObj(objPtr);
    objPtr->bytes = NULL;
    
    objPtr->internalRep.doubleValue = dblValue;
    objPtr->typePtr = &tclDoubleType;
    return objPtr;
}
#endif /* if TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbNewDoubleObj --
 *
 *	This procedure is normally called when debugging: i.e., when
 *	TCL_MEM_DEBUG is defined. It creates new double objects. It is the
 *	same as the Tcl_NewDoubleObj procedure above except that it calls
 *	Tcl_DbCkalloc directly with the file name and line number from its
 *	caller. This simplifies debugging since then the [memory active]
 *	command	will report the correct file name and line number when
 *	reporting objects that haven't been freed.
 *
 *	When TCL_MEM_DEBUG is not defined, this procedure just returns the
 *	result of calling Tcl_NewDoubleObj.
 *
 * Results:
 *	The newly created object is returned. This object will have an