Esempio n. 1
0
File: tkColor.c Progetto: arazaq/ns2
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;
}
Esempio n. 2
0
/*
 *--------------------------------------------------------------
 *
 * 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;
}
Esempio n. 3
0
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;
}
Esempio n. 4
0
/*************************************************************************
* 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;
}
Esempio n. 5
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;
}
Esempio n. 6
0
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);
}
Esempio n. 7
0
/*
** 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;
}
Esempio n. 8
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;
		}
Esempio n. 9
0
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);
    }
}
Esempio n. 10
0
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;
}
Esempio n. 11
0
File: window.c Progetto: recri/keyer
/*
** 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;
}
Esempio n. 12
0
File: tclf.c Progetto: nektomk/tcl-f
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;
}
Esempio n. 13
0
/*************************************************************************
* 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;
}
Esempio n. 14
0
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);
}
Esempio n. 15
0
File: ttkState.c Progetto: aosm/tcl
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;
}
Esempio n. 16
0
File: midi.c Progetto: recri/keyer
static int _read(_t *data, jack_nframes_t *framep, Tcl_Obj **bytes) {
  if (ring_buffer_items_available_to_read(&data->rb) < 3+sizeof(jack_nframes_t)+sizeof(size_t))
    return 0;
  int n = ring_buffer_get(&data->rb, sizeof(*framep), (unsigned char *)framep);
  size_t size;
  n += ring_buffer_get(&data->rb, sizeof(size), (unsigned char *)&size);
  *bytes = Tcl_NewObj();
  n += ring_buffer_get(&data->rb, size, Tcl_SetByteArrayLength(*bytes, size));
  return n;
}
Esempio n. 17
0
int sqlite3OutstandingMallocs(Tcl_Interp *interp){
  void *p;
  Tcl_Obj *pRes = Tcl_NewObj();
  Tcl_IncrRefCount(pRes);


  for(p=sqlite3_pFirst; p; p=((void **)p)[1]){
    Tcl_Obj *pEntry = Tcl_NewObj();
    Tcl_Obj *pStack = Tcl_NewObj();
    char *z;
    u32 iLine;
    int nBytes = sqlite3OsAllocationSize(p) - TESTALLOC_OVERHEAD;
    char *zAlloc = (char *)p;
    int i;

    Tcl_ListObjAppendElement(0, pEntry, Tcl_NewIntObj(nBytes));

    z = &zAlloc[TESTALLOC_OFFSET_FILENAME(p)];
    Tcl_ListObjAppendElement(0, pEntry, Tcl_NewStringObj(z, -1));

    z = &zAlloc[TESTALLOC_OFFSET_LINENUMBER(p)];
    memcpy(&iLine, z, sizeof(u32));
    Tcl_ListObjAppendElement(0, pEntry, Tcl_NewIntObj(iLine));

    z = &zAlloc[TESTALLOC_OFFSET_USER(p)];
    Tcl_ListObjAppendElement(0, pEntry, Tcl_NewStringObj(z, -1));

    z = &zAlloc[TESTALLOC_OFFSET_STACK(p)];
    for(i=0; i<TESTALLOC_STACKFRAMES; i++){
      char zHex[128];
      sprintf(zHex, "%p", ((void **)z)[i]);
      Tcl_ListObjAppendElement(0, pStack, Tcl_NewStringObj(zHex, -1));
    }

    Tcl_ListObjAppendElement(0, pEntry, pStack);
    Tcl_ListObjAppendElement(0, pRes, pEntry);
  }

  Tcl_ResetResult(interp);
  Tcl_SetObjResult(interp, pRes);
  Tcl_DecrRefCount(pRes);
  return TCL_OK;
}
Esempio n. 18
0
/*************************************************************************
* FUNCTION      :   RPMPRoblem_Obj::Create_from_problem                  *
* ARGUMENTS     :   ref to problem                                       *
* RETURNS       :   none                                                 *
* EXCEPTIONS    :   none                                                 *
* PURPOSE       :   Create a problem Tcl_Obj                             *
*************************************************************************/
Tcl_Obj *RPMPRoblem_Obj::Create_from_problem(const rpmProblem_s &x)
{
   Tcl_Obj *y = Tcl_NewObj();
   assert(y);
   Tcl_IncrRefCount(y);
   Tcl_InvalidateStringRep(y);
   y->typePtr = &mytype;
   y->internalRep.otherValuePtr = new RPMPRoblem_Obj(x);
   return y;
}
Esempio n. 19
0
File: tcltk.c Progetto: kmillar/rho
SEXP RTcl_ObjFromCharVector(SEXP args)
{
    char *s;
    Tcl_DString s_ds;
    int count;
    Tcl_Obj *tclobj, *elem;
    int i;
    SEXP val, drop;
    Tcl_Encoding encoding;
    const void *vmax = vmaxget();

    val = CADR(args);
    drop = CADDR(args);

    tclobj = Tcl_NewObj();

    count = length(val);
    encoding = Tcl_GetEncoding(RTcl_interp, "utf-8");
    if (count == 1 && LOGICAL(drop)[0]) {
	Tcl_DStringInit(&s_ds);
	s = Tcl_ExternalToUtfDString(encoding,
				     translateCharUTF8(STRING_ELT(val, 0)), 
				     -1, &s_ds);
	Tcl_SetStringObj(tclobj, s, -1);
	Tcl_DStringFree(&s_ds);
    } else
	for ( i = 0 ; i < count ; i++) {
	    elem = Tcl_NewObj();
	    Tcl_DStringInit(&s_ds);
	    s = Tcl_ExternalToUtfDString(encoding, 
					 translateCharUTF8(STRING_ELT(val, i)),
					 -1, &s_ds);
	    Tcl_SetStringObj(elem, s, -1);
	    Tcl_DStringFree(&s_ds);
	    Tcl_ListObjAppendElement(RTcl_interp, tclobj, elem);
	}

    Tcl_FreeEncoding(encoding);
    SEXP res = makeRTclObject(tclobj);
    vmaxset(vmax);
    return res;
}
Esempio n. 20
0
static VTableDB *VTDBNew(void)
{
    VTableDB *vtdbP = (VTableDB *) ckalloc(sizeof(*vtdbP));
    vtdbP->sqliteP = NULL;
    vtdbP->vticP = NULL;
    vtdbP->dbcmd_objP = NULL;
    vtdbP->null_objP = Tcl_NewObj();
    Tcl_IncrRefCount(vtdbP->null_objP);
    vtdbP->nrefs = 0;
    return vtdbP;
}
Esempio n. 21
0
static int _get(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) {
  // return the current detimed string
  _t *dp = (_t *)clientData;
  // hmm, how to avoid the buffer here, allocate a byte array?
  unsigned n = ring_buffer_items_available_to_read(&dp->ring);
  // fprintf(stderr, "%s:%d %u bytes available\n", __FILE__, __LINE__, n);
  Tcl_Obj *result = Tcl_NewObj();
  char *buff = Tcl_SetByteArrayLength(result, n);
  ring_buffer_get(&dp->ring, n, buff);
  Tcl_SetObjResult(interp, result);
  return TCL_OK;
}
Esempio n. 22
0
static OSErr 
OpenLibraryResource(
    struct CFragInitBlock* initBlkPtr)
{
    /*
     * The 3.0 version of the Universal headers changed CFragInitBlock
     * to an opaque pointer type.  CFragSystem7InitBlock is now the
     * real pointer.
     */
     
#if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300)
    struct CFragInitBlock *realInitBlkPtr = initBlkPtr;
#else 
    CFragSystem7InitBlock *realInitBlkPtr = (CFragSystem7InitBlock *) initBlkPtr;
#endif
    FSSpec* fileSpec = NULL;
    OSErr err = noErr;
    

