C++ Tcl_NewObj函数代码示例

Tcl_Obj *
TkDebugColor(
    Tk_Window tkwin,		/* The window in which the color will be used
				 * (not currently used). */
    char *name)			/* Name of the desired color. */
{
    Tcl_HashEntry *hashPtr;
    Tcl_Obj *resultPtr;
    TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr;

    resultPtr = Tcl_NewObj();
    hashPtr = Tcl_FindHashEntry(&dispPtr->colorNameTable, name);
    if (hashPtr != NULL) {
        TkColor *tkColPtr = Tcl_GetHashValue(hashPtr);

        if (tkColPtr == NULL) {
            Tcl_Panic("TkDebugColor found empty hash table entry");
        }
        for ( ; (tkColPtr != NULL); tkColPtr = tkColPtr->nextPtr) {
            Tcl_Obj *objPtr = Tcl_NewObj();

            Tcl_ListObjAppendElement(NULL, objPtr,
                                     Tcl_NewIntObj(tkColPtr->resourceRefCount));
            Tcl_ListObjAppendElement(NULL, objPtr,
                                     Tcl_NewIntObj(tkColPtr->objRefCount));
            Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
        }
    }
    return resultPtr;
}

/*
 *--------------------------------------------------------------
 *
 * mongotcl_setBsonError -- command deletion callback routine.
 *
 * Results:
 *      ...create an error message based on bson object error fields.
 *      ...set errorCode based on the same bson object error fields.
 *
 *      return TCL_ERROR
 *
 *--------------------------------------------------------------
 */
int
mongotcl_setBsonError (Tcl_Interp *interp, bson *bson) {
    Tcl_Obj *list = Tcl_NewObj();
    Tcl_Obj *errorCodeList = Tcl_NewObj();

    if (bson->err & BSON_NOT_UTF8) {
		Tcl_AddErrorInfo (interp, "bson not utf8");
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("NOT_UTF8",-1));
    }

    if (bson->err & BSON_FIELD_HAS_DOT) {
		Tcl_AddErrorInfo (interp, "bson field has dot");
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("HAS_DOT",-1));
    }

    if (bson->err & BSON_FIELD_INIT_DOLLAR) {
		Tcl_AddErrorInfo (interp, "bson field has initial dollar sign");
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("INIT_DOLLAR",-1));
    }

    if (bson->err & BSON_ALREADY_FINISHED) {
		Tcl_SetObjResult (interp, Tcl_NewStringObj ("bson already finished", -1));
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("ALREADY_FINISHED",-1));
    }

	Tcl_ListObjAppendElement(interp, errorCodeList, Tcl_NewStringObj("BSON",-1));
    Tcl_ListObjAppendElement(interp, errorCodeList, list);

    Tcl_SetObjErrorCode (interp, errorCodeList);

    return TCL_ERROR;
}

int
compare_attrs(struct directory *dp1, struct directory *dp2)
{
    struct bu_vls vls = BU_VLS_INIT_ZERO;
    Tcl_Obj *obj1, *obj2;
    int different = 0;

    if (db_version(dbip1) > 4) {
	bu_vls_printf(&vls, "_db1 attr get %s", dp1->d_namep);
	if (Tcl_Eval(INTERP, bu_vls_addr(&vls)) != TCL_OK) {
	    fprintf(stderr, "Cannot get attributes for %s\n", dp1->d_namep);
	    fprintf(stderr, "%s\n", Tcl_GetStringResult(INTERP));
	    bu_exit(1, NULL);
	}

	obj1 = Tcl_DuplicateObj(Tcl_GetObjResult(INTERP));
	Tcl_ResetResult(INTERP);
	if (dp1->d_flags & RT_DIR_REGION && verify_region_attribs) {
	    verify_region_attrs(dp1, dbip1, obj1);
	}
    } else {
	obj1 = Tcl_NewObj();
    }

    if (db_version(dbip2) > 4) {
	bu_vls_trunc(&vls, 0);
	bu_vls_printf(&vls, "_db2 attr get %s", dp1->d_namep);
	if (Tcl_Eval(INTERP, bu_vls_addr(&vls)) != TCL_OK) {
	    fprintf(stderr, "Cannot get attributes for %s\n", dp1->d_namep);
	    fprintf(stderr, "%s\n", Tcl_GetStringResult(INTERP));
	    bu_exit(1, NULL);
	}

	obj2 = Tcl_DuplicateObj(Tcl_GetObjResult(INTERP));
	Tcl_ResetResult(INTERP);
	if (dp1->d_flags & RT_DIR_REGION && verify_region_attribs) {
	    verify_region_attrs(dp2, dbip2, obj2);
	}
    } else {
	obj2 = Tcl_NewObj();
    }

    if ((dp1->d_flags & RT_DIR_REGION) && (dp2->d_flags & RT_DIR_REGION)) {
	/* don't complain about "region" attributes */
	remove_region_attrs(obj1);
	remove_region_attrs(obj2);
    }

    bu_vls_trunc(&vls, 0);
    different = do_compare(ATTRS, &vls, obj1, obj2, dp1->d_namep);

    printf("%s", bu_vls_addr(&vls));
    bu_vls_free(&vls);

    return different;
}

