C++ Tcl_GetObjResult函数代码示例

/*
  sequencer device channel create for reading or writing, not both at once.
*/
static int alsa_sequencer_open(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *port, Tcl_Obj *direction) {
  const char *port_name = Tcl_GetString(port), *direction_name = Tcl_GetString(direction);
  static snd_sequencer_t *input, **inputp;
  static snd_sequencer_t *output, **outputp;
  if (strcmp(direction_name, "r") == 0) {
    inputp = &input;
    outputp = NULL;
  } else if (strcmp(direction_name, "w") == 0) {
    inputp = NULL;
    outputp = &output;
  } else {
    Tcl_AppendResult(interp, "open direction must be r or w", NULL);
    return TCL_ERROR;
  }
  int err;
  if ((err = snd_sequencer_open(inputp, outputp, port_name, SND_SEQUENCER_NONBLOCK)) < 0) {
    Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "cannot open port \"%s\": %s", port_name, snd_strerror(err));
    return TCL_ERROR;
  }
  if (inputp) {
    snd_sequencer_read(input, NULL, 0); /* trigger reading */
    return sequencer_make_channel(clientData, interp, input, TCL_READABLE);
  }
  if (outputp) {
    if ((err = snd_sequencer_nonblock(output, 0)) < 0) {
      Tcl_AppendResult(interp, "cannot set blocking mode: ", snd_strerror(err), NULL);
      snd_sequencer_close(output);
      return TCL_ERROR;
    }
    return sequencer_make_channel(clientData, interp, output, TCL_WRITABLE);
  }
}

Tcl_CmdInfo *eul_tk_create_widget(char *type, char *name, LispRef listArgs)
{
    struct infoargs infoArgs;
    ParseArguments2(&infoArgs, type, name, listArgs);

    Tcl_CmdInfo cmdInfo = FindCreationFn(type);

    int result = cmdInfo.proc
    (
        cmdInfo.clientData,
        interp,
        infoArgs.argc,
        infoArgs.argv
    );

    Tcl_CmdInfo *newCmdInfo = (Tcl_CmdInfo *)gc_malloc(sizeof(Tcl_CmdInfo));
    *newCmdInfo = (Tcl_CmdInfo){0, NULL, 0, NULL, 0, NULL, 0, NULL};

    // It isn't clear what should be returned on error so return an empty
    // structure allocated on free-store
    if (result == TCL_ERROR)
    {
        return newCmdInfo;
    }

    result = Tcl_GetCommandInfo
    (
        interp,
        Tcl_GetString(Tcl_GetObjResult(interp)),
        newCmdInfo
    );

    return newCmdInfo;
}

/*
** Test for access permissions. Return true if the requested permission
** is available, or false otherwise.
*/
static int tvfsAccess(
  sqlite3_vfs *pVfs, 
  const char *zPath, 
  int flags, 
  int *pResOut
){
  Testvfs *p = (Testvfs *)pVfs->pAppData;
  if( p->pScript && p->mask&TESTVFS_ACCESS_MASK ){
    int rc;
    char *zArg = 0;
    if( flags==SQLITE_ACCESS_EXISTS ) zArg = "SQLITE_ACCESS_EXISTS";
    if( flags==SQLITE_ACCESS_READWRITE ) zArg = "SQLITE_ACCESS_READWRITE";
    if( flags==SQLITE_ACCESS_READ ) zArg = "SQLITE_ACCESS_READ";
    tvfsExecTcl(p, "xAccess", 
        Tcl_NewStringObj(zPath, -1), Tcl_NewStringObj(zArg, -1), 0
    );
    if( tvfsResultCode(p, &rc) ){
      if( rc!=SQLITE_OK ) return rc;
    }else{
      Tcl_Interp *interp = p->interp;
      if( TCL_OK==Tcl_GetBooleanFromObj(0, Tcl_GetObjResult(interp), pResOut) ){
        return SQLITE_OK;
      }
    }
  }
  return sqlite3OsAccess(PARENTVFS(pVfs), zPath, flags, pResOut);
}

static Tcl_Obj * tk_eval(const char *cmd)
{
    char *cmd_utf8;
    Tcl_DString  cmd_utf8_ds;

    Tcl_DStringInit(&cmd_utf8_ds);
    cmd_utf8 = Tcl_ExternalToUtfDString(NULL, cmd, -1, &cmd_utf8_ds);
    if (Tcl_Eval(RTcl_interp, cmd_utf8) == TCL_ERROR)
    {
	char p[512];
	if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500)
	    strcpy(p, _("tcl error.\n"));
	else {
	    char *res;
	    Tcl_DString  res_ds;

	    Tcl_DStringInit(&res_ds);
	    res = Tcl_UtfToExternalDString(NULL,
					   Tcl_GetStringResult(RTcl_interp),
					   -1, &res_ds);
	    snprintf(p, sizeof(p), "[tcl] %s.\n", res);
	    Tcl_DStringFree(&res_ds);
	}
	error(p);
    }
    Tcl_DStringFree(&cmd_utf8_ds);
    return Tcl_GetObjResult(RTcl_interp);
}