    if (realInitBlkPtr->fragLocator.where == kDataForkCFragLocator) {
    	fileSpec = realInitBlkPtr->fragLocator.u.onDisk.fileSpec;
    } else if (realInitBlkPtr->fragLocator.where == kResourceCFragLocator) {
    	fileSpec = realInitBlkPtr->fragLocator.u.inSegs.fileSpec;
    } else {
    	err = resFNotFound;
    }

    /*
     * Open the resource fork for this library in read-only mode.  
     * This will make it the current res file, ahead of the 
     * application's own resources.
     */
    
    if (fileSpec != NULL) {
	ourResFile = FSpOpenResFile(fileSpec, fsRdPerm);
	if (ourResFile == kResFileNotOpened) {
	    err = ResError();
	} else {
#ifdef TCL_REGISTER_LIBRARY
	    ourResToken = Tcl_NewObj();
	    Tcl_IncrRefCount(ourResToken);
	    p2cstr(realInitBlkPtr->libName);
	    Tcl_SetStringObj(ourResToken, (char *) realInitBlkPtr->libName, -1);
	    c2pstr((char *) realInitBlkPtr->libName);
	    TclMacRegisterResourceFork(ourResFile, ourResToken,
	            TCL_RESOURCE_DONT_CLOSE);
#endif
            SetResFileAttrs(ourResFile, mapReadOnly);
	}
    }
    
