Tcl Source Code

2011-08-16  Donal K. Fellows  <[email protected]>

	* generic/tclListObj.c (TclLindexList, TclLsetFlat): Silence warnings
	about (unreachable) cases of uninitialized variables.
	* generic/tclCmdIL.c (SelectObjFromSublist): Improve the generation of
	* generic/tclIndexObj.c (Tcl_ParseArgsObjv): messages through the use
	* generic/tclVar.c (ArrayStartSearchCmd):    of Tcl_ObjPrintf.

2011-08-15  Don Porter  <[email protected]>

	* generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value.

2011-08-15  Jan Nijtmans  <[email protected]>

	* generic/tclPosixStr.c:    [Bug 3388350]: mingw64 compiler warnings
	* win/tclWinPort.h:
	* win/configure.in
	* win/configure

2011-08-14  Jan Nijtmans  <[email protected]>

	* doc/FindExec.3: [Patch 3124554]: Move WishPanic from Tk to Tcl
	* doc/Panic.3     Added Documentation

2011-08-12  Don Porter  <[email protected]>

	* generic/tclPathObj.c:	[Bug 3389764]: Eliminate possibility that dup
	of a "path" value can create reference cycle.

2011-08-12  Donal K. Fellows  <[email protected]>

	* generic/tclZlib.c (ZlibTransformOutput): [Bug 3390073]: Return the
	correct length of written data for a compressing transform.

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {

            Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(

                    "element %d missing from sublist \"%s\"",
                    index, TclGetString(objPtr)));

            Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
                    "INDEXFAILED", NULL);
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	objPtr = currentObj;
    }

	/*
	 * Produce a fancy error message.
	 */

	int count;

	TclNewObj(resultPtr);

	Tcl_AppendStringsToObj(resultPtr,
		(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
		msg, " \"", key, NULL);
	if (STRING_AT(tablePtr, offset, 0) == NULL) {
	    Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
	} else {
	    Tcl_AppendStringsToObj(resultPtr, "\": must be ",
		    STRING_AT(tablePtr, offset, 0), NULL);
	    for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
		    *entryPtr != NULL;
		    entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
		if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
		    Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
			    " or ", *entryPtr, NULL);
		} else {
		    Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
		}
	    }
	}
	Tcl_SetObjResult(interp, resultPtr);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------

static int
SetIndexFromAny(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr)	/* The object to convert. */
{
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "can't convert value to index except via Tcl_GetIndexFromObj API",
	    -1));
    }
    return TCL_ERROR;
}

/*

	switch ((enum matchOptions) index) {
	case PRFMATCH_EXACT:
	    flags |= TCL_EXACT;
	    break;
	case PRFMATCH_MESSAGE:
	    if (i > (objc - 4)) {
		Tcl_AppendResult(interp, "missing message", NULL);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    message = Tcl_GetString(objv[i]);
	    break;
	case PRFMATCH_ERROR:
	    if (i > objc-4) {
		Tcl_AppendResult(interp, "missing error options", NULL);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
		return TCL_ERROR;
	    }
	    i++;
	    result = Tcl_ListObjLength(interp, objv[i], &errorLength);
	    if (result != TCL_OK) {
		return TCL_ERROR;
	    }
	    if ((errorLength % 2) != 0) {
		Tcl_AppendResult(interp, "error options must have an even"
			" number of elements", NULL);
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
		return TCL_ERROR;
	    }
	    errorPtr = objv[i];
	    break;
	}
    }

				 * successful exit. Will include the name of
				 * the command. */
    int nrem;			/* Size of leftovers.*/
    register const Tcl_ArgvInfo *infoPtr;
				/* Pointer to the current entry in the table
				 * of argument descriptions. */
    const Tcl_ArgvInfo *matchPtr;
				/* Descriptor that matches current argument */
    Tcl_Obj *curArg;		/* Current argument */
    const char *str = NULL;
    register char c;		/* Second character of current arg (used for
				 * quick check for matching; use 2nd char.
				 * because first char. will almost always be
				 * '-'). */
    int srcIndex;		/* Location from which to read next argument
				 * from objv. */
    int dstIndex;		/* Used to keep track of current arguments
				 * being processed, primarily for error
				 * reporting. */
    int objc;			/* # arguments in objv still to process. */
    int length;			/* Number of characters in current argument */

    if (remObjv != NULL) {
	/*
	 * Then we should copy the name of the command (0th argument).
	 */

	nrem = 1;

	/*
	 * Loop throught the argument descriptors searching for one with the
	 * matching key string. If found, leave a pointer to it in matchPtr.
	 */

	matchPtr = NULL;
	infoPtr = argTable;
	for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) {

	    if (infoPtr->keyStr == NULL) {
		continue;
	    }
	    if ((infoPtr->keyStr[1] != c)
		    || (strncmp(infoPtr->keyStr, str, length) != 0)) {
		continue;
	    }

			Tcl_GetString(objv[srcIndex]), "\"", NULL);
		goto error;
	    }
	    srcIndex++;
	    objc--;
	    break;
	case TCL_ARGV_FUNC: {
	    Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
		    infoPtr->srcPtr;
	    Tcl_Obj *argObj;

	    if (objc == 0) {
		argObj = NULL;
	    } else {
		argObj = objv[srcIndex];
	    }

	    if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
		srcIndex++;
		objc--;
	    }
	    break;
	}
	case TCL_ARGV_GENFUNC: {
	    Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
		    infoPtr->srcPtr;


	    objc = handlerProc(infoPtr->clientData, interp, objc,
		    &objv[srcIndex], infoPtr->dstPtr);
	    if (objc < 0) {
		goto error;
	    }
	    break;
	}
	case TCL_ARGV_HELP:
	    PrintUsage(interp, argTable);
	    goto error;
	default:

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad argument type %d in Tcl_ArgvInfo", infoPtr->type));


	    goto error;

	}
    }

    /*
     * If we broke out of the loop because of an OPT_REST argument, copy the
     * remaining arguments down.
     */

 *----------------------------------------------------------------------
 */

