Beispiel #1
0
void 
ParadynTkGUI::registerValidVisis (pdvector<VM_visiInfo> *via) {
  int i;
  int count;
  Tcl_DString namelist;
  Tcl_DString numlist;
  char num[8];

  count = via->size();  
  via->sort (compare_visi_names);
  Tcl_DStringInit(&namelist);
  Tcl_DStringInit(&numlist);
  
  for (i = 0; i < count; i++) {
    Tcl_DStringAppendElement(&namelist, (*via)[i].name.c_str());
    sprintf (num, "%d", ((*via)[i]).visiTypeId);
    Tcl_DStringAppendElement(&numlist, num);
  }
  Tcl_SetVar (interp, "vnames", Tcl_DStringValue(&namelist), 0);
  Tcl_SetVar (interp, "vnums", Tcl_DStringValue(&numlist), 0);
  Tcl_DStringFree (&namelist);
  Tcl_DStringFree (&numlist);
  sprintf (num, "%d", count);
  Tcl_SetVar (interp, "vcount", num, 0);
  delete via;
}
Beispiel #2
0
void
TnmSnmpDumpPDU(Tcl_Interp *interp, TnmSnmpPdu *pdu)
{
    if (hexdump) {

        int i, code, argc;
	const char **argv;
	char *name, *status;
	char buffer[80];
	Tcl_DString dst;
	Tcl_Channel channel;

	Tcl_DStringInit(&dst);

	name = TnmGetTableValue(tnmSnmpPDUTable, (unsigned) pdu->type);
	if (name == NULL) {
	    name = "(unknown PDU type)";
	}

	status = TnmGetTableValue(tnmSnmpErrorTable, (unsigned) pdu->errorStatus);
	if (status == NULL) {
	    status = "(unknown error code)";
	}
	
	if (pdu->type == ASN1_SNMP_GETBULK) {
	    sprintf(buffer, "%s %d non-repeaters %d max-repetitions %d\n", 
		    name, pdu->requestId,
		    pdu->errorStatus, pdu->errorIndex);
	} else if (pdu->type == ASN1_SNMP_TRAP1) {
	    sprintf(buffer, "%s\n", name);
	} else if (pdu->errorStatus == TNM_SNMP_NOERROR) {
	    sprintf(buffer, "%s %d %s\n", name, pdu->requestId, status);
	} else {
	    sprintf(buffer, "%s %d %s at %d\n", 
		    name, pdu->requestId, status, pdu->errorIndex);
	}

	Tcl_DStringAppend(&dst, buffer, -1);

	code = Tcl_SplitList(interp, Tcl_DStringValue(&pdu->varbind), 
			     &argc, &argv);
	if (code == TCL_OK) {
	    for (i = 0; i < argc; i++) {
		sprintf(buffer, "%4d.\t", i+1);
		Tcl_DStringAppend(&dst, buffer, -1);
		Tcl_DStringAppend(&dst, argv[i], -1);
		Tcl_DStringAppend(&dst, "\n", -1);
	    }
	    ckfree((char *) argv);
	}
	Tcl_ResetResult(interp);

	channel = Tcl_GetStdChannel(TCL_STDOUT);
	if (channel) {
	    Tcl_Write(channel,
		      Tcl_DStringValue(&dst), Tcl_DStringLength(&dst));
	}
	Tcl_DStringFree(&dst);
    }
}
Beispiel #3
0
static int
DoCopyFile(
    Tcl_DString *srcPtr,	/* Pathname of file to be copied (native). */
    Tcl_DString *dstPtr)	/* Pathname of file to copy to (native). */
{
    CONST TCHAR *nativeSrc, *nativeDst;

    nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
    nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);

    /*
     * Would throw an exception under NT if one of the arguments is a char
     * block device.
     */

    __try {
	if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
	    return TCL_OK;
	}
    } __except (-1) {}

    TclWinConvertError(GetLastError());
    if (Tcl_GetErrno() == EBADF) {
	Tcl_SetErrno(EACCES);
	return TCL_ERROR;
    }
    if (Tcl_GetErrno() == EACCES) {
	DWORD srcAttr, dstAttr;

	srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
	dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
	if (srcAttr != 0xffffffff) {
	    if (dstAttr == 0xffffffff) {
		dstAttr = 0;
	    }
	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
		Tcl_SetErrno(EISDIR);
	    }
	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
		(*tclWinProcs->setFileAttributesProc)(nativeDst, 
			dstAttr & ~FILE_ATTRIBUTE_READONLY);
		if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
		    return TCL_OK;
		}
		/*
		 * Still can't copy onto dst.  Return that error, and
		 * restore attributes of dst.
		 */

		TclWinConvertError(GetLastError());
		(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
	    }
	}
    }
    return TCL_ERROR;
}
Beispiel #4
0
static HRESULT
RegisterInterp(
    const char *name,
    RegisteredInterp *riPtr)
{
    HRESULT hr = S_OK;
    LPRUNNINGOBJECTTABLE pROT = NULL;
    LPMONIKER pmk = NULL;
    int i, offset;
    const char *actualName = name;
    Tcl_DString dString;
    Tcl_DStringInit(&dString);

    hr = GetRunningObjectTable(0, &pROT);
    if (SUCCEEDED(hr)) {
	offset = 0;
	for (i = 1; SUCCEEDED(hr); i++) {
	    if (i > 1) {
		if (i == 2) {
		    Tcl_DStringInit(&dString);
		    Tcl_DStringAppend(&dString, name, -1);
		    Tcl_DStringAppend(&dString, " #", 2);
		    offset = Tcl_DStringLength(&dString);
		    Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE);
		    actualName = Tcl_DStringValue(&dString);
		}
		sprintf(Tcl_DStringValue(&dString) + offset, "%d", i);
	    }

	    hr = BuildMoniker(actualName, &pmk);
	    if (SUCCEEDED(hr)) {

		hr = pROT->lpVtbl->Register(pROT,
		    ROTFLAGS_REGISTRATIONKEEPSALIVE,
		    riPtr->obj, pmk, &riPtr->cookie);

		pmk->lpVtbl->Release(pmk);
	    }

	    if (hr == MK_S_MONIKERALREADYREGISTERED) {
		pROT->lpVtbl->Revoke(pROT, riPtr->cookie);
	    } else if (hr == S_OK) {
		break;
	    }
	}

	pROT->lpVtbl->Release(pROT);
    }

    if (SUCCEEDED(hr)) {
	riPtr->name = strdup(actualName);
    }

    Tcl_DStringFree(&dString);
    return hr;
}
Beispiel #5
0
const char *
Tcl_GetEncodingNameFromEnvironment(
    Tcl_DString *bufPtr)
{
    Tcl_DStringInit(bufPtr);
    Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE);
    wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
    Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
    return Tcl_DStringValue(bufPtr);
}
int lexinput_tktext(char *buf, int max_size, int buf_size, void *index1, void *index2)
{
	int length, nbytes;
	Tcl_DString internal, temp;

	static int first = 1;
	static Tcl_DString external;
	static Tcl_Encoding encoding;

	if(first) {
		/* The lexers require ASCII encoding. */
		encoding = Tcl_GetEncoding(NULL, "ascii");
		if(encoding == NULL) {
			/* No ASCII encoding available. */
			return 0;
		}
		Tcl_DStringInit(&external);
		first = 0;
	}
	Tcl_DStringInit(&internal);

	if(Tcl_DStringLength(&external) == 0) {
		/* Translate the text to `external'. */
		if(tk_text_buffer(&internal, buf_size, index1, index2) > 0) {
			Tcl_UtfToExternalDString(encoding, Tcl_DStringValue(&internal), Tcl_DStringLength(&internal), &external);
		} else {
			return 0;
		}
	}

	/* Fill up the user-provided buffer as much as possible. */
	length = Tcl_DStringLength(&external);
	nbytes = (length > max_size) ? max_size : length;
	memcpy(buf, Tcl_DStringValue(&external), nbytes);

	/* I wish DStrings had a copy constructor. In fact, sometimes I wish
	 Tcl was written in C++. */
	if(length > nbytes) {
		Tcl_DStringInit(&temp);
		Tcl_DStringAppend(&temp, Tcl_DStringValue(&external) + nbytes, length - nbytes);
		Tcl_DStringFree(&external);
		Tcl_DStringInit(&external);
		Tcl_DStringAppend(&external, Tcl_DStringValue(&temp), Tcl_DStringLength(&temp));
		Tcl_DStringFree(&temp);
	} else {
		Tcl_DStringFree(&external);
		Tcl_DStringInit(&external);
	}

	/* Clean up. */
	Tcl_DStringFree(&internal);

	return nbytes;
}
int init_emboss_graph_create(Tcl_Interp *interp, 
			     int seq_id, 
			     int start, 
			     int end,
			     char *filename,
			     Tcl_Obj **graph_obj,
			     int *id)
{
    int seq_num, seq_len;
    in_emboss *input;
    Tcl_DString input_params;
    text_emboss *text_data;

    e_graph *data = NULL;

    seq_num = GetSeqNum(seq_id);
    seq_len = GetSeqLength(seq_num);

    /* if the end has not been defined, set it to be the sequence length */
    if (end == -1) {
	end = seq_len;
    }
    seq_len = end - start + 1;

    if (NULL == (input = (in_emboss *)xmalloc (sizeof(in_emboss))))
	return -1;

    read_emboss_data_file(filename, &data, graph_obj, &text_data);
    if (!data) {
	verror(ERR_FATAL,"emboss", "error in reading results\n");
	return -1;
    }

    /* create inputs parameters */
    Tcl_DStringInit(&input_params);
    vTcl_DStringAppend(&input_params, "sequence %s: from %d to %d\n",
		       GetSeqName(seq_num), start, end);

    vfuncparams("%s", Tcl_DStringValue(&input_params));
    input->params = strdup(Tcl_DStringValue(&input_params)); 
    Tcl_DStringFree(&input_params);

    if (-1 == (*id = store_emboss_graph(seq_num, start, end, data, input, 
					text_data, graph_obj))) {
	verror(ERR_FATAL,"emboss", "error in saving results\n");
	return -1;
    }
    xfree(data);
    return 0;
}
Beispiel #8
0
ClientData
TclNativeCreateNativeRep(
    Tcl_Obj *pathPtr)
{
    char *nativePathPtr;
    const char *str;
    Tcl_DString ds;
    Tcl_Obj *validPathPtr;
    size_t len;

    if (TclFSCwdIsNative()) {
	/*
	 * The cwd is native, which means we can use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}
	Tcl_IncrRefCount(validPathPtr);
    }

    str = TclGetString(validPathPtr);
    len = validPathPtr->length;
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    len = Tcl_DStringLength(&ds) + sizeof(char);
    if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
	/* See bug [3118489]: NUL in filenames */
	Tcl_DecrRefCount(validPathPtr);
	Tcl_DStringFree(&ds);
	return NULL;
    }
    Tcl_DecrRefCount(validPathPtr);
    nativePathPtr = ckalloc(len);
    memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);

    Tcl_DStringFree(&ds);
    return nativePathPtr;
}
Beispiel #9
0
static void expandPercentsEval(Tcl_Interp * interp,	/* interpreter context */
			       register char *before,	/* Command with percent expressions */
			       char *r,	/* vgpaneHandle string to substitute for "%r" */
			       int npts,	/* number of coordinates */
			       point * ppos	/* Cordinates to substitute for %t */
    )
{
    register char *string;
    Tcl_DString scripts;

    Tcl_DStringInit(&scripts);
    while (1) {
	/*
	 * Find everything up to the next % character and append it to the
	 * result string.
	 */

	for (string = before; (*string != 0) && (*string != '%'); string++) {
	    /* Empty loop body. */
	}
	if (string != before) {
	    Tcl_DStringAppend(&scripts, before, string - before);
	    before = string;
	}
	if (*before == 0) {
	    break;
	}
	/*
	 * There's a percent sequence here.  Process it.
	 */

	switch (before[1]) {
	case 'r':
	    Tcl_DStringAppend(&scripts, r, strlen(r));	/* vgcanvasHandle */
	    break;
	case 't':
	    dgsprintxy(&scripts, npts, ppos);
	    break;
	default:
	    Tcl_DStringAppend(&scripts, before + 1, 1);
	    break;
	}
	before += 2;
    }
    if (Tcl_GlobalEval(interp, Tcl_DStringValue(&scripts)) != TCL_OK)
	fprintf(stderr, "%s while in binding: %s\n\n",
		Tcl_GetStringResult(interp), Tcl_DStringValue(&scripts));
    Tcl_DStringFree(&scripts);
}
Beispiel #10
0
int ScriptTcl::Tcl_replicaSendrecv(ClientData, Tcl_Interp *interp, int argc, char **argv) {
  if ( argc < 3 || argc > 4 ) {
    Tcl_SetResult(interp,"args: data dest ?source?",TCL_VOLATILE);
    return TCL_ERROR;
  }
  Tcl_DString recvstr;
  Tcl_DStringInit(&recvstr);
  int sendcount = strlen(argv[1]);
  int recvcount = 0;
  int dest = atoi(argv[2]);
  int source = -1;
  if ( argc > 3 ) source = atoi(argv[3]);
#if CMK_HAS_PARTITION
  if (dest == CmiMyPartition()) {
    Tcl_DStringSetLength(&recvstr,sendcount);
    memcpy(Tcl_DStringValue(&recvstr),argv[1],sendcount);
  } else {
    DataMessage *recvMsg = NULL;
    replica_sendRecv(argv[1], sendcount, dest, CkMyPe(), &recvMsg, source, CkMyPe());
    CmiAssert(recvMsg != NULL);
    Tcl_DStringAppend(&recvstr, recvMsg->data, recvMsg->size);
    CmiFree(recvMsg);
  }
#endif
  Tcl_DStringResult(interp, &recvstr);
  Tcl_DStringFree(&recvstr);
  return TCL_OK;
}
Beispiel #11
0
/* compare two Tcl_DStrings */
int
TSP_Util_string_compare(Tcl_DString* s1, Tcl_DString* s2) {
    char* string2;
    int length2;

    return TSP_Util_string_compare_const(s1, Tcl_DStringValue(s2), Tcl_DStringLength(s2));
}
Beispiel #12
0
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;
}
Beispiel #13
0
/*
 *----------------------------------------------------------------------
 *
 * Nsf_PointerAdd --
 *
 *      Add an entry to our locally maintained hash table and set its
 *      value to the provided valuePtr. The keys are generated based on
 *      the passed type and the counter obtained from the type
 *      registration.
 *
 * Results:
 *      Tcl result code
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
int
Nsf_PointerAdd(Tcl_Interp *interp, char *buffer, size_t size, const char *typeName, void *valuePtr) {
  int *counterPtr;

  nonnull_assert(interp != NULL);
  nonnull_assert(buffer != NULL);
  nonnull_assert(typeName != NULL);
  nonnull_assert(valuePtr != NULL);

  counterPtr = Nsf_PointerTypeLookup(typeName);
  if (counterPtr != NULL) {
    Tcl_DString    ds, *dsPtr = &ds;
    Tcl_HashEntry *hPtr;
    int            isNew;

    Tcl_DStringInit(dsPtr);
    Tcl_DStringAppend(dsPtr, typeName, -1);
    Tcl_DStringAppend(dsPtr, ":%d", 3);
    NsfMutexLock(&pointerMutex);
    snprintf(buffer, size, Tcl_DStringValue(dsPtr), (*counterPtr)++);
    hPtr = Tcl_CreateHashEntry(pointerHashTablePtr, buffer, &isNew);
    NsfMutexUnlock(&pointerMutex);
    Tcl_SetHashValue(hPtr, valuePtr);
    /*fprintf(stderr, "Nsf_PointerAdd key '%s' prefix '%s' => %p value %p\n", buffer, typeName, hPtr, valuePtr);*/

    Tcl_DStringFree(dsPtr);
  } else {
    return NsfPrintError(interp, "no type converter for %s registered", typeName);
  }
  return TCL_OK;
}
Beispiel #14
0
/*
** Usage:  sqlite_exec_printf  DB  FORMAT  STRING
**
** Invoke the sqlite_exec_printf() interface using the open database
** DB.  The SQL is the string FORMAT.  The format string should contain
** one %s or %q.  STRING is the value inserted into %s or %q.
*/
static int test_exec_printf(
  void *NotUsed,
  Tcl_Interp *interp,    /* The TCL interpreter that invoked this command */
  int argc,              /* Number of arguments */
  char **argv            /* Text of each argument */
){
  sqlite *db;
  Tcl_DString str;
  int rc;
  char *zErr = 0;
  char zBuf[30];
  if( argc!=4 ){
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 
       " DB FORMAT STRING", 0);
    return TCL_ERROR;
  }
  if( getDbPointer(interp, argv[1], &db) ) return TCL_ERROR;
  Tcl_DStringInit(&str);
  rc = sqlite_exec_printf(db, argv[2], exec_printf_cb, &str, &zErr, argv[3]);
  sprintf(zBuf, "%d", rc);
  Tcl_AppendElement(interp, zBuf);
  Tcl_AppendElement(interp, rc==SQLITE_OK ? Tcl_DStringValue(&str) : zErr);
  Tcl_DStringFree(&str);
  if( zErr ) free(zErr);
  return TCL_OK;
}
Tcl_PackageInitProc *
TclpFindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    CONST char *symbol)
{
    Tcl_DString newName;
    Tcl_PackageInitProc *proc = NULL;
    shl_t handle = (shl_t)loadHandle;

    /*
     * Some versions of the HP system software still use "_" at the beginning
     * of exported symbols while others don't; try both forms of each name.
     */

    if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE,
	    (void *) &proc) != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, symbol, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    return proc;
}
Beispiel #16
0
static int
TraversalDelete( 
    Tcl_DString *srcPtr,	/* Source pathname to delete. */
    Tcl_DString *dstPtr,	/* Not used. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    TCHAR *nativeSrc;

    switch (type) {
	case DOTREE_F: {
	    if (DoDeleteFile(srcPtr) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
	case DOTREE_PRED: {
	    return TCL_OK;
	}
	case DOTREE_POSTD: {
	    if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
    }

    if (errorPtr != NULL) {
	nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
	Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
    }
    return TCL_ERROR;
}
Beispiel #17
0
long int
rde_ot_intern2 (RDE_STATE p,
		const char* operator,
		Tcl_Obj* detail1,
		Tcl_Obj* detail2)
{
    long int id;
    Tcl_DString buf;

    TRACE (("rde_ot_intern2 (%p, '%s' %p = '%s', %p = '%s')", p, operator,
	    detail1, Tcl_GetString(detail1)
	    detail2, Tcl_GetString(detail2)));
    if (IsCached (p, detail1, &id)) {
	return id;
    }

    TRACE (("INTERNALIZE"));

    /* Create a list of operator + detail1 + detail2.
     * Using a DString.
     */

    Tcl_DStringInit (&buf);
    Tcl_DStringAppendElement (&buf, operator);
    Tcl_DStringAppendElement (&buf, Tcl_GetString (detail1));
    Tcl_DStringAppendElement (&buf, Tcl_GetString (detail2));

    id = Make (p, detail1, Tcl_DStringValue (&buf));

    Tcl_DStringFree (&buf);
    return id;
}
Beispiel #18
0
char *
TclpReadlink(
    const char *path,		/* Path of file to readlink (UTF-8). */
    Tcl_DString *linkPtr)	/* Uninitialized or free DString filled with
				 * contents of link (UTF-8). */
{
#ifndef DJGPP
    char link[MAXPATHLEN];
    int length;
    const char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
    length = readlink(native, link, sizeof(link));	/* INTL: Native. */
    Tcl_DStringFree(&ds);

    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
#else
    return NULL;
#endif /* !DJGPP */
}
Beispiel #19
0
void
XOTclProfileFillTable(Tcl_HashTable* table, Tcl_DString* key,
		 double totalMicroSec) {
  Tcl_HashEntry* hPtr;
  char* keyStr = Tcl_DStringValue(key);
  long int* value;

  hPtr = Tcl_FindHashEntry(table, keyStr);
  if (!hPtr) {
    int nw;
    hPtr = Tcl_CreateHashEntry(table, keyStr, &nw);
    if (!nw)
      return;
    value = (long int*) ckalloc (sizeof(long int));
    *value = 0;
    Tcl_SetHashValue(hPtr, (ClientData) value);
  } else
    value = (long int*) Tcl_GetHashValue (hPtr);

  *value += totalMicroSec;


  /* {
    long int* d = (long int*) Tcl_GetHashValue (hPtr);
    fprintf(stderr, "Entered %s ... %ld\n", Tcl_GetHashKey(table, hPtr), *d);
    }*/

}
const char *
TclGetEnv(
    const char *name,		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr)	/* Uninitialized or free DString in which the
				 * value of the environment variable is
				 * stored. */
{
    int length, index;
    const char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);
    result = NULL;
    if (index != -1) {
	Tcl_DString envStr;

	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, -1);
	    result = Tcl_DStringValue(valuePtr);
	} else {
	    result = NULL;
	}
	Tcl_DStringFree(&envStr);
    }
    Tcl_MutexUnlock(&envMutex);
    return result;
}
Beispiel #21
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;
}
Beispiel #22
0
static void StateSpecUpdateString(Tcl_Obj *objPtr)
{
    unsigned int onbits = (objPtr->internalRep.longValue & 0xFFFF0000) >> 16;
    unsigned int offbits = objPtr->internalRep.longValue & 0x0000FFFF;
    unsigned int mask = onbits | offbits;
    Tcl_DString result;
    int i, len;

    Tcl_DStringInit(&result);

    for (i=0; stateNames[i] != NULL; ++i) {
	if (mask & (1<<i)) {
	    if (offbits & (1<<i))
		Tcl_DStringAppend(&result, "!", 1);
	    Tcl_DStringAppend(&result, stateNames[i], -1);
	    Tcl_DStringAppend(&result, " ", 1);
	}
    }

    len = Tcl_DStringLength(&result);
    if (len) {
	/* 'len' includes extra trailing ' ' */
	objPtr->bytes = Tcl_Alloc((unsigned)len);
	objPtr->length = len-1;
	strncpy(objPtr->bytes, Tcl_DStringValue(&result), (size_t)len-1);
	objPtr->bytes[len-1] = '\0';
    } else {
	/* empty string */
	objPtr->length = 0;
	objPtr->bytes = Tcl_Alloc(1);
	*objPtr->bytes = '\0';
    }

    Tcl_DStringFree(&result);
}
Beispiel #23
0
static NSVGimage *
GetCachedSVG(
    Tcl_Interp *interp,
    ClientData dataOrChan,
    Tcl_Obj *formatObj,
    RastOpts *ropts)
{
    int length;
    const char *data;
    NSVGcache *cachePtr = GetCachePtr(interp);
    NSVGimage *nsvgImage = NULL;

    if ((cachePtr != NULL) && (cachePtr->nsvgImage != NULL) &&
	(cachePtr->dataOrChan == dataOrChan)) {
        if (formatObj != NULL) {
	    data = Tcl_GetStringFromObj(formatObj, &length);
	    if (strcmp(data, Tcl_DStringValue(&cachePtr->formatString)) == 0) {
	        nsvgImage = cachePtr->nsvgImage;
		*ropts = cachePtr->ropts;
		cachePtr->nsvgImage = NULL;
	    }
	} else if (Tcl_DStringLength(&cachePtr->formatString) == 0) {
	    nsvgImage = cachePtr->nsvgImage;
	    *ropts = cachePtr->ropts;
	    cachePtr->nsvgImage = NULL;
	}
    }
    CleanCache(interp);
    return nsvgImage;
}
Beispiel #24
0
const char *
TkpGetString(
    TkWindow *winPtr,		/* Window where event occurred: needed to get
				 * input context. */
    XEvent *eventPtr,		/* X keyboard event. */
    Tcl_DString *dsPtr)		/* Uninitialized or empty string to hold
				 * result. */
{
    XKeyEvent *keyEv = &eventPtr->xkey;

    Tcl_DStringInit(dsPtr);
    if (keyEv->send_event == -1) {
	if (keyEv->nbytes > 0) {
	    Tcl_ExternalToUtfDString(TkWinGetKeyInputEncoding(),
		    keyEv->trans_chars, keyEv->nbytes, dsPtr);
	}
    } else if (keyEv->send_event == -2) {
	/*
	 * Special case for win2000 multi-lingal IME input. xkey.trans_chars[]
	 * already contains a UNICODE char.
	 */

	int unichar;
	char buf[TCL_UTF_MAX];
	int len;

	unichar = keyEv->trans_chars[1] & 0xff;
	unichar <<= 8;
	unichar |= keyEv->trans_chars[0] & 0xff;

	len = Tcl_UniCharToUtf((Tcl_UniChar) unichar, buf);

	Tcl_DStringAppend(dsPtr, buf, len);
    } else if (keyEv->send_event == -3) {
	/*
	 * Special case for WM_UNICHAR. xkey.trans_chars[] already contains a
	 * UTF-8 char.
	 */

	Tcl_DStringAppend(dsPtr, keyEv->trans_chars, keyEv->nbytes);
    } else {
	/*
	 * This is an event generated from generic code. It has no nchars or
	 * trans_chars members.
	 */

	KeySym keysym = KeycodeToKeysym(keyEv->keycode, keyEv->state, 0);

	if (((keysym != NoSymbol) && (keysym > 0) && (keysym < 256))
		|| (keysym == XK_Return) || (keysym == XK_Tab)) {
	    char buf[TCL_UTF_MAX];
	    int len;

	    len = Tcl_UniCharToUtf((Tcl_UniChar) (keysym & 255), buf);
	    Tcl_DStringAppend(dsPtr, buf, len);
	}
    }
    return Tcl_DStringValue(dsPtr);
}
Beispiel #25
0
static int 
TraversalCopy(
    Tcl_DString *srcPtr,	/* Source pathname to copy. */
    Tcl_DString *dstPtr,	/* Destination pathname of copy. */
    int type,			/* Reason for call - see TraverseWinTree() */
    Tcl_DString *errorPtr)	/* If non-NULL, initialized DString filled
				 * with UTF-8 name of file causing error. */
{
    TCHAR *nativeDst, *nativeSrc;
    DWORD attr;

    switch (type) {
	case DOTREE_F: {
	    if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) {
		return TCL_OK;
	    }
	    break;
	}
	case DOTREE_PRED: {
	    if (DoCreateDirectory(dstPtr) == TCL_OK) {
		nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
		nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
		attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
		if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
		    return TCL_OK;
		}
		TclWinConvertError(GetLastError());
	    }
	    break;
	}
        case DOTREE_POSTD: {
	    return TCL_OK;
	}
    }

    /*
     * There shouldn't be a problem with src, because we already
     * checked it to get here.
     */

    if (errorPtr != NULL) {
	nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
	Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
    }
    return TCL_ERROR;
}
Beispiel #26
0
/*
 * Further on, in UNICODE mode, we need to use Tcl_NewUnicodeObj,
 * while otherwise NewNativeObj is needed (which provides proper
 * conversion from native encoding to UTF-8).
 */