    return err;
}
Esempio n. 23
0
static int _return_list(Tcl_Interp *interp, const JSList *list) {
  Tcl_Obj *result = Tcl_NewObj();
  while (list != NULL) {
    if (Tcl_ListObjAppendElement(interp, result, _make_pointer(list->data)) != TCL_OK) {
      Tcl_DecrRefCount(result);
      return TCL_ERROR;
    } else {
      list = jack_slist_next(list);
    }
  }
  return fw_success_obj(interp, result);
}
Esempio n. 24
0
static Tcl_Obj *
convertFromUnknown (IUnknown *pUnknown, REFIID iid, Tcl_Interp *interp)
{
    if (pUnknown == 0) {
        return Tcl_NewObj();
    }

    const Interface *pInterface = InterfaceManager::instance().find(iid);
    return Extension::referenceHandles.newObj(
        interp,
        Reference::newReference(pUnknown, pInterface));
}
Esempio n. 25
0
static int
PlaceInfoCommand(
    Tcl_Interp *interp,		/* Interp into which to place result. */
    Tk_Window tkwin)		/* Token for the window to get info on. */
{
    Slave *slavePtr;
    Tcl_Obj *infoObj;

    slavePtr = FindSlave(tkwin);
    if (slavePtr == NULL) {
	return TCL_OK;
    }
    infoObj = Tcl_NewObj();
    if (slavePtr->masterPtr != NULL) {
	Tcl_AppendToObj(infoObj, "-in", -1);
	Tcl_ListObjAppendElement(NULL, infoObj,
		TkNewWindowObj(slavePtr->masterPtr->tkwin));
	Tcl_AppendToObj(infoObj, " ", -1);
    }
    Tcl_AppendPrintfToObj(infoObj,
	    "-x %d -relx %.4g -y %d -rely %.4g",
	    slavePtr->x, slavePtr->relX, slavePtr->y, slavePtr->relY);
    if (slavePtr->flags & CHILD_WIDTH) {
	Tcl_AppendPrintfToObj(infoObj, " -width %d", slavePtr->width);
    } else {
	Tcl_AppendToObj(infoObj, " -width {}", -1);
    }
    if (slavePtr->flags & CHILD_REL_WIDTH) {
	Tcl_AppendPrintfToObj(infoObj,
		" -relwidth %.4g", slavePtr->relWidth);
    } else {
	Tcl_AppendToObj(infoObj, " -relwidth {}", -1);
    }
    if (slavePtr->flags & CHILD_HEIGHT) {
	Tcl_AppendPrintfToObj(infoObj, " -height %d", slavePtr->height);
    } else {
	Tcl_AppendToObj(infoObj, " -height {}", -1);
    }
    if (slavePtr->flags & CHILD_REL_HEIGHT) {
	Tcl_AppendPrintfToObj(infoObj,
		" -relheight %.4g", slavePtr->relHeight);
    } else {
	Tcl_AppendToObj(infoObj, " -relheight {}", -1);
    }

    Tcl_AppendPrintfToObj(infoObj, " -anchor %s -bordermode %s",
	    Tk_NameOfAnchor(slavePtr->anchor),
	    borderModeStrings[slavePtr->borderMode]);
    Tcl_SetObjResult(interp, infoObj);
    return TCL_OK;
}
Esempio n. 26
0
//
// Return a list of ctable quote type names (cache it, too)
//
CTABLE_INTERNAL Tcl_Obj *ctable_quoteTypeList(Tcl_Interp *interp)
{
    static Tcl_Obj *result = NULL;

    if (!result) {
        int index;
	result = Tcl_NewObj();
        for(index = 0; ctable_quote_names[index]; index++) {
	    Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(ctable_quote_names[index], -1));
	}
	Tcl_IncrRefCount(result);
    }
    return result;
}
Esempio n. 27
0
void
TclpInitLibraryPath(
    char **valuePtr,
    int *lengthPtr,
    Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE	    64
    Tcl_Obj *pathPtr;
    char installLib[LIBRARY_SIZE];
    char *bytes;

    pathPtr = Tcl_NewObj();

    /*
     * Initialize the substring used when locating the script library. The
     * installLib variable computes the script library path relative to the
     * installed DLL.
     */

    sprintf(installLib, "lib/tcl%s", TCL_VERSION);

    /*
     * Look for the library relative to the TCL_LIBRARY env variable. If the
     * last dirname in the TCL_LIBRARY path does not match the last dirname in
     * the installLib variable, use the last dir name of installLib in
     * addition to the orginal TCL_LIBRARY path.
     */

    AppendEnvironment(pathPtr, installLib);

    /*
     * Look for the library in its default location.
     */

    Tcl_ListObjAppendElement(NULL, pathPtr,
	    TclGetProcessGlobalValue(&defaultLibraryDir));

    /*
     * Look for the library in its source checkout location.
     */

    Tcl_ListObjAppendElement(NULL, pathPtr,
	    TclGetProcessGlobalValue(&sourceLibraryDir));

    *encodingPtr = NULL;
    bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
    *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1);
    memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
    Tcl_DecrRefCount(pathPtr);
}
Esempio n. 28
0
/*
 *---------------------------------------------------------------------------
 *
 * HtmlImagePixmap --
 *
 * Results:
 *     Pixmap. Or zero.
 *
 * Side effects:
 *     May change the image storage to pixmap.
 *
 *---------------------------------------------------------------------------
 */