int
TclGetCompletionCodeFromObj(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *value,
    int *code)			/* Argument objects. */
{
    static const char *const returnCodes[] = {
	"ok", "error", "return", "break", "continue", NULL
    };

    if ((value->typePtr != &indexType)
	    && (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
	return TCL_OK;
    }
    if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL,
		TCL_EXACT, code)) {
	return TCL_OK;
    }
    /*
     * Value is not a legal completion code.
     */

    if (interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "bad completion code \"",
		TclGetString(value),
		"\": must be ok, error, return, break, "
		"continue, or an integer", NULL);
	Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
    }
    return TCL_ERROR;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    UpdateStringOfList,		/* updateStringProc */
    SetListFromAny		/* setFromAnyProc */
};

#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif


/*
 *----------------------------------------------------------------------
 *
 * NewListIntRep --
 *
 *	Creates a list internal rep with space for objc elements.  objc

    int objc;
    Tcl_Obj **objv;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
    }

    /*
     * Pull the elements to append from elemListPtr.
     */

    if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
	return TCL_ERROR;
    }

    /*
     * Insert the new elements starting after the lists's last element.
     * Delete zero existing elements.

		    LIST_MAX));
	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
	}
	return TCL_ERROR;
    }

    if (needGrow && !isShared) {
	/*
	 * Need to grow + unshared intrep => try to realloc
	 */

	attempt = 2 * numRequired;
	if (attempt <= LIST_MAX) {
	    newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
	}
	if (newPtr == NULL) {
	    attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
	    if (attempt > LIST_MAX) {

	    needGrow = 0;
	}
    }
    if (isShared || needGrow) {
	Tcl_Obj **dst, **src = &listRepPtr->elements;

	/*
	 * Either we have a shared intrep and we must copy to write, or we
	 * need to grow and realloc attempts failed.  Attempt intrep copy.

	 */

	attempt = 2 * numRequired;
	newPtr = AttemptNewList(NULL, attempt, NULL);
	if (newPtr == NULL) {
	    attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
	    if (attempt > LIST_MAX) {
		attempt = LIST_MAX;
	    }
	    newPtr = AttemptNewList(NULL, attempt, NULL);
	}
	if (newPtr == NULL) {
	    attempt = numRequired;
	    newPtr = AttemptNewList(interp, attempt, NULL);
	}
	if (newPtr == NULL) {
	    /*
	     * All growth attempts failed; throw the error.
	     */

	    return TCL_ERROR;
	}

	dst = &newPtr->elements;
	newPtr->refCount++;
	newPtr->canonicalFlag = listRepPtr->canonicalFlag;
	newPtr->elemCount = listRepPtr->elemCount;

	if (isShared) {
	    /*
	     * The original intrep must remain undisturbed.  Copy into the new
	     * one and bump refcounts
	     */
	    while (numElems--) {
		*dst = *src++;
		Tcl_IncrRefCount(*dst++);
	    }
	    listRepPtr->refCount--;
	} else {
	    /*
	     * Old intrep to be freed, re-use refCounts.

	     */

	    memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
	    ckfree(listRepPtr);
	}
	listRepPtr = newPtr;
    }
    listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;

    /*

    int numElems, numRequired, numAfterLast, start, i, j, isShared;

    if (Tcl_IsShared(listPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
    }
    if (listPtr->typePtr != &tclListType) {
	if (listPtr->bytes == tclEmptyStringRep) {
	    if (!objc) {


		return TCL_OK;
	    }
	    Tcl_SetListObj(listPtr, objc, NULL);
	} else {
	    int result = SetListFromAny(interp, listPtr);

	    if (result != TCL_OK) {
		return result;
	    }
	}

	first = numElems;	/* So we'll insert after last element. */
    }
    if (count < 0) {
	count = 0;
    } else if (numElems < first+count || first+count < 0) {
	/*
	 * The 'first+count < 0' condition here guards agains integer
	 * overflow in determining 'first+count'.
	 */

	count = numElems - first;
    }

    isShared = (listRepPtr->refCount > 1);
    numRequired = numElems - count + objc;

    if ((numRequired <= listRepPtr->maxElemCount) && !isShared) {

TclLindexList(
    Tcl_Interp *interp,		/* Tcl interpreter. */
    Tcl_Obj *listPtr,		/* List being unpacked. */
    Tcl_Obj *argPtr)		/* Index or index list. */
{

    int index;			/* Index into the list. */


    Tcl_Obj *indexListCopy;

    /*
     * Determine whether argPtr designates a list or a single index. We have
     * to be careful about the order of the checks to avoid repeated
     * shimmering; see TIP#22 and TIP#33 for the details.
     */

	 * argPtr designates something that is neither an index nor a
	 * well-formed list. Report the error via TclLindexFlat.
	 */

	return TclLindexFlat(interp, listPtr, 1, &argPtr);
    }

    if (indexListCopy->typePtr == &tclListType) {
	List *listRepPtr = ListRepPtr(indexListCopy);

	listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
		&listRepPtr->elements);
    } else {
	int indexCount = -1;	/* Size of the array of list indices. */
	Tcl_Obj **indices = NULL;
				/* Array of list indices. */

	Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
	listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
    }
    Tcl_DecrRefCount(indexListCopy);
    return listPtr;
}

