C++ Tcl_DStringFree函数代码示例

SEXP dotTclcallback(SEXP args)
{
    SEXP ans, callback = CADR(args), env;
    char buff[BUFFLEN];
    char *s;
    Tcl_DString s_ds;

    if (isFunction(callback))
        callback_closure(buff, BUFFLEN, callback);
    else if (isLanguage(callback)) {
        env = CADDR(args);
        callback_lang(buff, BUFFLEN, callback, env);
    }
    else
    	error(_("argument is not of correct type"));

    Tcl_DStringInit(&s_ds);
    s = Tcl_UtfToExternalDString(NULL, buff, -1, &s_ds);
    ans = mkString(s);
    Tcl_DStringFree(&s_ds);
    return ans;
}

static int
TestchmodCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    int i, mode;
    char *rest;

    if (argc < 2) {
    usage:
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" mode file ?file ...?", NULL);
	return TCL_ERROR;
    }

    mode = (int) strtol(argv[1], &rest, 8);
    if ((rest == argv[1]) || (*rest != '\0')) {
	goto usage;
    }

    for (i = 2; i < argc; i++) {
	Tcl_DString buffer;
	const char *translated;

	translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
	if (translated == NULL) {
	    return TCL_ERROR;
	}
	if (TestplatformChmod(translated, mode) != 0) {
	    Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
		    NULL);
	    return TCL_ERROR;
	}
	Tcl_DStringFree(&buffer);
    }
    return TCL_OK;
}

char *
TclpGetUserHome(
    CONST char *name,		/* User name for desired home directory. */
    Tcl_DString *bufferPtr)	/* Uninitialized or free DString filled with
				 * name of user's home directory. */
{
    struct passwd *pwPtr;
    Tcl_DString ds;
    CONST char *native;

    native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
    pwPtr = getpwnam(native);				/* INTL: Native. */
    Tcl_DStringFree(&ds);

    if (pwPtr == NULL) {
	endpwent();
	return NULL;
    }
    Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
    endpwent();
    return Tcl_DStringValue(bufferPtr);
}

TWAPI_EXTERN WCHAR *ObjToWinChars(Tcl_Obj *objP)
{

    WinChars *rep;
    Tcl_DString ds;
    int nbytes, len;
    char *utf8;
    
    if (objP->typePtr == &gWinCharsType)
        return WinCharsGet(objP)->chars;

    utf8 = ObjToStringN(objP, &nbytes);
    Tcl_WinUtfToTChar(utf8, nbytes, &ds);
    len = Tcl_DStringLength(&ds) / sizeof(WCHAR);
    rep = WinCharsNew((WCHAR *) Tcl_DStringValue(&ds), len);
    Tcl_DStringFree(&ds);
    
    /* Convert the passed object's internal rep */
    if (objP->typePtr && objP->typePtr->freeIntRepProc)
        objP->typePtr->freeIntRepProc(objP);
    WinCharsSet(objP, rep);
    return rep->chars;
}

int ScriptTcl::Tcl_replicaEval(ClientData, Tcl_Interp *interp, int argc, char **argv) {
  if ( argc != 3 ) {
    Tcl_SetResult(interp,"args: dest script",TCL_VOLATILE);
    return TCL_ERROR;
  }
  int dest = atoi(argv[1]);
  CHECK_REPLICA(dest);
#if CMK_HAS_PARTITION
  Tcl_DString recvstr;
  Tcl_DStringInit(&recvstr);
  DataMessage *recvMsg = NULL;
  replica_eval(argv[2], dest, CkMyPe(), &recvMsg);
  CmiAssert(recvMsg != NULL);
  int code = recvMsg->code;
  Tcl_DStringAppend(&recvstr, recvMsg->data, recvMsg->size);
  Tcl_DStringResult(interp, &recvstr);
  Tcl_DStringFree(&recvstr);
  CmiFree(recvMsg);
  return code;
#else
  return Tcl_EvalEx(interp,argv[2],-1,TCL_EVAL_GLOBAL);
#endif
}

static int
GetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    CONST char *fileName,	/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    DWORD result;
    Tcl_DString ds;
    TCHAR *nativeName;

    nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
    result = (*tclWinProcs->getFileAttributesProc)(nativeName);
    Tcl_DStringFree(&ds);

    if (result == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]);
    return TCL_OK;
}

/*-----------------------------------------------------------------------------
 * EvalTrapCode --
 *     Run code as the result of a signal.  The symbolic signal name is
 * formatted into the command replacing %S with the symbolic signal name.
 *
 * Parameters:
 *   o interp - The interpreter to run the signal in. If an error
 *     occures, then the result will be left in the interp.
 *   o signalNum - The signal number of the signal that occured.
 * Return:
 *   TCL_OK or TCL_ERROR.
 *-----------------------------------------------------------------------------
 */
