Esempio n. 1
0
static int
MenuButtonWidgetObjCmd(
    ClientData clientData,	/* Information about button widget. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    register TkMenuButton *mbPtr = clientData;
    int result, index;
    Tcl_Obj *objPtr;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
        return TCL_ERROR;
    }
    result = Tcl_GetIndexFromObj(interp, objv[1], commandNames, "option", 0,
                                 &index);
    if (result != TCL_OK) {
        return result;
    }
    Tcl_Preserve(mbPtr);

    switch (index) {
    case COMMAND_CGET:
        if (objc != 3) {
            Tcl_WrongNumArgs(interp, 1, objv, "cget option");
            goto error;
        }

        objPtr = Tk_GetOptionValue(interp, (char *) mbPtr,
                                   mbPtr->optionTable, objv[2], mbPtr->tkwin);
        if (objPtr == NULL) {
            goto error;
        }
        Tcl_SetObjResult(interp, objPtr);
        break;

    case COMMAND_CONFIGURE:
        if (objc <= 3) {
            objPtr = Tk_GetOptionInfo(interp, (char *) mbPtr,
                                      mbPtr->optionTable, (objc == 3) ? objv[2] : NULL,
                                      mbPtr->tkwin);
            if (objPtr == NULL) {
                goto error;
            }
            Tcl_SetObjResult(interp, objPtr);
        } else {
            result = ConfigureMenuButton(interp, mbPtr, objc-2, objv+2);
        }
        break;
    }
    Tcl_Release(mbPtr);
    return result;

error:
    Tcl_Release(mbPtr);
    return TCL_ERROR;
}
/* Ttk_TagOptionValue -- implements [$w tag configure $tag -option]
 */
Tcl_Obj *Ttk_TagOptionValue(
    Tcl_Interp *interp,
    Ttk_TagTable tagTable,
    Ttk_Tag tag,
    Tcl_Obj *optionName)
{
    return Tk_GetOptionValue(interp,
	tag->tagRecord, tagTable->optionTable, optionName, tagTable->tkwin);
}
Esempio n. 3
0
int TtkGetOptionValue(
    Tcl_Interp *interp, void *recordPtr, Tcl_Obj *optionName,
    Tk_OptionTable optionTable, Tk_Window tkwin)
{
    Tcl_Obj *result =
	Tk_GetOptionValue(interp,recordPtr,optionTable,optionName,tkwin);
    if (result) {
	Tcl_SetObjResult(interp, result);
	return TCL_OK;
    }
    return TCL_ERROR;
}
Esempio n. 4
0
/* TtkEnumerateOptions, TtkGetOptionValue --
 *	Common factors for data accessor commands.
 */
int TtkEnumerateOptions(
    Tcl_Interp *interp, void *recordPtr, const Tk_OptionSpec *specPtr,
    Tk_OptionTable optionTable, Tk_Window tkwin)
{
    Tcl_Obj *result = Tcl_NewListObj(0,0);
    while (specPtr->type != TK_OPTION_END)
    {
	Tcl_Obj *optionName = Tcl_NewStringObj(specPtr->optionName, -1);
	Tcl_Obj *optionValue =
	    Tk_GetOptionValue(interp,recordPtr,optionTable,optionName,tkwin);
	if (optionValue) {
	    Tcl_ListObjAppendElement(interp, result, optionName);
	    Tcl_ListObjAppendElement(interp, result, optionValue);
	}
	++specPtr;

	if (specPtr->type == TK_OPTION_END && specPtr->clientData != NULL) {
	    /* Chain to next option spec array: */
	    specPtr = specPtr->clientData;
	}
    }
    Tcl_SetObjResult(interp, result);
    return TCL_OK;
}
Esempio n. 5
0
int
TkTextWindowCmd(
    register TkText *textPtr,	/* Information about text widget. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. Someone else has already
				 * parsed this command enough to know that
				 * objv[1] is "window". */
{
    int optionIndex;
    static const char *const windOptionStrings[] = {
	"cget", "configure", "create", "names", NULL
    };
    enum windOptions {
	WIND_CGET, WIND_CONFIGURE, WIND_CREATE, WIND_NAMES
    };
    register TkTextSegment *ewPtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "option ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[2], windOptionStrings,
	    "window option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum windOptions) optionIndex) {
    case WIND_CGET: {
	TkTextIndex index;
	TkTextSegment *ewPtr;
	Tcl_Obj *objPtr;
	TkTextEmbWindowClient *client;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 3, objv, "index option");
	    return TCL_ERROR;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	ewPtr = TkTextIndexToSeg(&index, NULL);
	if (ewPtr->typePtr != &tkTextEmbWindowType) {
	    Tcl_AppendResult(interp, "no embedded window at index \"",
		    Tcl_GetString(objv[3]), "\"", NULL);
	    return TCL_ERROR;
	}

	/*
	 * Copy over client specific value before querying.
	 */

	client = EmbWinGetClient(textPtr, ewPtr);
	if (client != NULL) {
	    ewPtr->body.ew.tkwin = client->tkwin;
	} else {
	    ewPtr->body.ew.tkwin = NULL;
	}

	objPtr = Tk_GetOptionValue(interp, (char *) &ewPtr->body.ew,
		ewPtr->body.ew.optionTable, objv[4], textPtr->tkwin);
	if (objPtr == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, objPtr);
	return TCL_OK;
    }
    case WIND_CONFIGURE: {
	TkTextIndex index;
	TkTextSegment *ewPtr;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
	    return TCL_ERROR;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	ewPtr = TkTextIndexToSeg(&index, NULL);
	if (ewPtr->typePtr != &tkTextEmbWindowType) {
	    Tcl_AppendResult(interp, "no embedded window at index \"",
		    Tcl_GetString(objv[3]), "\"", NULL);
	    return TCL_ERROR;
	}
	if (objc <= 5) {
	    TkTextEmbWindowClient *client;
	    Tcl_Obj *objPtr;

	    /*
	     * Copy over client specific value before querying.
	     */

	    client = EmbWinGetClient(textPtr, ewPtr);
	    if (client != NULL) {
		ewPtr->body.ew.tkwin = client->tkwin;
	    } else {
		ewPtr->body.ew.tkwin = NULL;
	    }

	    objPtr = Tk_GetOptionInfo(interp, (char *) &ewPtr->body.ew,
		    ewPtr->body.ew.optionTable, (objc == 5) ? objv[4] : NULL,
		    textPtr->tkwin);
	    if (objPtr == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, objPtr);
	    return TCL_OK;
	} else {
	    TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);

	    /*
	     * It's probably not true that all window configuration can change
	     * the line height, so we could be more efficient here and only
	     * call this when necessary.
	     */

	    TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
		    index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
	    return EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
	}
    }
    case WIND_CREATE: {
	TkTextIndex index;
	int lineIndex;
	TkTextEmbWindowClient *client;
	int res;

	/*
	 * Add a new window. Find where to put the new window, and mark that
	 * position for redisplay.
	 */

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
	    return TCL_ERROR;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * Don't allow insertions on the last (dummy) line of the text.
	 */

	lineIndex = TkBTreeLinesTo(textPtr, index.linePtr);
	if (lineIndex == TkBTreeNumLines(textPtr->sharedTextPtr->tree,
		textPtr)) {
	    lineIndex--;
	    TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
		    lineIndex, 1000000, &index);
	}

	/*
	 * Create the new window segment and initialize it.
	 */

	ewPtr = (TkTextSegment *) ckalloc(EW_SEG_SIZE);
	ewPtr->typePtr = &tkTextEmbWindowType;
	ewPtr->size = 1;
	ewPtr->body.ew.sharedTextPtr = textPtr->sharedTextPtr;
	ewPtr->body.ew.linePtr = NULL;
	ewPtr->body.ew.tkwin = NULL;
	ewPtr->body.ew.create = NULL;
	ewPtr->body.ew.align = ALIGN_CENTER;
	ewPtr->body.ew.padX = ewPtr->body.ew.padY = 0;
	ewPtr->body.ew.stretch = 0;
	ewPtr->body.ew.optionTable = Tk_CreateOptionTable(interp, optionSpecs);

	client = (TkTextEmbWindowClient *)
		ckalloc(sizeof(TkTextEmbWindowClient));
	client->next = NULL;
	client->textPtr = textPtr;
	client->tkwin = NULL;
	client->chunkCount = 0;
	client->displayed = 0;
	client->parent = ewPtr;
	ewPtr->body.ew.clients = client;

	/*
	 * Link the segment into the text widget, then configure it (delete it
	 * again if the configuration fails).
	 */

	TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);
	TkBTreeLinkSegment(ewPtr, &index);
	res = EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
	client->tkwin = ewPtr->body.ew.tkwin;
	if (res != TCL_OK) {
	    TkTextIndex index2;

	    TkTextIndexForwChars(NULL, &index, 1, &index2, COUNT_INDICES);
	    TkBTreeDeleteIndexRange(textPtr->sharedTextPtr->tree, &index,
		    &index2);
	    return TCL_ERROR;
	}
	TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
		index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
	break;
    }
    case WIND_NAMES: {
	Tcl_HashSearch search;
	Tcl_HashEntry *hPtr;

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 3, objv, NULL);
	    return TCL_ERROR;
	}
	for (hPtr = Tcl_FirstHashEntry(&textPtr->sharedTextPtr->windowTable,
		&search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    Tcl_AppendElement(interp,
		    Tcl_GetHashKey(&textPtr->sharedTextPtr->markTable, hPtr));
	}
	break;
    }
    }
    return TCL_OK;
}
Esempio n. 6
0
static int
ScaleWidgetObjCmd(
    ClientData clientData,	/* Information about scale widget. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    TkScale *scalePtr = clientData;
    Tcl_Obj *objPtr;
    int index, result;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
        return TCL_ERROR;
    }
    result = Tcl_GetIndexFromObj(interp, objv[1], commandNames,
                                 "option", 0, &index);
    if (result != TCL_OK) {
        return result;
    }
    Tcl_Preserve(scalePtr);

    switch (index) {
    case COMMAND_CGET:
        if (objc != 3) {
            Tcl_WrongNumArgs(interp, 1, objv, "cget option");
            goto error;
        }
        objPtr = Tk_GetOptionValue(interp, (char *) scalePtr,
                                   scalePtr->optionTable, objv[2], scalePtr->tkwin);
        if (objPtr == NULL) {
            goto error;
        }
        Tcl_SetObjResult(interp, objPtr);
        break;
    case COMMAND_CONFIGURE:
        if (objc <= 3) {
            objPtr = Tk_GetOptionInfo(interp, (char *) scalePtr,
                                      scalePtr->optionTable,
                                      (objc == 3) ? objv[2] : NULL, scalePtr->tkwin);
            if (objPtr == NULL) {
                goto error;
            }
            Tcl_SetObjResult(interp, objPtr);
        } else {
            result = ConfigureScale(interp, scalePtr, objc-2, objv+2);
        }
        break;
    case COMMAND_COORDS: {
        int x, y;
        double value;
        Tcl_Obj *coords[2];

        if ((objc != 2) && (objc != 3)) {
            Tcl_WrongNumArgs(interp, 1, objv, "coords ?value?");
            goto error;
        }
        if (objc == 3) {
            if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) {
                goto error;
            }
        } else {
            value = scalePtr->value;
        }
        if (scalePtr->orient == ORIENT_VERTICAL) {
            x = scalePtr->vertTroughX + scalePtr->width/2
                + scalePtr->borderWidth;
            y = TkScaleValueToPixel(scalePtr, value);
        } else {
            x = TkScaleValueToPixel(scalePtr, value);
            y = scalePtr->horizTroughY + scalePtr->width/2
                + scalePtr->borderWidth;
        }
        coords[0] = Tcl_NewIntObj(x);
        coords[1] = Tcl_NewIntObj(y);
        Tcl_SetObjResult(interp, Tcl_NewListObj(2, coords));
        break;
    }
    case COMMAND_GET: {
        double value;
        int x, y;

        if ((objc != 2) && (objc != 4)) {
            Tcl_WrongNumArgs(interp, 1, objv, "get ?x y?");
            goto error;
        }
        if (objc == 2) {
            value = scalePtr->value;
        } else {
            if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) ||
                    (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) {
                goto error;
            }
            value = TkScalePixelToValue(scalePtr, x, y);
        }
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(scalePtr->format, value));
        break;
    }
    case COMMAND_IDENTIFY: {
        int x, y;
        const char *zone = "";

        if (objc != 4) {
            Tcl_WrongNumArgs(interp, 1, objv, "identify x y");
            goto error;
        }
        if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK)
                || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) {
            goto error;
        }
        switch (TkpScaleElement(scalePtr, x, y)) {
        case TROUGH1:
            zone = "trough1";
            break;
        case SLIDER:
            zone = "slider";
            break;
        case TROUGH2:
            zone = "trough2";
            break;
        }
        Tcl_SetObjResult(interp, Tcl_NewStringObj(zone, -1));
        break;
    }
    case COMMAND_SET: {
        double value;

        if (objc != 3) {
            Tcl_WrongNumArgs(interp, 1, objv, "set value");
            goto error;
        }
        if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) {
            goto error;
        }
        if (scalePtr->state != STATE_DISABLED) {
            TkScaleSetValue(scalePtr, value, 1, 1);
        }
        break;
    }
    }
    Tcl_Release(scalePtr);
    return result;

error:
    Tcl_Release(scalePtr);
    return TCL_ERROR;
}
Esempio n. 7
0
int
TkTextTagCmd(
    register TkText *textPtr,	/* Information about text widget. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. Someone else has already
				 * parsed this command enough to know that
				 * objv[1] is "tag". */
{
    static const char *const tagOptionStrings[] = {
	"add", "bind", "cget", "configure", "delete", "lower", "names",
	"nextrange", "prevrange", "raise", "ranges", "remove", NULL
    };
    enum tagOptions {
	TAG_ADD, TAG_BIND, TAG_CGET, TAG_CONFIGURE, TAG_DELETE, TAG_LOWER,
	TAG_NAMES, TAG_NEXTRANGE, TAG_PREVRANGE, TAG_RAISE, TAG_RANGES,
	TAG_REMOVE
    };
    int optionIndex, i;
    register TkTextTag *tagPtr;
    TkTextIndex index1, index2;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "option ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObjStruct(interp, objv[2], tagOptionStrings,
	    sizeof(char *), "tag option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum tagOptions)optionIndex) {
    case TAG_ADD:
    case TAG_REMOVE: {
	int addTag;

	if (((enum tagOptions)optionIndex) == TAG_ADD) {
	    addTag = 1;
	} else {
	    addTag = 0;
	}
	if (objc < 5) {
	    Tcl_WrongNumArgs(interp, 3, objv,
		    "tagName index1 ?index2 index1 index2 ...?");
	    return TCL_ERROR;
	}
	tagPtr = TkTextCreateTag(textPtr, Tcl_GetString(objv[3]), NULL);
	if (tagPtr->elide) {
		/*
		* Indices are potentially obsolete after adding or removing
		* elided character ranges, especially indices having "display"
		* or "any" submodifier, therefore increase the epoch.
		*/
		textPtr->sharedTextPtr->stateEpoch++;
	}
	for (i = 4; i < objc; i += 2) {
	    if (TkTextGetObjIndex(interp, textPtr, objv[i],
		    &index1) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (objc > (i+1)) {
		if (TkTextGetObjIndex(interp, textPtr, objv[i+1],
			&index2) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (TkTextIndexCmp(&index1, &index2) >= 0) {
		    return TCL_OK;
		}
	    } else {
		index2 = index1;
		TkTextIndexForwChars(NULL,&index2, 1, &index2, COUNT_INDICES);
	    }

	    if (tagPtr->affectsDisplay) {
		TkTextRedrawTag(textPtr->sharedTextPtr, NULL, &index1, &index2,
			tagPtr, !addTag);
	    } else {
		/*
		 * Still need to trigger enter/leave events on tags that have
		 * changed.
		 */

		TkTextEventuallyRepick(textPtr);
	    }
	    if (TkBTreeTag(&index1, &index2, tagPtr, addTag)) {
		/*
		 * If the tag is "sel", and we actually adjusted something
		 * then grab the selection if we're supposed to export it and
		 * don't already have it.
		 *
		 * Also, invalidate partially-completed selection retrievals.
		 * We only need to check whether the tag is "sel" for this
		 * textPtr (not for other peer widget's "sel" tags) because we
		 * cannot reach this code path with a different widget's "sel"
		 * tag.
		 */

		if (tagPtr == textPtr->selTagPtr) {
		    /*
		     * Send an event that the selection changed. This is
		     * equivalent to:
		     *	   event generate $textWidget <<Selection>>
		     */

		    TkTextSelectionEvent(textPtr);

		    if (addTag && textPtr->exportSelection
			    && !(textPtr->flags & GOT_SELECTION)) {
			Tk_OwnSelection(textPtr->tkwin, XA_PRIMARY,
				TkTextLostSelection, textPtr);
			textPtr->flags |= GOT_SELECTION;
		    }
		    textPtr->abortSelections = 1;
		}
	    }
	}
	break;
    }
    case TAG_BIND:
	if ((objc < 4) || (objc > 6)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName ?sequence? ?command?");
	    return TCL_ERROR;
	}
	tagPtr = TkTextCreateTag(textPtr, Tcl_GetString(objv[3]), NULL);

	/*
	 * Make a binding table if the widget doesn't already have one.
	 */

	if (textPtr->sharedTextPtr->bindingTable == NULL) {
	    textPtr->sharedTextPtr->bindingTable =
		    Tk_CreateBindingTable(interp);
	}

	if (objc == 6) {
	    int append = 0;
	    unsigned long mask;
	    const char *fifth = Tcl_GetString(objv[5]);

	    if (fifth[0] == 0) {
		return Tk_DeleteBinding(interp,
			textPtr->sharedTextPtr->bindingTable,
			(ClientData) tagPtr->name, Tcl_GetString(objv[4]));
	    }
	    if (fifth[0] == '+') {
		fifth++;
		append = 1;
	    }
	    mask = Tk_CreateBinding(interp,
		    textPtr->sharedTextPtr->bindingTable,
		    (ClientData) tagPtr->name, Tcl_GetString(objv[4]), fifth,
		    append);
	    if (mask == 0) {
		return TCL_ERROR;
	    }
	    if (mask & (unsigned) ~(ButtonMotionMask|Button1MotionMask
		    |Button2MotionMask|Button3MotionMask|Button4MotionMask
		    |Button5MotionMask|ButtonPressMask|ButtonReleaseMask
		    |EnterWindowMask|LeaveWindowMask|KeyPressMask
		    |KeyReleaseMask|PointerMotionMask|VirtualEventMask)) {
		Tk_DeleteBinding(interp, textPtr->sharedTextPtr->bindingTable,
			(ClientData) tagPtr->name, Tcl_GetString(objv[4]));
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"requested illegal events; only key, button, motion,"
			" enter, leave, and virtual events may be used", -1));
		Tcl_SetErrorCode(interp, "TK", "TEXT", "TAG_BIND_EVENT",NULL);
		return TCL_ERROR;
	    }
	} else if (objc == 5) {
	    const char *command;

	    command = Tk_GetBinding(interp,
		    textPtr->sharedTextPtr->bindingTable,
		    (ClientData) tagPtr->name, Tcl_GetString(objv[4]));
	    if (command == NULL) {
		const char *string = Tcl_GetString(Tcl_GetObjResult(interp));

		/*
		 * Ignore missing binding errors. This is a special hack that
		 * relies on the error message returned by FindSequence in
		 * tkBind.c.
		 */

		if (string[0] != '\0') {
		    return TCL_ERROR;
		}
		Tcl_ResetResult(interp);
	    } else {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
	    }
	} else {
	    Tk_GetAllBindings(interp, textPtr->sharedTextPtr->bindingTable,
		    (ClientData) tagPtr->name);
	}
	break;
    case TAG_CGET:
	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 1, objv, "tag cget tagName option");
	    return TCL_ERROR;
	} else {
	    Tcl_Obj *objPtr;

	    tagPtr = FindTag(interp, textPtr, objv[3]);
	    if (tagPtr == NULL) {
		return TCL_ERROR;
	    }
	    objPtr = Tk_GetOptionValue(interp, (char *) tagPtr,
		    tagPtr->optionTable, objv[4], textPtr->tkwin);
	    if (objPtr == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, objPtr);
	    return TCL_OK;
	}
	break;
    case TAG_CONFIGURE: {
	int newTag;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 3, objv,
		    "tagName ?-option? ?value? ?-option value ...?");
	    return TCL_ERROR;
	}
	tagPtr = TkTextCreateTag(textPtr, Tcl_GetString(objv[3]), &newTag);
	if (objc <= 5) {
	    Tcl_Obj *objPtr = Tk_GetOptionInfo(interp, (char *) tagPtr,
		    tagPtr->optionTable,
		    (objc == 5) ? objv[4] : NULL, textPtr->tkwin);

	    if (objPtr == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, objPtr);
	    return TCL_OK;
	} else {
	    int result = TCL_OK;

	    if (Tk_SetOptions(interp, (char *) tagPtr, tagPtr->optionTable,
		    objc-4, objv+4, textPtr->tkwin, NULL, NULL) != TCL_OK) {
		return TCL_ERROR;
	    }

	    /*
	     * Some of the configuration options, like -underline and
	     * -justify, require additional translation (this is needed
	     * because we need to distinguish a particular value of an option
	     * from "unspecified").
	     */

	    if (tagPtr->borderWidth < 0) {
		tagPtr->borderWidth = 0;
	    }
	    if (tagPtr->reliefString != NULL) {
		if (Tk_GetRelief(interp, tagPtr->reliefString,
			&tagPtr->relief) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->justifyString != NULL) {
		if (Tk_GetJustify(interp, tagPtr->justifyString,
			&tagPtr->justify) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->lMargin1String != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin,
			tagPtr->lMargin1String, &tagPtr->lMargin1) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->lMargin2String != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin,
			tagPtr->lMargin2String, &tagPtr->lMargin2) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->offsetString != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin, tagPtr->offsetString,
			&tagPtr->offset) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->overstrikeString != NULL) {
		if (Tcl_GetBoolean(interp, tagPtr->overstrikeString,
			&tagPtr->overstrike) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->rMarginString != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin,
			tagPtr->rMarginString, &tagPtr->rMargin) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->spacing1String != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin,
			tagPtr->spacing1String, &tagPtr->spacing1) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tagPtr->spacing1 < 0) {
		    tagPtr->spacing1 = 0;
		}
	    }
	    if (tagPtr->spacing2String != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin,
			tagPtr->spacing2String, &tagPtr->spacing2) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tagPtr->spacing2 < 0) {
		    tagPtr->spacing2 = 0;
		}
	    }
	    if (tagPtr->spacing3String != NULL) {
		if (Tk_GetPixels(interp, textPtr->tkwin,
			tagPtr->spacing3String, &tagPtr->spacing3) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (tagPtr->spacing3 < 0) {
		    tagPtr->spacing3 = 0;
		}
	    }
	    if (tagPtr->tabArrayPtr != NULL) {
		ckfree(tagPtr->tabArrayPtr);
		tagPtr->tabArrayPtr = NULL;
	    }
	    if (tagPtr->tabStringPtr != NULL) {
		tagPtr->tabArrayPtr =
			TkTextGetTabs(interp, textPtr, tagPtr->tabStringPtr);
		if (tagPtr->tabArrayPtr == NULL) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->underlineString != NULL) {
		if (Tcl_GetBoolean(interp, tagPtr->underlineString,
			&tagPtr->underline) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    if (tagPtr->elideString != NULL) {
		if (Tcl_GetBoolean(interp, tagPtr->elideString,
			&tagPtr->elide) != TCL_OK) {
		    return TCL_ERROR;
		}

		/*
		 * Indices are potentially obsolete after changing -elide,
		 * especially those computed with "display" or "any"
		 * submodifier, therefore increase the epoch.
		 */

		textPtr->sharedTextPtr->stateEpoch++;
	    }

	    /*
	     * If the "sel" tag was changed, be sure to mirror information
	     * from the tag back into the text widget record. NOTE: we don't
	     * have to free up information in the widget record before
	     * overwriting it, because it was mirrored in the tag and hence
	     * freed when the tag field was overwritten.
	     */

	    if (tagPtr == textPtr->selTagPtr) {
		textPtr->selBorder = tagPtr->border;
		textPtr->selBorderWidth = tagPtr->borderWidth;
		textPtr->selBorderWidthPtr = tagPtr->borderWidthPtr;
		textPtr->selFgColorPtr = tagPtr->fgColor;
	    }

	    tagPtr->affectsDisplay = 0;
	    tagPtr->affectsDisplayGeometry = 0;
	    if ((tagPtr->elideString != NULL)
		    || (tagPtr->tkfont != None)
		    || (tagPtr->justifyString != NULL)
		    || (tagPtr->lMargin1String != NULL)
		    || (tagPtr->lMargin2String != NULL)
		    || (tagPtr->offsetString != NULL)
		    || (tagPtr->rMarginString != NULL)
		    || (tagPtr->spacing1String != NULL)
		    || (tagPtr->spacing2String != NULL)
		    || (tagPtr->spacing3String != NULL)
		    || (tagPtr->tabStringPtr != NULL)
		    || (tagPtr->tabStyle != TK_TEXT_TABSTYLE_NONE)
		    || (tagPtr->wrapMode != TEXT_WRAPMODE_NULL)) {
		tagPtr->affectsDisplay = 1;
		tagPtr->affectsDisplayGeometry = 1;
	    }
	    if ((tagPtr->border != NULL)
		    || (tagPtr->reliefString != NULL)
		    || (tagPtr->bgStipple != None)
		    || (tagPtr->fgColor != NULL)
		    || (tagPtr->fgStipple != None)
		    || (tagPtr->overstrikeString != NULL)
		    || (tagPtr->underlineString != NULL)) {
		tagPtr->affectsDisplay = 1;
	    }
	    if (!newTag) {
		/*
		 * This line is not necessary if this is a new tag, since it
		 * can't possibly have been applied to anything yet.
		 */

		/*
		 * VMD: If this is the 'sel' tag, then we don't need to call
		 * this for all peers, unless we actually want to synchronize
		 * sel-style changes across the peers.
		 */

		TkTextRedrawTag(textPtr->sharedTextPtr, NULL,
			NULL, NULL, tagPtr, 1);
	    }
	    return result;
	}
	break;
    }
    case TAG_DELETE: {
	Tcl_HashEntry *hPtr;

	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName ?tagName ...?");
	    return TCL_ERROR;
	}
	for (i = 3; i < objc; i++) {
	    hPtr = Tcl_FindHashEntry(&textPtr->sharedTextPtr->tagTable,
		    Tcl_GetString(objv[i]));
	    if (hPtr == NULL) {
		/*
		 * Either this tag doesn't exist or it's the 'sel' tag (which
		 * is not in the hash table). Either way we don't want to
		 * delete it.
		 */

		continue;
	    }
	    tagPtr = Tcl_GetHashValue(hPtr);
	    if (tagPtr == textPtr->selTagPtr) {
		continue;
	    }
	    if (tagPtr->affectsDisplay) {
		TkTextRedrawTag(textPtr->sharedTextPtr, NULL,
			NULL, NULL, tagPtr, 1);
	    }
	    TkTextDeleteTag(textPtr, tagPtr);
	    Tcl_DeleteHashEntry(hPtr);
	}
	break;
    }
    case TAG_LOWER: {
	TkTextTag *tagPtr2;
	int prio;

	if ((objc != 4) && (objc != 5)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName ?belowThis?");
	    return TCL_ERROR;
	}
	tagPtr = FindTag(interp, textPtr, objv[3]);
	if (tagPtr == NULL) {
	    return TCL_ERROR;
	}
	if (objc == 5) {
	    tagPtr2 = FindTag(interp, textPtr, objv[4]);
	    if (tagPtr2 == NULL) {
		return TCL_ERROR;
	    }
	    if (tagPtr->priority < tagPtr2->priority) {
		prio = tagPtr2->priority - 1;
	    } else {
		prio = tagPtr2->priority;
	    }
	} else {
	    prio = 0;
	}
	ChangeTagPriority(textPtr, tagPtr, prio);

	/*
	 * If this is the 'sel' tag, then we don't actually need to call this
	 * for all peers.
	 */

	TkTextRedrawTag(textPtr->sharedTextPtr, NULL, NULL, NULL, tagPtr, 1);
	break;
    }
    case TAG_NAMES: {
	TkTextTag **arrayPtr;
	int arraySize;
	Tcl_Obj *listObj;

	if ((objc != 3) && (objc != 4)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "?index?");
	    return TCL_ERROR;
	}
	if (objc == 3) {
	    Tcl_HashSearch search;
	    Tcl_HashEntry *hPtr;

	    arrayPtr = ckalloc(textPtr->sharedTextPtr->numTags
		    * sizeof(TkTextTag *));
	    for (i=0, hPtr = Tcl_FirstHashEntry(
		    &textPtr->sharedTextPtr->tagTable, &search);
		    hPtr != NULL; i++, hPtr = Tcl_NextHashEntry(&search)) {
		arrayPtr[i] = Tcl_GetHashValue(hPtr);
	    }

	    /*
	     * The 'sel' tag is not in the hash table.
	     */

	    arrayPtr[i] = textPtr->selTagPtr;
	    arraySize = ++i;
	} else {
	    if (TkTextGetObjIndex(interp, textPtr, objv[3],
		    &index1) != TCL_OK) {
		return TCL_ERROR;
	    }
	    arrayPtr = TkBTreeGetTags(&index1, textPtr, &arraySize);
	    if (arrayPtr == NULL) {
		return TCL_OK;
	    }
	}

	SortTags(arraySize, arrayPtr);
	listObj = Tcl_NewListObj(0, NULL);

	for (i = 0; i < arraySize; i++) {
	    tagPtr = arrayPtr[i];
	    Tcl_ListObjAppendElement(interp, listObj,
		    Tcl_NewStringObj(tagPtr->name,-1));
	}
	Tcl_SetObjResult(interp, listObj);
	ckfree(arrayPtr);
	break;
    }
    case TAG_NEXTRANGE: {
	TkTextIndex last;
	TkTextSearch tSearch;
	char position[TK_POS_CHARS];
	Tcl_Obj *resultObj;

	if ((objc != 5) && (objc != 6)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName index1 ?index2?");
	    return TCL_ERROR;
	}
	tagPtr = FindTag(NULL, textPtr, objv[3]);
	if (tagPtr == NULL) {
	    return TCL_OK;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[4], &index1) != TCL_OK) {
	    return TCL_ERROR;
	}
	TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
		TkBTreeNumLines(textPtr->sharedTextPtr->tree, textPtr),
		0, &last);
	if (objc == 5) {
	    index2 = last;
	} else if (TkTextGetObjIndex(interp, textPtr, objv[5],
		&index2) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * The search below is a bit tricky. Rather than use the B-tree
	 * facilities to stop the search at index2, let it search up until the
	 * end of the file but check for a position past index2 ourselves.
	 * The reason for doing it this way is that we only care whether the
	 * *start* of the range is before index2; once we find the start, we
	 * don't want TkBTreeNextTag to abort the search because the end of
	 * the range is after index2.
	 */

	TkBTreeStartSearch(&index1, &last, tagPtr, &tSearch);
	if (TkBTreeCharTagged(&index1, tagPtr)) {
	    TkTextSegment *segPtr;
	    int offset;

	    /*
	     * The first character is tagged. See if there is an on-toggle
	     * just before the character. If not, then skip to the end of this
	     * tagged range.
	     */

	    for (segPtr = index1.linePtr->segPtr, offset = index1.byteIndex;
		    offset >= 0;
		    offset -= segPtr->size, segPtr = segPtr->nextPtr) {
		if ((offset == 0) && (segPtr->typePtr == &tkTextToggleOnType)
			&& (segPtr->body.toggle.tagPtr == tagPtr)) {
		    goto gotStart;
		}
	    }
	    if (!TkBTreeNextTag(&tSearch)) {
		return TCL_OK;
	    }
	}

	/*
	 * Find the start of the tagged range.
	 */

	if (!TkBTreeNextTag(&tSearch)) {
	    return TCL_OK;
	}

    gotStart:
	if (TkTextIndexCmp(&tSearch.curIndex, &index2) >= 0) {
	    return TCL_OK;
	}
	resultObj = Tcl_NewObj();
	TkTextPrintIndex(textPtr, &tSearch.curIndex, position);
	Tcl_ListObjAppendElement(NULL, resultObj,
		Tcl_NewStringObj(position, -1));
	TkBTreeNextTag(&tSearch);
	TkTextPrintIndex(textPtr, &tSearch.curIndex, position);
	Tcl_ListObjAppendElement(NULL, resultObj,
		Tcl_NewStringObj(position, -1));
	Tcl_SetObjResult(interp, resultObj);
	break;
    }
    case TAG_PREVRANGE: {
	TkTextIndex last;
	TkTextSearch tSearch;
	char position1[TK_POS_CHARS];
	char position2[TK_POS_CHARS];
	Tcl_Obj *resultObj;

	if ((objc != 5) && (objc != 6)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName index1 ?index2?");
	    return TCL_ERROR;
	}
	tagPtr = FindTag(NULL, textPtr, objv[3]);
	if (tagPtr == NULL) {
	    return TCL_OK;
	}
	if (TkTextGetObjIndex(interp, textPtr, objv[4], &index1) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (objc == 5) {
	    TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr, 0, 0,
		    &index2);
	} else if (TkTextGetObjIndex(interp, textPtr, objv[5],
		&index2) != TCL_OK) {
	    return TCL_ERROR;
	}

	/*
	 * The search below is a bit weird. The previous toggle can be either
	 * an on or off toggle. If it is an on toggle, then we need to turn
	 * around and search forward for the end toggle. Otherwise we keep
	 * searching backwards.
	 */

	TkBTreeStartSearchBack(&index1, &index2, tagPtr, &tSearch);

	if (!TkBTreePrevTag(&tSearch)) {
	    /*
	     * Special case, there may be a tag off toggle at index1, and a
	     * tag on toggle before the start of a partial peer widget. In
	     * this case we missed it.
	     */

	    if (textPtr->start != NULL && (textPtr->start == index2.linePtr)
		    && (index2.byteIndex == 0)
		    && TkBTreeCharTagged(&index2, tagPtr)
		    && (TkTextIndexCmp(&index2, &index1) < 0)) {
		/*
		 * The first character is tagged, so just add the range from
		 * the first char to the start of the range.
		 */

		TkTextPrintIndex(textPtr, &index2, position1);
		TkTextPrintIndex(textPtr, &index1, position2);
		goto gotPrevIndexPair;
	    }
	    return TCL_OK;
	}

	if (tSearch.segPtr->typePtr == &tkTextToggleOnType) {
	    TkTextPrintIndex(textPtr, &tSearch.curIndex, position1);
	    if (textPtr->start != NULL) {
		/*
		 * Make sure the first index is not before the first allowed
		 * text index in this widget.
		 */

		TkTextIndex firstIndex;

		firstIndex.linePtr = textPtr->start;
		firstIndex.byteIndex = 0;
		firstIndex.textPtr = NULL;
		if (TkTextIndexCmp(&tSearch.curIndex, &firstIndex) < 0) {
		    if (TkTextIndexCmp(&firstIndex, &index1) >= 0) {
			/*
			 * But now the new first index is actually too far
			 * along in the text, so nothing is returned.
			 */

			return TCL_OK;
		    }
		    TkTextPrintIndex(textPtr, &firstIndex, position1);
		}
	    }
	    TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
		    TkBTreeNumLines(textPtr->sharedTextPtr->tree, textPtr),
		    0, &last);
	    TkBTreeStartSearch(&tSearch.curIndex, &last, tagPtr, &tSearch);
	    TkBTreeNextTag(&tSearch);
	    TkTextPrintIndex(textPtr, &tSearch.curIndex, position2);
	} else {
	    TkTextPrintIndex(textPtr, &tSearch.curIndex, position2);
	    TkBTreePrevTag(&tSearch);
	    TkTextPrintIndex(textPtr, &tSearch.curIndex, position1);
	    if (TkTextIndexCmp(&tSearch.curIndex, &index2) < 0) {
		if (textPtr->start != NULL && index2.linePtr == textPtr->start
			&& index2.byteIndex == 0) {
		    /* It's ok */
		    TkTextPrintIndex(textPtr, &index2, position1);
		} else {
		    return TCL_OK;
		}
	    }
	}

    gotPrevIndexPair:
	resultObj = Tcl_NewObj();
	Tcl_ListObjAppendElement(NULL, resultObj,
		Tcl_NewStringObj(position1, -1));
	Tcl_ListObjAppendElement(NULL, resultObj,
		Tcl_NewStringObj(position2, -1));
	Tcl_SetObjResult(interp, resultObj);
	break;
    }
    case TAG_RAISE: {
	TkTextTag *tagPtr2;
	int prio;

	if ((objc != 4) && (objc != 5)) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName ?aboveThis?");
	    return TCL_ERROR;
	}
	tagPtr = FindTag(interp, textPtr, objv[3]);
	if (tagPtr == NULL) {
	    return TCL_ERROR;
	}
	if (objc == 5) {
	    tagPtr2 = FindTag(interp, textPtr, objv[4]);
	    if (tagPtr2 == NULL) {
		return TCL_ERROR;
	    }
	    if (tagPtr->priority <= tagPtr2->priority) {
		prio = tagPtr2->priority;
	    } else {
		prio = tagPtr2->priority + 1;
	    }
	} else {
	    prio = textPtr->sharedTextPtr->numTags-1;
	}
	ChangeTagPriority(textPtr, tagPtr, prio);

	/*
	 * If this is the 'sel' tag, then we don't actually need to call this
	 * for all peers.
	 */

	TkTextRedrawTag(textPtr->sharedTextPtr, NULL, NULL, NULL, tagPtr, 1);
	break;
    }
    case TAG_RANGES: {
	TkTextIndex first, last;
	TkTextSearch tSearch;
	Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
	int count = 0;

	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 3, objv, "tagName");
	    return TCL_ERROR;
	}
	tagPtr = FindTag(NULL, textPtr, objv[3]);
	if (tagPtr == NULL) {
	    return TCL_OK;
	}
	TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr, 0, 0,
		&first);
	TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
		TkBTreeNumLines(textPtr->sharedTextPtr->tree, textPtr),
		0, &last);
	TkBTreeStartSearch(&first, &last, tagPtr, &tSearch);
	if (TkBTreeCharTagged(&first, tagPtr)) {
	    Tcl_ListObjAppendElement(NULL, listObj,
		    TkTextNewIndexObj(textPtr, &first));
	    count++;
	}
	while (TkBTreeNextTag(&tSearch)) {
	    Tcl_ListObjAppendElement(NULL, listObj,
		    TkTextNewIndexObj(textPtr, &tSearch.curIndex));
	    count++;
	}
	if (count % 2 == 1) {
	    /*
	     * If a text widget uses '-end', it won't necessarily run to the
	     * end of the B-tree, and therefore the tag range might not be
	     * closed. In this case we add the end of the range.
	     */

	    Tcl_ListObjAppendElement(NULL, listObj,
		    TkTextNewIndexObj(textPtr, &last));
	}
	Tcl_SetObjResult(interp, listObj);
	break;
    }
    }
    return TCL_OK;
}
Esempio n. 8
0
File: tkBusy.c Progetto: das/tk
int
Tk_BusyObjCmd(
    ClientData clientData,	/* Main window associated with interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tk_Window tkwin = clientData;
    Tcl_HashTable *busyTablePtr = &((TkWindow *) tkwin)->mainPtr->busyTable;
    Busy *busyPtr;
    Tcl_Obj *objPtr;
    int index, result = TCL_OK;
    static const char *const optionStrings[] = {
        "cget", "configure", "current", "forget", "hold", "status", NULL
    };
    enum options {
        BUSY_CGET, BUSY_CONFIGURE, BUSY_CURRENT, BUSY_FORGET, BUSY_HOLD,
        BUSY_STATUS
    };

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "options ?arg arg ...?");
        return TCL_ERROR;
    }

    /*
     * [tk busy <window>] command shortcut.
     */

    if (Tcl_GetString(objv[1])[0] == '.') {
        if (objc%2 == 1) {
            Tcl_WrongNumArgs(interp, 1, objv, "window ?option value ...?");
            return TCL_ERROR;
        }
        return HoldBusy(busyTablePtr, interp, objv[1], objc-2, objv+2);
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
                            &index) != TCL_OK) {
        return TCL_ERROR;
    }
    switch ((enum options) index) {
    case BUSY_CGET:
        if (objc != 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "window option");
            return TCL_ERROR;
        }
        busyPtr = GetBusy(interp, busyTablePtr, objv[2]);
        if (busyPtr == NULL) {
            return TCL_ERROR;
        }
        Tcl_Preserve(busyPtr);
        objPtr = Tk_GetOptionValue(interp, (char *) busyPtr,
                                   busyPtr->optionTable, objv[3], busyPtr->tkBusy);
        if (objPtr == NULL) {
            result = TCL_ERROR;
        } else {
            Tcl_SetObjResult(interp, objPtr);
        }
        Tcl_Release(busyPtr);
        return result;

    case BUSY_CONFIGURE:
        if (objc < 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "window ?option? ?value ...?");
            return TCL_ERROR;
        }
        busyPtr = GetBusy(interp, busyTablePtr, objv[2]);
        if (busyPtr == NULL) {
            return TCL_ERROR;
        }
        Tcl_Preserve(busyPtr);
        if (objc <= 4) {
            objPtr = Tk_GetOptionInfo(interp, (char *) busyPtr,
                                      busyPtr->optionTable, (objc == 4) ? objv[3] : NULL,
                                      busyPtr->tkBusy);
            if (objPtr == NULL) {
                result = TCL_ERROR;
            } else {
                Tcl_SetObjResult(interp, objPtr);
            }
        } else {
            result = ConfigureBusy(interp, busyPtr, objc-3, objv+3);
        }
        Tcl_Release(busyPtr);
        return result;

    case BUSY_CURRENT: {
        Tcl_HashEntry *hPtr;
        Tcl_HashSearch cursor;
        const char *pattern = (objc == 3 ? Tcl_GetString(objv[2]) : NULL);

        objPtr = Tcl_NewObj();
        for (hPtr = Tcl_FirstHashEntry(busyTablePtr, &cursor); hPtr != NULL;
                hPtr = Tcl_NextHashEntry(&cursor)) {
            busyPtr = Tcl_GetHashValue(hPtr);
            if (pattern == NULL ||
                    Tcl_StringMatch(Tk_PathName(busyPtr->tkRef), pattern)) {
                Tcl_ListObjAppendElement(interp, objPtr,
                                         TkNewWindowObj(busyPtr->tkRef));
            }
        }
        Tcl_SetObjResult(interp, objPtr);
        return TCL_OK;
    }

    case BUSY_FORGET:
        if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "window");
            return TCL_ERROR;
        }
        busyPtr = GetBusy(interp, busyTablePtr, objv[2]);
        if (busyPtr == NULL) {
            return TCL_ERROR;
        }
        TkpHideBusyWindow(busyPtr);
        Tcl_EventuallyFree(busyPtr, DestroyBusy);
        return TCL_OK;

    case BUSY_HOLD:
        if (objc < 3 || objc%2 != 1) {
            Tcl_WrongNumArgs(interp, 2, objv, "window ?option value ...?");
            return TCL_ERROR;
        }
        return HoldBusy(busyTablePtr, interp, objv[2], objc-3, objv+3);

    case BUSY_STATUS:
        if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "window");
            return TCL_ERROR;
        }
        Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
                             GetBusy(interp, busyTablePtr, objv[2]) != NULL));
        return TCL_OK;
    }

    Tcl_Panic("unhandled option: %d", index);
    return TCL_ERROR;		/* Unreachable */
}