/*
 *----------------------------------------------------------------------
 *

    /*
     * Anchor the linked list of Tcl_Obj's whose string reps must be
     * invalidated if the operation succeeds.
     */

    retValuePtr = subListPtr;
    chainPtr = NULL;
    result = TCL_OK;

    /*
     * Loop through all the index arguments, and for each one dive into the
     * appropriate sublist.
     */

    do {
	int elemCount;
	Tcl_Obj *parentList, **elemPtrs;

	/*
	 * Check for the possible error conditions...
	 */

	if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
		!= TCL_OK) {
	    /* ...the sublist we're indexing into isn't a list at all. */
	    result = TCL_ERROR;
	    break;
	}

	/*
	 * WARNING: the macro TclGetIntForIndexM is not safe for
	 * post-increments, avoid '*indexArray++' here.
	 */

	if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
		!= TCL_OK)  {
	    /* ...the index we're trying to use isn't an index at all. */
	    result = TCL_ERROR;
	    indexArray++;
	    break;
	}
	indexArray++;

	if (index < 0 || index > elemCount) {
	    /* ...the index points outside the sublist. */
	    if (interp != NULL) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("list index out of range", -1));

		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
			"BADINDEX", NULL);
	    }
	    result = TCL_ERROR;
	    break;
	}

	/*
	 * No error conditions.  As long as we're not yet on the last index,
	 * determine the next sublist for the next pass through the loop, and
	 * take steps to make sure it is an unshared copy, as we intend to
	 * modify it.
	 */


	if (--indexCount) {
	    parentList = subListPtr;
	    if (index == elemCount) {
		subListPtr = Tcl_NewObj();
	    } else {
		subListPtr = elemPtrs[index];
	    }

	if (retValuePtr != listPtr) {
	    Tcl_DecrRefCount(retValuePtr);
	}
	return NULL;
    }

    /*
     * Store valuePtr in proper sublist and return. The -1 is to avoid a
     * compiler warning (not a problem because we checked that we have a
     * proper list - or something convertible to one - above).
     */

    len = -1;
    TclListObjLength(NULL, subListPtr, &len);
    if (index == len) {
	Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
    } else {
	TclListObjSetElement(NULL, subListPtr, index, valuePtr);
    }
    Tcl_InvalidateStringRep(subListPtr);
    Tcl_IncrRefCount(retValuePtr);

    if (listPtr->typePtr != &tclListType) {
	int result;

	if (listPtr->bytes == tclEmptyStringRep) {
	    if (interp != NULL) {
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("list index out of range", -1));

		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
			"BADINDEX", NULL);
	    }
	    return TCL_ERROR;
	}
	result = SetListFromAny(interp, listPtr);
	if (result != TCL_OK) {
	    return result;
	}
    }

	/*
	 * Allocate enough space to hold a (Tcl_Obj *) for each
	 * (possible) list element.
	 */

	estCount = TclMaxListLength(nextElem, length, &limit);
	estCount += (estCount == 0);	/* Smallest list struct holds 1
					 * element. */
	listRepPtr = AttemptNewList(interp, estCount, NULL);
	if (listRepPtr == NULL) {
	    return TCL_ERROR;
	}
	elemPtrs = &listRepPtr->elements;

	/*
	 * Each iteration, parse and store a list element.
	 */

	while (nextElem < limit) {
	    const char *elemStart;
	    int elemSize, literal;

	    if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
		    &elemStart, &nextElem, &elemSize, &literal)) {
		while (--elemPtrs >= &listRepPtr->elements) {
		    Tcl_DecrRefCount(*elemPtrs);
		}
		ckfree((char *) listRepPtr);
		return TCL_ERROR;
	    }

     * Mark the list as being canonical; although it will now have a string
     * rep, it is one we derived through proper "canonical" quoting and so
     * it's known to be free from nasties relating to [concat] and [eval].
     */

    listRepPtr->canonicalFlag = 1;

    /*
     * Handle empty list case first, so rest of the routine is simpler.
     */

    if (numElems == 0) {
	listPtr->bytes = tclEmptyStringRep;
	listPtr->length = 0;
	return;
    }

    /*
     * Pass 1: estimate space, gather flags.
     */

    if (numElems <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else {
	/*
	 * We know numElems <= LIST_MAX, so this is safe.
	 */

	flagPtr = ckalloc(numElems * sizeof(int));
    }
    elemPtrs = &listRepPtr->elements;
    for (i = 0; i < numElems; i++) {
	flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
	elem = TclGetStringFromObj(elemPtrs[i], &length);
	bytesNeeded += TclScanElement(elem, length, flagPtr+i);
	if (bytesNeeded < 0) {
	    Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
	}
    }
    if (bytesNeeded > INT_MAX - numElems + 1) {
	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
    }
    bytesNeeded += numElems;

    /*
     * Pass 2: copy into string rep buffer.
     */

    listPtr->length = bytesNeeded - 1;
    listPtr->bytes = ckalloc(bytesNeeded);
    dst = listPtr->bytes;
    for (i = 0; i < numElems; i++) {
	flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
	elem = TclGetStringFromObj(elemPtrs[i], &length);
	dst += TclConvertElement(elem, length, dst, flagPtr[i]);
	*dst++ = ' ';
    }
    listPtr->bytes[listPtr->length] = '\0';

    if (flagPtr != localFlags) {

     * Make a new array search with a free name.
     */

    searchPtr = ckalloc(sizeof(ArraySearch));
    hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
    if (isNew) {
	searchPtr->id = 1;

	varPtr->flags |= VAR_SEARCH_ACTIVE;
	searchPtr->nextPtr = NULL;
    } else {


	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;


	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
    }
    searchPtr->varPtr = varPtr;
    searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
	    &searchPtr->search);
    Tcl_SetHashValue(hPtr, searchPtr);
    Tcl_SetObjResult(interp,
	    Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ArrayAnyMoreCmd --