static HRESULT
Async(
TkWinSendCom *obj,
VARIANT Cmd,
EXCEPINFO *pExcepInfo,
UINT *puArgErr)
{
HRESULT hr = S_OK;
int result = TCL_OK;
VARIANT vCmd;
VariantInit(&vCmd);
hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR);
if (FAILED(hr)) {
Tcl_SetStringObj(Tcl_GetObjResult(obj->interp),
"invalid args: Async(command)", -1);
SetExcepInfo(obj->interp, pExcepInfo);
hr = DISP_E_EXCEPTION;
}
if (SUCCEEDED(hr)) {
if (obj->interp) {
Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal,
(int)SysStringLen(vCmd.bstrVal));
result = TkWinSend_QueueCommand(obj->interp, scriptPtr);
}
}
VariantClear(&vCmd);
return hr;
}
/*
sequencer device channel create for reading or writing, not both at once.
*/
static int alsa_sequencer_open(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *port, Tcl_Obj *direction) {
const char *port_name = Tcl_GetString(port), *direction_name = Tcl_GetString(direction);
static snd_sequencer_t *input, **inputp;
static snd_sequencer_t *output, **outputp;
if (strcmp(direction_name, "r") == 0) {
inputp = &input;
outputp = NULL;
} else if (strcmp(direction_name, "w") == 0) {
inputp = NULL;
outputp = &output;
} else {
Tcl_AppendResult(interp, "open direction must be r or w", NULL);
return TCL_ERROR;
}
int err;
if ((err = snd_sequencer_open(inputp, outputp, port_name, SND_SEQUENCER_NONBLOCK)) < 0) {
Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "cannot open port \"%s\": %s", port_name, snd_strerror(err));
return TCL_ERROR;
}
if (inputp) {
snd_sequencer_read(input, NULL, 0); /* trigger reading */
return sequencer_make_channel(clientData, interp, input, TCL_READABLE);
}
if (outputp) {
if ((err = snd_sequencer_nonblock(output, 0)) < 0) {
Tcl_AppendResult(interp, "cannot set blocking mode: ", snd_strerror(err), NULL);
snd_sequencer_close(output);
return TCL_ERROR;
}
return sequencer_make_channel(clientData, interp, output, TCL_WRITABLE);
}
}
Tcl_CmdInfo *eul_tk_create_widget(char *type, char *name, LispRef listArgs)
{
struct infoargs infoArgs;
ParseArguments2(&infoArgs, type, name, listArgs);
Tcl_CmdInfo cmdInfo = FindCreationFn(type);
int result = cmdInfo.proc
(
cmdInfo.clientData,
interp,
infoArgs.argc,
infoArgs.argv
);
Tcl_CmdInfo *newCmdInfo = (Tcl_CmdInfo *)gc_malloc(sizeof(Tcl_CmdInfo));
*newCmdInfo = (Tcl_CmdInfo){0, NULL, 0, NULL, 0, NULL, 0, NULL};
// It isn't clear what should be returned on error so return an empty
// structure allocated on free-store
if (result == TCL_ERROR)
{
return newCmdInfo;
}
result = Tcl_GetCommandInfo
(
interp,
Tcl_GetString(Tcl_GetObjResult(interp)),
newCmdInfo
);
return newCmdInfo;
}
/*
** Test for access permissions. Return true if the requested permission
** is available, or false otherwise.
*/
static int tvfsAccess(
sqlite3_vfs *pVfs,
const char *zPath,
int flags,
int *pResOut
){
Testvfs *p = (Testvfs *)pVfs->pAppData;
if( p->pScript && p->mask&TESTVFS_ACCESS_MASK ){
int rc;
char *zArg = 0;
if( flags==SQLITE_ACCESS_EXISTS ) zArg = "SQLITE_ACCESS_EXISTS";
if( flags==SQLITE_ACCESS_READWRITE ) zArg = "SQLITE_ACCESS_READWRITE";
if( flags==SQLITE_ACCESS_READ ) zArg = "SQLITE_ACCESS_READ";
tvfsExecTcl(p, "xAccess",
Tcl_NewStringObj(zPath, -1), Tcl_NewStringObj(zArg, -1), 0
);
if( tvfsResultCode(p, &rc) ){
if( rc!=SQLITE_OK ) return rc;
}else{
Tcl_Interp *interp = p->interp;
if( TCL_OK==Tcl_GetBooleanFromObj(0, Tcl_GetObjResult(interp), pResOut) ){
return SQLITE_OK;
}
}
}
return sqlite3OsAccess(PARENTVFS(pVfs), zPath, flags, pResOut);
}
static Tcl_Obj * tk_eval(const char *cmd)
{
char *cmd_utf8;
Tcl_DString cmd_utf8_ds;
Tcl_DStringInit(&cmd_utf8_ds);
cmd_utf8 = Tcl_ExternalToUtfDString(NULL, cmd, -1, &cmd_utf8_ds);
if (Tcl_Eval(RTcl_interp, cmd_utf8) == TCL_ERROR)
{
char p[512];
if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500)
strcpy(p, _("tcl error.\n"));
else {
char *res;
Tcl_DString res_ds;
Tcl_DStringInit(&res_ds);
res = Tcl_UtfToExternalDString(NULL,
Tcl_GetStringResult(RTcl_interp),
-1, &res_ds);
snprintf(p, sizeof(p), "[tcl] %s.\n", res);
Tcl_DStringFree(&res_ds);
}
error(p);
}
Tcl_DStringFree(&cmd_utf8_ds);
return Tcl_GetObjResult(RTcl_interp);
}
int NS(ProcCheck) (
Tcl_Interp * interp,
struct Tcl_Obj * cmdObj,
char const * const wrongNrStr
)
{
int ret,len;
Tcl_DString cmd;
if (!Tcl_GetCommandFromObj (interp, cmdObj)) {
Tcl_WrongNumArgs (interp, 0, NULL, wrongNrStr);
return TCL_ERROR;
}
Tcl_DStringInit(&cmd);
Tcl_DStringAppendElement(&cmd,"info");
Tcl_DStringAppendElement(&cmd,"args");
Tcl_DStringAppendElement(&cmd,Tcl_GetString(cmdObj));
ret = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&cmd);
TclErrorCheck(ret);
TclErrorCheck(Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &len));
if (len != 1) {
Tcl_DString msg;
Tcl_DStringInit(&msg);
Tcl_DStringAppend(&msg,"wrong # args: ", -1);
if (len > 1) Tcl_DStringAppend(&msg,"only ", -1);
Tcl_DStringAppend(&msg,"one argument for procedure \"", -1);
Tcl_DStringAppend(&msg,Tcl_GetString(cmdObj), -1);
Tcl_DStringAppend(&msg,"\" is required", -1);
Tcl_DStringResult(interp, &msg);
Tcl_DStringFree(&msg);
return TCL_ERROR;
}
return TCL_OK;
}
static AP_Result tcl_coerce_number(AP_World *w, AP_Obj interp_name, AP_Obj item, AP_Obj atom)
{
Tcl_Interp *interp;
AP_Obj result;
interp = GetInterp(w, interp_name);
if (!interp) return AP_EXCEPTION;
if (AP_ObjType(w, item) == AP_INTEGER
|| AP_ObjType(w, item) == AP_FLOAT) result = item;
else {
Tcl_Obj *tcl_obj = PrologToTclObj(w, item, interp);
int r;
r = Tcl_ConvertToType(interp, tcl_obj, tcl_integer_type);
if (r != TCL_OK)
r = Tcl_ConvertToType(interp, tcl_obj, tcl_double_type);
if (r != TCL_OK)
return AP_SetException(w,
AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "error"), 2,
AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "tcl_error"), 1,
TclToPrologObj(interp, Tcl_GetObjResult(interp), w, NULL)),
AP_UNBOUND_OBJ));
result = TclToPrologObj(interp, tcl_obj, w, NULL);
Tcl_DecrRefCount(tcl_obj);
}
return AP_Unify(w, result, atom);
}
int Tcl_AppInit(Tcl_Interp *interp)
{
if (Tcl_Init(interp) == TCL_ERROR)
return TCL_ERROR;
if (tcl_interface_init(interp, &debug) != TCL_OK)
{
fprintf(stderr, "%s, tcl interface init error", __FUNCTION__);
return TCL_ERROR;
}
if (strlen(script) && Tcl_EvalFile(interp, script) != TCL_OK)
{
char *result;
result = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL);
if (result)
{
printf("*************\n");
Tcl_Eval(interp, "puts $::errorInfo");
printf("*************\n");
}
return TCL_ERROR;
}
return TCL_OK;
}
int
TclpListVolumes(
Tcl_Interp *interp) /* Interpreter to which to pass the volume list */
{
Tcl_Obj *resultPtr, *elemPtr;
char buf[4];
int i;
resultPtr = Tcl_GetObjResult(interp);
buf[1] = ':';
buf[2] = '/';
buf[3] = '\0';
/*
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
for (i = 0; i < 26; i++) {
buf[0] = (char) ('a' + i);
if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
|| (GetLastError() == ERROR_NOT_READY)) {
elemPtr = Tcl_NewStringObj(buf, -1);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
return TCL_OK;
}
/**
* 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 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;
}
SEXP dotTclObjv(SEXP args)
{
SEXP t,
avec = CADR(args),
nm = getAttrib(avec, R_NamesSymbol);
int objc, i, result;
Tcl_Obj **objv;
const void *vmax = vmaxget();
for (objc = 0, i = 0; i < length(avec); i++){
if (!isNull(VECTOR_ELT(avec, i)))
objc++;
if (!isNull(nm) && strlen(translateChar(STRING_ELT(nm, i))))
objc++;
}
objv = (Tcl_Obj **) R_alloc(objc, sizeof(Tcl_Obj *));
for (objc = i = 0; i < length(avec); i++){
const char *s;
char *tmp;
if (!isNull(nm) && strlen(s = translateChar(STRING_ELT(nm, i)))){
tmp = calloc(strlen(s)+2, sizeof(char));
*tmp = '-';
strcpy(tmp+1, s);
objv[objc++] = Tcl_NewStringObj(tmp, -1);
free(tmp);
}
if (!isNull(t = VECTOR_ELT(avec, i)))
objv[objc++] = (Tcl_Obj *) R_ExternalPtrAddr(t);
}
for (i = objc; i--; ) Tcl_IncrRefCount(objv[i]);
result = Tcl_EvalObjv(RTcl_interp, objc, objv, 0);
for (i = objc; i--; ) Tcl_DecrRefCount(objv[i]);
if (result == TCL_ERROR)
{
char p[512];
if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500)
strcpy(p, _("tcl error.\n"));
else {
char *res;
Tcl_DString res_ds;
Tcl_DStringInit(&res_ds);
res = Tcl_UtfToExternalDString(NULL,
Tcl_GetStringResult(RTcl_interp),
-1, &res_ds);
snprintf(p, sizeof(p), "[tcl] %s.\n", res);
Tcl_DStringFree(&res_ds);
}
error(p);
}
SEXP res = makeRTclObject(Tcl_GetObjResult(RTcl_interp));
vmaxset(vmax);
return res;
}
int
TnmSetConfig(Tcl_Interp *interp, TnmConfig *config, ClientData object, int objc, Tcl_Obj *const objv[])
{
int i, option, code;
TnmTable *elemPtr;
Tcl_Obj *listPtr;
Tcl_Obj *objPtr;
if (objc % 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?option value? ?option value? ...");
return TCL_ERROR;
}
/*
* First scan through the list of options to make sure that
* we don't run on an unknown option later when we have
* already modified the object.
*/
for (i = 2; i < objc; i += 2) {
option = TnmGetTableKeyFromObj(interp, config->optionTable,
objv[i], "option");
if (option < 0) {
return TCL_ERROR;
}
}
/*
* Now call the function to actually modify the object. Note,
* this version does not rollback changes so an object might
* end up in a half modified state.
*/
for (i = 2; i < objc; i += 2) {
option = TnmGetTableKeyFromObj(interp, config->optionTable,
objv[i], "option");
code = (config->setOption)(interp, object, option, objv[i+1]);
if (code != TCL_OK) {
return TCL_ERROR;
}
}
/*
* Create a new list which contains all the configuration
* options and their current values.
*/
listPtr = Tcl_GetObjResult(interp);
for (elemPtr = config->optionTable; elemPtr->value; elemPtr++) {
objPtr = (config->getOption)(interp, object, (int) elemPtr->key);
if (objPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(elemPtr->value, -1));
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
}
}
return TCL_OK;
}
int fbsql_numrows(Tcl_Interp *interp, int sql_number, int argc, char **argv) {
Tcl_Obj *obj_result;
/* set result object pointer */
obj_result = Tcl_GetObjResult(interp);
Tcl_SetIntObj(obj_result,connection[sql_number].NUMROWS);
return TCL_OK;
}
static void
setStringsResult (Tcl_Interp *interp, ...) {
Tcl_ResetResult(interp);
va_list arguments;
va_start(arguments, interp);
Tcl_AppendStringsToObjVA(Tcl_GetObjResult(interp), arguments);
va_end(arguments);
}
/*
* ------------------------------------------------------------------------
* Itk_ArchOptAccessError()
*
* Simply utility which adds error information after an option
* value access fails. Adds traceback information to the given
* interpreter.
* ------------------------------------------------------------------------
*/
void
Itk_ArchOptAccessError(
Tcl_Interp *interp, /* interpreter handling this object */
ArchInfo *info, /* info associated with mega-widget */
ArchOption *archOpt) /* option that couldn't be accessed */
{
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"internal error: cannot access itk_option(", archOpt->switchName, ")",
(char*)NULL);
if (info->itclObj->accessCmd) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, " in widget \"", -1);
Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, resultPtr);
Tcl_AppendToObj(resultPtr, "\"", -1);
}
}
static void
windows_error (Tcl_Interp *interp, const char *fn)
{
char buf[20];
sprintf (buf, "%lu", (unsigned long) GetLastError ());
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"Windows error in ", fn, ": ", buf, (char *) NULL);
}
char *
TkWin_getWindowID(void)
{
Tcl_Obj *result;
if (Tcl_Eval(interp, "winfo id .screen") == TCL_ERROR)
return NULL;
result = Tcl_GetObjResult(interp);
return Tcl_GetStringFromObj(result, NULL);
}
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
CONST char *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not read \"", fileName, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
static int
GetFileFinderAttributes(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute option. */
char *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
FInfo finfo;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
err = FSpGetFInfo(&fileSpec, &finfo);
}
if (err == noErr) {
switch (objIndex) {
case MAC_CREATOR_ATTRIBUTE:
*attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdCreator);
break;
case MAC_HIDDEN_ATTRIBUTE:
*attributePtrPtr = Tcl_NewBooleanObj(finfo.fdFlags
& kIsInvisible);
break;
case MAC_TYPE_ATTRIBUTE:
*attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdType);
break;
}
} else if (err == fnfErr) {
long dirID;
Boolean isDirectory = 0;
err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
if ((err == noErr) && isDirectory) {
if (objIndex == MAC_HIDDEN_ATTRIBUTE) {
*attributePtrPtr = Tcl_NewBooleanObj(0);
} else {
*attributePtrPtr = Tcl_NewOSTypeObj('Fldr');
}
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't get attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
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);
}
}
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot set attribute \"", tclpFileAttrStrings[objIndex],
"\" for file \"", fileName, "\" : attribute is readonly",
(char *) NULL);
return TCL_ERROR;
}
static int
GetOp(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv)
{
Tk_Window tkwin = clientData;
char *string;
int buffer;
int nBytes;
buffer = 0;
if (objc == 3) {
if (GetCutNumberFromObj(interp, objv[2], &buffer) != TCL_OK) {
return TCL_ERROR;
}
}
string = XFetchBuffer(Tk_Display(tkwin), &nBytes, buffer);
if (string != NULL) {
int limit;
char *p;
int i;
if (string[nBytes - 1] == '\0') {
limit = nBytes - 1;
} else {
limit = nBytes;
}
for (p = string, i = 0; i < limit; i++, p++) {
int c;
c = (unsigned char)*p;
if (c == 0) {
*p = ' '; /* Convert embedded NUL bytes */
}
}
if (limit == nBytes) {
char *newPtr;
/*
* Need to copy the string into a bigger buffer so we can
* add a NUL byte on the end.
*/
newPtr = Blt_AssertMalloc(nBytes + 1);
memcpy(newPtr, string, nBytes);
newPtr[nBytes] = '\0';
Blt_Free(string);
string = newPtr;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp), string, nBytes);
}
return TCL_OK;
}
static void
AttributesPosixError(
Tcl_Interp *interp, /* The interp that has the error */
int objIndex, /* The attribute which caused the problem. */
char *fileName, /* The name of the file which caused the
* error. */
int getOrSet) /* 0 for get; 1 for set */
{
TclWinConvertError(GetLastError());
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot ", getOrSet ? "set" : "get", " attribute \"",
tclpFileAttrStrings[objIndex], "\" for file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
}
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;
}
void DupStatCmdTests::getempty()
{
registerCmd();
int stat = Tcl_Eval(m_pNativeInterp, "dupstat get");
EQ(TCL_OK, stat);
CTCLObject result(Tcl_GetObjResult(m_pNativeInterp));
result.Bind(m_pInterp);
EQ(2, result.llength());
EQ(0, (int)(result.lindex(0)));
EQ(std::string(""), std::string(result.lindex(1)));
}
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;
}
/*
** The main function for threads created with [sqlthread spawn].
*/
static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){
Tcl_Interp *interp;
Tcl_Obj *pRes;
Tcl_Obj *pList;
int rc;
SqlThread *p = (SqlThread *)pSqlThread;
extern int Sqlitetest_mutex_Init(Tcl_Interp*);
interp = Tcl_CreateInterp();
Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0);
Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0);
#if SQLITE_OS_UNIX && defined(SQLITE_ENABLE_UNLOCK_NOTIFY)
Tcl_CreateObjCommand(interp, "sqlite3_blocking_step", blocking_step_proc,0,0);
Tcl_CreateObjCommand(interp,
"sqlite3_blocking_prepare_v2", blocking_prepare_v2_proc, (void *)1, 0);
Tcl_CreateObjCommand(interp,
"sqlite3_nonblocking_prepare_v2", blocking_prepare_v2_proc, 0, 0);
#endif
Sqlitetest1_Init(interp);
Sqlitetest_mutex_Init(interp);
Sqlite3_Init(interp);
rc = Tcl_Eval(interp, p->zScript);
pRes = Tcl_GetObjResult(interp);
pList = Tcl_NewObj();
Tcl_IncrRefCount(pList);
Tcl_IncrRefCount(pRes);
if( rc!=TCL_OK ){
Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1));
Tcl_ListObjAppendElement(interp, pList, pRes);
postToParent(p, pList);
Tcl_DecrRefCount(pList);
pList = Tcl_NewObj();
}
Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1));
Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1));
Tcl_ListObjAppendElement(interp, pList, pRes);
postToParent(p, pList);
ckfree((void *)p);
Tcl_DecrRefCount(pList);
Tcl_DecrRefCount(pRes);
Tcl_DeleteInterp(interp);
while( Tcl_DoOneEvent(TCL_ALL_EVENTS|TCL_DONT_WAIT) );
Tcl_ExitThread(0);
TCL_THREAD_CREATE_RETURN;
}
/*
* ------------------------------------------------------------------------
* Itk_GetArchInfo()
*
* Finds the extra Archetype info associated with the given object.
* Returns TCL_OK and a pointer to the info if found. Returns
* TCL_ERROR along with an error message in interp->result if not.
* ------------------------------------------------------------------------
*/
int
Itk_GetArchInfo(
Tcl_Interp *interp, /* interpreter handling this object */
ItclObject *contextObj, /* object with desired data */
ArchInfo **infoPtr) /* returns: pointer to extra info */
{
Tcl_HashTable *objsWithArchInfo;
Tcl_HashEntry *entry;
/*
* If there is any problem finding the info, return an error.
*/
objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj);
if (!entry) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"internal error: no Archetype information for widget",
(char*)NULL);
if (contextObj->accessCmd) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, " \"", -1);
Tcl_GetCommandFullName(interp, contextObj->accessCmd, resultPtr);
Tcl_AppendToObj(resultPtr, "\"", -1);
}
return TCL_ERROR;
}
/*
* Otherwise, return the requested info.
*/
*infoPtr = (ArchInfo*)Tcl_GetHashValue(entry);
return TCL_OK;
}
int
ComObject::eval (TclObject script, TclObject *pResult)
{
int completionCode =
#if TCL_MINOR_VERSION >= 1
Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
#else
Tcl_GlobalEvalObj(m_interp, script);
#endif
if (pResult != 0) {
*pResult = Tcl_GetObjResult(m_interp);
}
return completionCode;
}