/*************************************************************************
* FUNCTION      :   RPMTransaction_Set::RPM_callback                     *
* ARGUMENTS     :   none                                                 *
* RETURNS       :   TCL_OK or TCL_ERROR                                  *
* EXCEPTIONS    :   none                                                 *
* PURPOSE       :   Set or get problem mask flags                        *
*************************************************************************/
void *RPMTransaction_Set::RPM_callback( const void * h,
                                        const rpmCallbackType what,
                                        const unsigned long amount,
                                        const unsigned long total,
                                        fnpyKey key
                                      )
{
    // Build up the list of call back bits
    Tcl_Obj *bitstring = Tcl_NewObj();
    for (unsigned i = 0; i < sizeof(bits)/sizeof(bits[0]); ++i)
    {
        if (what & bits[i].bit)
        {
            Tcl_ListObjAppendElement(_interp,bitstring,Tcl_NewStringObj(bits[i].msg,-1));
        }
    }
    RPMHeader_Obj *hdr = (RPMHeader_Obj *)key;
    Tcl_Obj *cmd[] =
    {
        Tcl_NewStringObj("::RPM::Callback",-1),
        bitstring,
        Tcl_NewLongObj(amount),
        Tcl_NewLongObj(total),
        hdr?hdr->Get_obj():Tcl_NewObj()
    };
    Tcl_Obj *script = Tcl_NewListObj(sizeof(cmd)/sizeof(cmd[0]),cmd);
    Tcl_IncrRefCount(script);
    Tcl_EvalObj(_interp,script);
    Tcl_DecrRefCount(script);

    // Now, handle any special operations here
    if (what & RPMCALLBACK_INST_OPEN_FILE)
    {
        assert(hdr);
        FD_t fd = hdr->Open();
        if (!fd || Ferror(fd))
        {
            if (fd)
            {
                Fclose(fd);
                fd = 0;
            }
        }
        return (void *)fd;
    }
    if (what & RPMCALLBACK_INST_CLOSE_FILE)
    {
        assert(hdr);
        hdr->Close();
        return 0;
    }
    return 0;
}

/*
** The main function for threads created with [sqlthread spawn].
*/
static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){
  Tcl_Interp *interp;
  Tcl_Obj *pRes;
  Tcl_Obj *pList;
  int rc;
  SqlThread *p = (SqlThread *)pSqlThread;
  extern int Sqlitetest_mutex_Init(Tcl_Interp*);

  interp = Tcl_CreateInterp();
  Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);
  Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0);
#if SQLITE_OS_UNIX && defined(SQLITE_ENABLE_UNLOCK_NOTIFY)
  Tcl_CreateObjCommand(interp, "sqlite3_blocking_step", blocking_step_proc,0,0);
  Tcl_CreateObjCommand(interp, 
      "sqlite3_blocking_prepare_v2", blocking_prepare_v2_proc, (void *)1, 0);
  Tcl_CreateObjCommand(interp, 
      "sqlite3_nonblocking_prepare_v2", blocking_prepare_v2_proc, 0, 0);
#endif
  Sqlitetest1_Init(interp);
  Sqlitetest_mutex_Init(interp);
  Sqlite3_Init(interp);

  rc = Tcl_Eval(interp, p->zScript);
  pRes = Tcl_GetObjResult(interp);
  pList = Tcl_NewObj();
  Tcl_IncrRefCount(pList);
  Tcl_IncrRefCount(pRes);

  if( rc!=TCL_OK ){
    Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1));
    Tcl_ListObjAppendElement(interp, pList, pRes);
    postToParent(p, pList);
    Tcl_DecrRefCount(pList);
    pList = Tcl_NewObj();
  }

  Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1));
  Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));
  Tcl_ListObjAppendElement(interp, pList, pRes);
  postToParent(p, pList);

  ckfree((void *)p);
  Tcl_DecrRefCount(pList);
  Tcl_DecrRefCount(pRes);
  Tcl_DeleteInterp(interp);
  while( Tcl_DoOneEvent(TCL_ALL_EVENTS|TCL_DONT_WAIT) );
  Tcl_ExitThread(0);
  TCL_THREAD_CREATE_RETURN;
}

