C++ Tcl_Release函数代码示例

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

static void
DeleteImage(
    ImageMaster *masterPtr)	/* Pointer to main data structure for image. */
{
    Image *imagePtr;
    Tk_ImageType *typePtr;

    typePtr = masterPtr->typePtr;
    masterPtr->typePtr = NULL;
    if (typePtr != NULL) {
	for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
		imagePtr = imagePtr->nextPtr) {
	    typePtr->freeProc(imagePtr->instanceData, imagePtr->display);
	    imagePtr->changeProc(imagePtr->widgetClientData, 0, 0,
		    masterPtr->width, masterPtr->height, masterPtr->width,
		    masterPtr->height);
	}
	typePtr->deleteProc(masterPtr->masterData);
    }
    if (masterPtr->instancePtr == NULL) {
	if (masterPtr->hPtr != NULL) {
	    Tcl_DeleteHashEntry(masterPtr->hPtr);
	}
	Tcl_Release(masterPtr->winPtr);
	ckfree(masterPtr);
    } else {
	masterPtr->deleted = 1;
    }
}

static void plustot_env_evalfile(t_plustot_env *x, t_symbol *fname)
{
    char buf1[MAXPDSTRING], buf2[MAXPDSTRING], *nameptr, *dir;
    int fd;
    dir = canvas_getdir(x->x_glist)->s_name;
    if ((fd = open_via_path(dir, fname->s_name, "",
			    buf1, &nameptr, MAXPDSTRING, 0)) < 0)
    {
	loud_error((t_pd *)x, "file '%s' not found", fname->s_name);
    }
    else
    {
	Tcl_Interp *interp = plustin_getinterp(x->x_tin);
	FILE *fp;
    	close(fd);
	strcpy(buf2, buf1);
	strcat(buf2, "/");
	strcat(buf2, nameptr);
	sys_bashfilename(buf2, buf2);
	Tcl_Preserve(interp);
	if (Tcl_EvalFile(interp, buf2) != TCL_OK)
	{
	    strcpy(buf1, "evaluation failed (");
	    strncat(buf1, buf2, MAXPDSTRING - strlen(buf1) - 2);
	    strcat(buf1, ")");
	    plusloud_tclerror((t_pd *)x, interp, buf1);
	}
	Tcl_Release(interp);
    }
}

