/**
*
* Get file association
*
* @param __filename - a file name
* @param __extcmd - a pointer of structures encapsulate file action
* @return TCL_OK if successful, TCL_ERROR otherwise
*/
int
_get_file_associations (wchar_t *__filename, extension_action_t **__extcmd)
{
Tcl_Obj *value, *associate =
Tcl_GetVar2Ex (interpreter, "association", NULL, TCL_GLOBAL_ONLY);
char *filename;
if (associate == NULL)
{
return TCL_ERROR;
}
wcs2mbs(&filename, __filename);
if (tcllib_fa_get_object (interpreter,
associate,
Tcl_NewStringObj (filename, -1), &value) != TCL_OK)
{
return TCL_ERROR;
}
*__extcmd = tcllib_extcmd_from_object (value);
SAFE_FREE (filename);
return TCL_OK;
}
static int tclvarColumn(sqlite3_vtab_cursor *cur, sqlite3_context *ctx, int i){
Tcl_Obj *p1;
Tcl_Obj *p2;
const char *z1;
const char *z2 = "";
tclvar_cursor *pCur = (tclvar_cursor*)cur;
Tcl_Interp *interp = ((tclvar_vtab *)cur->pVtab)->interp;
Tcl_ListObjIndex(interp, pCur->pList1, pCur->i1, &p1);
Tcl_ListObjIndex(interp, pCur->pList2, pCur->i2, &p2);
z1 = Tcl_GetString(p1);
if( p2 ){
z2 = Tcl_GetString(p2);
}
switch (i) {
case 0: {
sqlite3_result_text(ctx, z1, -1, SQLITE_TRANSIENT);
break;
}
case 1: {
sqlite3_result_text(ctx, z2, -1, SQLITE_TRANSIENT);
break;
}
case 2: {
Tcl_Obj *pVal = Tcl_GetVar2Ex(interp, z1, *z2?z2:0, TCL_GLOBAL_ONLY);
sqlite3_result_text(ctx, Tcl_GetString(pVal), -1, SQLITE_TRANSIENT);
break;
}
}
return SQLITE_OK;
}
enum MqErrorE NS(ProcError) (
struct TclContextS * const tclctx,
MQ_CST proc
)
{
SETUP_interp
enum MqErrorE ret = MQ_OK;
Tcl_Obj *item;
Tcl_Obj *errorCode = Tcl_GetVar2Ex (interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
if (
Tcl_ListObjIndex (NULL, errorCode, 0, &item) == TCL_ERROR || // index "0" is not in the list "code"
strncmp (Tcl_GetString (item), "TCLMSGQUE", 9) // error is not from "TCLMSGQUE"
) {
// tcl error
ret = MqErrorC (MQCTX,proc,-1,Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY));
} else {
// tclmsgque error
int errnum = -1;
int errcode = -1;
Tcl_ListObjIndex (NULL, errorCode, 1, &item);
Tcl_GetIntFromObj(NULL, item, &errnum);
Tcl_ListObjIndex (NULL, errorCode, 2, &item);
Tcl_GetIntFromObj(NULL, item, &errcode);
Tcl_ListObjIndex (NULL, errorCode, 3, &item);
ret = MqErrorSet (MQCTX, errnum, (enum MqErrorE) errcode, Tcl_GetString(item), NULL);
}
Tcl_ResetResult(interp);
return ret;
}
HRESULT
ComObject::hresultFromErrorCode () const
{
#if TCL_MINOR_VERSION >= 1
Tcl_Obj *pErrorCode =
Tcl_GetVar2Ex(m_interp, "::errorCode", 0, TCL_LEAVE_ERR_MSG);
#else
TclObject errorCodeVarName("::errorCode");
Tcl_Obj *pErrorCode =
Tcl_ObjGetVar2(m_interp, errorCodeVarName, 0, TCL_LEAVE_ERR_MSG);
#endif
if (pErrorCode == 0) {
return E_UNEXPECTED;
}
Tcl_Obj *pErrorClass;
if (Tcl_ListObjIndex(m_interp, pErrorCode, 0, &pErrorClass) != TCL_OK) {
return E_UNEXPECTED;
}
if (strcmp(Tcl_GetStringFromObj(pErrorClass, 0), "COM") != 0) {
return E_UNEXPECTED;
}
Tcl_Obj *pHresult;
if (Tcl_ListObjIndex(m_interp, pErrorCode, 1, &pHresult) != TCL_OK) {
return E_UNEXPECTED;
}
HRESULT hr;
if (Tcl_GetLongFromObj(m_interp, pHresult, &hr) != TCL_OK) {
return E_UNEXPECTED;
}
return hr;
}
void tclSendThread(Tcl_ThreadId thread, Tcl_Interp *interpreter, CONST char *script)
{
ThreadEvent *event;
Tcl_Channel errorChannel;
Tcl_Obj *object;
int boolean;
object = Tcl_GetVar2Ex(interpreter, "::tcl_platform", "threaded", 0);
if ((object == 0) || (Tcl_GetBooleanFromObj(interpreter, object, &boolean) != TCL_OK) || !boolean) {
errorChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errorChannel == NULL) return;
Tcl_WriteChars(
errorChannel, "error: Python thread requested script evaluation on Tcl core not compiled for multithreading.\n", -1
);
return;
}
event = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent));
event->event.proc = ThreadEventProc;
event->interpreter = interpreter;
event->script = strcpy(Tcl_Alloc(strlen(script) + 1), script);
Tcl_MutexLock(&threadMutex);
Tcl_ThreadQueueEvent(thread, (Tcl_Event *)event, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(thread);
Tcl_MutexUnlock(&threadMutex);
}
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);
}
static int
asyncSignalHandler(ClientData data, Tcl_Interp *interp, int code)
{
ElTclSignalContext *ctx = data;
Tcl_Obj *result, *errorInfo, *errorCode;
if (ctx->script == ELTCL_SIGDFL || ctx->script == ELTCL_SIGIGN) {
fputs("Warning: wrong signal delivered for Tcl\n", stdout);
return code;
}
/* save interpreter state */
result = Tcl_GetObjResult(ctx->iinfo->interp);
if (result != NULL) Tcl_IncrRefCount(result);
errorInfo = Tcl_GetVar2Ex(ctx->iinfo->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (errorInfo != NULL) Tcl_IncrRefCount(errorInfo);
errorCode = Tcl_GetVar2Ex(ctx->iinfo->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (errorCode != NULL) Tcl_IncrRefCount(errorCode);
/* eval script */
if (Tcl_EvalObjEx(ctx->iinfo->interp,
ctx->script, TCL_EVAL_GLOBAL) != TCL_OK)
Tcl_BackgroundError(ctx->iinfo->interp);
/* restore interpreter state */
if (errorInfo != NULL) {
Tcl_SetVar2Ex(ctx->iinfo->interp, "errorInfo", NULL, errorInfo,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorInfo);
}
if (errorCode != NULL) {
Tcl_SetVar2Ex(ctx->iinfo->interp, "errorCode", NULL, errorCode,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorCode);
}
if (result != NULL) {
Tcl_SetObjResult(ctx->iinfo->interp, result);
Tcl_DecrRefCount(result);
}
return code;
}
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 void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
int partial) /* Non-zero means there already exists a
* partial command, so use the secondary
* prompt. */
{
Tcl_Obj *promptCmd;
int code;
Tcl_Channel outChannel, errChannel;
promptCmd = Tcl_GetVar2Ex(interp,
partial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY);
if (promptCmd == NULL) {
defaultPrompt:
if (!partial) {
/*
* We must check that outChannel is a real channel - it is
* possible that someone has transferred stdout out of this
* interpreter with "interp transfer".
*/
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_WriteChars(outChannel, "% ", 2);
}
}
} else {
code = Tcl_EvalObjEx(interp, promptCmd, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
/*
* We must check that errChannel is a real channel - it is
* possible that someone has transferred stderr out of this
* interpreter with "interp transfer".
*/
errChannel = Tcl_GetChannel(interp, "stderr", NULL);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
}
SEXP RTcl_ObjFromVar(SEXP args)
{
Tcl_Obj *tclobj;
const void *vmax = vmaxget();
tclobj = Tcl_GetVar2Ex(RTcl_interp,
translateChar(STRING_ELT(CADR(args), 0)),
NULL,
0);
SEXP res = makeRTclObject(tclobj);
vmaxset(vmax);
return res;
}
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE
* after a prompt is printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel chan;
if (isPtr->prompt == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
(isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
return;
}
if (promptCmdPtr == NULL) {
defaultPrompt:
if (isPtr->prompt == PROMPT_START) {
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
strlen(DEFAULT_PRIMARY_PROMPT));
}
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
goto defaultPrompt;
}
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_Flush(chan);
}
isPtr->prompt = PROMPT_NONE;
}
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
PromptType *promptPtr) /* Points to type of prompt to print. Filled
* with PROMPT_NONE after a prompt is
* printed. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel outChannel, errChannel;
if (*promptPtr == PROMPT_NONE) {
return;
}
promptCmdPtr = Tcl_GetVar2Ex(interp,
((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (Tcl_InterpDeleted(interp)) {
return;
}
if (promptCmdPtr == NULL) {
defaultPrompt:
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if ((*promptPtr == PROMPT_START)
&& (outChannel != (Tcl_Channel) NULL)) {
Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
strlen(DEFAULT_PRIMARY_PROMPT));
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
*promptPtr = PROMPT_NONE;
}
static int check_sandboxing(Tcl_Interp *interp, char **sandbox_exec_path, char **profilestr)
{
Tcl_Obj *tcl_result;
int active;
int len;
tcl_result = Tcl_GetVar2Ex(interp, "portsandbox_active", NULL, TCL_GLOBAL_ONLY);
if (!tcl_result || Tcl_GetBooleanFromObj(interp, tcl_result, &active) != TCL_OK || !active) {
return 0;
}
tcl_result = Tcl_GetVar2Ex(interp, "portutil::autoconf::sandbox_exec_path", NULL, TCL_GLOBAL_ONLY);
if (!tcl_result || !(*sandbox_exec_path = Tcl_GetString(tcl_result))) {
return 0;
}
tcl_result = Tcl_GetVar2Ex(interp, "portsandbox_profile", NULL, TCL_GLOBAL_ONLY);
if (!tcl_result || !(*profilestr = Tcl_GetStringFromObj(tcl_result, &len))
|| len == 0) {
return 0;
}
return 1;
}
static char *traceFunc( ClientData data,
Tcl_Interp *interp, const char *name1, const char *name2, int flags)
{
SpinButtonParams *para = (SpinButtonParams *)data;
if( para->inSetVar == 0 && name1 != NULL )
{
Tcl_Obj *val = Tcl_GetVar2Ex( interp, name1, name2, flags );
if( val )
{
setValue( para, val );
doCommand( para, val, 1 );
}
}
return NULL;
}
static Tcl_Obj *
GetWidgetDemoPath(
Tcl_Interp *interp)
{
Tcl_Obj *libpath, *result = NULL;
libpath = Tcl_GetVar2Ex(gInterp, "tk_library", NULL, TCL_GLOBAL_ONLY);
if (libpath) {
Tcl_Obj *demo[2] = { Tcl_NewStringObj("demos", 5),
Tcl_NewStringObj("widget", 6) };
Tcl_IncrRefCount(libpath);
result = Tcl_FSJoinToPath(libpath, 2, demo);
Tcl_DecrRefCount(libpath);
}
return result;
}
SEXP RTcl_GetArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
Tcl_Obj *tclobj;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
tclobj = Tcl_GetVar2Ex(RTcl_interp, xstr, istr, 0);
vmaxset(vmax);
if (tclobj == NULL)
return R_NilValue;
else
return makeRTclObject(tclobj);
}
static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
InteractiveState *isPtr) /* InteractiveState. */
{
Tcl_Obj *promptCmdPtr;
int code;
Tcl_Channel chan;
promptCmdPtr = Tcl_GetVar2Ex(interp,
isPtr->gotPartial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY);
if (promptCmdPtr == NULL) {
defaultPrompt:
if (!isPtr->gotPartial) {
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
strlen(DEFAULT_PRIMARY_PROMPT));
}
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
if (Tcl_GetStringResult(interp)[0] != '\0') {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
goto defaultPrompt;
}
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan != NULL) {
Tcl_Flush(chan);
}
}
/*
* Ttk_FireTrace --
* Executes a trace handle as if the variable has been written.
*
* Note: may reenter the interpreter.
*/
int Ttk_FireTrace(Ttk_TraceHandle *tracePtr)
{
Tcl_Interp *interp = tracePtr->interp;
void *clientData = tracePtr->clientData;
const char *name = Tcl_GetString(tracePtr->varnameObj);
Ttk_TraceProc callback = tracePtr->callback;
Tcl_Obj *valuePtr;
const char *value;
/* Read the variable.
* Note that this can reenter the interpreter, and anything can happen --
* including the current trace handle being freed!
*/
valuePtr = Tcl_GetVar2Ex(interp, name, NULL, TCL_GLOBAL_ONLY);
value = valuePtr ? Tcl_GetString(valuePtr) : NULL;
/* Call callback.
*/
callback(clientData, value);
return TCL_OK;
}
/*
* Tcl_VarTraceProc for trace handles.
*/
static char *
VarTraceProc(
ClientData clientData, /* Widget record pointer */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* (unused) */
const char *name2, /* (unused) */
int flags) /* Information about what happened. */
{
Ttk_TraceHandle *tracePtr = clientData;
const char *name, *value;
Tcl_Obj *valuePtr;
if (flags & TCL_INTERP_DESTROYED) {
return NULL;
}
name = Tcl_GetString(tracePtr->varnameObj);
/*
* If the variable is being unset, then re-establish the trace:
*/
if (flags & TCL_TRACE_DESTROYED) {
Tcl_TraceVar(interp, name,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VarTraceProc, clientData);
tracePtr->callback(tracePtr->clientData, NULL);
return NULL;
}
/*
* Call the callback:
*/
valuePtr = Tcl_GetVar2Ex(interp, name, NULL, TCL_GLOBAL_ONLY);
value = valuePtr ? Tcl_GetString(valuePtr) : NULL;
tracePtr->callback(tracePtr->clientData, value);
return NULL;
}
EXTERN int
Pgtcl_Init(Tcl_Interp *interp)
{
double tclversion;
Tcl_Obj *tclVersionObj;
PgCmd *cmdPtr;
#ifdef WIN32
WSADATA wsaData;
#endif
#ifdef USE_TCL_STUBS
if (Tcl_InitStubs(interp, "8.1", 0) == NULL)
return TCL_ERROR;
#endif
#ifdef WIN32X
/*
* On Windows, need to explicitly load the libpq library to
* force the call to WSAStartup.
*/
Tcl_Obj *tresult;
if (LoadLibrary("libpq.dll") == NULL) {
//char buf[32];
//sprintf(buf, "%d", GetLastError());
tresult = Tcl_NewStringObj("Cannot load \"libpq.dll\" (or dependant), error was ");
Tcl_AppendToObj(tresult, GetLastError(), -1);
Tcl_SetObjResult(interp, tresult);
/*
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"Cannot load \"libpq.dll\" (or dependant), error was ",
GetLastError(), NULL);
*/
return TCL_ERROR;
}
#endif
#ifdef WIN32
if (WSAStartup(MAKEWORD(1, 1), &wsaData))
{
/*
* No really good way to do error handling here, since we
* don't know how we were loaded
*/
return FALSE;
}
#endif
/*
* Tcl versions >= 8.1 use UTF-8 for their internal string
* representation. Therefore PGCLIENTENCODING must be set to UNICODE
* for these versions.
*/
if ((tclVersionObj = Tcl_GetVar2Ex(interp, "tcl_version", NULL, TCL_GLOBAL_ONLY)) == NULL)
return TCL_ERROR;
if (Tcl_GetDoubleFromObj(interp, tclVersionObj, &tclversion) == TCL_ERROR)
return TCL_ERROR;
if (tclversion >= 8.1)
Tcl_PutEnv("PGCLIENTENCODING=UNICODE");
/* register all pgtcl commands */
for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
Tcl_CreateObjCommand(interp, cmdPtr->name,
cmdPtr->objProc, (ClientData) "::",NULL);
Tcl_CreateObjCommand(interp, cmdPtr->name2,
cmdPtr->objProc, (ClientData) "::pg::",NULL);
}
if (Tcl_Eval(interp, "namespace eval ::pg namespace export *") == TCL_ERROR)
return TCL_ERROR;
return Tcl_PkgProvide(interp, "Pgtcl", PACKAGE_VERSION);
}
int
TclInterpreter::run() {
/*
* If a script file was specified then just source that file
* and quit.
*/
if (tclStartupScriptFileName != NULL) {
code = Tcl_EvalFile(interp, tclStartupScriptFileName);
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
*/
Tcl_AddErrorInfo(interp, "");
Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
return 0;
}
else {
/*
const char *pwd = getInterpPWD(interp);
simulationInfo.start();
simulationInfo.addInputFile(tclStartupScriptFileName, pwd);
*/
/*
* We're running interactively. Source a user-specific startup
* file if the application specified one and if the file exists.
*/
Tcl_DStringFree(&argString);
Tcl_SourceRCFile(interp);
/*
* 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.
*/
/*
if (simulationInfoOutputFilename != 0) {
simulationInfo.start();
}
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
while (1) {
if (tty) {
Tcl_Obj *promptCmdPtr;
char one[12] = "tcl_prompt1";
char two[12] = "tcl_prompt2";
promptCmdPtr = Tcl_GetVar2Ex(interp,
(gotPartial ? one : two),
NULL, TCL_GLOBAL_ONLY);
if (promptCmdPtr == NULL) {
defaultPrompt:
if (!gotPartial && outChannel) {
Tcl_WriteChars(outChannel, "OpenSees > ", 11);
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
goto defaultPrompt;
}
}
if (outChannel) {
Tcl_Flush(outChannel);
}
}
if (!inChannel) {
return 0;
// goto done;
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
return 0; //goto done;
}
if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
return 0; // goto done;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
gotPartial = 1;
continue;
}
gotPartial = 0;
code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
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_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
}
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DecrRefCount(commandPtr);
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
}
#endif
}
}
return 0;
}
/*
** This routine runs first.
*/
int main(int argc, char **argv){
Tcl_Interp *interp;
char *args;
char buf[100];
int tty;
char TCLdir[20];
char TKdir[20];
char autopath[20];
char sourceCmd[80];
#ifdef WITHOUT_TK
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
char buffer[1000];
int code, gotPartial, length;
Tcl_Channel inChannel, outChannel, errChannel;
#endif
/* Create a Tcl interpreter
*/
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
if( Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 1)==0 ){
return 1;
}
args = Tcl_Merge(argc-1, (CONST84 char * CONST *)argv+1);
Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
ckfree(args);
sprintf(buf, "%d", argc-1);
Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "argv0", argv[0], TCL_GLOBAL_ONLY);
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* We have to initialize the virtual filesystem before calling
** Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
** its startup script files.
*/
Zvfs_Init(interp);
Tcl_SetVar(interp, "extname", "", TCL_GLOBAL_ONLY);
Zvfs_Mount(interp, (char *)Tcl_GetNameOfExecutable(), "/");
sprintf(TCLdir, "%s/tcl", mountPt);
Tcl_SetVar2(interp, "env", "TCL_LIBRARY", TCLdir, TCL_GLOBAL_ONLY);
sprintf(TKdir, "%s/tk", mountPt);
Tcl_SetVar2(interp, "env", "TK_LIBRARY", TKdir, TCL_GLOBAL_ONLY);
/* Initialize Tcl and Tk
*/
if( Tcl_Init(interp) ) return TCL_ERROR;
sprintf(autopath, " %s", TCLdir);
Tcl_SetVar(interp, "auto_path", autopath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_libPath", TCLdir, TCL_GLOBAL_ONLY);
#ifdef WITHOUT_TK
Tcl_SetVar(interp, "extname", "tclsh", TCL_GLOBAL_ONLY);
#else
Tk_InitConsoleChannels(interp);
if ( Tk_Init(interp) ) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp,"Tk", Tk_Init, 0);
Tk_CreateConsoleWindow(interp);
#endif
/* Start up all extensions.
*/
#if defined(__WIN32__)
/* DRL - Do the standard Windows extentions */
if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Registry", Registry_Init, 0);
if (Dde_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Dde", Dde_Init, 0);
#endif
#ifndef WITHOUT_TDOM
if (Tdom_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tdom", Tdom_Init, Tdom_SafeInit);
#endif
#ifndef WITHOUT_TLS
if (Tls_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tls", Tls_Init, Tls_SafeInit);
#endif
/*
#ifndef WITHOUT_MKZIPLIB
if (Mkziplib_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Mkziplib", Mkziplib_Init, Mkziplib_SafeInit);
#endif
*/
#ifndef WITHOUT_XOTCL
if (Xotcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Xotcl", Xotcl_Init, Xotcl_SafeInit);
/*
if (Xotclexpat_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "xotclexpat", Xotclexpat_Init, 0);
*/
/*
if (Xotclsdbm_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
*/
// Tcl_StaticPackage(interp, "xotclsdbm", Xotclsdbm_Init, Xotclsdbm_SafeInit);
/*
if (Xotclgdbm_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
*/
// Tcl_StaticPackage(interp, "xotclgdbm", Xotclgdbm_Init, Xotclgdbm_SafeInit);
#endif
#ifndef WITHOUT_TGDBM
if (Tgdbm_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tgdbm", Tgdbm_Init, 0);
#endif
#ifndef WITHOUT_THREAD
if (Thread_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Thread", Thread_Init, 0);
#endif
#if !defined(WITHOUT_TK) && !defined(WITHOUT_WINICO) && (defined(__WIN32__) || defined(_WIN32))
if (Winico_Init(interp) == TCL_ERROR) return TCL_ERROR;
Tcl_StaticPackage(interp, "Winico", Winico_Init, Winico_SafeInit);
#endif
/* Add some freeWrap commands */
if (Freewrap_Init(interp) == TCL_ERROR) return TCL_ERROR;
/* After all extensions are registered, start up the
** program by running freewrapCmds.tcl.
*/
sprintf(sourceCmd, "source %s/freewrapCmds.tcl", mountPt);
Tcl_Eval(interp, sourceCmd);
#ifndef WITHOUT_TK
/*
* Loop infinitely, waiting for commands to execute. When there
* are no windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
#else
/*
* 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);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
while (1) {
if (tty) {
Tcl_Obj *promptCmdPtr;
promptCmdPtr = Tcl_GetVar2Ex(interp,
(gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
NULL, TCL_GLOBAL_ONLY);
if (promptCmdPtr == NULL) {
defaultPrompt:
if (!gotPartial && outChannel) {
Tcl_WriteChars(outChannel, "% ", 2);
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
goto defaultPrompt;
}
}
if (outChannel) {
Tcl_Flush(outChannel);
}
}
if (!inChannel) {
goto done;
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
goto done;
}
if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
goto done;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
gotPartial = 1;
continue;
}
gotPartial = 0;
code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
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_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
}
}
/*
* 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_Eval call should never return.
*/
done:
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
sprintf(buffer, "exit %d", 0);
Tcl_Eval(interp, buffer);
#endif
return TCL_OK;
}
/*
* Loads the initialization script from image file resource
*/
TCL_RESULT Twapi_SourceResource(Tcl_Interp *interp, HANDLE dllH, const char *name, int try_file)
{
HRSRC hres = NULL;
unsigned char *dataP;
DWORD sz;
HGLOBAL hglob;
int result;
int compressed;
Tcl_Obj *pathObj;
/*
* Locate the twapi resource and load it if found. First check for
* compressed type. Then uncompressed.
*/
compressed = 1;
hres = FindResourceA(dllH,
name,
TWAPI_SCRIPT_RESOURCE_TYPE_LZMA);
if (!hres) {
hres = FindResourceA(dllH,
name,
TWAPI_SCRIPT_RESOURCE_TYPE);
compressed = 0;
}
if (hres) {
sz = SizeofResource(dllH, hres);
hglob = LoadResource(dllH, hres);
if (sz && hglob) {
dataP = LockResource(hglob);
if (dataP) {
/* If compressed, we need to uncompress it first */
if (compressed) {
dataP = TwapiLzmaUncompressBuffer(interp, dataP, sz, &sz);
if (dataP == NULL)
return TCL_ERROR; /* interp already has error */
}
/* The resource is expected to be UTF-8 (actually strict ASCII) */
/* TBD - double check use of GLOBAL and DIRECT */
result = Tcl_EvalEx(interp, (char *)dataP, sz, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
if (compressed)
TwapiLzmaFreeBuffer(dataP);
if (result == TCL_OK)
Tcl_ResetResult(interp);
return result;
}
}
return Twapi_AppendSystemError(interp, GetLastError());
}
if (!try_file) {
Tcl_AppendResult(interp, "Resource ", name, " not found.", NULL);
return TCL_ERROR;
}
/*
* No resource found. Try loading from twapi script directory if defined
* or from the twapi dll install directory
*/
pathObj = Tcl_GetVar2Ex(interp, "::" TWAPI_TCL_NAMESPACE "::scriptdir",
NULL, 0);
if (pathObj != NULL) {
pathObj = Tcl_DuplicateObj(pathObj);
Tcl_AppendToObj(pathObj, "/", 1);
} else {
Tcl_ResetResult(interp); /* Since the GetVar may have store error */
pathObj = TwapiGetInstallDir(interp, dllH);
}
if (pathObj == NULL)
return TCL_ERROR;
ObjIncrRefs(pathObj); /* Must before calling any Tcl_FS functions */
/* This bit of shenanigans is to allow MingW based builds to load
* twapi modules from files without requiring a resource */
#if defined(__GNUC__)
if (lstrlenA(name) > 6 && _strnicmp(name, "twapi_", 6) == 0)
name += 6;
#endif
Tcl_AppendStringsToObj(pathObj, name, ".tcl", NULL);
result = Tcl_FSEvalFile(interp, pathObj);
ObjDecrRefs(pathObj);
return result;
#if 0
/* Caller should be doing PkgProvide as appropriate. This function
is not only called for packages.
*/
if (result != TCL_OK)
return result;
return Tcl_PkgProvide(interp, MODULENAME, MODULEVERSION);
#endif
}
static int
GetProcsCmd(ClientData arg, Tcl_Interp *interp, int argc, char **argv)
{
Tcl_Parse parse;
Tcl_Obj *cmdPtr, *valsPtr[2];
char *p, *vars[2], *next, *script;
char err[100];
int i, n, len;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " script initVar procVar\"", NULL);
return TCL_ERROR;
}
p = argv[1];
n = strlen(p);
/*
* Get the current values of init and procs vars, if any.
*/
argv += 2;
argc -= 2;
for (i = 0; i < argc; ++i) {
vars[i] = argv[i];
valsPtr[i] = Tcl_GetVar2Ex(interp, vars[i], NULL, 0);
}
/*
* Parse and append procs and non-proc command to script vars.
*/
do {
if (Tcl_ParseCommand(interp, p, n, 0, &parse) != TCL_OK) {
sprintf(err, "\n (script offset %d)", p - argv[1]);
Tcl_AddErrorInfo(interp, err);
return TCL_ERROR;
}
if (parse.numWords > 0) {
if (strncmp(parse.tokenPtr->start, "proc", 4) != 0) {
i = 0; /* NB: Append init var. */
} else {
i = 1; /* NB: Append proc var. */
}
/*
* Check that previous script value is newline terminated
* before appending the next command.
*/
if (valsPtr[i] != NULL) {
script = Tcl_GetStringFromObj(valsPtr[i], &len);
if (len > 0 && script[len-1] != '\n'
&& Tcl_SetVar2(interp, vars[i], NULL, "\n",
TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE) == NULL) {
return TCL_ERROR;
}
}
cmdPtr = Tcl_NewStringObj(parse.commandStart, parse.commandSize);
Tcl_IncrRefCount(cmdPtr);
valsPtr[i] = Tcl_SetVar2Ex(interp, vars[i], NULL, cmdPtr,
TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(cmdPtr);
if (valsPtr[i] == NULL) {
return TCL_ERROR;
}
}
next = parse.commandStart + parse.commandSize;
n -= next - p;
p = next;
Tcl_FreeParse(&parse);
} while (n > 0);
return TCL_OK;
}
static int configure( Tcl_Interp *interp, SpinButtonParams *para,
GnoclOption options[] )
{
int ret = TCL_ERROR;
int blocked = 0;
int setAdjust = 0;
GtkAdjustment *oldAdjust = gtk_spin_button_get_adjustment(
para->spinButton );
gfloat lower = oldAdjust->lower;
gfloat upper = oldAdjust->upper;
gfloat stepInc = oldAdjust->step_increment;
gfloat pageInc = oldAdjust->page_increment;
if( gnoclSetOptions( interp, options, G_OBJECT( para->spinButton ), -1 )
!= TCL_OK )
goto cleanExit;
gnoclAttacheOptCmdAndVar( options + onValueChangedIdx, ¶->onValueChanged,
options + variableIdx, ¶->variable,
"value-changed", G_OBJECT( para->spinButton ),
G_CALLBACK( changedFunc ), interp, traceFunc, para );
if( para->onValueChanged != NULL )
{
blocked = g_signal_handlers_block_matched(
G_OBJECT( para->spinButton ), G_SIGNAL_MATCH_FUNC,
0, 0, NULL, (gpointer *)changedFunc, NULL );
}
if( options[valueIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[valueIdx].optName, "-value" ) == 0 );
gtk_spin_button_set_value( para->spinButton, options[valueIdx].val.d );
if( para->variable )
{
Tcl_Obj *obj = getObjValue( para->spinButton );
para->inSetVar++;
obj = Tcl_SetVar2Ex( para->interp, para->variable, NULL, obj,
TCL_GLOBAL_ONLY );
para->inSetVar--;
if( obj == NULL )
goto cleanExit;
}
}
/* if variable is set, synchronize variable and widget */
if( options[variableIdx].status == GNOCL_STATUS_CHANGED
&& para->variable != NULL
&& options[valueIdx].status != GNOCL_STATUS_CHANGED )
{
Tcl_Obj *var = Tcl_GetVar2Ex( interp, para->variable, NULL,
TCL_GLOBAL_ONLY );
assert( strcmp( options[variableIdx].optName, "-variable" ) == 0 );
if( var == NULL ) /* variable does not yet exist */
{
Tcl_Obj *obj = getObjValue( para->spinButton );
para->inSetVar++;
obj = Tcl_SetVar2Ex( para->interp, para->variable, NULL, obj,
TCL_GLOBAL_ONLY );
para->inSetVar--;
if( obj == NULL )
goto cleanExit;
}
else
{
double d;
if( Tcl_GetDoubleFromObj( interp, var, &d ) != TCL_OK )
goto cleanExit;
gtk_spin_button_set_value( para->spinButton, d );
}
}
if( options[lowerIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[lowerIdx].optName, "-lower" ) == 0 );
lower = options[lowerIdx].val.d;
setAdjust = 1;
}
if( options[upperIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[upperIdx].optName, "-upper" ) == 0 );
upper = options[upperIdx].val.d;
setAdjust = 1;
}
if( options[stepIncIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[stepIncIdx].optName, "-stepInc" ) == 0 );
stepInc = options[stepIncIdx].val.d;
setAdjust = 1;
}
if( options[pageIncIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[pageIncIdx].optName, "-pageInc" ) == 0 );
pageInc = options[pageIncIdx].val.d;
setAdjust = 1;
}
if( setAdjust )
{
/* see also scale.c */
/* last parameter is pageSize, where it is used? */
gtk_spin_button_set_adjustment( para->spinButton,
GTK_ADJUSTMENT( gtk_adjustment_new( oldAdjust->value, lower, upper,
stepInc, pageInc, 0 ) ) );
/* gtk_spin_button_update( para->spinButton ); */
}
/*
spinButtonTraceFunc( para, interp, para->variable, NULL, 0 );
*/
ret = TCL_OK;
cleanExit:
if( blocked )
{
g_signal_handlers_unblock_matched(
G_OBJECT( para->spinButton ), G_SIGNAL_MATCH_FUNC, 0,
0, NULL, (gpointer *)changedFunc, NULL );
}
return ret;
}