void
NsfStackDump(Tcl_Interp *interp) {
  Interp     *iPtr = (Interp *)interp;
  CallFrame  *f, *v;
  Tcl_Obj    *varCmdObj;

  nonnull_assert(interp != NULL);

  f = iPtr->framePtr;
  v = iPtr->varFramePtr;
  varCmdObj = Tcl_NewObj();
  fprintf (stderr, "     TCL STACK:\n");
  if (f == 0) {
    fprintf(stderr, "- ");
  }
  while (f) {
    Tcl_Obj *cmdObj = Tcl_NewObj();
    fprintf(stderr, "\tFrame=%p ", (void *)f);
    if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) {
      fprintf(stderr,"caller %p ", (void *)Tcl_CallFrame_callerPtr(f));
      fprintf(stderr,"callerV %p ", (void *)Tcl_CallFrame_callerVarPtr(f));
      Tcl_GetCommandFullName(interp, (Tcl_Command)f->procPtr->cmdPtr, cmdObj);
      fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), (void *)f->procPtr->cmdPtr, f->level);
    } else {
        if (f && f->varTablePtr) {
            fprintf(stderr, "var_table = %p ", (void *)f->varTablePtr);
        }
        fprintf(stderr, "- \n");
    }
    DECR_REF_COUNT(cmdObj);
    f = f->callerPtr;
  }

  fprintf (stderr, "     VARFRAME:\n");
  fprintf(stderr, "\tFrame=%p ", (void *)v);
  if (v != NULL) {
      fprintf(stderr, "caller %p var_table %p ", (void *)v->callerPtr, (void *)v->varTablePtr);
      /*      if (v->varTablePtr != NULL)
              panic(0, "testing");*/
  }
  if (v != NULL && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) {
    Tcl_GetCommandFullName(interp, (Tcl_Command)  v->procPtr->cmdPtr, varCmdObj);
    fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level);
  } else {
    fprintf(stderr, "- \n");
  }
  DECR_REF_COUNT(varCmdObj);
}

/*
** This is an alternative callback for database queries.  Instead
** of invoking a TCL script to handle the result, this callback just
** appends each column of the result to a list.  After the query
** is complete, the list is returned.
*/
static int DbEvalCallback2(
  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_Obj *pList = (Tcl_Obj*)clientData;
  int i;
  if( azCol==0 ) return 0;
  for(i=0; i<nCol; i++){
    Tcl_Obj *pElem;
    if( azCol[i] && *azCol[i] ){
#ifdef UTF_TRANSLATION_NEEDED
      Tcl_DString dCol;
      Tcl_DStringInit(&dCol);
      Tcl_ExternalToUtfDString(NULL, azCol[i], -1, &dCol);
      pElem = Tcl_NewStringObj(Tcl_DStringValue(&dCol), -1);
      Tcl_DStringFree(&dCol);
#else
      pElem = Tcl_NewStringObj(azCol[i], -1);
#endif
    }else{
      pElem = Tcl_NewObj();
    }
    Tcl_ListObjAppendElement(0, pList, pElem);
  }
  return 0;
}

		static Tcl_Obj* create(boost::shared_ptr<Network>& network, std::size_t const index) {
			// instantiate new TCL object
			Tcl_Obj* const w = Tcl_NewObj();
			w->typePtr = CircuitWrapper::type();
			w->internalRep.otherValuePtr = new CircuitWrapper(network, index);
			return w;
		}

void
Sv_RegisterListCommands(void)
{
    static int initialized = 0;

    if (initialized == 0) {
        Tcl_MutexLock(&initMutex);
        if (initialized == 0) {
            /* Create list with 1 empty element. */
            Tcl_Obj *listobj = Tcl_NewObj();
            listobj = Tcl_NewListObj(1, &listobj);
            Sv_RegisterObjType(listobj->typePtr, DupListObjShared);
            Tcl_DecrRefCount(listobj);

            Sv_RegisterCommand("lpop",     SvLpopObjCmd,     NULL, 0);
            Sv_RegisterCommand("lpush",    SvLpushObjCmd,    NULL, 0);
            Sv_RegisterCommand("lappend",  SvLappendObjCmd,  NULL, 0);
            Sv_RegisterCommand("lreplace", SvLreplaceObjCmd, NULL, 0);
            Sv_RegisterCommand("linsert",  SvLinsertObjCmd,  NULL, 0);
            Sv_RegisterCommand("llength",  SvLlengthObjCmd,  NULL, 0);
            Sv_RegisterCommand("lindex",   SvLindexObjCmd,   NULL, 0);
            Sv_RegisterCommand("lrange",   SvLrangeObjCmd,   NULL, 0);
            Sv_RegisterCommand("lsearch",  SvLsearchObjCmd,  NULL, 0);
            Sv_RegisterCommand("lset",     SvLsetObjCmd,     NULL, 0);

            initialized = 1;
        }
        Tcl_MutexUnlock(&initMutex);
    }
}