static int
InterpreterObjCmd(
    ClientData clientData,	/* */
    Tcl_Interp *interp,		/* Current interpreter */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* Argument objects */
{
    int index, result = TCL_OK;
    static const char *const options[] = {"eval", "record", NULL};
    enum option {OTHER_EVAL, OTHER_RECORD};
    ConsoleInfo *info = clientData;
    Tcl_Interp *otherInterp = info->interp;

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

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

    if ((otherInterp == NULL) || Tcl_InterpDeleted(otherInterp)) {
	Tcl_AppendResult(interp, "no active master interp", NULL);
	return TCL_ERROR;
    }

    Tcl_Preserve(otherInterp);
    switch ((enum option) index) {
    case OTHER_EVAL:
   	result = Tcl_GlobalEvalObj(otherInterp, objv[2]);

	/*
	 * TODO: Should exceptions be filtered here?
	 */

	Tcl_SetReturnOptions(interp,
		Tcl_GetReturnOptions(otherInterp, result));
	Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
	break;
    case OTHER_RECORD:
   	Tcl_RecordAndEvalObj(otherInterp, objv[2], TCL_EVAL_GLOBAL);

	/*
	 * By not setting result, we discard any exceptions or errors here and
	 * always return TCL_OK. All the caller wants is the interp result to
	 * display, whether that's result or error message.
	 */

	Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
	break;
    }
    Tcl_Release(otherInterp);
    return result;
}

static void
IvyDirectMsgCB(IvyClientPtr	app,
	       void		*user_data,
	       int		id,
	       char		*msg)
{
  filter_struct	*filter = (filter_struct *) user_data;
  int		result, size;
  char		*script_to_call;
  char		int_buffer[INTEGER_SPACE];

  sprintf(int_buffer, "%d", id);
  
  size = strlen(filter->script) + 1;
  size += strlen(int_buffer) + 1;
  size += strlen(msg) + 1;
  
  script_to_call = ckalloc(size);
  strcpy(script_to_call, filter->script);
  strcat(script_to_call, " ");
  strcat(script_to_call, int_buffer);
  strcat(script_to_call, " \"");
  strcat(script_to_call, msg);
  strcat(script_to_call, "\"");
  
  Tcl_Preserve(filter->interp);
  result = Tcl_GlobalEval(filter->interp, script_to_call);
  ckfree(script_to_call);
  
  if (result != TCL_OK) {
    Tcl_BackgroundError(filter->interp);
  }
  Tcl_Release(filter->interp);
}

static void
CmdDeleteProc(
    ClientData clientData)
{
    RegisteredInterp *riPtr = (RegisteredInterp *)clientData;

    /*
     * Lock the package structure in memory.
     */

    Tcl_Preserve(clientData);

    /*
     * Revoke the ROT registration.
     */

    RevokeObjectRegistration(riPtr);

    /*
     * Release the registration object.
     */

    riPtr->obj->lpVtbl->Release(riPtr->obj);
    riPtr->obj = NULL;

    Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri");

    /*
     * Unlock the package data structure.
     */

    Tcl_Release(clientData);

    ckfree(clientData);
}

static void
IvyDieCB(IvyClientPtr	app,
	 void		*user_data, /* script a appeler */
	 int		id)
{
  filter_struct	*filter = (filter_struct *) user_data;
  int		result, size;
  char		idstr[INTEGER_SPACE];
  char		*script_to_call;

  sprintf(idstr, "%d", id);
  size = strlen(filter->script) + INTEGER_SPACE + 1;
  script_to_call = ckalloc(size);
  strcpy(script_to_call, filter->script);
  strcat(script_to_call, " \"");
  strcat(script_to_call, idstr);
  strcat(script_to_call, "\"");
  
  Tcl_Preserve(filter->interp);
  result = Tcl_GlobalEval(filter->interp, script_to_call);
  ckfree(script_to_call);

  if (result != TCL_OK) {
    Tcl_BackgroundError(filter->interp);
  }
  Tcl_Release(filter->interp);
}

void
TkWmProtocolEventProc(
    TkWindow *winPtr,		/* Window to which the event was sent. */
    XEvent *eventPtr)		/* X event. */
{
    WmInfo *wmPtr;
    ProtocolHandler *protPtr;
    Tcl_Interp *interp;
    Atom protocol;
    int result;

    wmPtr = winPtr->wmInfoPtr;
    if (wmPtr == NULL) {
	return;
    }
    protocol = (Atom) eventPtr->xclient.data.l[0];
    for (protPtr = wmPtr->protPtr; protPtr != NULL;
	    protPtr = protPtr->nextPtr) {
	if (protocol == protPtr->protocol) {
	    Tcl_Preserve(protPtr);
	    interp = protPtr->interp;
	    Tcl_Preserve(interp);
	    result = Tcl_EvalEx(interp, protPtr->command, -1, TCL_EVAL_GLOBAL);
	    if (result != TCL_OK) {
		Tcl_AddErrorInfo(interp, "\n    (command for \"");
		Tcl_AddErrorInfo(interp,
			Tk_GetAtomName((Tk_Window) winPtr, protocol));
		Tcl_AddErrorInfo(interp, "\" window manager protocol)");
		Tcl_BackgroundError(interp);
	    }
	    Tcl_Release(interp);
	    Tcl_Release(protPtr);
	    return;
	}
    }

    /*
     * No handler was present for this protocol. If this is a WM_DELETE_WINDOW
     * message then just destroy the window.
     */

    if (protocol == Tk_InternAtom((Tk_Window) winPtr, "WM_DELETE_WINDOW")) {
	Tk_DestroyWindow((Tk_Window) winPtr);
    }
}

static void
IvyAppCB(IvyClientPtr	app,
	 void		*user_data, /* script a appeler */
	 IvyApplicationEvent event)
{
  static const char	*app_event_str[] = {
    "Connected", "Disconnected" };
  filter_struct	*filter = (filter_struct *) user_data;
  int		result, size, dummy;
  char		*script_to_call;
  Tcl_HashEntry	*entry;
  
  entry = Tcl_FindHashEntry(&app_table, IvyGetApplicationName(app));
  if (event == IvyApplicationConnected) {
    if (!entry) {
      entry = Tcl_CreateHashEntry(&app_table, IvyGetApplicationName(app), &dummy);
      Tcl_SetHashValue(entry, (ClientData) app);
    }
  }

  size = strlen(filter->script) + INTEGER_SPACE;
  if (entry) {
    size += strlen(IvyGetApplicationName(app)) + 3;
  }
  else {
    size += 4;
  }
  script_to_call = ckalloc(size);
  strcpy(script_to_call, filter->script);
  strcat(script_to_call, " ");
  if (entry) {
	strcat(script_to_call, " \"");
    strcat(script_to_call, IvyGetApplicationName(app));
	strcat(script_to_call, "\"");
  }
  else {
    strcat(script_to_call, "???");
  }
  strcat(script_to_call, " \"");
  strcat(script_to_call, app_event_str[event%2]);
  strcat(script_to_call, "\"");
  
  Tcl_Preserve(filter->interp);
  result = Tcl_GlobalEval(filter->interp, script_to_call);
  ckfree(script_to_call);

  if (result != TCL_OK) {
    Tcl_BackgroundError(filter->interp);
  }
  Tcl_Release(filter->interp);

  if (event == IvyApplicationDisconnected) {
    if (entry) {
      Tcl_DeleteHashEntry(entry);
    }
  }
}

static int
PreprocessMenu(
    TkMenu *menuPtr)
{
    int index, result, finished;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
                                 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

    Tcl_Preserve((ClientData) menuPtr);

    /*
     * First, let's process the post command on ourselves. If this command
     * destroys this menu, or if there was an error, we are done.
     */

    result = TkPostCommand(menuPtr);
    if ((result != TCL_OK) || (menuPtr->tkwin == NULL)) {
        goto done;
    }

    /*
     * Now, we go through structure and process all of the commands. Since the
     * structure is changing, we stop after we do one command, and start over.
     * When we get through without doing any, we are done.
     */

    do {
        finished = 1;
        for (index = 0; index < menuPtr->numEntries; index++) {
            register TkMenuEntry *entryPtr = menuPtr->entries[index];

            if ((entryPtr->type == CASCADE_ENTRY)
                    && (entryPtr->namePtr != NULL)
                    && (entryPtr->childMenuRefPtr != NULL)
                    && (entryPtr->childMenuRefPtr->menuPtr != NULL)) {
                TkMenu *cascadeMenuPtr = entryPtr->childMenuRefPtr->menuPtr;

                if (cascadeMenuPtr->postCommandGeneration !=
                        tsdPtr->postCommandGeneration) {
                    cascadeMenuPtr->postCommandGeneration =
                        tsdPtr->postCommandGeneration;
                    result = PreprocessMenu(cascadeMenuPtr);
                    if (result != TCL_OK) {
                        goto done;
                    }
                    finished = 0;
                    break;
                }
            }
        }
    } while (!finished);

done:
    Tcl_Release((ClientData) menuPtr);
    return result;
}

static int
ThreadEventProc(
    Tcl_Event *evPtr,		/* Really ThreadEvent */
    int mask)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
    ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
    Tcl_Interp *interp = tsdPtr->interp;
    int code;
    const char *result, *errorCode, *errorInfo;

    if (interp == NULL) {
	code = TCL_ERROR;
	result = "no target interp!";
	errorCode = "THREAD";
	errorInfo = "";
    } else {
	Tcl_Preserve((ClientData) interp);
	Tcl_ResetResult(interp);
	Tcl_CreateThreadExitHandler(ThreadFreeProc,
		(ClientData) threadEventPtr->script);
	code = Tcl_GlobalEval(interp, threadEventPtr->script);
	Tcl_DeleteThreadExitHandler(ThreadFreeProc,
		(ClientData) threadEventPtr->script);
	if (code != TCL_OK) {
	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
	} else {
	    errorCode = errorInfo = NULL;
	}
	result = Tcl_GetStringResult(interp);
    }
    ckfree(threadEventPtr->script);
    if (resultPtr) {
	Tcl_MutexLock(&threadMutex);
	resultPtr->code = code;
	resultPtr->result = ckalloc(strlen(result) + 1);
	strcpy(resultPtr->result, result);
	if (errorCode != NULL) {
	    resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
	    strcpy(resultPtr->errorCode, errorCode);
	}
	if (errorInfo != NULL) {
	    resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
	    strcpy(resultPtr->errorInfo, errorInfo);
	}
	Tcl_ConditionNotify(&resultPtr->done);
	Tcl_MutexUnlock(&threadMutex);
    }
    if (interp != NULL) {
	Tcl_Release((ClientData) interp);
    }
    return 1;
}