#ifdef UNICODE
#   define NewNativeObj Tcl_NewUnicodeObj
#else /* !UNICODE */
    static Tcl_Obj *NewNativeObj(char *string, int length) {
	Tcl_Obj *obj;
	Tcl_DString ds;
	Tcl_ExternalToUtfDString(NULL, string, length, &ds);
	obj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	return obj;
}
Beispiel #27
0
Tcl_Obj *Tcl_NewWStringObj(const wchar_t *str)
{
	Tcl_DString ds;
	Tcl_WinTCharToUtf(str, -1, &ds);
	Tcl_Obj *result = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	Tcl_DStringFree(&ds);
	return result;
};
Beispiel #28
0
/* assign a var from an string */
Tcl_Obj*
TSP_Util_lang_assign_var_string(Tcl_Obj* targetVarName, Tcl_DString* sourceVarName) {
    if (targetVarName != NULL) {
        Tcl_DecrRefCount(targetVarName);
    }
    targetVarName = Tcl_NewStringObj(Tcl_DStringValue(sourceVarName), Tcl_DStringLength(sourceVarName));
    Tcl_IncrRefCount(targetVarName);
    return targetVarName;
}
Beispiel #29
0
/* convert to an int from a string */
int
TSP_Util_lang_convert_int_string(Tcl_Interp* interp, Tcl_DString* sourceVarName, Tcl_WideInt* targetVarName) {
    int rc;
    Tcl_Obj* obj = Tcl_NewStringObj(Tcl_DStringValue(sourceVarName), Tcl_DStringLength(sourceVarName));
    Tcl_IncrRefCount(obj);
    rc = Tcl_GetWideIntFromObj(interp, obj, targetVarName);
    Tcl_DecrRefCount(obj);
    return rc;
}
Beispiel #30
0
Tcl_Obj *Tcl_NewGuidObj(const GUID& Guid)
{
	wchar_t guidstr[37];
	FSF.sprintf(guidstr,L"%08x-%04x-%04x-%02x%02x-%02x%02x%02x%02x%02x%02x",Guid.Data1,Guid.Data2,Guid.Data3,Guid.Data4[0],Guid.Data4[1],Guid.Data4[2],Guid.Data4[3],Guid.Data4[4],Guid.Data4[5],Guid.Data4[6],Guid.Data4[7]);
	Tcl_DString ds;
	Tcl_WinTCharToUtf(guidstr, -1, &ds);
	Tcl_Obj *result = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	Tcl_DStringFree(&ds);
	return result;
};