int NS(ProcCheck) (
  Tcl_Interp * interp,
  struct Tcl_Obj * cmdObj,
  char const * const wrongNrStr
)
{
  int ret,len;
  Tcl_DString cmd;
  if (!Tcl_GetCommandFromObj (interp, cmdObj)) {
    Tcl_WrongNumArgs (interp, 0, NULL, wrongNrStr);
    return TCL_ERROR;
  }
  Tcl_DStringInit(&cmd);
  Tcl_DStringAppendElement(&cmd,"info");
  Tcl_DStringAppendElement(&cmd,"args");
  Tcl_DStringAppendElement(&cmd,Tcl_GetString(cmdObj));
  ret = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), TCL_EVAL_GLOBAL);
  Tcl_DStringFree(&cmd);
  TclErrorCheck(ret);
  TclErrorCheck(Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &len));
  if (len != 1) {
    Tcl_DString msg;
    Tcl_DStringInit(&msg);
    Tcl_DStringAppend(&msg,"wrong # args: ", -1);
    if (len > 1) Tcl_DStringAppend(&msg,"only ", -1);
    Tcl_DStringAppend(&msg,"one argument for procedure \"", -1);
    Tcl_DStringAppend(&msg,Tcl_GetString(cmdObj), -1);
    Tcl_DStringAppend(&msg,"\" is required", -1);
    Tcl_DStringResult(interp, &msg);
    Tcl_DStringFree(&msg);
    return TCL_ERROR;
  }
  return TCL_OK;
}

static AP_Result tcl_coerce_number(AP_World *w, AP_Obj interp_name, AP_Obj item, AP_Obj atom)
{	
	Tcl_Interp *interp;
	AP_Obj result;
	
	interp = GetInterp(w, interp_name);
	if (!interp) return AP_EXCEPTION;
	
	if (AP_ObjType(w, item) == AP_INTEGER
		|| AP_ObjType(w, item) == AP_FLOAT) result = item;
	else {
		Tcl_Obj *tcl_obj = PrologToTclObj(w, item, interp);
		int r;
		r = Tcl_ConvertToType(interp, tcl_obj, tcl_integer_type);
		if (r != TCL_OK)
			r = Tcl_ConvertToType(interp, tcl_obj, tcl_double_type);
		if (r != TCL_OK)
			return AP_SetException(w,
				AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "error"), 2,
					AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "tcl_error"), 1,
						TclToPrologObj(interp, Tcl_GetObjResult(interp), w, NULL)),
					AP_UNBOUND_OBJ));
		result = TclToPrologObj(interp, tcl_obj, w, NULL);
		Tcl_DecrRefCount(tcl_obj);
	}

	return AP_Unify(w, result, atom);
}

int Tcl_AppInit(Tcl_Interp *interp)
{
    if (Tcl_Init(interp) == TCL_ERROR)
        return TCL_ERROR;

    if (tcl_interface_init(interp, &debug) != TCL_OK)
    {
        fprintf(stderr, "%s, tcl interface init error", __FUNCTION__);
        return TCL_ERROR;
    }

    if (strlen(script) && Tcl_EvalFile(interp, script) != TCL_OK)
    {
        char *result;

        result = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL);
        if (result)
        {
            printf("*************\n");
            Tcl_Eval(interp, "puts $::errorInfo");
            printf("*************\n");
        }

        return TCL_ERROR;
    }

    return TCL_OK;
}

int
TclpListVolumes( 
    Tcl_Interp *interp)    /* Interpreter to which to pass the volume list */
{
    Tcl_Obj *resultPtr, *elemPtr;
    char buf[4];
    int i;

    resultPtr = Tcl_GetObjResult(interp);

    buf[1] = ':';
    buf[2] = '/';
    buf[3] = '\0';

    /*
     * On Win32s: 
     * GetLogicalDriveStrings() isn't implemented.
     * GetLogicalDrives() returns incorrect information.
     */

    for (i = 0; i < 26; i++) {
        buf[0] = (char) ('a' + i);
	if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)  
		|| (GetLastError() == ERROR_NOT_READY)) {
	    elemPtr = Tcl_NewStringObj(buf, -1);
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }
    return TCL_OK;	
}