static void
FreeMainInterp(
    ClientData clientData)
{
    Tcl_Interp *interp = clientData;

    /*if (TclInExit()) return;*/

    if (!Tcl_InterpDeleted(interp)) {
	Tcl_DeleteInterp(interp);
    }
    Tcl_SetStartupScript(NULL, NULL);
    Tcl_Release(interp);
}

static int ThreadEventProc(Tcl_Event *event, int mask)
{
    int code;
    ThreadEvent *data = (ThreadEvent *)event;                                                    /* event is really a ThreadEvent */

    Tcl_Preserve(data->interpreter);
    code = Tcl_EvalEx(data->interpreter, data->script, -1, TCL_EVAL_GLOBAL);
    Tcl_Free(data->script);
    if (code != TCL_OK) {
        ThreadErrorProc(data->interpreter);
    }
    Tcl_Release(data->interpreter);
    return 1;
}

void EM_DeleteInterp(Tcl_Interp *interp) {

#if WITH_DEBUGGING_INIT
    ErrorLogger( NO_ERR_START, LOC, _proc_EM_DeleteInterp, NULL);
#endif

    /*
     * avoid freeing storage when in use, now release
     */
    Tcl_Release(interp);

    Tcl_DeleteInterp(interp);

} /** End of 'EM_DeleteInterp' **/

void
TkClipCleanup(
    TkDisplay *dispPtr)		/* Display associated with clipboard */
{
    if (dispPtr->clipWindow != NULL) {
	Tk_DeleteSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom,
		dispPtr->applicationAtom);
	Tk_DeleteSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom,
		dispPtr->windowAtom);

	Tk_DestroyWindow(dispPtr->clipWindow);
	Tcl_Release((ClientData) dispPtr->clipWindow);
	dispPtr->clipWindow = NULL;
    }
}