static int
EvalTrapCode (Tcl_Interp *interp, int signalNum)
{
    int          result;
    Tcl_DString  command;
    Tcl_Obj     *saveObjPtr;

    saveObjPtr = TclX_SaveResultErrorInfo (interp);
    Tcl_ResetResult (interp);

    /*
     * Format the signal name into the command.  This also allows the signal
     * to be reset in the command.
     */

    result = FormatTrapCode (interp,
                             signalNum,
                             &command);
    if (result == TCL_OK)
        result = Tcl_GlobalEval (interp, 
                                 command.string);

    Tcl_DStringFree (&command);

    if (result == TCL_ERROR) {
        char errorInfo [128];

        sprintf (errorInfo, "\n    while executing signal trap code for %s%s",
                 Tcl_SignalId (signalNum), " signal");
        Tcl_AddErrorInfo (interp, errorInfo);

        return TCL_ERROR;
    }
    
    TclX_RestoreResultErrorInfo (interp, saveObjPtr);
    return TCL_OK;
}

/********************************************************************************************
 * test_File
 * purpose : This function replaces the "file" command of the TCL, to ensure that
 *           when checking if a file exists, we also look inside our buffers.
 * input   : clientData - used for creating new command in tcl
 *           interp - interpreter for tcl commands
 *           argc - number of parameters entered to the new command
 *           argv - the parameters entered to the tcl command
 * output  : none
 * return  : TCL_OK
 ********************************************************************************************/
int test_File(ClientData clientData, Tcl_Interp *interp,int argc, char *argv[])
{
    int i, retCode;
    Tcl_DString str;

    if ((argc == 3) && (strncmp(argv[1], "exis", 4)) == 0)
    {
        /* "file exist" command - overloaded... */
        if (tclGetFile(argv[2]) != NULL)
        {
            Tcl_SetResult(interp, (char *)"1", TCL_STATIC);
            return TCL_OK;
        }
    }

    /* Continue executing the real "file" command */
    Tcl_DStringInit(&str);
    Tcl_DStringAppendElement(&str, "fileOverloaded");
    for(i = 1; i < argc; i++)
        Tcl_DStringAppendElement(&str, argv[i]);
    retCode = Tcl_Eval(interp, Tcl_DStringValue(&str));
    Tcl_DStringFree(&str);
    return retCode;
}

static void dns_tcl_iporhostres(sockname_t *ip, char *hostn, int ok, void *other)
{
  devent_tclinfo_t *tclinfo = (devent_tclinfo_t *) other;
  Tcl_DString list;

  Tcl_DStringInit(&list);
  Tcl_DStringAppendElement(&list, tclinfo->proc);
  Tcl_DStringAppendElement(&list, iptostr(&ip->addr.sa));
  Tcl_DStringAppendElement(&list, hostn);
  Tcl_DStringAppendElement(&list, ok ? "1" : "0");

  if (tclinfo->paras) {
    EGG_CONST char *argv[2];
    char *output;

    argv[0] = Tcl_DStringValue(&list);
    argv[1] = tclinfo->paras;
    output = Tcl_Concat(2, argv);

    if (Tcl_Eval(interp, output) == TCL_ERROR) {
      putlog(LOG_MISC, "*", DCC_TCLERROR, tclinfo->proc, tcl_resultstring());
      Tcl_BackgroundError(interp);
    }
    Tcl_Free(output);
  } else if (Tcl_Eval(interp, Tcl_DStringValue(&list)) == TCL_ERROR) {
    putlog(LOG_MISC, "*", DCC_TCLERROR, tclinfo->proc, tcl_resultstring());
    Tcl_BackgroundError(interp);
  }

  Tcl_DStringFree(&list);

  nfree(tclinfo->proc);
  if (tclinfo->paras)
    nfree(tclinfo->paras);
  nfree(tclinfo);
}

/*
** This is a second alternative callback for database queries.  A the
** first column of the first row of the result is made the TCL result.
*/
static int DbEvalCallback3(
  void *clientData,      /* An instance of CallbackData */
  int nCol,              /* Number of columns in the result */
  char ** azCol,         /* Data for each column */
  char ** azN            /* Name for each column */
){
  Tcl_Interp *interp = (Tcl_Interp*)clientData;
  Tcl_Obj *pElem;
  if( azCol==0 ) return 1;
  if( nCol==0 ) return 1;
#ifdef UTF_TRANSLATION_NEEDED
  {
    Tcl_DString dCol;
    Tcl_DStringInit(&dCol);
    Tcl_ExternalToUtfDString(NULL, azCol[0], -1, &dCol);
    pElem = Tcl_NewStringObj(Tcl_DStringValue(&dCol), -1);
    Tcl_DStringFree(&dCol);
  }
#else
  pElem = Tcl_NewStringObj(azCol[0], -1);
#endif
  Tcl_SetObjResult(interp, pElem);
  return 1;
}

