int
compare_attrs(struct directory *dp1, struct directory *dp2)
{
struct bu_vls vls = BU_VLS_INIT_ZERO;
Tcl_Obj *obj1, *obj2;
int different = 0;
if (db_version(dbip1) > 4) {
bu_vls_printf(&vls, "_db1 attr get %s", dp1->d_namep);
if (Tcl_Eval(INTERP, bu_vls_addr(&vls)) != TCL_OK) {
fprintf(stderr, "Cannot get attributes for %s\n", dp1->d_namep);
fprintf(stderr, "%s\n", Tcl_GetStringResult(INTERP));
bu_exit(1, NULL);
}
obj1 = Tcl_DuplicateObj(Tcl_GetObjResult(INTERP));
Tcl_ResetResult(INTERP);
if (dp1->d_flags & RT_DIR_REGION && verify_region_attribs) {
verify_region_attrs(dp1, dbip1, obj1);
}
} else {
obj1 = Tcl_NewObj();
}
if (db_version(dbip2) > 4) {
bu_vls_trunc(&vls, 0);
bu_vls_printf(&vls, "_db2 attr get %s", dp1->d_namep);
if (Tcl_Eval(INTERP, bu_vls_addr(&vls)) != TCL_OK) {
fprintf(stderr, "Cannot get attributes for %s\n", dp1->d_namep);
fprintf(stderr, "%s\n", Tcl_GetStringResult(INTERP));
bu_exit(1, NULL);
}
obj2 = Tcl_DuplicateObj(Tcl_GetObjResult(INTERP));
Tcl_ResetResult(INTERP);
if (dp1->d_flags & RT_DIR_REGION && verify_region_attribs) {
verify_region_attrs(dp2, dbip2, obj2);
}
} else {
obj2 = Tcl_NewObj();
}
if ((dp1->d_flags & RT_DIR_REGION) && (dp2->d_flags & RT_DIR_REGION)) {
/* don't complain about "region" attributes */
remove_region_attrs(obj1);
remove_region_attrs(obj2);
}
bu_vls_trunc(&vls, 0);
different = do_compare(ATTRS, &vls, obj1, obj2, dp1->d_namep);
printf("%s", bu_vls_addr(&vls));
bu_vls_free(&vls);
return different;
}
static int xQueryPhraseCb(
const Fts5ExtensionApi *pApi,
Fts5Context *pFts,
void *pCtx
){
F5tFunction *p = (F5tFunction*)pCtx;
static sqlite3_int64 iCmd = 0;
Tcl_Obj *pEval;
int rc;
char zCmd[64];
F5tApi sApi;
sApi.pApi = pApi;
sApi.pFts = pFts;
sprintf(zCmd, "f5t_2_%lld", iCmd++);
Tcl_CreateObjCommand(p->interp, zCmd, xF5tApi, &sApi, 0);
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zCmd, -1));
rc = Tcl_EvalObjEx(p->interp, pEval, 0);
Tcl_DecrRefCount(pEval);
Tcl_DeleteCommand(p->interp, zCmd);
if( rc==TCL_OK ){
rc = f5tResultToErrorCode(Tcl_GetStringResult(p->interp));
}
return rc;
}
/**
* 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;
}
static Tcl_Obj *Ttk_Use(
Tcl_Interp *interp,
Tcl_HashTable *table,
Allocator allocate,
Tk_Window tkwin,
Tcl_Obj *objPtr)
{
int newEntry;
Tcl_HashEntry *entryPtr =
Tcl_CreateHashEntry(table,Tcl_GetString(objPtr),&newEntry);
Tcl_Obj *cacheObj;
if (!newEntry) {
return Tcl_GetHashValue(entryPtr);
}
cacheObj = Tcl_DuplicateObj(objPtr);
Tcl_IncrRefCount(cacheObj);
if (allocate(interp, tkwin, cacheObj)) {
Tcl_SetHashValue(entryPtr, cacheObj);
return cacheObj;
} else {
Tcl_DecrRefCount(cacheObj);
Tcl_SetHashValue(entryPtr, NULL);
Tcl_BackgroundException(interp, TCL_ERROR);
return NULL;
}
}
/* Ttk_TraceVariable(interp, varNameObj, callback, clientdata) --
* Attach a write trace to the specified variable,
* which will pass the variable's value to 'callback'
* whenever the variable is set.
*
* When the variable is unset, passes NULL to the callback
* and reattaches the trace.
*/
Ttk_TraceHandle *Ttk_TraceVariable(
Tcl_Interp *interp,
Tcl_Obj *varnameObj,
Ttk_TraceProc callback,
void *clientData)
{
Ttk_TraceHandle *h = (Ttk_TraceHandle*)ckalloc(sizeof(*h));
int status;
h->interp = interp;
h->varnameObj = Tcl_DuplicateObj(varnameObj);
Tcl_IncrRefCount(h->varnameObj);
h->clientData = clientData;
h->callback = callback;
status = Tcl_TraceVar(interp, Tcl_GetString(varnameObj),
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VarTraceProc, (ClientData)h);
if (status != TCL_OK) {
Tcl_DecrRefCount(h->varnameObj);
ckfree((ClientData)h);
return NULL;
}
return h;
}
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;
}
static void tvfsExecTcl(
Testvfs *p,
const char *zMethod,
Tcl_Obj *arg1,
Tcl_Obj *arg2,
Tcl_Obj *arg3,
Tcl_Obj *arg4
){
int rc; /* Return code from Tcl_EvalObj() */
Tcl_Obj *pEval;
assert( p->pScript );
assert( zMethod );
assert( p );
assert( arg2==0 || arg1!=0 );
assert( arg3==0 || arg2!=0 );
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(p->pScript);
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zMethod, -1));
if( arg1 ) Tcl_ListObjAppendElement(p->interp, pEval, arg1);
if( arg2 ) Tcl_ListObjAppendElement(p->interp, pEval, arg2);
if( arg3 ) Tcl_ListObjAppendElement(p->interp, pEval, arg3);
if( arg4 ) Tcl_ListObjAppendElement(p->interp, pEval, arg4);
rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
if( rc!=TCL_OK ){
Tcl_BackgroundError(p->interp);
Tcl_ResetResult(p->interp);
}
}
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;
}
static Tcl_Obj*
rcBuildCmdList(ReflectingChannel* chan_, Tcl_Obj* cmd_)
{
Tcl_Obj* vec = Tcl_DuplicateObj(chan_->_context);
Tcl_IncrRefCount(vec);
Tcl_ListObjAppendElement(chan_->_interp, vec, cmd_);
Tcl_ListObjAppendElement(chan_->_interp, vec, chan_->_name);
return vec; /* with refcount 1 */
}
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;
}
static int stateHandlerInvoke(Tcl_Event* p, int flags) {
/* called from Tcl event loop, when the connection status changes */
connectionEvent *cev =(connectionEvent *) p;
pvInfo *info = cev->info;
Tcl_Obj *script = Tcl_DuplicateObj(info->connectprefix);
Tcl_IncrRefCount(script);
/* append cmd of PV and up/down */
Tcl_Obj *cmdname = Tcl_NewObj();
Tcl_GetCommandFullName(info->interp, info->cmd, cmdname);
int code = Tcl_ListObjAppendElement(info->interp, script, cmdname);
if (code != TCL_OK) {
goto bgerr;
}
if (cev->op == CA_OP_CONN_UP) {
info->connected = 1;
/* Retrieve information about type and number of elements */
info->nElem = ca_element_count(info->id);
info->type = ca_field_type(info->id);
} else {
info->connected = 0;
}
code = Tcl_ListObjAppendElement(info->interp, script, Tcl_NewBooleanObj(info->connected));
if (code != TCL_OK) {
goto bgerr;
}
Tcl_Preserve(info->interp);
code = Tcl_EvalObjEx(info->interp, script, TCL_EVAL_GLOBAL);
if (code != TCL_OK) { goto bgerr; }
Tcl_Release(info->interp);
Tcl_DecrRefCount(script);
/* this event was successfully handled */
return 1;
bgerr:
/* put error in background */
Tcl_AddErrorInfo(info->interp, "\n (epics connection callback script)");
Tcl_BackgroundException(info->interp, code);
/* this event was successfully handled */
return 1;
}
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
TkWinSend_SetExcepInfo(
Tcl_Interp *interp,
EXCEPINFO *pExcepInfo)
{
Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
ICreateErrorInfo *pCEI;
IErrorInfo *pEI, **ppEI = &pEI;
HRESULT hr;
if (!pExcepInfo) {
return;
}
opError = Tcl_GetObjResult(interp);
opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
opErrorCode = Tcl_GetVar2Ex(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
/*
* Pack the trace onto the end of the Tcl exception descriptor.
*/
opErrorCode = Tcl_DuplicateObj(opErrorCode);
Tcl_IncrRefCount(opErrorCode);
Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
/* TODO: Handle failure to append */
pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
Tcl_DecrRefCount(opErrorCode);
pExcepInfo->scode = E_FAIL;
hr = CreateErrorInfo(&pCEI);
if (!SUCCEEDED(hr)) {
return;
}
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);
}
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);
}
}
}
void
TclHideLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
register CompileEnv *envPtr,/* Points to CompileEnv whose literal array
* contains the entry being hidden. */
int index) /* The index of the entry in the literal
* array. */
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &(envPtr->localLitTable);
int localHash, length;
char *bytes;
Tcl_Obj *newObjPtr;
lPtr = &(envPtr->literalArrayPtr[index]);
/*
* To avoid unwanted sharing we need to copy the object and remove it from
* the local and global literal tables. It still has a slot in the literal
* array so it can be referred to by byte codes, but it will not be
* matched by literal searches.
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
bytes = TclGetStringFromObj(newObjPtr, &length);
localHash = (HashString(bytes, length) & localTablePtr->mask);
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
if (entryPtr == lPtr) {
*nextPtrPtr = lPtr->nextPtr;
lPtr->nextPtr = NULL;
localTablePtr->numEntries--;
break;
}
nextPtrPtr = &entryPtr->nextPtr;
}
}
Tcl_Obj *
TclpTempFileName(void)
{
Tcl_Obj *retVal, *nameObj = Tcl_NewObj();
int fd;
Tcl_IncrRefCount(nameObj);
fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, nameObj);
if (fd == -1) {
Tcl_DecrRefCount(nameObj);
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
TclpObjDeleteFile(nameObj);
close(fd);
retVal = Tcl_DuplicateObj(nameObj);
Tcl_DecrRefCount(nameObj);
return retVal;
}
static int xTokenizeCb(
void *pCtx,
const char *zToken, int nToken,
int iStart, int iEnd
){
F5tFunction *p = (F5tFunction*)pCtx;
Tcl_Obj *pEval = Tcl_DuplicateObj(p->pScript);
int rc;
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zToken, nToken));
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewIntObj(iStart));
Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewIntObj(iEnd));
rc = Tcl_EvalObjEx(p->interp, pEval, 0);
Tcl_DecrRefCount(pEval);
if( rc==TCL_OK ){
rc = f5tResultToErrorCode(Tcl_GetStringResult(p->interp));
}
return rc;
}
/*
** This is the callback from a quota-over-limit.
*/
static void tclQuotaCallback(
const char *zFilename, /* Name of file whose size increases */
sqlite3_int64 *piLimit, /* IN/OUT: The current limit */
sqlite3_int64 iSize, /* Total size of all files in the group */
void *pArg /* Client data */
){
TclQuotaCallback *p; /* Callback script object */
Tcl_Obj *pEval; /* Script to evaluate */
Tcl_Obj *pVarname; /* Name of variable to pass as 2nd arg */
unsigned int rnd; /* Random part of pVarname */
int rc; /* Tcl error code */
p = (TclQuotaCallback *)pArg;
if( p==0 ) return;
pVarname = Tcl_NewStringObj("::piLimit_", -1);
Tcl_IncrRefCount(pVarname);
sqlite3_randomness(sizeof(rnd), (void *)&rnd);
Tcl_AppendObjToObj(pVarname, Tcl_NewIntObj((int)(rnd&0x7FFFFFFF)));
Tcl_ObjSetVar2(p->interp, pVarname, 0, Tcl_NewWideIntObj(*piLimit), 0);
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewStringObj(zFilename, -1));
Tcl_ListObjAppendElement(0, pEval, pVarname);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewWideIntObj(iSize));
rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
if( rc==TCL_OK ){
Tcl_Obj *pLimit = Tcl_ObjGetVar2(p->interp, pVarname, 0, 0);
rc = Tcl_GetWideIntFromObj(p->interp, pLimit, piLimit);
Tcl_UnsetVar(p->interp, Tcl_GetString(pVarname), 0);
}
Tcl_DecrRefCount(pEval);
Tcl_DecrRefCount(pVarname);
if( rc!=TCL_OK ) Tcl_BackgroundError(p->interp);
}
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;
}
/* $scale set $newValue
*/
static int
ScaleSetCommand(
void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
Scale *scalePtr = recordPtr;
double from = 0.0, to = 1.0, value;
int result = TCL_OK;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "set value");
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
if (scalePtr->core.state & TTK_STATE_DISABLED) {
return TCL_OK;
}
/* ASSERT: fromObj and toObj are valid doubles.
*/
Tcl_GetDoubleFromObj(interp, scalePtr->scale.fromObj, &from);
Tcl_GetDoubleFromObj(interp, scalePtr->scale.toObj, &to);
/* Limit new value to between 'from' and 'to':
*/
if (from < to) {
value = value < from ? from : value > to ? to : value;
} else {
value = value < to ? to : value > from ? from : value;
}
/*
* Set value:
*/
Tcl_DecrRefCount(scalePtr->scale.valueObj);
scalePtr->scale.valueObj = Tcl_NewDoubleObj(value);
Tcl_IncrRefCount(scalePtr->scale.valueObj);
TtkRedisplayWidget(&scalePtr->core);
/*
* Set attached variable, if any:
*/
if (scalePtr->scale.variableObj != NULL) {
Tcl_ObjSetVar2(interp, scalePtr->scale.variableObj, NULL,
scalePtr->scale.valueObj, TCL_GLOBAL_ONLY);
}
if (WidgetDestroyed(&scalePtr->core)) {
return TCL_ERROR;
}
/*
* Invoke -command, if any:
*/
if (scalePtr->scale.commandObj != NULL) {
Tcl_Obj *cmdObj = Tcl_DuplicateObj(scalePtr->scale.commandObj);
Tcl_IncrRefCount(cmdObj);
Tcl_AppendToObj(cmdObj, " ", 1);
Tcl_AppendObjToObj(cmdObj, scalePtr->scale.valueObj);
result = Tcl_EvalObjEx(interp, cmdObj, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdObj);
}
return result;
}
static int
TestobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
const char *index, *subCmd, *string;
const Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "duplicate") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "freeallvars") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i] != NULL) {
Tcl_DecrRefCount(varPtr[i]);
varPtr[i] = NULL;
}
}
} else if (strcmp(subCmd, "invalidateStringRep") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_InvalidateStringRep(varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "newobj") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
const char *typeName;
/*
* Return an object containing the name of the argument's type of
* internal rep. If none exists, return "none".
*/
if (objc != 3) {
goto wrongNumArgs;
}
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
} else if (strcmp(subCmd, "types") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
if (Tcl_AppendAllObjTypes(interp,
Tcl_GetObjResult(interp)) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be assign, convert, duplicate, freeallvars, "
"newobj, objcount, objtype, refcount, type, or types", NULL);
return TCL_ERROR;
}
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);
}
}
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
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;
}
/*
* 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;
}
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);
}
}
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);
}