CommandDef (values, clientData, interp, objc, objv)
{
  Handle *handle;
  DBFHandle dbfHandle;
  int fieldCount, i;
  Tcl_Obj *resultPtr, *listPtr;

  if (objc != 2)
    {
      Tcl_WrongNumArgs (interp, 1, objv, "filename");
      return TCL_ERROR;
    }
  if (DbfGetHandleFromObj (interp, objv[1], &handle) != TCL_OK)
    {
      return TCL_ERROR;
    }
  dbfHandle = handle->dbfHandle;
  fieldCount = DBFGetFieldCount (dbfHandle);
  resultPtr = Tcl_GetObjResult (interp);
  for (i = 0; i < fieldCount; i++)
    {
      listPtr = Tcl_NewObj ();
      if (ListObjAppendField (interp, listPtr, dbfHandle, i) != TCL_OK)
        {
          return TCL_ERROR;
        }
      if (Tcl_ListObjAppendElement (interp, resultPtr, listPtr) != TCL_OK)
        {
          return TCL_ERROR;
        }
    }
  return TCL_OK;
}

/*
** create fft and filter windows.
*/
static int _command(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) {
  // check for usage
  if (argc != 3) return fw_error_obj(interp, Tcl_ObjPrintf("usage: %s type size", Tcl_GetString(objv[0])));
  char *type_name = Tcl_GetString(objv[1]);
  int itype = -1;
  for (int i = 0; window_names[i] != NULL; i += 1)
    if (strcmp(window_names[i], type_name) == 0) {
      itype = i;
      break;
    }
  if (itype < 0) {
    Tcl_AppendResult(interp, "unknown window type, should be one of ", NULL);
    for (int i = 0; window_names[i] != NULL; i += 1) {
      if (i > 0) {
	Tcl_AppendResult(interp, ", ", NULL);
	if (window_names[i+1] == NULL)
	  Tcl_AppendResult(interp, "or ", NULL);
      }
      Tcl_AppendResult(interp, window_names[i], NULL);
    }
    return TCL_ERROR;
  }
  int size;
  if (Tcl_GetIntFromObj(interp, objv[2], &size) != TCL_OK) return TCL_ERROR;
  Tcl_Obj *result = Tcl_NewObj();
  float *window = (float *)Tcl_SetByteArrayLength(result, size*sizeof(float));
  window_make(itype, size, window);
  Tcl_SetObjResult(interp, result);
  return TCL_OK;
}

static int
installConsts(Tcl_Interp *interp,struct ConstEntry *table) {
	struct ConstEntry *entry;
	if (table==NULL) return TCL_ERROR;
	for(entry=table+0;entry->objPtr!=NULL;entry++) {
		Tcl_Obj *obj;
		if (*entry->objPtr!=NULL) {
			//WARN("const %s already defined\n",entry->name);
			continue;
		}
		if (entry->value==NULL)
			obj=Tcl_NewObj();
		else
			obj=Tcl_NewStringObj(entry->value,-1);
		Tcl_IncrRefCount(obj);
		if (entry->typePtr!=NULL && *entry->typePtr!=NULL) {
			if (Tcl_ConvertToType(interp,obj,*entry->typePtr)!=TCL_OK) {
				ERR("in convert const %s to %s",entry->name,(*entry->typePtr)->name);
				Tcl_DecrRefCount(obj);
				return TCL_ERROR;
			}
		}
		Tcl_IncrRefCount(obj);
		*entry->objPtr=obj;
	}
	return TCL_OK;
}

/*************************************************************************
* FUNCTION      :   RPMPRoblem_Obj::Get_Obj                              *
* ARGUMENTS     :   none                                                 *
* RETURNS       :   Object with refcount of 0                            *
* EXCEPTIONS    :   none                                                 *
* PURPOSE       :   Create a Tcl_Obj from a problem                      *
*************************************************************************/
Tcl_Obj *RPMPRoblem_Obj::Get_obj(void)
{
   Tcl_Obj *obj = Tcl_NewObj();
   obj->typePtr = &mytype;
   obj->internalRep.otherValuePtr = Dup();
   Tcl_InvalidateStringRep(obj);
   return obj;
}

static Tcl_Obj *
newUnicodeObj (const Tcl_UniChar *pWide, int length)
{
    if (pWide == 0) {
        return Tcl_NewObj();
    }
    return Tcl_NewUnicodeObj(const_cast<Tcl_UniChar *>(pWide), length);
}

Tcl_Obj *Ttk_NewStateSpecObj(unsigned int onbits, unsigned int offbits)
{
    Tcl_Obj *objPtr = Tcl_NewObj();

    Tcl_InvalidateStringRep(objPtr);
    objPtr->typePtr = &StateSpecObjType;
    objPtr->internalRep.longValue = (onbits << 16) | offbits;

    return objPtr;
}