/**
 * Load a new transformation matrix.  This will be followed by
 * many calls to plot_draw().
 */
HIDDEN int
plot_loadMatrix(struct dm *dmp, fastf_t *mat, int which_eye)
{
    Tcl_Obj *obj;

    if (!dmp)
	return TCL_ERROR;

    obj = Tcl_GetObjResult(dmp->dm_interp);
    if (Tcl_IsShared(obj))
	obj = Tcl_DuplicateObj(obj);

    if (((struct plot_vars *)dmp->dm_vars.priv_vars)->debug) {
	struct bu_vls tmp_vls = BU_VLS_INIT_ZERO;

	Tcl_AppendStringsToObj(obj, "plot_loadMatrix()\n", (char *)NULL);

	bu_vls_printf(&tmp_vls, "which eye = %d\t", which_eye);
	bu_vls_printf(&tmp_vls, "transformation matrix = \n");
	bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[0], mat[4], mat[8], mat[12]);
	bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[1], mat[5], mat[9], mat[13]);
	bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[2], mat[6], mat[10], mat[14]);
	bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[3], mat[7], mat[11], mat[15]);

	Tcl_AppendStringsToObj(obj, bu_vls_addr(&tmp_vls), (char *)NULL);
	bu_vls_free(&tmp_vls);
    }

    MAT_COPY(plotmat, mat);
    Tcl_SetObjResult(dmp->dm_interp, obj);
    return TCL_OK;
}

static int DBus_EventHandler(Tcl_Event *evPtr, int flags)
{
   Tcl_DBusEvent *ev;
   DBusMessageIter iter;
   Tcl_Obj *script, *result;
   int rc;

   if (!(flags & TCL_IDLE_EVENTS)) return 0;
   ev = (Tcl_DBusEvent *) evPtr;
   script = ev->script;
   if (Tcl_IsShared(script))
     script = Tcl_DuplicateObj(script);
   Tcl_ListObjAppendElement(ev->interp, script, 
			    DBus_MessageInfo(ev->interp, ev->msg));
   /* read the parameters and append to the script */
   if (dbus_message_iter_init(ev->msg, &iter)) {
      Tcl_ListObjAppendList(ev->interp, script,
	DBus_IterList(ev->interp, &iter, (ev->flags & DBUSFLAG_DETAILS) != 0));
   }
   /* Excute the constructed Tcl command */
   rc = Tcl_EvalObjEx(ev->interp, script, TCL_EVAL_GLOBAL);
   if (rc != TCL_ERROR) {
      /* Report success only if noreply == 0 and async == 0 */
      if (!(ev->flags & DBUSFLAG_NOREPLY) && !(ev->flags & DBUSFLAG_ASYNC)) {
         /* read the parameters and append to the script */;
	 result = Tcl_GetObjResult(ev->interp);
	 DBus_SendMessage(ev->interp, ev->conn,
			  DBUS_MESSAGE_TYPE_METHOD_RETURN, NULL, NULL, NULL,
			  dbus_message_get_sender(ev->msg),
			  dbus_message_get_serial(ev->msg),
			  NULL, 1, &result);
      }
   } else {
      /* Always report failures if noreply == 0 */
      if (!(ev->flags & DBUSFLAG_NOREPLY)) {
	 result = Tcl_GetObjResult(ev->interp);
	 DBus_Error(ev->interp, ev->conn, NULL,
		    dbus_message_get_sender(ev->msg),
		    dbus_message_get_serial(ev->msg),
		    Tcl_GetString(result));
      }
   }
   dbus_message_unref(ev->msg);
   Tcl_DecrRefCount(ev->script);
   /* The event structure will be cleaned up by Tcl_ServiceEvent */
   return 1;
}