Pixmap
HtmlImagePixmap(HtmlImage2 *pImage)
{
    if (!pImage->pImageServer->pTree->options.imagepixmapify ||
        !pImage->pImageName ||
        !getImageCompressed(pImage) ||
        pImage->width<=0 ||
        pImage->height<=0
    ) {
        return 0;
    }
    if (!pImage->isValid) {
        HtmlImageImage(pImage);
    }
    if (!pImage->pixmap && !HtmlImageAlphaChannel(pImage)) {
        Tk_Window win = pImage->pImageServer->pTree->tkwin;
        Tcl_Interp *interp = pImage->pImageServer->pTree->interp;

        Pixmap pix;
        int rc;
        Tcl_Obj *pGetData;

#if 0
printf("Pixmapifying - nData = %d\n", nData);
#endif

        pix = Tk_GetPixmap(Tk_Display(win), Tk_WindowId(win),
            pImage->width, pImage->height, Tk_Depth(win)
        );
        Tk_RedrawImage(
            pImage->image, 0, 0, pImage->width, pImage->height, pix, 0, 0
        );

        pImage->pixmap = pix;

        pGetData = Tcl_NewObj();
        Tcl_IncrRefCount(pGetData);
        Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("image",-1));
        Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("create",-1));
        Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("photo",-1));
        Tcl_ListObjAppendElement(0, pGetData, pImage->pImageName);
        pImage->nIgnoreChange++;
        rc = Tcl_EvalObjEx(interp, pGetData, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
        pImage->nIgnoreChange--;
        Tcl_DecrRefCount(pGetData);
        assert(rc==TCL_OK);
    }
    return pImage->pixmap;
}
Esempio n. 29
0
/*
** This SQLite callback records the datatype of all columns.
**
** The pArg argument is really a pointer to a TCL interpreter.  The
** column names are inserted as the result of this interpreter.
**
** This routine returns non-zero which causes the query to abort.
*/
static int rememberDataTypes(void *pArg, int nCol, char **argv, char **colv){
  int i;
  Tcl_Interp *interp = (Tcl_Interp*)pArg;
  Tcl_Obj *pList, *pElem;
  if( colv[nCol+1]==0 ){
    return 1;
  }
  pList = Tcl_NewObj();
  for(i=0; i<nCol; i++){
    pElem = Tcl_NewStringObj(colv[i+nCol] ? colv[i+nCol] : "NULL", -1);
    Tcl_ListObjAppendElement(interp, pList, pElem);
  }
  Tcl_SetObjResult(interp, pList);
  return 1;
}
Esempio n. 30
0
static int
TestwinclockCmd(
    ClientData dummy,		/* Unused */
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Argument count */
    Tcl_Obj *const objv[])	/* Argument vector */
{
    static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
				/* The Posix epoch, expressed as a Windows
				 * FILETIME */
    Tcl_Time tclTime;		/* Tcl clock */
    FILETIME sysTime;		/* System clock */
    Tcl_Obj *result;		/* Result of the command */
    LARGE_INTEGER t1, t2;
    LARGE_INTEGER p1, p2;

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

    QueryPerformanceCounter(&p1);

    Tcl_GetTime(&tclTime);
    GetSystemTimeAsFileTime(&sysTime);
    t1.LowPart = posixEpoch.dwLowDateTime;
    t1.HighPart = posixEpoch.dwHighDateTime;
    t2.LowPart = sysTime.dwLowDateTime;
    t2.HighPart = sysTime.dwHighDateTime;
    t2.QuadPart -= t1.QuadPart;

    QueryPerformanceCounter(&p2);

    result = Tcl_NewObj();
    Tcl_ListObjAppendElement(interp, result,
	    Tcl_NewIntObj((int) (t2.QuadPart / 10000000)));
    Tcl_ListObjAppendElement(interp, result,
	    Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000)));
    Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec));
    Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec));

    Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart));
    Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart));

    Tcl_SetObjResult(interp, result);

    return TCL_OK;
}