/*-----------------------------------------------------------------------------
* ReturnStatList --
*
* Return file stat infomation as a keyed list.
*
* Parameters:
* o interp (I) - The list is returned in result.
* o ttyDev (O) - A boolean indicating if the device is associated with a
* tty.
* o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
*-----------------------------------------------------------------------------
*/
static void
ReturnStatList (Tcl_Interp *interp, int ttyDev, struct stat *statBufPtr)
{
Tcl_Obj *keylPtr = TclX_NewKeyedListObj ();
TclX_KeyedListSet (interp, keylPtr, "atime",
Tcl_NewLongObj ((long) statBufPtr->st_atime));
TclX_KeyedListSet (interp, keylPtr, "ctime",
Tcl_NewLongObj ((long) statBufPtr->st_ctime));
TclX_KeyedListSet (interp, keylPtr, "dev",
Tcl_NewIntObj ((int) statBufPtr->st_dev));
TclX_KeyedListSet (interp, keylPtr, "gid",
Tcl_NewIntObj ((int) statBufPtr->st_gid));
TclX_KeyedListSet (interp, keylPtr, "ino",
Tcl_NewIntObj ((int) statBufPtr->st_ino));
TclX_KeyedListSet (interp, keylPtr, "mode",
Tcl_NewIntObj ((int) statBufPtr->st_mode));
TclX_KeyedListSet (interp, keylPtr, "mtime",
Tcl_NewLongObj ((long) statBufPtr->st_mtime));
TclX_KeyedListSet (interp, keylPtr, "nlink",
Tcl_NewIntObj ((int) statBufPtr->st_nlink));
TclX_KeyedListSet (interp, keylPtr, "size",
Tcl_NewLongObj ((long) statBufPtr->st_size));
TclX_KeyedListSet (interp, keylPtr, "uid",
Tcl_NewIntObj ((int) statBufPtr->st_uid));
TclX_KeyedListSet (interp, keylPtr, "tty",
Tcl_NewBooleanObj (ttyDev));
TclX_KeyedListSet (interp, keylPtr, "type",
Tcl_NewStringObj (StrFileType (statBufPtr), -1));
Tcl_SetObjResult (interp, keylPtr);
}
/*************************************************************************
* FUNCTION : RPMPRoblem_Obj::Get_part *
* ARGUMENTS : enum of part to get *
* RETURNS : part as a Tcl_Obj with a 0 refcount *
* EXCEPTIONS : none *
* PURPOSE : Get a part of the problem report *
*************************************************************************/
Tcl_Obj *RPMPRoblem_Obj::Get_part(PARTS x)
{
switch (x)
{
case PACKAGE:
return Tcl_NewStringObj(problem.pkgNEVR?problem.pkgNEVR:"",-1);
case ALT:
return Tcl_NewStringObj(problem.altNEVR?problem.altNEVR:"",-1);
case KEY:
return Tcl_NewLongObj((long)problem.key);
case TYPE:
return Tcl_NewStringObj(Prob_to_string(problem.type),-1);
case IGNORE:
return Tcl_NewIntObj(problem.ignoreProblem);
case STRING:
return Tcl_NewStringObj(problem.str1?problem.str1:"",-1);
case INT:
return Tcl_NewLongObj(problem.ulong1);
}
return 0;
}
static int _get(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) {
if (argc != 2)
return fw_error_obj(interp, Tcl_ObjPrintf("usage: %s get", Tcl_GetString(objv[0])));
_t *data = (_t *)clientData;
if ( ! data->started)
return fw_error_obj(interp, Tcl_ObjPrintf("audio-tap %s is not running", Tcl_GetString(objv[0])));
// figure out where to read from
while (1) {
// start with no choice
buffer_t *choice = NULL;
// look for the oldest unread buffer
for (int i = 0; i < data->buff_n; i += 1)
if ( ! data->buffs[i].bread && (choice == NULL || choice->bframe > data->buffs[i].bframe))
choice = &data->buffs[i];
// if nothing was found, return an empty string
if (choice == NULL) {
Tcl_Obj *result[] = { Tcl_NewLongObj(0), Tcl_NewStringObj("", -1), NULL };
return fw_success_obj(interp, Tcl_NewListObj(2, result));
}
// attempt to grab the choice
Tcl_IncrRefCount(choice->buff);
// if it's now marked as read, then the process callback grabbed it
// loop back and try again
if (choice->bread) {
Tcl_DecrRefCount(choice->buff);
continue;
}
// it's ours now that the ref count incremented
Tcl_Obj *result[] = { Tcl_NewLongObj(choice->bframe), choice->buff, NULL };
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
Tcl_DecrRefCount(choice->buff);
choice->bread = 1;
return TCL_OK;
}
}
/*-----------------------------------------------------------------------------
* ReturnStatItem --
*
* Return a single file status item.
*
* Parameters:
* o interp (I) - Item or error returned in result.
* o channel (I) - Channel the file is assoicated with.
* o ttyDev (O) - A boolean indicating if the device is associated with a
* tty.
* o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
* o itemName (I) - The name of the desired item.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
ReturnStatItem (Tcl_Interp *interp,
Tcl_Channel channel,
int ttyDev,
struct stat *statBufPtr,
char *itemName)
{
Tcl_Obj *objPtr;
if (STREQU (itemName, "dev"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_dev);
else if (STREQU (itemName, "ino"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_ino);
else if (STREQU (itemName, "mode"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_mode);
else if (STREQU (itemName, "nlink"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_nlink);
else if (STREQU (itemName, "uid"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_uid);
else if (STREQU (itemName, "gid"))
objPtr = Tcl_NewIntObj ((int) statBufPtr->st_gid);
else if (STREQU (itemName, "size"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_size);
else if (STREQU (itemName, "atime"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_atime);
else if (STREQU (itemName, "mtime"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_mtime);
else if (STREQU (itemName, "ctime"))
objPtr = Tcl_NewLongObj ((long) statBufPtr->st_ctime);
else if (STREQU (itemName, "type"))
objPtr = Tcl_NewStringObj (StrFileType (statBufPtr), -1);
else if (STREQU (itemName, "tty"))
objPtr = Tcl_NewBooleanObj (ttyDev);
else if (STREQU (itemName, "remotehost")) {
objPtr = TclXGetHostInfo (interp, channel, TRUE);
if (objPtr == NULL)
return TCL_ERROR;
} else if (STREQU (itemName, "localhost")) {
objPtr = TclXGetHostInfo (interp, channel, FALSE);
if (objPtr == NULL)
return TCL_ERROR;
} else {
TclX_AppendObjResult (interp, "Got \"", itemName,
"\", expected one of ",
"\"atime\", \"ctime\", \"dev\", \"gid\", ",
"\"ino\", \"mode\", \"mtime\", \"nlink\", ",
"\"size\", \"tty\", \"type\", \"uid\", ",
"\"remotehost\", or \"localhost\"",
(char *) NULL);
return TCL_ERROR;
}
Tcl_SetObjResult (interp, objPtr);
return TCL_OK;
}
/*************************************************************************
* 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;
}
static int
TestgetwindowinfoObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
long hwnd;
Tcl_Obj *dictObj = NULL, *classObj = NULL, *textObj = NULL;
Tcl_Obj *childrenObj = NULL;
TCHAR buf[512];
int cch, cchBuf = 256;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "hwnd");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[1], &hwnd) != TCL_OK)
return TCL_ERROR;
cch = GetClassName(INT2PTR(hwnd), buf, cchBuf);
if (cch == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to get class name: ", -1));
AppendSystemError(interp, GetLastError());
return TCL_ERROR;
} else {
Tcl_DString ds;
Tcl_WinTCharToUtf(buf, -1, &ds);
classObj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
dictObj = Tcl_NewDictObj();
Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("class", 5), classObj);
Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("id", 2),
Tcl_NewLongObj(GetWindowLongA(INT2PTR(hwnd), GWL_ID)));
cch = GetWindowText(INT2PTR(hwnd), (LPTSTR)buf, cchBuf);
textObj = Tcl_NewUnicodeObj((LPCWSTR)buf, cch);
Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("text", 4), textObj);
Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("parent", 6),
Tcl_NewLongObj(PTR2INT(GetParent((INT2PTR(hwnd))))));
childrenObj = Tcl_NewListObj(0, NULL);
EnumChildWindows(INT2PTR(hwnd), EnumChildrenProc, (LPARAM)childrenObj);
Tcl_DictObjPut(interp, dictObj, Tcl_NewStringObj("children", -1), childrenObj);
Tcl_SetObjResult(interp, dictObj);
return TCL_OK;
}
turbine_code turbine_run_string(MPI_Comm comm, const char* script,
int argc, const char** argv, char* output,
Tcl_Interp* interp)
{
bool created_interp = false;
if (interp == NULL)
{
// Create Tcl interpreter:
interp = Tcl_CreateInterp();
Tcl_Init(interp);
created_interp = true;
}
if (comm != MPI_COMM_NULL)
{
// Store communicator pointer in Tcl variable for turbine::init
MPI_Comm* comm_ptr = &comm;
Tcl_Obj* TURBINE_ADLB_COMM =
Tcl_NewStringObj("TURBINE_ADLB_COMM", -1);
Tcl_Obj* adlb_comm_ptr = Tcl_NewLongObj((long) comm_ptr);
Tcl_ObjSetVar2(interp, TURBINE_ADLB_COMM, NULL, adlb_comm_ptr, 0);
}
// Render argc/argv for Tcl
turbine_tcl_set_integer(interp, "argc", argc);
Tcl_Obj* argv_obj = Tcl_NewStringObj("argv", -1);
Tcl_Obj* argv_val_obj;
if (argc > 0)
argv_val_obj = turbine_tcl_list_new(argc, argv);
else
argv_val_obj = Tcl_NewStringObj("", 0);
Tcl_ObjSetVar2(interp, argv_obj, NULL, argv_val_obj, 0);
if (output != NULL)
turbine_tcl_set_wideint(interp, "turbine_run_output",
(ptrdiff_t) output);
// Run the user script
int rc = Tcl_Eval(interp, script);
// Check for errors
if (rc != TCL_OK)
{
Tcl_Obj* error_dict = Tcl_GetReturnOptions(interp, rc);
Tcl_Obj* error_info = Tcl_NewStringObj("-errorinfo", -1);
Tcl_Obj* error_msg;
Tcl_DictObjGet(interp, error_dict, error_info, &error_msg);
char* msg_string = Tcl_GetString(error_msg);
printf("turbine_run(): Tcl error: %s\n", msg_string);
return TURBINE_ERROR_UNKNOWN;
}
if (created_interp)
{
// Clean up
Tcl_DeleteInterp(interp);
}
return TURBINE_SUCCESS;
}
static int
rcSeek (ClientData cd_, long offset, int seekMode, int* errorCodePtr)
{
ReflectingChannel* chan = (ReflectingChannel*) cd_;
int n = -1;
Tcl_SavedResult sr;
Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_seek);
Tcl_Interp* ip = chan->_interp;
Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewLongObj(offset));
Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(seekMode));
Tcl_SaveResult(ip, &sr);
if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK &&
Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK)
chan->_watchMask = chan->_validMask;
Tcl_RestoreResult(ip, &sr);
Tcl_DecrRefCount(cmd);
if (n < 0)
*errorCodePtr = EINVAL;
return n;
}
static Tcl_Obj*
getObject(const QVariant& v)
{
Tcl_Obj* value;
QString text;
switch (v.type()) {
case QVariant::Int:
case QVariant::UInt:
value = Tcl_NewLongObj(v.toInt());
break;
case QVariant::Bool:
value = Tcl_NewBooleanObj(v.toBool());
break;
case QVariant::Double:
value = Tcl_NewDoubleObj(v.toDouble());
break;
case QVariant::Date:
text = v.toDate().toString(Qt::ISODate);
value = Tcl_NewStringObj(text.utf8(), text.utf8().length());
break;
default:
text = v.toString();
value = Tcl_NewStringObj(text.utf8(), text.utf8().length());
break;
}
Tcl_IncrRefCount(value);
return value;
}
/* ARGSUSED */
int
TclCreateThread(
Tcl_Interp *interp, /* Current interpreter. */
char *script, /* Script to execute */
int joinable) /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
Tcl_ThreadId id;
ctrl.script = script;
ctrl.condWait = NULL;
ctrl.flags = 0;
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
ckfree((char *) ctrl.script);
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using something on our stack!
*/
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_PidObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
int i;
Tcl_Obj *resultPtr, *longObjPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
} else {
/*
* Get the channel and make sure that it refers to a pipe.
*/
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
if (Tcl_GetChannelType(chan) != &pipeChannelType) {
return TCL_OK;
}
/*
* Extract the process IDs from the pipe structure.
*/
pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
int
Turbine_TaskComm_Cmd(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
TCL_ARGS(1);
Tcl_Obj* result = Tcl_NewLongObj(turbine_task_comm);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
static BOOL CALLBACK
EnumChildrenProc(
HWND hwnd,
LPARAM lParam)
{
Tcl_Obj *listObj = (Tcl_Obj *) lParam;
Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewLongObj(PTR2INT(hwnd)));
return TRUE;
}
static Tcl_Obj *_make_pointer(void *pointer) {
// fprintf(stderr, "make pointer %lu\n", (long int)pointer);
#if __WORDSIZE == 64
return Tcl_NewLongObj((long)pointer);
#elif __WORDSIZE == 32
return Tcl_NewIntObj((int)pointer);
#else
#error "sizeof(void *) isn't obvious"
#endif
}
static Tcl_Obj*
AsObj(PyObject *value)
{
Tcl_Obj *result;
if (PyString_Check(value))
return Tcl_NewStringObj(PyString_AS_STRING(value),
PyString_GET_SIZE(value));
else if (PyInt_Check(value))
return Tcl_NewLongObj(PyInt_AS_LONG(value));
else if (PyFloat_Check(value))
return Tcl_NewDoubleObj(PyFloat_AS_DOUBLE(value));
else if (PyTuple_Check(value)) {
Tcl_Obj **argv = (Tcl_Obj**)
ckalloc(PyTuple_Size(value)*sizeof(Tcl_Obj*));
int i;
if(!argv)
return 0;
for(i=0;i<PyTuple_Size(value);i++)
argv[i] = AsObj(PyTuple_GetItem(value,i));
result = Tcl_NewListObj(PyTuple_Size(value), argv);
ckfree(FREECAST argv);
return result;
}
else if (PyUnicode_Check(value)) {
#if TKMAJORMINOR <= 8001
/* In Tcl 8.1 we must use UTF-8 */
PyObject* utf8 = PyUnicode_AsUTF8String(value);
if (!utf8)
return 0;
result = Tcl_NewStringObj(PyString_AS_STRING(utf8),
PyString_GET_SIZE(utf8));
Py_DECREF(utf8);
return result;
#else /* TKMAJORMINOR > 8001 */
/* In Tcl 8.2 and later, use Tcl_NewUnicodeObj() */
if (sizeof(Py_UNICODE) != sizeof(Tcl_UniChar)) {
/* XXX Should really test this at compile time */
PyErr_SetString(PyExc_SystemError,
"Py_UNICODE and Tcl_UniChar differ in size");
return 0;
}
return Tcl_NewUnicodeObj(PyUnicode_AS_UNICODE(value),
PyUnicode_GET_SIZE(value));
#endif /* TKMAJORMINOR > 8001 */
}
else {
PyObject *v = PyObject_Str(value);
if (!v)
return 0;
result = AsObj(v);
Py_DECREF(v);
return result;
}
}
static int
msg_date(Tcl_Interp *interp, notmuch_message_t *msg, int argc, const char *argv[]) {
if (argc != 0) {
tcl_result_printf(interp, "expected: msg date");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewLongObj(notmuch_message_get_date(msg)));
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_PidObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
} else {
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeState *pipePtr;
int i;
Tcl_Obj *resultPtr, *longObjPtr;
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
extern int swift_mpi_init(Tcl_Interp *interp) {
#if defined(VMDMPI)
if (getenv("VMDNOSWIFTCOMM") == NULL) {
if (MPI_SUCCESS == MPI_Comm_dup(MPI_COMM_WORLD, &turbine_adlb_comm)) {
Tcl_Obj* TURBINE_ADLB_COMM = Tcl_NewStringObj("TURBINE_ADLB_COMM", -1);
// XXX this is another gross hack. This passes the MPI communicator pointer
// as if it were a long, to make it available through Tcl,
// but there MUST be a better way. This is copied from what was done in NAMD.
Tcl_Obj* adlb_comm_ptr = Tcl_NewLongObj((long) &turbine_adlb_comm);
Tcl_ObjSetVar2(interp, TURBINE_ADLB_COMM, NULL, adlb_comm_ptr, 0);
}
}
#endif
return 0;
}
/*
*------------------------------------------------------------------------
*
* TclThreadList --
*
* Return a list of threads running Tcl interpreters.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int
TclThreadList(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr;
Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewLongObj((long) tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
static int Hello_Cmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
long n1;
long n2;
Tcl_Obj *res;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "n1 n2");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[1], &n1) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[2], &n2) != TCL_OK) {
return TCL_ERROR;
}
res = Tcl_NewLongObj(n1 + n2);
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
TestfindwindowObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const TCHAR *title = NULL, *class = NULL;
Tcl_DString titleString, classString;
HWND hwnd = NULL;
int r = TCL_OK;
Tcl_DStringInit(&classString);
Tcl_DStringInit(&titleString);
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
return TCL_ERROR;
}
title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
if (objc == 3) {
class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
}
hwnd = FindWindow(class, title);
if (hwnd == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
AppendSystemError(interp, GetLastError());
r = TCL_ERROR;
} else {
Tcl_SetObjResult(interp, Tcl_NewLongObj(PTR2INT(hwnd)));
}
Tcl_DStringFree(&titleString);
Tcl_DStringFree(&classString);
return r;
}
Tcl_Obj *
Tcljson_TclObjFromJsonObj(struct json_object *joPtr)
{
Tcl_Obj *objPtr;
enum json_type type;
char *def = NULL;
if (joPtr == NULL) {
objPtr = Tcl_NewStringObj(&def, -1);
return objPtr;
}
type = json_object_get_type(joPtr);
switch (type) {
case json_type_string:
objPtr = Tcl_NewStringObj(json_object_get_string(joPtr), -1);
break;
case json_type_int:
objPtr = Tcl_NewIntObj(json_object_get_int(joPtr));
break;
case json_type_double:
objPtr = Tcl_NewLongObj(json_object_get_double(joPtr));
break;
case json_type_boolean:
objPtr = Tcl_NewBooleanObj(json_object_get_boolean(joPtr));
break;
case json_type_object:
Tcljson_JsonObjToTclObj(joPtr, &objPtr);
break;
case json_type_array:
Tcljson_JsonObjToTclObj(joPtr, &objPtr);
break;
default:
objPtr = Tcl_NewStringObj(json_object_to_json_string(joPtr), -1);
break;
}
return objPtr;
}
/** \brief create the <B>msgque get</B> subcommand
*
* \tclmsgque_man
*
* \param[in] interp current Tcl interpreter
* \param[in] objc number of objects in \e objv
* \param[in] objv array of \e Tcl_Obj objects
* \return Tcl error-code
*/
static int NS(Const) (
Tcl_Interp * interp,
int objc,
struct Tcl_Obj *const *objv
)
{
int index;
Tcl_Obj *Obj = NULL;
static const char *constant[] = {
"maxY", "minY", "maxS", "minS", "maxI", "minI", "maxF", "minF", "maxW", "minW", "maxD", "minD", NULL
};
enum constants {
MAXY, MINY, MAXS, MINS, MAXI, MINI, MAXF, MINF, MAXW, MINW, MAXD, MIND,
};
// read the index
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "constant");
return TCL_ERROR;
}
// get the Index
TclErrorCheck (Tcl_GetIndexFromObj (interp, objv[2], constant, "constant", 0, &index));
// do the work
switch ((enum constants) index) {
case MAXY:
Obj = Tcl_NewIntObj (SCHAR_MAX);
break;
case MINY:
Obj = Tcl_NewIntObj (SCHAR_MIN);
break;
case MAXS:
Obj = Tcl_NewIntObj (SHRT_MAX);
break;
case MINS:
Obj = Tcl_NewIntObj (SHRT_MIN);
break;
case MAXI:
Obj = Tcl_NewLongObj (INT_MAX);
break;
case MINI:
Obj = Tcl_NewLongObj (INT_MIN);
break;
case MAXF:
Obj = Tcl_NewDoubleObj (FLT_MAX);
break;
case MINF:
Obj = Tcl_NewDoubleObj (FLT_MIN);
break;
case MAXW:
Obj = Tcl_NewWideIntObj (LLONG_MAX);
break;
case MINW:
Obj = Tcl_NewWideIntObj (LLONG_MIN);
break;
case MAXD:
Obj = Tcl_NewDoubleObj (DBL_MAX);
break;
case MIND:
Obj = Tcl_NewDoubleObj (DBL_MIN);
break;
}
Tcl_SetObjResult (interp, Obj);
return TCL_OK;
}
Tcl_Obj*
TnmSnmpNorm(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
{
int i, code, objc;
Tcl_Obj **objv;
Tcl_Obj *vbListPtr = NULL;
/*
* The following Tcl_Objs are allocated once and reused whenever
* we need to expand a varbind list containing object identifiers
* without any value or type elements.
*/
static Tcl_Obj *nullType = NULL;
static Tcl_Obj *zeroValue = NULL;
static Tcl_Obj *nullValue = NULL;
if (! nullType) {
nullType = Tcl_NewStringObj("NULL", 4);
Tcl_IncrRefCount(nullType);
}
if (! zeroValue) {
zeroValue = Tcl_NewIntObj(0);
Tcl_IncrRefCount(zeroValue);
}
if (! nullValue) {
nullValue = Tcl_NewStringObj(NULL, 0);
Tcl_IncrRefCount(nullValue);
}
/*
* Split the varbind list into a list of varbinds. Create a
* new Tcl list to hold the expanded varbind list.
*/
code = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
if (code != TCL_OK) {
goto errorExit;
}
vbListPtr = Tcl_NewListObj(0, NULL);
for (i = 0; i < objc; i++) {
int vbc, type;
Tcl_Obj **vbv, *vbPtr;
TnmOid* oidPtr;
Tcl_Obj *oidObjPtr, *typeObjPtr, *valueObjPtr;
TnmMibNode *nodePtr = NULL;
/*
* Create a new varbind element in the expanded result list
* for each varbind.
*/
vbPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, vbListPtr, vbPtr);
code = Tcl_ListObjGetElements(interp, objv[i], &vbc, &vbv);
if (code != TCL_OK) {
goto errorExit;
}
/*
* Get the object identifier value from the first list
* element. Check the number of list elements and assign
* them to the oid, type and value variables.
*/
switch (vbc) {
case 1:
oidObjPtr = vbv[0];
typeObjPtr = nullType;
valueObjPtr = nullValue;
break;
case 2:
oidObjPtr = vbv[0];
typeObjPtr = NULL;
valueObjPtr = vbv[1];
break;
case 3:
oidObjPtr = vbv[0];
typeObjPtr = vbv[1];
valueObjPtr = vbv[2];
break;
default: {
char msg[80];
sprintf(msg, "illegal number of elements in varbind %d", i);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
msg, (char *) NULL);
goto errorExit;
}
}
/*
* Check/resolve the object identifier and assign it to the
* result list. Make sure to make a deep copy if the object
* identifier value is shared since the string representation
* must be invalidated to ensure that hexadecimal
* sub-identifier are converted into decimal sub-identifier.
*/
oidPtr = TnmGetOidFromObj(interp, oidObjPtr);
if (! oidPtr) {
goto errorExit;
}
if (Tcl_IsShared(oidObjPtr)) {
oidObjPtr = Tcl_DuplicateObj(oidObjPtr);
}
TnmOidObjSetRep(oidObjPtr, TNM_OID_AS_OID);
Tcl_InvalidateStringRep(oidObjPtr);
Tcl_ListObjAppendElement(interp, vbPtr, oidObjPtr);
/*
* Lookup the type in the MIB if there is no type given in the
* varbind element.
*/
if (! typeObjPtr) {
int syntax;
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
if (! nodePtr) {
char msg[80];
sprintf(msg, "failed to lookup the type for varbind %d", i);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
msg, (char *) NULL);
goto errorExit;
}
syntax = (nodePtr->typePtr && nodePtr->typePtr->name)
? nodePtr->typePtr->syntax : nodePtr->syntax;
typeObjPtr = Tcl_NewStringObj(
TnmGetTableValue(tnmSnmpTypeTable, (unsigned) syntax), -1);
}
type = TnmGetTableKeyFromObj(NULL, tnmSnmpTypeTable,
typeObjPtr, NULL);
if (type == -1) {
type = TnmGetTableKeyFromObj(NULL, tnmSnmpExceptionTable,
typeObjPtr, NULL);
if (type == -1) {
char msg[80];
invalidType:
sprintf(msg, "illegal type in varbind %d", i);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
msg, (char *) NULL);
goto errorExit;
}
}
Tcl_ListObjAppendElement(interp, vbPtr, typeObjPtr);
/*
* Check the value and perform any conversions needed to
* convert the value into the base type representation.
*/
switch (type) {
case ASN1_INTEGER: {
long longValue;
code = Tcl_GetLongFromObj(interp, valueObjPtr, &longValue);
if (code != TCL_OK) {
if (! nodePtr) {
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
}
if (nodePtr) {
Tcl_Obj *value;
value = TnmMibScanValue(nodePtr->typePtr, nodePtr->syntax,
valueObjPtr);
if (! value) {
goto errorExit;
}
Tcl_ResetResult(interp);
code = Tcl_GetLongFromObj(interp, value, &longValue);
}
if (code != TCL_OK) {
goto errorExit;
}
valueObjPtr = Tcl_NewLongObj(longValue);
}
if (flags & TNM_SNMP_NORM_INT) {
if (! nodePtr) {
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
}
if (nodePtr && nodePtr->typePtr) {
Tcl_Obj *newPtr;
newPtr = TnmMibFormatValue(nodePtr->typePtr,
nodePtr->syntax,
valueObjPtr);
if (newPtr) {
valueObjPtr = newPtr;
}
}
}
break;
}
case ASN1_COUNTER32:
case ASN1_GAUGE32:
case ASN1_TIMETICKS: {
TnmUnsigned32 u;
code = TnmGetUnsigned32FromObj(interp, valueObjPtr, &u);
if (code != TCL_OK) {
goto errorExit;
}
break;
}
case ASN1_COUNTER64: {
TnmUnsigned64 u;
code = TnmGetUnsigned64FromObj(interp, valueObjPtr, &u);
if (code != TCL_OK) {
goto errorExit;
}
break;
}
case ASN1_IPADDRESS: {
if (TnmGetIpAddressFromObj(interp, valueObjPtr) == NULL) {
goto errorExit;
}
Tcl_InvalidateStringRep(valueObjPtr);
break;
}
case ASN1_OBJECT_IDENTIFIER:
if (! TnmGetOidFromObj(interp, valueObjPtr)) {
goto errorExit;
}
if (Tcl_IsShared(valueObjPtr)) {
valueObjPtr = Tcl_DuplicateObj(valueObjPtr);
}
if (flags & TNM_SNMP_NORM_OID) {
TnmOidObjSetRep(valueObjPtr, TNM_OID_AS_NAME);
} else {
TnmOidObjSetRep(valueObjPtr, TNM_OID_AS_OID);
}
Tcl_InvalidateStringRep(valueObjPtr);
break;
case ASN1_OCTET_STRING: {
int len;
if (! nodePtr) {
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
}
if (nodePtr) {
Tcl_Obj *scan;
scan = TnmMibScanValue(nodePtr->typePtr, nodePtr->syntax,
valueObjPtr);
if (scan) {
valueObjPtr = scan;
}
}
if (TnmGetOctetStringFromObj(interp, valueObjPtr, &len) == NULL) {
goto errorExit;
}
Tcl_InvalidateStringRep(valueObjPtr);
break;
}
case ASN1_NULL:
valueObjPtr = nullValue;
break;
default:
goto invalidType;
}
Tcl_ListObjAppendElement(interp, vbPtr, valueObjPtr);
}
return vbListPtr;
errorExit:
if (vbListPtr) {
Tcl_DecrRefCount(vbListPtr);
}
return NULL;
}
Tcl_Obj *ARecGetLong( Tcl_Interp *ip, ARecType *type, void *here, int m, int objc, Tcl_Obj*const* objv, int flags) { return Tcl_NewLongObj( *((long *) here)); }
Tcl_Obj *ARecGetUInt( Tcl_Interp *ip, ARecType *type, void *here, int m, int objc, Tcl_Obj*const* objv, int flags) { return Tcl_NewLongObj( *((unsigned int *) here)); }
/* ARGSUSED */
int
Tcl_ScanObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
const char *string, *end, *baseString;
char op = 0;
int width, underflow = 0;
Tcl_WideInt wideValue;
Tcl_UniChar ch, sch;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
char buf[513]; /* Temporary buffer to hold scanned number
* strings before they are passed to
* strtoul. */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName ...?");
return TCL_ERROR;
}
format = Tcl_GetStringFromObj(objv[2], NULL);
numVars = objc-3;
/*
* Check for errors in the format string.
*/
if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = Tcl_GetStringFromObj(objv[1], NULL);
baseString = string;
/*
* Iterate over the format string filling in the result objects until we
* reach the end of input, the end of the format string, or there is a
* mismatch.
*/
objIndex = 0;
nconversions = 0;
while (*format != '\0') {
int parseFlag = TCL_PARSE_NO_WHITESPACE;
format += Tcl_UtfToUniChar(format, &ch);
flags = 0;
/*
* If we see whitespace in the format, skip whitespace in the string.
*/
if (Tcl_UniCharIsSpace(ch)) {
offset = Tcl_UtfToUniChar(string, &sch);
while (Tcl_UniCharIsSpace(sch)) {
if (*string == '\0') {
goto done;
}
string += offset;
offset = Tcl_UtfToUniChar(string, &sch);
}
continue;
}
if (ch != '%') {
literal:
if (*string == '\0') {
underflow = 1;
goto done;
}
string += Tcl_UtfToUniChar(string, &sch);
if (ch != sch) {
goto done;
}
continue;
}
format += Tcl_UtfToUniChar(format, &ch);
if (ch == '%') {
goto literal;
}
/*
* Check for assignment suppression ('*') or an XPG3-style assignment
* ('%n$').
*/
if (ch == '*') {
flags |= SCAN_SUPPRESS;
format += Tcl_UtfToUniChar(format, &ch);
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
char *formatEnd;
value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
if (*formatEnd == '$') {
format = formatEnd+1;
format += Tcl_UtfToUniChar(format, &ch);
objIndex = (int) value - 1;
}
}
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */
format += Tcl_UtfToUniChar(format, &ch);
} else {
width = 0;
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += Tcl_UtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
/*
* Fall through so we skip to the next character.
*/
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
nconversions++;
continue;
case 'd':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
break;
case 'i':
op = 'i';
parseFlag |= TCL_PARSE_SCAN_PREFIXES;
break;
case 'o':
op = 'i';
parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
break;
case 'x':
case 'X':
op = 'i';
parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
break;
case 'b':
op = 'i';
parseFlag |= TCL_PARSE_BINARY_ONLY;
break;
case 'u':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
flags |= SCAN_UNSIGNED;
break;
case 'f':
case 'e':
case 'E':
case 'g':
case 'G':
op = 'f';
break;
case 's':
op = 's';
break;
case 'c':
op = 'c';
flags |= SCAN_NOSKIP;
break;
case '[':
op = '[';
flags |= SCAN_NOSKIP;
break;
}
/*
* At this point, we will need additional characters from the string
* to proceed.
*/
if (*string == '\0') {
underflow = 1;
goto done;
}
/*
* Skip any leading whitespace at the beginning of a field unless the
* format suppresses this behavior.
*/
if (!(flags & SCAN_NOSKIP)) {
while (*string != '\0') {
offset = Tcl_UtfToUniChar(string, &sch);
if (!Tcl_UniCharIsSpace(sch)) {
break;
}
string += offset;
}
if (*string == '\0') {
underflow = 1;
goto done;
}
}
/*
* Perform the requested scanning operation.
*/
switch (op) {
case 's':
/*
* Scan a string up to width characters or whitespace.
*/
if (width == 0) {
width = ~0;
}
end = string;
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (Tcl_UniCharIsSpace(sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
string = end;
break;
case '[': {
CharSet cset;
if (width == 0) {
width = ~0;
}
end = string;
format = BuildCharSet(&cset, format);
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (!CharInSet(&cset, (int)sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
ReleaseCharSet(&cset);
if (string == end) {
/*
* Nothing matched the range, stop processing.
*/
goto done;
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
string = end;
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
string += Tcl_UtfToUniChar(string, &sch);
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj((int)sch);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
objPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
underflow = 1;
}
}
goto done;
}
string = end;
if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
break;
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
if (TclGetString(objPtr)[0] == '-') {
wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
sprintf(buf, "%" TCL_LL_MODIFIER "u",
(Tcl_WideUInt)wideValue);
Tcl_SetStringObj(objPtr, buf, -1);
} else {
Tcl_SetWideIntObj(objPtr, wideValue);
}
} else if (!(flags & SCAN_BIG)) {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
} else {
value = LONG_MAX;
}
}
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
sprintf(buf, "%lu", value); /* INTL: ISO digit */
Tcl_SetStringObj(objPtr, buf, -1);
} else {
Tcl_SetLongObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
break;
case 'f':
/*
* Scan a floating point number
*/
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
underflow = 1;
}
}
goto done;
} else if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
if (objPtr->typePtr == &tclDoubleType) {
dvalue = objPtr->internalRep.doubleValue;
} else
#endif
{
Tcl_DecrRefCount(objPtr);
goto done;
}
}
Tcl_SetDoubleObj(objPtr, dvalue);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
string = end;
}
}
static int
TestintobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
long longValue;
const char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared), we
* must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
} else if (strcmp(subCmd, "setlong") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "setmaxlong") == 0) {
long maxLong = LONG_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], maxLong);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
}
} else if (strcmp(subCmd, "ismaxlong") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
((longValue == LONG_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get2") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
* Tcl_GetIntFromObj returns an error if the long int held in an
* integer object's internal representation is too large to fit in an
* int.
*/
if (objc != 3) {
goto wrongNumArgs;
}
#if (INT_MAX == LONG_MAX) /* int is same size as long int */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
return TCL_OK;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, get2, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TestfindwindowObjCmd(
ClientData clientData, /* Main window for application. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const TCHAR *title = NULL, *class = NULL;
Tcl_DString titleString, classString;
HWND hwnd = NULL;
int r = TCL_OK;
DWORD myPid;
Tcl_DStringInit(&classString);
Tcl_DStringInit(&titleString);
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "title ?class?");
return TCL_ERROR;
}
title = Tcl_WinUtfToTChar(Tcl_GetString(objv[1]), -1, &titleString);
if (objc == 3) {
class = Tcl_WinUtfToTChar(Tcl_GetString(objv[2]), -1, &classString);
}
if (title[0] == 0)
title = NULL;
#if 0
hwnd = FindWindow(class, title);
#else
/* We want find a window the belongs to us and not some other process */
hwnd = NULL;
myPid = GetCurrentProcessId();
while (1) {
DWORD pid, tid;
hwnd = FindWindowEx(NULL, hwnd, class, title);
if (hwnd == NULL)
break;
tid = GetWindowThreadProcessId(hwnd, &pid);
if (tid == 0) {
/* Window has gone */
hwnd = NULL;
break;
}
if (pid == myPid)
break; /* Found it */
}
#endif
if (hwnd == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to find window: ", -1));
AppendSystemError(interp, GetLastError());
r = TCL_ERROR;
} else {
Tcl_SetObjResult(interp, Tcl_NewLongObj(PTR2INT(hwnd)));
}
Tcl_DStringFree(&titleString);
Tcl_DStringFree(&classString);
return r;
}
/* ARGSUSED */
int
Tcl_ThreadObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static const char *threadOptions[] = {
"create", "exit", "id", "join", "names",
"send", "wait", "errorproc", NULL
};
enum options {
THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make sure the initial thread is on the list before doing anything.
*/
if (tsdPtr->interp == NULL) {
Tcl_MutexLock(&threadMutex);
tsdPtr->interp = interp;
ListUpdateInner(tsdPtr);
Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
Tcl_MutexUnlock(&threadMutex);
}
switch ((enum options)option) {
case THREAD_CREATE: {
char *script;
int joinable, len;
if (objc == 2) {
/*
* Neither joinable nor special script
*/
joinable = 0;
script = "testthread wait"; /* Just enter event loop */
} else if (objc == 3) {
/*
* Possibly -joinable, then no special script, no joinable, then
* its a script.
*/
script = Tcl_GetStringFromObj(objv[2], &len);
if ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp (script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
/*
* Remember the script
*/
joinable = 0;
}
} else if (objc == 4) {
/*
* Definitely a script available, but is the flag -joinable?
*/
script = Tcl_GetStringFromObj(objv[2], &len);
joinable = ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp(script, "-joinable", (size_t) len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
return TclCreateThread(interp, script, joinable);
}
case THREAD_EXIT:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
ListRemove(NULL);
Tcl_ExitThread(0);
return TCL_OK;
case THREAD_ID:
if (objc == 2) {
Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
case THREAD_JOIN: {
long id;
int result, status;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
if (result == TCL_OK) {
Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
} else {
char buf [20];
sprintf(buf, "%ld", id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
}
case THREAD_NAMES:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return TclThreadList(interp);
case THREAD_SEND: {
long id;
char *script;
int wait, arg;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
return TCL_ERROR;
}
if (objc == 5) {
if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
return TCL_ERROR;
}
wait = 0;
arg = 3;
} else {
wait = 1;
arg = 2;
}
if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
script = Tcl_GetString(objv[arg]);
return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
}
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
errorProcString = ckalloc(strlen(proc)+1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
case THREAD_WAIT:
while (1) {
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
}
return TCL_OK;
}