SEXP dotTclObjv(SEXP args)
{
    SEXP t,
	avec = CADR(args),
	nm = getAttrib(avec, R_NamesSymbol);
    int objc, i, result;
    Tcl_Obj **objv;
    const void *vmax = vmaxget();

    for (objc = 0, i = 0; i < length(avec); i++){
	if (!isNull(VECTOR_ELT(avec, i)))
	    objc++;
	if (!isNull(nm) && strlen(translateChar(STRING_ELT(nm, i))))
	    objc++;
    }

    objv = (Tcl_Obj **) R_alloc(objc, sizeof(Tcl_Obj *));

    for (objc = i = 0; i < length(avec); i++){
	const char *s;
	char *tmp;
	if (!isNull(nm) && strlen(s = translateChar(STRING_ELT(nm, i)))){
	    tmp = calloc(strlen(s)+2, sizeof(char));
	    *tmp = '-';
	    strcpy(tmp+1, s);
	    objv[objc++] = Tcl_NewStringObj(tmp, -1);
	    free(tmp);
	}
	if (!isNull(t = VECTOR_ELT(avec, i)))
	    objv[objc++] = (Tcl_Obj *) R_ExternalPtrAddr(t);
    }

    for (i = objc; i--; ) Tcl_IncrRefCount(objv[i]);
    result = Tcl_EvalObjv(RTcl_interp, objc, objv, 0);
    for (i = objc; i--; ) Tcl_DecrRefCount(objv[i]);

    if (result == TCL_ERROR)
    {
	char p[512];
	if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500)
	    strcpy(p, _("tcl error.\n"));
	else {
	    char *res;
	    Tcl_DString  res_ds;
	    Tcl_DStringInit(&res_ds);
	    res = Tcl_UtfToExternalDString(NULL,
					   Tcl_GetStringResult(RTcl_interp),
					   -1, &res_ds);
	    snprintf(p, sizeof(p), "[tcl] %s.\n", res);
	    Tcl_DStringFree(&res_ds);
	}
	error(p);
    }

    SEXP res = makeRTclObject(Tcl_GetObjResult(RTcl_interp));
    vmaxset(vmax);
    return res;
}

int
TnmSetConfig(Tcl_Interp *interp, TnmConfig *config, ClientData object, int objc, Tcl_Obj *const objv[])
{
    int i, option, code;
    TnmTable *elemPtr;
    Tcl_Obj *listPtr;
    Tcl_Obj *objPtr;

    if (objc % 2) {
	Tcl_WrongNumArgs(interp, 2, objv, "?option value? ?option value? ...");
	return TCL_ERROR;
    }

    /*
     * First scan through the list of options to make sure that
     * we don't run on an unknown option later when we have 
     * already modified the object.
     */

    for (i = 2; i < objc; i += 2) {
	option = TnmGetTableKeyFromObj(interp, config->optionTable,
				       objv[i], "option");
	if (option < 0) {
	    return TCL_ERROR;
	}
    }

    /*
     * Now call the function to actually modify the object. Note,
     * this version does not rollback changes so an object might
     * end up in a half modified state.
     */
	
    for (i = 2; i < objc; i += 2) {
	option = TnmGetTableKeyFromObj(interp, config->optionTable,
				       objv[i], "option");
	code = (config->setOption)(interp, object, option, objv[i+1]);
	if (code != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    /*
     * Create a new list which contains all the configuration
     * options and their current values.
     */

    listPtr = Tcl_GetObjResult(interp);
    for (elemPtr = config->optionTable; elemPtr->value; elemPtr++) {
	objPtr = (config->getOption)(interp, object, (int) elemPtr->key);
	if (objPtr) {
	    Tcl_ListObjAppendElement(interp, listPtr, 
				     Tcl_NewStringObj(elemPtr->value, -1));
	    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
	}
    }
    return TCL_OK;
}

int fbsql_numrows(Tcl_Interp *interp, int sql_number, int argc, char **argv) {
	Tcl_Obj *obj_result;

	/* set result object pointer */
	obj_result = Tcl_GetObjResult(interp);
	Tcl_SetIntObj(obj_result,connection[sql_number].NUMROWS);
	
	return TCL_OK;
}

static void
setStringsResult (Tcl_Interp *interp, ...) {
  Tcl_ResetResult(interp);

  va_list arguments;
  va_start(arguments, interp);
  Tcl_AppendStringsToObjVA(Tcl_GetObjResult(interp), arguments);
  va_end(arguments);
}

/*
 * ------------------------------------------------------------------------
 *  Itk_ArchOptAccessError()
 *
 *  Simply utility which adds error information after an option
 *  value access fails.  Adds traceback information to the given
 *  interpreter.
 * ------------------------------------------------------------------------
 */
void
Itk_ArchOptAccessError(
    Tcl_Interp *interp,            /* interpreter handling this object */
    ArchInfo *info,                /* info associated with mega-widget */
    ArchOption *archOpt)           /* option that couldn't be accessed */
{
    Tcl_ResetResult(interp);

    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
        "internal error: cannot access itk_option(", archOpt->switchName, ")",
        (char*)NULL);

    if (info->itclObj->accessCmd) {
        Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
        Tcl_AppendToObj(resultPtr, " in widget \"", -1);
        Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, resultPtr);
        Tcl_AppendToObj(resultPtr, "\"", -1);
    }
}