/*int GetRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) {

    int num_entry;
    int i;
    char buf[1024];

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"",
            argv[0], " filename\"", (char*)NULL);
        return TCL_ERROR;
    }

    if (!renzymes) {
        free_renzymes (renzymes);
    }

    renzymes = get_enzyme(argv[1]);
    printf("num_entry=%d\n", renzymes->used);

    if (!renzymes)
        return TCL_OK;

    num_entry = renzymes->used;
    Tcl_ResetResult(interp);
    for (i = 0; i < num_entry; i++) {
        sprintf(buf, "%s {%s} %s %s %.0f",renzymes->renzyme[i]->name,
                renzymes->renzyme[i]->rec_seq_text,
                renzymes->renzyme[i]->prototype,
                renzymes->renzyme[i]->supplier_codes,
                renzymes->renzyme[i]->av_frag_size);
        Tcl_AppendElement(interp, buf);
    }
    return TCL_OK;
}
*/
int GetRenzInfo(ClientData clientData, Tcl_Interp *interp, int argc, char **argv) {

    int num_entry;
    int i;

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"",
            argv[0], " filename\"", (char*)NULL);
        return TCL_ERROR;
    }

    if (!renzymes) {
        free_renzymes (renzymes);
    }

    renzymes = get_enzyme(argv[1]);
    /* printf("num_entry=%d\n", renzymes->used); */
    if (!renzymes)
        return TCL_OK;

    num_entry = renzymes->used;
    Tcl_ResetResult(interp);
    for (i = 0; i < num_entry; i++) {
        Tcl_DString dstr;
        Tcl_DStringInit(&dstr);
        vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->name);
        vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->rec_seq_text);
        vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->prototype);
        vTcl_DStringAppendElement(&dstr, "%s", renzymes->renzyme[i]->supplier_codes);
        vTcl_DStringAppendElement(&dstr, "%.f", renzymes->renzyme[i]->av_frag_size);
        Tcl_AppendElement(interp, Tcl_DStringValue(&dstr));

        Tcl_DStringFree(&dstr);
    }
    return TCL_OK;
}

static void overloadedGlobFunction(
  sqlite3_context *pContext,
  int nArg,
  sqlite3_value **apArg
){
  Tcl_Interp *interp = sqlite3_user_data(pContext);
  Tcl_DString str;
  int i;
  int rc;
  Tcl_DStringInit(&str);
  Tcl_DStringAppendElement(&str, "::echo_glob_overload");
  for(i=0; i<nArg; i++){
    Tcl_DStringAppendElement(&str, (char*)sqlite3_value_text(apArg[i]));
  }
  rc = Tcl_Eval(interp, Tcl_DStringValue(&str));
  Tcl_DStringFree(&str);
  if( rc ){
    sqlite3_result_error(pContext, Tcl_GetStringResult(interp), -1);
  }else{
    sqlite3_result_text(pContext, Tcl_GetStringResult(interp),
                        -1, SQLITE_TRANSIENT);
  }
  Tcl_ResetResult(interp);
}

static HRESULT
BuildMoniker(
    const char *name,
    LPMONIKER *ppmk)
{
    LPMONIKER pmkClass = NULL;
    HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass);

    if (SUCCEEDED(hr)) {
	LPMONIKER pmkItem = NULL;
	Tcl_DString dString;

	Tcl_DStringInit(&dString);
	Tcl_UtfToUniCharDString(name, -1, &dString);
	hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem);
	Tcl_DStringFree(&dString);
	if (SUCCEEDED(hr)) {
	    hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk);
	    pmkItem->lpVtbl->Release(pmkItem);
	}
	pmkClass->lpVtbl->Release(pmkClass);
    }
    return hr;
}

CONST char *
Tcl_GetEncodingNameFromEnvironment(
    Tcl_DString *bufPtr)
{
    CONST char *encoding;
    CONST char *knownEncoding;

    Tcl_DStringInit(bufPtr);

    /*
     * Determine the current encoding from the LC_* or LANG environment
     * variables. We previously used setlocale() to determine the locale, but
     * this does not work on some systems (e.g. Linux/i386 RH 5.0).
     */

#ifdef HAVE_LANGINFO
    if (
#ifdef WEAK_IMPORT_NL_LANGINFO
	    nl_langinfo != NULL &&
#endif
	    setlocale(LC_CTYPE, "") != NULL) {
	Tcl_DString ds;

	/*
	 * Use a DString so we can modify case.
	 */

	Tcl_DStringInit(&ds);
	encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
	Tcl_UtfToLower(Tcl_DStringValue(&ds));
	knownEncoding = SearchKnownEncodings(encoding);
	if (knownEncoding != NULL) {
	    Tcl_DStringAppend(bufPtr, knownEncoding, -1);
	} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
	    Tcl_DStringAppend(bufPtr, encoding, -1);
	}
	Tcl_DStringFree(&ds);
	if (Tcl_DStringLength(bufPtr)) {
	    return Tcl_DStringValue(bufPtr);
	}
    }
