HIDDEN int
dm_bestXType_tcl(void *clientData, int argc, const char **argv)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Tcl_Obj *obj;
const char *best_dm;
char buffer[256] = {0};
if (argc != 2) {
struct bu_vls vls = BU_VLS_INIT_ZERO;
bu_vls_printf(&vls, "helplib dm_bestXType");
Tcl_Eval(interp, bu_vls_addr(&vls));
bu_vls_free(&vls);
return TCL_ERROR;
}
obj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
snprintf(buffer, 256, "%s", argv[1]);
best_dm = dm_bestXType(buffer);
if (best_dm) {
Tcl_AppendStringsToObj(obj, best_dm, (char *)NULL);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
return TCL_ERROR;
}
/**
* P L O T _ L O A D M A T R I X
*
* Load a new transformation matrix. This will be followed by
* many calls to plot_draw().
*/
HIDDEN int
plot_loadMatrix(struct dm *dmp, fastf_t *mat, int which_eye)
{
Tcl_Obj *obj;
if (!dmp)
return TCL_ERROR;
obj = Tcl_GetObjResult(dmp->dm_interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
if (((struct plot_vars *)dmp->dm_vars.priv_vars)->debug) {
struct bu_vls tmp_vls = BU_VLS_INIT_ZERO;
Tcl_AppendStringsToObj(obj, "plot_loadMatrix()\n", (char *)NULL);
bu_vls_printf(&tmp_vls, "which eye = %d\t", which_eye);
bu_vls_printf(&tmp_vls, "transformation matrix = \n");
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[0], mat[4], mat[8], mat[12]);
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[1], mat[5], mat[9], mat[13]);
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[2], mat[6], mat[10], mat[14]);
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[3], mat[7], mat[11], mat[15]);
Tcl_AppendStringsToObj(obj, bu_vls_addr(&tmp_vls), (char *)NULL);
bu_vls_free(&tmp_vls);
}
MAT_COPY(plotmat, mat);
Tcl_SetObjResult(dmp->dm_interp, obj);
return TCL_OK;
}
int
TkWinSend_QueueCommand(
Tcl_Interp *interp,
Tcl_Obj *cmdPtr)
{
SendEvent *evPtr;
TRACE("SendQueueCommand()\n");
evPtr = ckalloc(sizeof(SendEvent));
evPtr->header.proc = SendEventProc;
evPtr->header.nextPtr = NULL;
evPtr->interp = interp;
Tcl_Preserve(evPtr->interp);
if (Tcl_IsShared(cmdPtr)) {
evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr);
} else {
evPtr->cmdPtr = cmdPtr;
Tcl_IncrRefCount(evPtr->cmdPtr);
}
Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
return 0;
}
TclObject &
TclObject::lappend (Tcl_Obj *pElement)
{
if (Tcl_IsShared(m_pObj)) {
Tcl_DecrRefCount(m_pObj);
m_pObj = Tcl_DuplicateObj(m_pObj);
Tcl_IncrRefCount(m_pObj);
}
Tcl_ListObjAppendElement(NULL, m_pObj, pElement);
// TODO: Should check for error result if conversion to list failed.
return *this;
}
HIDDEN int
plot_debug(struct dm *dmp, int lvl)
{
Tcl_Obj *obj;
obj = Tcl_GetObjResult(dmp->dm_interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
dmp->dm_debugLevel = lvl;
(void)fflush(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp);
Tcl_AppendStringsToObj(obj, "flushed\n", (char *)NULL);
Tcl_SetObjResult(dmp->dm_interp, obj);
return TCL_OK;
}
HIDDEN int
plot_logfile(struct dm *dmp, const char *filename)
{
Tcl_Obj *obj;
obj = Tcl_GetObjResult(dmp->dm_interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
bu_vls_sprintf(&dmp->dm_log, "%s", filename);
(void)fflush(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp);
Tcl_AppendStringsToObj(obj, "flushed\n", (char *)NULL);
Tcl_SetObjResult(dmp->dm_interp, obj);
return TCL_OK;
}
static int DBus_EventHandler(Tcl_Event *evPtr, int flags)
{
Tcl_DBusEvent *ev;
DBusMessageIter iter;
Tcl_Obj *script, *result;
int rc;
if (!(flags & TCL_IDLE_EVENTS)) return 0;
ev = (Tcl_DBusEvent *) evPtr;
script = ev->script;
if (Tcl_IsShared(script))
script = Tcl_DuplicateObj(script);
Tcl_ListObjAppendElement(ev->interp, script,
DBus_MessageInfo(ev->interp, ev->msg));
/* read the parameters and append to the script */
if (dbus_message_iter_init(ev->msg, &iter)) {
Tcl_ListObjAppendList(ev->interp, script,
DBus_IterList(ev->interp, &iter, (ev->flags & DBUSFLAG_DETAILS) != 0));
}
/* Excute the constructed Tcl command */
rc = Tcl_EvalObjEx(ev->interp, script, TCL_EVAL_GLOBAL);
if (rc != TCL_ERROR) {
/* Report success only if noreply == 0 and async == 0 */
if (!(ev->flags & DBUSFLAG_NOREPLY) && !(ev->flags & DBUSFLAG_ASYNC)) {
/* read the parameters and append to the script */;
result = Tcl_GetObjResult(ev->interp);
DBus_SendMessage(ev->interp, ev->conn,
DBUS_MESSAGE_TYPE_METHOD_RETURN, NULL, NULL, NULL,
dbus_message_get_sender(ev->msg),
dbus_message_get_serial(ev->msg),
NULL, 1, &result);
}
} else {
/* Always report failures if noreply == 0 */
if (!(ev->flags & DBUSFLAG_NOREPLY)) {
result = Tcl_GetObjResult(ev->interp);
DBus_Error(ev->interp, ev->conn, NULL,
dbus_message_get_sender(ev->msg),
dbus_message_get_serial(ev->msg),
Tcl_GetString(result));
}
}
dbus_message_unref(ev->msg);
Tcl_DecrRefCount(ev->script);
/* The event structure will be cleaned up by Tcl_ServiceEvent */
return 1;
}
/* ARGSUSED */
int
Tcl_CloseObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
/*
* If there is an error message and it ends with a newline, remove the
* newline. This is done for command pipeline channels where the error
* output from the subprocesses is stored in interp's result.
*
* NOTE: This is likely to not have any effect on regular error
* messages produced by drivers during the closing of a channel,
* because the Tcl convention is that such error messages do not have
* a terminating newline.
*/
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
char *string;
int len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
string = TclGetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
return TCL_ERROR;
}
return TCL_OK;
}
void
SetExcepInfo(
Tcl_Interp* interp,
EXCEPINFO *pExcepInfo)
{
if (pExcepInfo) {
Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
ICreateErrorInfo *pCEI;
IErrorInfo *pEI, **ppEI = &pEI;
HRESULT hr;
opError = Tcl_GetObjResult(interp);
opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo",NULL, TCL_GLOBAL_ONLY);
opErrorCode = Tcl_GetVar2Ex(interp, "errorCode",NULL, TCL_GLOBAL_ONLY);
if (Tcl_IsShared(opErrorCode)) {
Tcl_Obj *ec = Tcl_DuplicateObj(opErrorCode);
Tcl_IncrRefCount(ec);
Tcl_DecrRefCount(opErrorCode);
opErrorCode = ec;
}
Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
pExcepInfo->scode = E_FAIL;
hr = CreateErrorInfo(&pCEI);
if (SUCCEEDED(hr)) {
hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch);
hr = pCEI->lpVtbl->SetDescription(pCEI,
pExcepInfo->bstrDescription);
hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource);
hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo,
(void**) ppEI);
if (SUCCEEDED(hr)) {
SetErrorInfo(0, pEI);
pEI->lpVtbl->Release(pEI);
}
pCEI->lpVtbl->Release(pCEI);
}
}
}
static int _process(jack_nframes_t nframes, void *arg) {
_t *data = (_t *)arg;
if (data->started) {
// this will work funny if there are xruns happening, as when we try to use --driver netone
jack_nframes_t wframe = sdrkit_last_frame_time(arg);
size_t offset = (wframe&(data->buff_size-1));
if (offset + nframes > data->buff_size) {
fprintf(stderr, "offset = %ld + nframes = %ld > size = %d\n", offset, (long)nframes, data->buff_size);
// need to implement a misaligned copy/set, but I'm betting that jacks frame time is buffer aligned
// and I was winning the bet until I tried to use --driver netone
} else {
float *in0 = jack_port_get_buffer(framework_input(arg,0), nframes);
float *in1 = jack_port_get_buffer(framework_input(arg,1), nframes);
int size;
if (data->opts.as_complex) {
float complex *out = (float complex *)Tcl_GetByteArrayFromObj(data->current->buff, &size);
out += offset;
for (int i = nframes; --i >= 0; )
*out++ = *in0++ + I * *in1++;
} else {
float *out = (float *)Tcl_GetByteArrayFromObj(data->current->buff, &size);
out += offset;
memcpy(out, in0, nframes*sizeof(float));
out += data->buff_size;
memcpy(out, in1, nframes*sizeof(float));
}
// check for end of current buffer
if (offset+nframes == data->buff_size) {
data->current->bframe = wframe - offset;
data->current->bread = 0;
for (int i = 0; i < data->buff_n; i += 1)
if (data->buffs[i].bframe < data->current->bframe && ! Tcl_IsShared(data->buffs[i].buff))
data->current = &data->buffs[i];
data->current->bread = 1;
}
}
}
return 0;
}
HIDDEN int
dm_validXType_tcl(void *clientData, int argc, const char **argv)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
struct bu_vls vls = BU_VLS_INIT_ZERO;
Tcl_Obj *obj;
if (argc != 3) {
bu_vls_printf(&vls, "helplib dm_validXType");
Tcl_Eval(interp, bu_vls_addr(&vls));
bu_vls_free(&vls);
return TCL_ERROR;
}
bu_vls_printf(&vls, "%d", dm_validXType(argv[1], argv[2]));
obj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
Tcl_AppendStringsToObj(obj, bu_vls_addr(&vls), (char *)NULL);
bu_vls_free(&vls);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/* ARGSUSED */
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
int mask) /* Not used. */
{
int code, length;
InteractiveState *isPtr = clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(chan)) {
return;
}
if (isPtr->tty) {
/*
* Would be better to find a way to exit the mainLoop? Or perhaps
* evaluate [exit]? Leaving as is for now due to compatibility
* concerns.
*/
Tcl_Exit(0);
}
Tcl_DeleteChannelHandler(chan, StdinProc, isPtr);
return;
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
Tcl_GetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
/*
* Disable the stdin channel handler while evaluating the command;
* otherwise if the command re-enters the event loop we might process
* commands from stdin before the current command is finished. Among other
* things, this will trash the text of the command being evaluated.
*/
Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(commandPtr);
isPtr->commandPtr = commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (chan != NULL) {
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr);
}
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && (chan != NULL)) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
/*
* If a tty stdin is still around, output a prompt.
*/
prompt:
if (isPtr->tty && (isPtr->input != NULL)) {
Prompt(interp, isPtr);
isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
}
}
static int
TestlistobjCmd(
ClientData clientData, /* Not used */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"set",
"get",
"replace"
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
LISTOBJ_REPLACE
};
const char* index; /* Argument giving the variable number */
int varIndex; /* Variable number converted to binary */
int cmdIndex; /* Ordinal number of the subcommand */
int first; /* First index in the list */
int count; /* Count of elements in a list */
if (objc < 3) {
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;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
0, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_REPLACE:
if (objc < 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"varIndex start count ?element...?");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
}
return TCL_OK;
}
static int
PrefixMatchObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags = 0, result, index;
int dummyLength, i, errorLength;
Tcl_Obj *errorPtr = NULL;
const char *message = "option";
Tcl_Obj *tablePtr, *objPtr, *resultPtr;
static const char *const matchOptions[] = {
"-error", "-exact", "-message", NULL
};
enum matchOptions {
PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE
};
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? table string");
return TCL_ERROR;
}
for (i = 1; i < (objc - 2); i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum matchOptions) index) {
case PRFMATCH_EXACT:
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
message = Tcl_GetString(objv[i]);
break;
case PRFMATCH_ERROR:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
result = Tcl_ListObjLength(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error options must have an even number of elements",
-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
errorPtr = objv[i];
break;
}
}
tablePtr = objv[objc - 2];
objPtr = objv[objc - 1];
/*
* Check that table is a valid list first, since we want to handle that
* error case regardless of level.
*/
result = Tcl_ListObjLength(interp, tablePtr, &dummyLength);
if (result != TCL_OK) {
return result;
}
result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags,
&index);
if (result != TCL_OK) {
if (errorPtr != NULL && errorLength == 0) {
Tcl_ResetResult(interp);
return TCL_OK;
} else if (errorPtr == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(errorPtr)) {
errorPtr = Tcl_DuplicateObj(errorPtr);
}
Tcl_ListObjAppendElement(interp, errorPtr,
Tcl_NewStringObj("-code", 5));
Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result));
return Tcl_SetReturnOptions(interp, errorPtr);
}
result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr);
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
is.commandPtr = Tcl_NewObj();
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(chan, valuePtr);
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
Tcl_AppendToObj(is.commandPtr, "\n", 1);
if (!TclObjCommandComplete(is.commandPtr)) {
is.prompt = PROMPT_CONTINUE;
continue;
}
is.prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
Tcl_CreateChannelHandler(is.input, TCL_READABLE,
StdinProc, &is);
}
mainLoopProc();
Tcl_SetMainLoop(NULL);
if (is.input) {
Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
Tcl_SetMainLoop(NULL);
}
if (is.commandPtr != NULL) {
Tcl_DecrRefCount(is.commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
* happening. Maybe interp has been deleted; maybe [exit] was redefined,
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
static int
ImageToPostscript(
Tcl_Interp *interp, /* Leave Postscript or error message here. */
Tk_Canvas canvas, /* Information about overall canvas. */
Tk_Item *itemPtr, /* Item for which Postscript is wanted. */
int prepass) /* 1 means this is a prepass to collect font
* information; 0 means final Postscript is
* being created.*/
{
ImageItem *imgPtr = (ImageItem *) itemPtr;
Tk_Window canvasWin = Tk_CanvasTkwin(canvas);
double x, y;
int width, height;
Tk_Image image;
Tk_State state = itemPtr->state;
if (state == TK_STATE_NULL) {
state = Canvas(canvas)->canvas_state;
}
image = imgPtr->image;
if (Canvas(canvas)->currentItemPtr == itemPtr) {
if (imgPtr->activeImage != NULL) {
image = imgPtr->activeImage;
}
} else if (state == TK_STATE_DISABLED) {
if (imgPtr->disabledImage != NULL) {
image = imgPtr->disabledImage;
}
}
if (image == NULL) {
/*
* Image item without actual image specified.
*/
return TCL_OK;
}
Tk_SizeOfImage(image, &width, &height);
/*
* Compute the coordinates of the lower-left corner of the image, taking
* into account the anchor position for the image.
*/
x = imgPtr->x;
y = Tk_CanvasPsY(canvas, imgPtr->y);
switch (imgPtr->anchor) {
case TK_ANCHOR_NW:
y -= height;
break;
case TK_ANCHOR_N:
x -= width/2.0;
y -= height;
break;
case TK_ANCHOR_NE:
x -= width;
y -= height;
break;
case TK_ANCHOR_E:
x -= width;
y -= height/2.0;
break;
case TK_ANCHOR_SE:
x -= width;
break;
case TK_ANCHOR_S:
x -= width/2.0;
break;
case TK_ANCHOR_SW:
break;
case TK_ANCHOR_W:
y -= height/2.0;
break;
case TK_ANCHOR_CENTER:
x -= width/2.0;
y -= height/2.0;
break;
}
if (!prepass) {
Tcl_Obj *psObj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(psObj)) {
psObj = Tcl_DuplicateObj(psObj);
Tcl_SetObjResult(interp, psObj);
}
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g translate\n", x, y);
}
return Tk_PostscriptImage(image, interp, canvasWin,
((TkCanvas *) canvas)->psInfo, 0, 0, width, height, prepass);
}
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;
}
/*
* P L O T _ O P E N
*
* Fire up the display manager, and the display processor.
*
*/
struct dm *
plot_open(Tcl_Interp *interp, int argc, const char *argv[])
{
static int count = 0;
struct dm *dmp;
Tcl_Obj *obj;
BU_ALLOC(dmp, struct dm);
*dmp = dm_plot; /* struct copy */
dmp->dm_interp = interp;
BU_ALLOC(dmp->dm_vars.priv_vars, struct plot_vars);
obj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
bu_vls_init(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls);
bu_vls_init(&dmp->dm_pathName);
bu_vls_init(&dmp->dm_tkName);
bu_vls_printf(&dmp->dm_pathName, ".dm_plot%d", count++);
bu_vls_printf(&dmp->dm_tkName, "dm_plot%d", count++);
/* skip first argument */
--argc; ++argv;
/* Process any options */
((struct plot_vars *)dmp->dm_vars.priv_vars)->is_3D = 1; /* 3-D w/color, by default */
while (argv[0] != (char *)0 && argv[0][0] == '-') {
switch (argv[0][1]) {
case '3':
break;
case '2':
((struct plot_vars *)dmp->dm_vars.priv_vars)->is_3D = 0; /* 2-D, for portability */
break;
case 'g':
((struct plot_vars *)dmp->dm_vars.priv_vars)->grid = 1;
break;
case 'f':
((struct plot_vars *)dmp->dm_vars.priv_vars)->floating = 1;
break;
case 'z':
case 'Z':
/* Enable Z clipping */
Tcl_AppendStringsToObj(obj, "Clipped in Z to viewing cube\n", (char *)NULL);
dmp->dm_zclip = 1;
break;
default:
Tcl_AppendStringsToObj(obj, "bad PLOT option ", argv[0], "\n", (char *)NULL);
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
argv++;
}
if (argv[0] == (char *)0) {
Tcl_AppendStringsToObj(obj, "no filename or filter specified\n", (char *)NULL);
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
if (argv[0][0] == '|') {
bu_vls_strcpy(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, &argv[0][1]);
while ((++argv)[0] != (char *)0) {
bu_vls_strcat(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, " ");
bu_vls_strcat(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, argv[0]);
}
((struct plot_vars *)dmp->dm_vars.priv_vars)->is_pipe = 1;
} else {
bu_vls_strcpy(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, argv[0]);
}
if (((struct plot_vars *)dmp->dm_vars.priv_vars)->is_pipe) {
if ((((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp =
popen(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls), "w")) == NULL) {
perror(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls));
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
Tcl_AppendStringsToObj(obj, "piped to ",
bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls),
"\n", (char *)NULL);
} else {
if ((((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp =
fopen(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls), "wb")) == NULL) {
perror(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls));
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
Tcl_AppendStringsToObj(obj, "plot stored in ",
bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls),
"\n", (char *)NULL);
}
setbuf(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp,
((struct plot_vars *)dmp->dm_vars.priv_vars)->ttybuf);
if (((struct plot_vars *)dmp->dm_vars.priv_vars)->is_3D)
pl_3space(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp,
-2048, -2048, -2048, 2048, 2048, 2048);
else
pl_space(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp,
-2048, -2048, 2048, 2048);
MAT_IDN(plotmat);
Tcl_SetObjResult(interp, obj);
return dmp;
}
void
Tcl_Main(
int argc, /* Number of arguments. */
char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc)
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
{
Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;
const char *encodingName = NULL;
PromptType prompt = PROMPT_START;
int code, length, tty, exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString appName;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
&& ('-' != argv[3][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
const char *pathName = Tcl_GetStringFromObj(path, &length);
Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
Tcl_SetStartupScript(path, encodingName);
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteChars(errChannel,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* If a script file was specified then just source that file and quit.
* Must fetch it again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(errChannel, valuePtr);
}
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) {
if (mainLoopProc == NULL) {
if (tty) {
Prompt(interp, &prompt);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel == NULL) {
break;
}
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(inChannel)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
prompt = PROMPT_CONTINUE;
continue;
}
prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
InteractiveState *isPtr = NULL;
if (inChannel) {
if (tty) {
Prompt(interp, &prompt);
}
isPtr = (InteractiveState *)
ckalloc(sizeof(InteractiveState));
isPtr->input = inChannel;
isPtr->tty = tty;
isPtr->commandPtr = commandPtr;
isPtr->prompt = prompt;
isPtr->interp = interp;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
TCL_LINK_BOOLEAN);
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
isPtr);
}
mainLoopProc();
mainLoopProc = NULL;
if (inChannel) {
tty = isPtr->tty;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
TCL_LINK_BOOLEAN);
prompt = isPtr->prompt;
commandPtr = isPtr->commandPtr;
if (isPtr->input != NULL) {
Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr);
}
ckfree((char *) isPtr);
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
#ifdef TCL_MEM_DEBUG
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
if (tclMemDumpFileName != NULL) {
mainLoopProc = NULL;
Tcl_DeleteInterp(interp);
}
#endif
}
done:
if ((exitCode == 0) && (mainLoopProc != NULL)
&& !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
mainLoopProc = NULL;
}
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp)) {
if (!Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
* is happening. Maybe interp has been deleted; maybe [exit] was
* redefined, maybe we've blown up because of an exceeded limit. We
* still want to cleanup and exit.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
}
Tcl_SetStartupScript(NULL, NULL);
/*
* If we get here, the master interp has been deleted. Allow its
* destruction with the last matching Tcl_Release.
*/
Tcl_Release(interp);
Tcl_Exit(exitCode);
}
void
Tcl_RegisterConfig(
Tcl_Interp *interp, /* Interpreter the configuration command is
* registered in. */
const char *pkgName, /* Name of the package registering the
* embedded configuration. ASCII, thus in
* UTF-8 too. */
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
QCCD *cdPtr = ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
}
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
* Phase I: Adding the provided information to the internal database of
* package meta data.
*
* Phase II: Create a command for querying this database, specific to the
* package registering its configuration. This is the approved interface
* in TIP 59. In the future a more general interface should be done, as
* follow-up to TIP 59. Simply because our database is now general across
* packages, and not a structure tied to one package.
*
* Note, the created command will have a reference through its clientdata.
*/
Tcl_IncrRefCount(cdPtr->pkg);
/*
* For venc == NULL aka bogus encoding we skip the step setting up the
* dictionaries visible at Tcl level. I.e. they are not filled
*/
pDB = GetConfigDict(interp);
/*
* Retrieve package specific configuration...
*/
if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
|| (pkgDict == NULL)) {
pkgDict = Tcl_NewDictObj();
} else if (Tcl_IsShared(pkgDict)) {
pkgDict = Tcl_DuplicateObj(pkgDict);
}
/*
* Extend the package configuration...
* We cannot assume that the encodings are initialized, therefore
* store the value as-is in a byte array. See Bug [9b2e636361].
*/
for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
}
/*
* Write the changes back into the overall database.
*/
Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
* information.
*/
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "::");
Tcl_DStringAppend(&cmdName, pkgName, -1);
/*
* The incomplete command name is the name of the namespace to place it
* in.
*/
if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
TCL_GLOBAL_ONLY) == NULL) {
if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
NULL, NULL) == NULL) {
Tcl_Panic("%s.\n%s: %s",
Tcl_GetStringResult(interp), "Tcl_RegisterConfig",
"Unable to create namespace for package configuration.");
}
}
TclDStringAppendLiteral(&cmdName, "::pkgconfig");
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
"Unable to create query command for package configuration");
}
Tcl_DStringFree(&cmdName);
}
static int
TeststringobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "getunicode",
"appendself", "appendself2", NULL
};
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;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
if (objc > (MAX_STRINGS+3)) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 3: /* get2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
* 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".
*/
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
return TCL_OK;
}
static int
TestbignumobjCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
"set", "get", "mult10", "div10", NULL
};
enum options {
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
};
int index, varIndex;
const char *string;
mp_int bignumValue, newValue;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case BIGNUM_SET:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "var value");
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (mp_init(&bignumValue) != MP_OKAY) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_init", -1));
return TCL_ERROR;
}
if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_read_radix", -1));
return TCL_ERROR;
}
/*
* 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_SetBignumObj(varPtr[varIndex], &bignumValue);
} else {
SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
}
break;
case BIGNUM_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
break;
case BIGNUM_MULT10:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_init(&newValue) != MP_OKAY
|| (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) {
mp_clear(&bignumValue);
mp_clear(&newValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_mul_d", -1));
return TCL_ERROR;
}
mp_clear(&bignumValue);
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
break;
case BIGNUM_DIV10:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_init(&newValue) != MP_OKAY
|| (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) {
mp_clear(&bignumValue);
mp_clear(&newValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_div_d", -1));
return TCL_ERROR;
}
mp_clear(&bignumValue);
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &newValue);
} else {
SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
}
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
return TCL_OK;
}
static int
TestdoubleobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex;
double doubleValue;
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_GetDouble(interp, string, &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
/*
* 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_SetDoubleObj(varPtr[varIndex], doubleValue);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} 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, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
}
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_GetDoubleFromObj(interp, varPtr[varIndex],
&doubleValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0);
} else {
SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
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 void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
0, NULL);
if (length == 0) {
char *msgPtr;
length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
0, NULL);
if (length > 0) {
wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
length + 1);
LocalFree(msgPtr);
}
}
if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
strcpy(msgBuf, "function not supported under Win32s");
} else {
sprintf(msgBuf, "unknown error: %ld", error);
}
msg = msgBuf;
} else {
Tcl_Encoding encoding;
char *msgPtr;
encoding = Tcl_GetEncoding(NULL, "unicode");
Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
Tcl_FreeEncoding(encoding);
LocalFree(wMsgPtr);
msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
*/
if (msgPtr[length-1] == '\n') {
--length;
}
if (msgPtr[length-1] == '\r') {
--length;
}
msgPtr[length] = 0;
msg = msgPtr;
}
sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
Tcl_AppendToObj(resultPtr, msg, length);
Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
}
}
//
// ctable_RunBatch - Run a batch of ctable commands without invoking the
// Tcl interpreter.
//
// Any commands that return non-empty results or have error results get
// accumulated into a result list that gets returned.
//
// Returned is a list of lists, one per non-empty or error result, where
// the first element is the index number of the list element that got
// the error or non-empty result, whether it's an error or OK return,
// (the actual Tcl result code as in return -code), and the result or
// error message.
//
static int
ctable_RunBatch (Tcl_Interp *interp, CTable *ctable, Tcl_Obj *tableCmdObj, Tcl_Obj *batchListObj) {
int listObjc;
Tcl_Obj **listObjv;
int i;
int commandResult = TCL_ERROR;
Tcl_Obj *resultListObj = Tcl_NewObj ();
Tcl_Obj *commandResultObj;
Tcl_Obj *oneResultObj[2];
Tcl_Obj *oneResultValueObj[2];
if (Tcl_ListObjGetElements (interp, batchListObj, &listObjc, &listObjv) == TCL_ERROR) {
Tcl_AppendResult (interp, " while processing batch list", (char *)NULL);
return TCL_ERROR;
}
// nothing to do? ok, you get a nice, pristine, empty result
if (listObjc == 0) {
return TCL_OK;
}
for (i = 0; i < listObjc; i++) {
int cmdObjc;
Tcl_Obj **cmdObjv;
Tcl_Obj *batchCmdObj;
batchCmdObj = listObjv[i];
if (Tcl_IsShared (batchCmdObj)) {
batchCmdObj = Tcl_DuplicateObj (batchCmdObj);
}
if (Tcl_ListObjReplace (interp, batchCmdObj, 0, 0, 1, &tableCmdObj) == TCL_ERROR) {
commandResult = TCL_ERROR;
goto accumulate_result;
}
if (Tcl_ListObjGetElements (interp, batchCmdObj, &cmdObjc, &cmdObjv) == TCL_ERROR) {
commandResult = TCL_ERROR;
goto accumulate_result;
}
// reset the result since the command we're about to invoke sets
// stuff into the result. we make arrangements to copy out the
// result if anything's there after executing the command.
Tcl_ResetResult (interp);
commandResult = ctable->creator->command (ctable, interp, cmdObjc, cmdObjv);
commandResultObj = Tcl_GetObjResult (interp);
// if we got an OK result and nothing in the result object, there's
// nothing to accumulate in our result list
if ((commandResult == TCL_OK) && (commandResultObj->typePtr == NULL && commandResultObj->length == 0)) continue;
accumulate_result:
// each result sublist is {indexNumber {tclResultNumber tclResultValue}}
oneResultObj[0] = Tcl_NewIntObj (i);
oneResultValueObj[0] = Tcl_NewIntObj (commandResult);
oneResultValueObj[1] = Tcl_GetObjResult (interp);
oneResultObj[1] = Tcl_NewListObj (2, oneResultValueObj);
if (Tcl_ListObjAppendElement (interp, resultListObj, Tcl_NewListObj (2, oneResultObj))) {
Tcl_AppendResult (interp, " while appending a command result", (char *)NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult (interp, resultListObj);
return TCL_OK;
}