#endif /* HAVE_LANGINFO */

    /*
     * Classic fallback check. This tries a homebrew algorithm to determine
     * what encoding should be used based on env vars.
     */

    encoding = getenv("LC_ALL");

    if (encoding == NULL || encoding[0] == '\0') {
	encoding = getenv("LC_CTYPE");
    }
    if (encoding == NULL || encoding[0] == '\0') {
	encoding = getenv("LANG");
    }
    if (encoding == NULL || encoding[0] == '\0') {
	encoding = NULL;
    }

    if (encoding != NULL) {
	CONST char *p;
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	p = encoding;
	encoding = Tcl_DStringAppend(&ds, p, -1);
	Tcl_UtfToLower(Tcl_DStringValue(&ds));

	knownEncoding = SearchKnownEncodings(encoding);
	if (knownEncoding != NULL) {
	    Tcl_DStringAppend(bufPtr, knownEncoding, -1);
	} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
	    Tcl_DStringAppend(bufPtr, encoding, -1);
	}
	if (Tcl_DStringLength(bufPtr)) {
	    Tcl_DStringFree(&ds);
	    return Tcl_DStringValue(bufPtr);
	}

	/*
	 * We didn't recognize the full value as an encoding name. If there is
	 * an encoding subfield, we can try to guess from that.
	 */

	for (p = encoding; *p != '\0'; p++) {
	    if (*p == '.') {
		p++;
		break;
	    }
	}
	if (*p != '\0') {
	    knownEncoding = SearchKnownEncodings(p);
	    if (knownEncoding != NULL) {
		Tcl_DStringAppend(bufPtr, knownEncoding, -1);
	    } else if (NULL != Tcl_GetEncoding(NULL, p)) {
		Tcl_DStringAppend(bufPtr, p, -1);
	    }
	}
	Tcl_DStringFree(&ds);
//.........这里部分代码省略.........

static void
TransferXEventsToTcl(
    Display *display)
{
    union {
	int type;
	XEvent x;
	TkKeyEvent k;
    } event;
    Window w;
    TkDisplay *dispPtr = NULL;

    /*
     * Transfer events from the X event queue to the Tk event queue after XIM
     * event filtering. KeyPress and KeyRelease events need special treatment
     * so that they get directed according to Tk's focus rules during XIM
     * handling. Theoretically they can go to the wrong place still (if
     * there's a focus change in the queue) but if we push the handling off
     * until Tk_HandleEvent then many input methods actually cease to work
     * correctly. Most of the time, Tk processes its event queue fast enough
     * for this to not be an issue anyway. [Bug 1924761]
     */

    while (QLength(display) > 0) {
	XNextEvent(display, &event.x);
	w = None;
	if (event.type == KeyPress || event.type == KeyRelease) {
	    for (dispPtr = TkGetDisplayList(); ; dispPtr = dispPtr->nextPtr) {
		if (dispPtr == NULL) {
		    break;
		} else if (dispPtr->display == event.x.xany.display) {
		    if (dispPtr->focusPtr != NULL) {
			w = dispPtr->focusPtr->window;
		    }
		    break;
		}
	    }
	}
	if (XFilterEvent(&event.x, w)) {
	    continue;
	}
	if (event.type == KeyPress || event.type == KeyRelease) {
	    event.k.charValuePtr = NULL;
	    event.k.charValueLen = 0;
	    event.k.keysym = NoSymbol;

	    /*
	     * Force the calling of the input method engine now. The results
	     * from it will be cached in the event so that they don't get lost
	     * (to a race condition with other XIM-handled key events) between
	     * entering the event queue and getting serviced. [Bug 1924761]
	     */

#ifdef TK_USE_INPUT_METHODS
	    if (event.type == KeyPress && dispPtr &&
		    (dispPtr->flags & TK_DISPLAY_USE_IM)) {
		if (dispPtr->focusPtr && dispPtr->focusPtr->inputContext) {
		    Tcl_DString ds;

		    Tcl_DStringInit(&ds);
		    (void) TkpGetString(dispPtr->focusPtr, &event.x, &ds);
		    Tcl_DStringFree(&ds);
		}
	    }
#endif
	}
	Tk_QueueWindowEvent(&event.x, TCL_QUEUE_TAIL);
    }
}