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;
char *index, *subCmd, *string;
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) {
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) {
char buf[TCL_INTEGER_SPACE];
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;
}
TclFormatInt(buf, varPtr[varIndex]->refCount);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} 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;
}
Tcl_Obj*
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
CONST char *src = Tcl_FSGetNativePath(pathPtr);
CONST char *target = NULL;
if (src == NULL) {
return NULL;
}
/*
* If we're making a symbolic link and the path is relative, then we
* must check whether it exists _relative_ to the directory in which
* the src is found (not relative to the current cwd which is just not
* relevant in this case).
*
* If we're making a hard link, then a relative path is just converted
* to absolute relative to the cwd.
*/
if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
Tcl_Obj *dirPtr, *absPtr;
dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return NULL;
}
absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
Tcl_IncrRefCount(absPtr);
if (Tcl_FSAccess(absPtr, F_OK) == -1) {
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
target = Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
if (access(target, F_OK) == -1) {
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
}
if (access(src, F_OK) != -1) {
/*
* Src exists.
*/
errno = EEXIST;
return NULL;
}
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
int targetLen;
Tcl_DString ds;
Tcl_Obj *transPtr;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = Tcl_GetStringFromObj(transPtr, &targetLen);
target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
toPtr = NULL;
}
Tcl_DStringFree(&ds);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
if (link(target, src) != 0) {
return NULL;
}
} else {
errno = ENODEV;
return NULL;
}
return toPtr;
} else {
Tcl_Obj *linkPtr = NULL;
char link[MAXPATHLEN];
int length;
Tcl_DString ds;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
if (linkPtr != NULL) {
Tcl_IncrRefCount(linkPtr);
}
return linkPtr;
}
}
/*
** Open an tvfs file handle.
*/
static int tvfsOpen(
sqlite3_vfs *pVfs,
const char *zName,
sqlite3_file *pFile,
int flags,
int *pOutFlags
){
int rc;
TestvfsFile *pTestfile = (TestvfsFile *)pFile;
TestvfsFd *pFd;
Tcl_Obj *pId = 0;
Testvfs *p = (Testvfs *)pVfs->pAppData;
pFd = (TestvfsFd *)ckalloc(sizeof(TestvfsFd) + PARENTVFS(pVfs)->szOsFile);
memset(pFd, 0, sizeof(TestvfsFd) + PARENTVFS(pVfs)->szOsFile);
pFd->pShm = 0;
pFd->pShmId = 0;
pFd->zFilename = zName;
pFd->pVfs = pVfs;
pFd->pReal = (sqlite3_file *)&pFd[1];
memset(pTestfile, 0, sizeof(TestvfsFile));
pTestfile->pFd = pFd;
/* Evaluate the Tcl script:
**
** SCRIPT xOpen FILENAME KEY-VALUE-ARGS
**
** If the script returns an SQLite error code other than SQLITE_OK, an
** error is returned to the caller. If it returns SQLITE_OK, the new
** connection is named "anon". Otherwise, the value returned by the
** script is used as the connection name.
*/
Tcl_ResetResult(p->interp);
if( p->pScript && p->mask&TESTVFS_OPEN_MASK ){
Tcl_Obj *pArg = Tcl_NewObj();
Tcl_IncrRefCount(pArg);
if( flags&SQLITE_OPEN_MAIN_DB ){
const char *z = &zName[strlen(zName)+1];
while( *z ){
Tcl_ListObjAppendElement(0, pArg, Tcl_NewStringObj(z, -1));
z += strlen(z) + 1;
Tcl_ListObjAppendElement(0, pArg, Tcl_NewStringObj(z, -1));
z += strlen(z) + 1;
}
}
tvfsExecTcl(p, "xOpen", Tcl_NewStringObj(pFd->zFilename, -1), pArg, 0, 0);
Tcl_DecrRefCount(pArg);
if( tvfsResultCode(p, &rc) ){
if( rc!=SQLITE_OK ) return rc;
}else{
pId = Tcl_GetObjResult(p->interp);
}
}
if( (p->mask&TESTVFS_OPEN_MASK) && tvfsInjectIoerr(p) ) return SQLITE_IOERR;
if( tvfsInjectCantopenerr(p) ) return SQLITE_CANTOPEN;
if( tvfsInjectFullerr(p) ) return SQLITE_FULL;
if( !pId ){
pId = Tcl_NewStringObj("anon", -1);
}
Tcl_IncrRefCount(pId);
pFd->pShmId = pId;
Tcl_ResetResult(p->interp);
rc = sqlite3OsOpen(PARENTVFS(pVfs), zName, pFd->pReal, flags, pOutFlags);
if( pFd->pReal->pMethods ){
sqlite3_io_methods *pMethods;
int nByte;
if( pVfs->iVersion>1 ){
nByte = sizeof(sqlite3_io_methods);
}else{
nByte = offsetof(sqlite3_io_methods, xShmMap);
}
pMethods = (sqlite3_io_methods *)ckalloc(nByte);
memcpy(pMethods, &tvfs_io_methods, nByte);
pMethods->iVersion = pFd->pReal->pMethods->iVersion;
if( pMethods->iVersion>pVfs->iVersion ){
pMethods->iVersion = pVfs->iVersion;
}
if( pVfs->iVersion>1 && ((Testvfs *)pVfs->pAppData)->isNoshm ){
pMethods->xShmUnmap = 0;
pMethods->xShmLock = 0;
pMethods->xShmBarrier = 0;
pMethods->xShmMap = 0;
}
pFile->pMethods = pMethods;
}
return rc;
}
void
TclpInitLibraryPath(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
CONST char *str;
Tcl_DString buffer;
pathPtr = Tcl_NewObj();
/*
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
str = getenv("TCL_LIBRARY"); /* INTL: Native. */
Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
str = Tcl_DStringValue(&buffer);
if ((str != NULL) && (str[0] != '\0')) {
Tcl_DString ds;
int pathc;
CONST char **pathv;
char installLib[LIBRARY_SIZE];
Tcl_DStringInit(&ds);
/*
* Initialize the substrings used when locating an executable. The
* installLib variable computes the path as though the executable is
* installed.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
/*
* If TCL_LIBRARY is set, search there.
*/
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_SplitPath(str, &pathc, &pathv);
if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
/*
* If TCL_LIBRARY is set but refers to a different tcl
* installation than the current version, try fiddling with the
* specified directory to make it refer to this installation by
* removing the old "tclX.Y" and substituting the current version
* string.
*/
pathv[pathc - 1] = installLib + 4;
str = Tcl_JoinPath(pathc, pathv, &ds);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) pathv);
}
/*
* Finally, look for the library relative to the compiled-in path. This is
* needed when users install Tcl with an exec-prefix that is different
* from the prefix.
*/
{
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
str = tclLibPath;
} else
#endif /* HAVE_COREFOUNDATION */
{
/*
* TODO: Pull this value from the TIP 59 table.
*/
str = defaultLibraryDir;
}
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
*valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
/*************************************************************************
* FUNCTION : RPMTransaction_Set::ProbFlags *
* ARGUMENTS : none *
* RETURNS : TCL_OK or TCL_ERROR *
* EXCEPTIONS : none *
* PURPOSE : Set or get problem mask flags *
*************************************************************************/
int RPMTransaction_Set::ProbFlags(Tcl_Interp *interp,int objc, Tcl_Obj *const objv[])
{
if (objc >= 3)
{
// Build a list of indexes matching the packages given.
Tcl_Obj *args = Tcl_NewListObj(objc-2,objv+2);
if (!args)
return Error("Cannot concat arglist!");
Tcl_IncrRefCount(args);
// Iterate over list and build up the list
unsigned mask = prob_flags;
int count = 0;
if (Tcl_ListObjLength(interp,args,&count) != TCL_OK)
{
parse_error:
Tcl_DecrRefCount(args);
return TCL_ERROR;
}
for (int i = 0; i < count; ++i)
{
Tcl_Obj *flag = 0;
int which = 0;
if (Tcl_ListObjIndex(interp,args,i,&flag) != TCL_OK)
goto parse_error;
if (Tcl_GetIndexFromObjStruct(interp,flag,(char **)&Prob_bits[0].msg,sizeof(Prob_bits[0]),
"flag",0,&which
) != TCL_OK)
goto parse_error;
if (Prob_bits[which].bit == RPMPROB_FILTER_NONE )
mask = RPMPROB_FILTER_NONE;
else
mask |= Prob_bits[which].bit;
}
Tcl_DecrRefCount(args);
prob_flags = mask;
}
// Now, build the return list
Tcl_Obj *val = Tcl_NewObj();
Tcl_IncrRefCount(val);
if (prob_flags == 0)
{
if (Tcl_ListObjAppendElement(interp,val,Tcl_NewStringObj(Prob_bits[0].msg,-1)) != TCL_OK)
{
out_err:
Tcl_DecrRefCount(val);
return TCL_ERROR;
}
}
else if (prob_flags == (unsigned)(-1))
{
if (Tcl_ListObjAppendElement(interp,val,Tcl_NewStringObj("all",-1)) != TCL_OK)
{
goto out_err;
}
}
else
{
for (int i = 0; Prob_bits[i].msg; ++i)
{
if (Prob_bits[i].bit == (unsigned)(-1))
continue;
if (prob_flags & Prob_bits[i].bit)
{
if (Tcl_ListObjAppendElement(interp,val,Tcl_NewStringObj(Prob_bits[i].msg,-1)) != TCL_OK)
{
Tcl_DecrRefCount(val);
return TCL_ERROR;
}
}
}
}
return OK(val);
}
/* ARGSUSED */
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
int mask) /* Not used. */
{
InteractiveState *isPtr = (InteractiveState *) clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
int code, length;
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, (ClientData) 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, (ClientData) 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 != (Tcl_Channel) NULL) {
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
(ClientData) isPtr);
}
if (code != TCL_OK) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length >0) && (outChannel != (Tcl_Channel) NULL)) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
/*
* If a tty stdin is still around, output a prompt.
*/
prompt:
if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
Prompt(interp, &(isPtr->prompt));
isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
}
}
Tk_Image
HtmlImageImage(HtmlImage2 *pImage)
{
assert(pImage && (pImage->isValid == 1 || pImage->isValid == 0));
if (!pImage->isValid) {
/* pImage->image is invalid. This happens if the underlying Tk
* image, or the image that this is a scaled copy of, is changed
* or deleted. It also happens the first time this function is
* called after a call to HtmlImageScale().
*/
Tk_PhotoHandle photo;
Tk_PhotoImageBlock block;
Tcl_Interp *interp = pImage->pImageServer->pTree->interp;
HtmlImage2 *pUnscaled = pImage->pUnscaled;
if (pUnscaled->pixmap) {
Tcl_Obj *apObj[4];
int rc;
/*printf("TODO: BAD. Have to recreate image to make scaled copy.\n");*/
apObj[0] = pUnscaled->pImageName;
apObj[1] = Tcl_NewStringObj("configure", -1);
apObj[2] = Tcl_NewStringObj("-data", -1);
apObj[3] = pUnscaled->pCompressed;
Tcl_IncrRefCount(apObj[1]);
Tcl_IncrRefCount(apObj[2]);
Tcl_IncrRefCount(apObj[3]);
pUnscaled->nIgnoreChange++;
rc = Tcl_EvalObjv(interp, 4, apObj, TCL_EVAL_GLOBAL);
pUnscaled->nIgnoreChange--;
assert(rc==TCL_OK);
Tcl_IncrRefCount(apObj[3]);
Tcl_DecrRefCount(apObj[2]);
Tcl_DecrRefCount(apObj[1]);
}
assert(pUnscaled);
if (!pImage->pImageName) {
/* If pImageName is still NULL, then create a new photo
* image to write the scaled data to. Todo: Is it possible
* to do this without invoking a script, creating the Tcl
* command etc.?
*/
Tk_Window win = pImage->pImageServer->pTree->tkwin;
Tcl_Interp *interp = pImage->pImageServer->pTree->interp;
const char *z;
Tcl_Eval(interp, "image create photo");
pImage->pImageName = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(pImage->pImageName);
assert(0 == pImage->pDelete);
assert(0 == pImage->image);
z = Tcl_GetString(pImage->pImageName);
pImage->image = Tk_GetImage(interp, win, z, imageChanged, pImage);
}
assert(pImage->image);
CHECK_INTEGER_PLAUSIBILITY(pImage->width);
CHECK_INTEGER_PLAUSIBILITY(pImage->height);
CHECK_INTEGER_PLAUSIBILITY(pUnscaled->width);
CHECK_INTEGER_PLAUSIBILITY(pUnscaled->height);
/* Write the scaled data into image pImage->image */
photo = Tk_FindPhoto(interp, Tcl_GetString(pUnscaled->pImageName));
if (photo) {
Tk_PhotoGetImage(photo, &block);
}
if (photo && block.pixelPtr) {
int x, y; /* Iterator variables */
int w, h; /* Width and height of unscaled image */
int sw, sh; /* Width and height of scaled image */
Tk_PhotoHandle s_photo;
Tk_PhotoImageBlock s_block;
sw = pImage->width;
sh = pImage->height;
w = pUnscaled->width;
h = pUnscaled->height;
s_photo = Tk_FindPhoto(interp, Tcl_GetString(pImage->pImageName));
s_block.pixelPtr = (unsigned char *)HtmlAlloc("temp", sw * sh * 4);
s_block.width = sw;
s_block.height = sh;
s_block.pitch = sw * 4;
s_block.pixelSize = 4;
s_block.offset[0] = 0;
s_block.offset[1] = 1;
s_block.offset[2] = 2;
s_block.offset[3] = 3;
for (x=0; x<sw; x++) {
int orig_x = ((x * w) / sw);
for (y=0; y<sh; y++) {
unsigned char *zOrig;
unsigned char *zScale;
int orig_y = ((y * h) / sh);
zOrig = &block.pixelPtr[
orig_x * block.pixelSize + orig_y * block.pitch];
zScale = &s_block.pixelPtr[
x * s_block.pixelSize + y * s_block.pitch];
zScale[0] = zOrig[block.offset[0]];
zScale[1] = zOrig[block.offset[1]];
zScale[2] = zOrig[block.offset[2]];
zScale[3] = zOrig[block.offset[3]];
}
}
photoputblock(interp, s_photo, &s_block, 0, 0, sw, sh, 0);
HtmlFree(s_block.pixelPtr);
} else {
return HtmlImageImage(pImage->pUnscaled);
}
pImage->isValid = 1;
if (pUnscaled->pixmap) {
Tcl_Obj *apObj[4];
apObj[0] = Tcl_NewStringObj("image", -1);
apObj[1] = Tcl_NewStringObj("create", -1);
apObj[2] = Tcl_NewStringObj("photo", -1);
apObj[3] = pUnscaled->pImageName;
Tcl_IncrRefCount(apObj[0]);
Tcl_IncrRefCount(apObj[1]);
Tcl_IncrRefCount(apObj[2]);
pUnscaled->nIgnoreChange++;
Tcl_EvalObjv(interp, 4, apObj, TCL_EVAL_GLOBAL);
pUnscaled->nIgnoreChange--;
Tcl_DecrRefCount(apObj[2]);
Tcl_DecrRefCount(apObj[1]);
Tcl_IncrRefCount(apObj[0]);
}
}
return pImage->image;
}
void ics_tcl_handler(struct ics_server *ics, struct ics_trigger *trig, struct ics_data *data)
{
int ret;
Tcl_Obj *command;
Tcl_Obj *ics_label;
Tcl_Obj *who;
Tcl_Obj *action;
Tcl_Obj *message;
Tcl_Obj *sender;
Tcl_Obj *game_id;
Tcl_Obj *white;
Tcl_Obj *black;
Tcl_Obj *winner;
Tcl_Obj *loser;
Tcl_Obj *result;
Tcl_Obj *style12;
Tcl_Obj *initial_time;
Tcl_Obj *time_increment;
Tcl_Obj **objv;
char *hackpad;
size_t hackpad_len;
switch (trig->type)
{
/* alecmao(U) tells you: hi */
case ICS_TRIG_TELL:
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
for (hackpad_len=0; data->tokens[0][hackpad_len] != '\0' && data->tokens[0][hackpad_len] != '('; hackpad_len++);
hackpad = tmalloc0(hackpad_len + 1);
strncpy(hackpad, data->tokens[0], hackpad_len);
sender = Tcl_NewStringObj(hackpad, strlen(hackpad));
hackpad = &data->txt_packet[strlen(data->tokens[0]) + strlen(data->tokens[1]) + strlen(data->tokens[2]) + 3];
message = Tcl_NewStringObj(hackpad, strlen(hackpad));
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(sender);
Tcl_IncrRefCount(message);
objv = tmalloc(sizeof(Tcl_Obj *) * 4);
objv[0] = command;
objv[1] = ics_label;
objv[2] = sender;
objv[3] = message;
ret = Tcl_EvalObjv(ics->tclinterp, 4, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(sender);
Tcl_DecrRefCount(message);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
/* <ICS Label> <game id> <white> <black> <winner> <loser> <result> <message> */
case ICS_TRIG_ENDGAME:
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
game_id = Tcl_NewIntObj(ics->game->game_number);
white = Tcl_NewStringObj(ics->game->white_name, strlen(ics->game->white_name));
black = Tcl_NewStringObj(ics->game->black_name, strlen(ics->game->black_name));
winner = Tcl_NewStringObj(ics->game->winner_name, strlen(ics->game->winner_name));
loser = Tcl_NewStringObj(ics->game->loser_name, strlen(ics->game->loser_name));
result = Tcl_NewStringObj(ics->game->end_result, strlen(ics->game->end_result));
message = Tcl_NewStringObj(ics->game->end_message, strlen(ics->game->end_message));
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(game_id);
Tcl_IncrRefCount(white);
Tcl_IncrRefCount(black);
Tcl_IncrRefCount(winner);
Tcl_IncrRefCount(loser);
Tcl_IncrRefCount(result);
Tcl_IncrRefCount(message);
objv = tmalloc(sizeof(Tcl_Obj *) * 9);
objv[0] = command;
objv[1] = ics_label;
objv[2] = game_id;
objv[3] = white;
objv[4] = black;
objv[5] = winner;
objv[6] = loser;
objv[7] = result;
objv[8] = message;
ret = Tcl_EvalObjv(ics->tclinterp, 9, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(game_id);
Tcl_DecrRefCount(white);
Tcl_DecrRefCount(black);
Tcl_DecrRefCount(winner);
Tcl_DecrRefCount(loser);
Tcl_DecrRefCount(result);
Tcl_DecrRefCount(message);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
/* <ICS Label> <game id> <white> <black> <initial time> <time increment> */
case ICS_TRIG_GAME:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
game_id = Tcl_NewIntObj(ics->game->game_number);
white = Tcl_NewStringObj(ics->game->white_name, strlen(ics->game->white_name));
black = Tcl_NewStringObj(ics->game->black_name, strlen(ics->game->black_name));
initial_time = Tcl_NewIntObj(ics->game->initial_time);
time_increment = Tcl_NewIntObj(ics->game->increment_time);
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(game_id);
Tcl_IncrRefCount(white);
Tcl_IncrRefCount(black);
Tcl_IncrRefCount(initial_time);
Tcl_IncrRefCount(time_increment);
objv = tmalloc(sizeof(Tcl_Obj *) * 7);
objv[0] = command;
objv[1] = ics_label;
objv[2] = game_id;
objv[3] = white;
objv[4] = black;
objv[5] = initial_time;
objv[6] = time_increment;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(ics->tclinterp, 7, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(game_id);
Tcl_DecrRefCount(white);
Tcl_DecrRefCount(black);
Tcl_DecrRefCount(initial_time);
Tcl_DecrRefCount(time_increment);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
/* <ICS Label> <Message> */
case ICS_TRIG_MSG:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
message = Tcl_NewStringObj(data->txt_packet, strlen(data->txt_packet));
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(message);
objv = tmalloc(sizeof(Tcl_Obj *) * 3);
objv[0] = command;
objv[1] = ics_label;
objv[2] = message;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(ics->tclinterp, 3, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(message);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
case ICS_TRIG_CONNECT:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
who = Tcl_NewStringObj(data->tokens[1], strlen(data->tokens[1]));
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(who);
objv = tmalloc(sizeof(Tcl_Obj *) * 3);
objv[0] = command;
objv[1] = ics_label;
objv[2] = who;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(ics->tclinterp, 3, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(who);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
case ICS_TRIG_MOVE:
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
style12 = Tcl_NewStringObj(ics->game->style_twelve, strlen(ics->game->style_twelve));
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(style12);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 3);
objv[0] = command;
objv[1] = ics_label;
objv[2] = style12;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(ics->tclinterp, 3, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(style12);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
case ICS_TRIG_NOTIFY:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
ics_label = Tcl_NewStringObj(ics->label, strlen(ics->label));
who = Tcl_NewStringObj(data->tokens[1], strlen(data->tokens[1]));
action = Tcl_NewStringObj(data->tokens[3], strlen(data->tokens[3]));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(ics_label);
Tcl_IncrRefCount(who);
Tcl_IncrRefCount(action);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 4);
objv[0] = command;
objv[1] = ics_label;
objv[2] = who;
objv[3] = action;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(ics->tclinterp, 4, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(ics_label);
Tcl_DecrRefCount(who);
Tcl_DecrRefCount(action);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(ics->tclinterp));
}
free(objv);
break;
}
return;
}
/* ARGSUSED */
int
Tcl_OpenObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int pipeline, prot;
const char *modeString, *what;
Tcl_Channel chan;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
return TCL_ERROR;
}
prot = 0666;
if (objc == 2) {
modeString = "r";
} else {
modeString = TclGetString(objv[2]);
if (objc == 4) {
char *permString = TclGetString(objv[3]);
int code = TCL_ERROR;
int scanned = TclParseAllWhiteSpace(permString, -1);
/* Support legacy octal numbers */
if ((permString[scanned] == '0')
&& (permString[scanned+1] >= '0')
&& (permString[scanned+1] <= '7')) {
Tcl_Obj *permObj;
TclNewLiteralStringObj(permObj, "0o");
Tcl_AppendToObj(permObj, permString+scanned+1, -1);
code = TclGetIntFromObj(NULL, permObj, &prot);
Tcl_DecrRefCount(permObj);
}
if ((code == TCL_ERROR)
&& TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
return TCL_ERROR;
}
}
}
pipeline = 0;
what = TclGetString(objv[1]);
if (what[0] == '|') {
pipeline = 1;
}
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
int mode, seekFlag, cmdObjc, binary;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
}
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
if (mode == -1) {
chan = NULL;
} else {
int flags = TCL_STDERR | TCL_ENFORCE_MODE;
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
flags |= TCL_STDOUT;
break;
case O_WRONLY:
flags |= TCL_STDIN;
break;
case O_RDWR:
flags |= (TCL_STDIN | TCL_STDOUT);
break;
default:
Tcl_Panic("Tcl_OpenCmd: invalid mode value");
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if (binary) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
ckfree((char *) cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
return TCL_OK;
}
void
TkMakeRawCurvePostscript(
Tcl_Interp *interp, /* Interpreter in whose result the Postscript
* is to be stored. */
Tk_Canvas canvas, /* Canvas widget for which the Postscript is
* being generated. */
double *pointPtr, /* Array of input coordinates: x0, y0, x1, y1,
* etc.. */
int numPoints) /* Number of points at pointPtr. */
{
int i;
double *segPtr;
Tcl_Obj *psObj;
/*
* Put the first point into the path.
*/
psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n",
pointPtr[0], Tk_CanvasPsY(canvas, pointPtr[1]));
/*
* Loop through all the remaining points in the curve, generating a
* straight line or curve section for every three of them.
*/
for (i=numPoints-1,segPtr=pointPtr ; i>=3 ; i-=3,segPtr+=6) {
if (segPtr[0]==segPtr[2] && segPtr[1]==segPtr[3] &&
segPtr[4]==segPtr[6] && segPtr[5]==segPtr[7]) {
/*
* The control points on this segment are equal to their
* neighbouring knots, so this segment is just a straight line.
*/
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n",
segPtr[6], Tk_CanvasPsY(canvas, segPtr[7]));
} else {
/*
* This is a generic Bezier curve segment.
*/
Tcl_AppendPrintfToObj(psObj,
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
segPtr[2], Tk_CanvasPsY(canvas, segPtr[3]),
segPtr[4], Tk_CanvasPsY(canvas, segPtr[5]),
segPtr[6], Tk_CanvasPsY(canvas, segPtr[7]));
}
}
/*
* If there are any points left that haven't been used, then build the
* last segment and generate Postscript in the same way for that.
*/
if (i > 0) {
int j;
double control[8];
for (j=0; j<2*i+2; j++) {
control[j] = segPtr[j];
}
for (; j<8; j++) {
control[j] = pointPtr[j-2*i-2];
}
if (control[0]==control[2] && control[1]==control[3] &&
control[4]==control[6] && control[5]==control[7]) {
/*
* Straight line.
*/
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n",
control[6], Tk_CanvasPsY(canvas, control[7]));
} else {
/*
* Bezier curve segment.
*/
Tcl_AppendPrintfToObj(psObj,
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
control[2], Tk_CanvasPsY(canvas, control[3]),
control[4], Tk_CanvasPsY(canvas, control[5]),
control[6], Tk_CanvasPsY(canvas, control[7]));
}
}
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
}
/* This handles all triggers which have a handler of tcl, or was set that way through
* a bind in a TCL script.
*
* Rewritten to use the proper way, instead of doing that Tcl_ValEval() garbage.
*/
void tcl_handler(struct network *net, struct trigger *trig, struct irc_data *data, struct dcc_session *dcc, const char *dccbuf)
{
int ret;
char *my_arg;
Tcl_Obj *command;
Tcl_Obj *nick;
Tcl_Obj *uhost;
Tcl_Obj *hand;
Tcl_Obj *chan;
Tcl_Obj *arg;
Tcl_Obj *msg;
Tcl_Obj *from;
Tcl_Obj *keyword;
Tcl_Obj *text;
Tcl_Obj **objv;
switch (trig->type)
{
case TRIG_PUB:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0]));
/* We do this because I'm retarded and have no way of figuring out what should happen after the mask */
my_arg = tstrdup(troll_makearg(data->rest_str,trig->mask));
arg = Tcl_NewStringObj(my_arg, strlen(my_arg));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(chan);
Tcl_IncrRefCount(arg);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 6);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = chan;
objv[5] = arg;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(chan);
Tcl_DecrRefCount(arg);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(my_arg);
free(objv);
break;
case TRIG_PUBM:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0]));
text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(chan);
Tcl_IncrRefCount(text);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 6);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = chan;
objv[5] = text;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(chan);
Tcl_DecrRefCount(text);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
case TRIG_MSG:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
/* This is stupid, I don't even remember why the hell I did this */
my_arg = ((&data->rest_str[strlen(trig->mask)] == NULL) || &data->rest_str[strlen(trig->mask)+1] == NULL) ? "" : &data->rest_str[strlen(trig->mask)+1];
text = Tcl_NewStringObj(my_arg, strlen(my_arg));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(text);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 5);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = text;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 5, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(text);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
case TRIG_MSGM:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
/* This is stupid, I don't even remember why the hell I did this */
text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(text);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 5);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = text;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 5, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(text);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
case TRIG_TOPC:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0]));
text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(chan);
Tcl_IncrRefCount(text);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 6);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = chan;
objv[5] = text;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(chan);
Tcl_DecrRefCount(text);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
case TRIG_RAW:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
from = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0]));
keyword = Tcl_NewStringObj(trig->command, strlen(trig->command));
text = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(from);
Tcl_IncrRefCount(keyword);
Tcl_IncrRefCount(text);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 4);
objv[0] = command;
objv[1] = from;
objv[2] = keyword;
objv[3] = text;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 4, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(from);
Tcl_DecrRefCount(keyword);
Tcl_DecrRefCount(text);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
/* :[email protected] JOIN :#test */
case TRIG_JOIN:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
chan = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(chan);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 5);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = chan;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 5, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(chan);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
/* :[email protected] PART #boo :eat my shit */
case TRIG_PART:
/* The proper way of doing things, according to #tcl on freenode (they'd know) */
command = Tcl_NewStringObj(trig->command, strlen(trig->command));
nick = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
uhost = Tcl_NewStringObj(data->prefix->host, strlen(data->prefix->host));
hand = Tcl_NewStringObj(data->prefix->nick, strlen(data->prefix->nick));
chan = Tcl_NewStringObj(data->c_params[0], strlen(data->c_params[0]));
msg = Tcl_NewStringObj(data->rest_str, strlen(data->rest_str));
/* We need to increase the reference count, because if TCL suddenly gets some
* time for GC, it will notice a zero reference count
*/
Tcl_IncrRefCount(command);
Tcl_IncrRefCount(nick);
Tcl_IncrRefCount(uhost);
Tcl_IncrRefCount(hand);
Tcl_IncrRefCount(chan);
Tcl_IncrRefCount(msg);
/* I don't need a NULL last array element */
objv = tmalloc(sizeof(Tcl_Obj *) * 6);
objv[0] = command;
objv[1] = nick;
objv[2] = uhost;
objv[3] = hand;
objv[4] = chan;
objv[5] = msg;
/* Call <command> <nick> <uhost> <hand> <chan> <arg> */
ret = Tcl_EvalObjv(net->tclinterp, 6, objv, TCL_EVAL_GLOBAL);
/* Decrement the reference count so the GC will catch it */
Tcl_DecrRefCount(command);
Tcl_DecrRefCount(nick);
Tcl_DecrRefCount(uhost);
Tcl_DecrRefCount(hand);
Tcl_DecrRefCount(chan);
Tcl_DecrRefCount(msg);
/* If we returned an error, send it to trollbot's warning channel */
if (ret == TCL_ERROR)
{
troll_debug(LOG_WARN,"TCL Error: %s\n",Tcl_GetStringResult(net->tclinterp));
}
free(objv);
break;
}
}
void
TkMakeBezierPostscript(
Tcl_Interp *interp, /* Interpreter in whose result the Postscript
* is to be stored. */
Tk_Canvas canvas, /* Canvas widget for which the Postscript is
* being generated. */
double *pointPtr, /* Array of input coordinates: x0, y0, x1, y1,
* etc.. */
int numPoints) /* Number of points at pointPtr. */
{
int closed, i;
int numCoords = numPoints*2;
double control[8];
Tcl_Obj *psObj;
/*
* If the curve is a closed one then generate a special spline that spans
* the last points and the first ones. Otherwise just put the first point
* into the path.
*/
if ((pointPtr[0] == pointPtr[numCoords-2])
&& (pointPtr[1] == pointPtr[numCoords-1])) {
closed = 1;
control[0] = 0.5*pointPtr[numCoords-4] + 0.5*pointPtr[0];
control[1] = 0.5*pointPtr[numCoords-3] + 0.5*pointPtr[1];
control[2] = 0.167*pointPtr[numCoords-4] + 0.833*pointPtr[0];
control[3] = 0.167*pointPtr[numCoords-3] + 0.833*pointPtr[1];
control[4] = 0.833*pointPtr[0] + 0.167*pointPtr[2];
control[5] = 0.833*pointPtr[1] + 0.167*pointPtr[3];
control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2];
control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3];
psObj = Tcl_ObjPrintf(
"%.15g %.15g moveto\n"
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
control[0], Tk_CanvasPsY(canvas, control[1]),
control[2], Tk_CanvasPsY(canvas, control[3]),
control[4], Tk_CanvasPsY(canvas, control[5]),
control[6], Tk_CanvasPsY(canvas, control[7]));
} else {
closed = 0;
control[6] = pointPtr[0];
control[7] = pointPtr[1];
psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n",
control[6], Tk_CanvasPsY(canvas, control[7]));
}
/*
* Cycle through all the remaining points in the curve, generating a curve
* section for each vertex in the linear path.
*/
for (i = numPoints-2, pointPtr += 2; i > 0; i--, pointPtr += 2) {
control[2] = 0.333*control[6] + 0.667*pointPtr[0];
control[3] = 0.333*control[7] + 0.667*pointPtr[1];
/*
* Set up the last two control points. This is done differently for
* the last spline of an open curve than for other cases.
*/
if ((i == 1) && !closed) {
control[6] = pointPtr[2];
control[7] = pointPtr[3];
} else {
control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2];
control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3];
}
control[4] = 0.333*control[6] + 0.667*pointPtr[0];
control[5] = 0.333*control[7] + 0.667*pointPtr[1];
Tcl_AppendPrintfToObj(psObj,
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
control[2], Tk_CanvasPsY(canvas, control[3]),
control[4], Tk_CanvasPsY(canvas, control[5]),
control[6], Tk_CanvasPsY(canvas, control[7]));
}
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
}
/* ARGSUSED */
int
Tcl_ScanObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
const char *string, *end, *baseString;
char op = 0;
int width, underflow = 0;
Tcl_WideInt wideValue;
Tcl_UniChar ch, sch;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
char buf[513]; /* Temporary buffer to hold scanned number
* strings before they are passed to
* strtoul. */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName ...?");
return TCL_ERROR;
}
format = Tcl_GetStringFromObj(objv[2], NULL);
numVars = objc-3;
/*
* Check for errors in the format string.
*/
if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = Tcl_GetStringFromObj(objv[1], NULL);
baseString = string;
/*
* Iterate over the format string filling in the result objects until we
* reach the end of input, the end of the format string, or there is a
* mismatch.
*/
objIndex = 0;
nconversions = 0;
while (*format != '\0') {
int parseFlag = TCL_PARSE_NO_WHITESPACE;
format += Tcl_UtfToUniChar(format, &ch);
flags = 0;
/*
* If we see whitespace in the format, skip whitespace in the string.
*/
if (Tcl_UniCharIsSpace(ch)) {
offset = Tcl_UtfToUniChar(string, &sch);
while (Tcl_UniCharIsSpace(sch)) {
if (*string == '\0') {
goto done;
}
string += offset;
offset = Tcl_UtfToUniChar(string, &sch);
}
continue;
}
if (ch != '%') {
literal:
if (*string == '\0') {
underflow = 1;
goto done;
}
string += Tcl_UtfToUniChar(string, &sch);
if (ch != sch) {
goto done;
}
continue;
}
format += Tcl_UtfToUniChar(format, &ch);
if (ch == '%') {
goto literal;
}
/*
* Check for assignment suppression ('*') or an XPG3-style assignment
* ('%n$').
*/
if (ch == '*') {
flags |= SCAN_SUPPRESS;
format += Tcl_UtfToUniChar(format, &ch);
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
char *formatEnd;
value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
if (*formatEnd == '$') {
format = formatEnd+1;
format += Tcl_UtfToUniChar(format, &ch);
objIndex = (int) value - 1;
}
}
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */
format += Tcl_UtfToUniChar(format, &ch);
} else {
width = 0;
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += Tcl_UtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
/*
* Fall through so we skip to the next character.
*/
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
nconversions++;
continue;
case 'd':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
break;
case 'i':
op = 'i';
parseFlag |= TCL_PARSE_SCAN_PREFIXES;
break;
case 'o':
op = 'i';
parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
break;
case 'x':
op = 'i';
parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
break;
case 'b':
op = 'i';
parseFlag |= TCL_PARSE_BINARY_ONLY;
break;
case 'u':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
flags |= SCAN_UNSIGNED;
break;
case 'f':
case 'e':
case 'g':
op = 'f';
break;
case 's':
op = 's';
break;
case 'c':
op = 'c';
flags |= SCAN_NOSKIP;
break;
case '[':
op = '[';
flags |= SCAN_NOSKIP;
break;
}
/*
* At this point, we will need additional characters from the string
* to proceed.
*/
if (*string == '\0') {
underflow = 1;
goto done;
}
/*
* Skip any leading whitespace at the beginning of a field unless the
* format suppresses this behavior.
*/
if (!(flags & SCAN_NOSKIP)) {
while (*string != '\0') {
offset = Tcl_UtfToUniChar(string, &sch);
if (!Tcl_UniCharIsSpace(sch)) {
break;
}
string += offset;
}
if (*string == '\0') {
underflow = 1;
goto done;
}
}
/*
* Perform the requested scanning operation.
*/
switch (op) {
case 's':
/*
* Scan a string up to width characters or whitespace.
*/
if (width == 0) {
width = ~0;
}
end = string;
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (Tcl_UniCharIsSpace(sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
string = end;
break;
case '[': {
CharSet cset;
if (width == 0) {
width = ~0;
}
end = string;
format = BuildCharSet(&cset, format);
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (!CharInSet(&cset, (int)sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
ReleaseCharSet(&cset);
if (string == end) {
/*
* Nothing matched the range, stop processing.
*/
goto done;
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
string = end;
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
string += Tcl_UtfToUniChar(string, &sch);
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj((int)sch);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
objPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
underflow = 1;
}
}
goto done;
}
string = end;
if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
break;
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
if (TclGetString(objPtr)[0] == '-') {
wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
sprintf(buf, "%" TCL_LL_MODIFIER "u",
(Tcl_WideUInt)wideValue);
Tcl_SetStringObj(objPtr, buf, -1);
} else {
Tcl_SetWideIntObj(objPtr, wideValue);
}
} else if (!(flags & SCAN_BIG)) {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
} else {
value = LONG_MAX;
}
}
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
sprintf(buf, "%lu", value); /* INTL: ISO digit */
Tcl_SetStringObj(objPtr, buf, -1);
} else {
Tcl_SetLongObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
break;
case 'f':
/*
* Scan a floating point number
*/
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
underflow = 1;
}
}
goto done;
} else if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
if (objPtr->typePtr == &tclDoubleType) {
dvalue = objPtr->internalRep.doubleValue;
} else
#endif
{
Tcl_DecrRefCount(objPtr);
goto done;
}
}
Tcl_SetDoubleObj(objPtr, dvalue);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
string = end;
}
}
void *
weechat_tcl_exec (struct t_plugin_script *script,
int ret_type, const char *function,
const char *format, void **argv)
{
int argc, i, llength;
int *ret_i;
char *ret_cv;
void *ret_val;
Tcl_Obj *cmdlist;
Tcl_Interp *interp;
struct t_plugin_script *old_tcl_script;
old_tcl_script = tcl_current_script;
tcl_current_script = script;
interp = (Tcl_Interp*)script->interpreter;
if (function && function[0])
{
cmdlist = Tcl_NewListObj (0, NULL);
Tcl_IncrRefCount (cmdlist); /* +1 */
Tcl_ListObjAppendElement (interp, cmdlist, Tcl_NewStringObj (function,-1));
}
else
{
tcl_current_script = old_tcl_script;
return NULL;
}
if (format && format[0])
{
argc = strlen (format);
for (i = 0; i < argc; i++)
{
switch (format[i])
{
case 's': /* string */
Tcl_ListObjAppendElement (interp, cmdlist,
Tcl_NewStringObj (argv[i], -1));
break;
case 'i': /* integer */
Tcl_ListObjAppendElement (interp, cmdlist,
Tcl_NewIntObj (*((int *)argv[i])));
break;
case 'h': /* hash */
Tcl_ListObjAppendElement (interp, cmdlist,
weechat_tcl_hashtable_to_dict (interp, argv[i]));
break;
}
}
}
if (Tcl_ListObjLength (interp, cmdlist, &llength) != TCL_OK)
llength = 0;
if (Tcl_EvalObjEx (interp, cmdlist, TCL_EVAL_DIRECT) == TCL_OK)
{
Tcl_ListObjReplace (interp, cmdlist, 0, llength, 0, NULL); /* remove elements, decrement their ref count */
Tcl_DecrRefCount (cmdlist); /* -1 */
ret_val = NULL;
if (ret_type == WEECHAT_SCRIPT_EXEC_STRING)
{
ret_cv = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &i);
if (ret_cv)
ret_val = (void *)strdup (ret_cv);
else
ret_val = NULL;
}
else if ( ret_type == WEECHAT_SCRIPT_EXEC_INT
&& Tcl_GetIntFromObj (interp, Tcl_GetObjResult (interp), &i) == TCL_OK)
{
ret_i = (int *)malloc (sizeof (*ret_i));
if (ret_i)
*ret_i = i;
ret_val = (void *)ret_i;
}
else if (ret_type == WEECHAT_SCRIPT_EXEC_HASHTABLE)
{
ret_val = weechat_tcl_dict_to_hashtable (interp,
Tcl_GetObjResult (interp),
WEECHAT_SCRIPT_HASHTABLE_DEFAULT_SIZE,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_STRING);
}
tcl_current_script = old_tcl_script;
if (ret_val)
return ret_val;
weechat_printf (NULL,
weechat_gettext ("%s%s: function \"%s\" must return a "
"valid value"),
weechat_prefix ("error"), TCL_PLUGIN_NAME, function);
return NULL;
}
Tcl_ListObjReplace (interp, cmdlist, 0, llength, 0, NULL); /* remove elements, decrement their ref count */
Tcl_DecrRefCount (cmdlist); /* -1 */
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to run function \"%s\": %s"),
weechat_prefix ("error"), TCL_PLUGIN_NAME, function,
Tcl_GetStringFromObj (Tcl_GetObjResult (interp), &i));
tcl_current_script = old_tcl_script;
return NULL;
}
static int obj_Cgmap(ClientData /*UNUSED*/, Tcl_Interp *interp, int argc, Tcl_Obj * const objv[])
{
Tcl_Obj *atomselect = NULL;
Tcl_Obj *object = NULL;
Tcl_Obj *bytes = NULL;
Tcl_Obj *bytes_append = NULL;
Tcl_Obj *sel = NULL;
float *coords = NULL;
float *coords_append = NULL;
const char *blockid_field = "user";
const char *order_field = "user2";
const char *weight_field= "user3";
int nframes, natoms, ncoords, result, length;
int first, last, stride;
int molid, append_molid;
natoms = ncoords = result = 0;
molid = append_molid = 0;
first = last = 0;
stride = 1;
nframes = 1;
std::vector<float> weight;
std::vector<int> bead;
std::vector<int> index;
// Parse Arguments
int n = 1;
while (n < argc) {
const char *cmd = Tcl_GetString(objv[n]);
if (!strncmp(cmd, "-molid", 7)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &molid) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-append", 8)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &append_molid) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-sel", 5)) {
sel = objv[n+1];
n += 2;
} else if (!strncmp(cmd, "-first", 5)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &first) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-last", 4)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &last) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-stride", 6)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &stride) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-weight", 7)) {
weight_field = Tcl_GetString(objv[n+1]);
n += 2;
} else if (!strncmp(cmd, "-blockid", 7)) {
blockid_field = Tcl_GetString(objv[n+1]);
n += 2;
} else if (!strncmp(cmd, "-order", 6)) {
order_field = Tcl_GetString(objv[n+1]);
n += 2;
} else {
Tcl_WrongNumArgs(interp,1,objv, (char *)"molid");
return TCL_ERROR;
}
}
// Create an internal selection that we can manipulate if none was defined
// Note that a passed selection overides the passed molid
if (!sel) {
Tcl_Obj *script = Tcl_ObjPrintf("atomselect %i all", molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
return TCL_ERROR;
}
atomselect = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(atomselect);
} else {
// Create a internal selection that is a COPY of the passed selection
atomselect = Tcl_DuplicateObj(sel);
Tcl_IncrRefCount(atomselect);
// Get the molid
Tcl_Obj *script = Tcl_DuplicateObj(sel);
Tcl_AppendToObj(script, " molid", -1);
if(Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
return TCL_ERROR;
}
Tcl_Obj *molid_result = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, molid_result, &molid) != TCL_OK) {return TCL_ERROR;}
}
// Get the number of frames
Tcl_Obj *script = Tcl_ObjPrintf("molinfo %i get numframes", molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling molinfo for nframes", TCL_STATIC);
return TCL_ERROR;
}
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &nframes) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of frames", TCL_STATIC);
return TCL_ERROR;
}
if ( first < 0 || first >= nframes ) {
Tcl_SetResult(interp, (char *) "Cgmap: illegal value of first_frame", TCL_STATIC);
return TCL_ERROR;
}
if ( last == -1 || last > nframes || last < first ) last = nframes;
// Get the number of atoms from selection
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendToObj(script, " num", -1);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
return TCL_ERROR;
}
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &natoms) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of atoms", TCL_STATIC);
return TCL_ERROR;
}
// Make sure we actually have some atoms
if (natoms == 0) {
Tcl_SetResult(interp, (char *) "Cgmap: Selection or molecule contains no atoms", TCL_STATIC);
return TCL_ERROR;
}
// Get the weights (mass)
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendPrintfToObj (script, " get %s", weight_field);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for weights", TCL_STATIC);
return TCL_ERROR;
}
ncoords = parse_vector(Tcl_GetObjResult(interp), weight, interp);
if (ncoords == -1) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
return TCL_ERROR;
}
// Get the bead IDs
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendPrintfToObj (script, " get %s", blockid_field);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for blocks", TCL_STATIC);
return TCL_ERROR;
}
ncoords = parse_ivector(Tcl_GetObjResult(interp), bead, interp, true);
if (ncoords == -1) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
return TCL_ERROR;
}
// Get the atom IDs, we use these as a map when accessing the coordinate array
// user2 is set via ::CGit::setBeadID
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendPrintfToObj (script, " get %s", order_field);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for order", TCL_STATIC);
return TCL_ERROR;
}
ncoords = parse_ivector(Tcl_GetObjResult(interp), index, interp, true);
if (ncoords == -1) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
return TCL_ERROR;
}
// Get current frame of the target mol
script = Tcl_ObjPrintf("molinfo %d get frame", append_molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's current frame", TCL_STATIC);
return TCL_ERROR;
}
int append_frame = 0;
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &append_frame) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's current frame", TCL_STATIC);
return TCL_ERROR;
}
//Get number of atoms in target (append) mol
script = Tcl_ObjPrintf("molinfo %i get numatoms", append_molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's number of atoms", TCL_STATIC);
return TCL_ERROR;
}
int append_natoms = 0;
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &append_natoms) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's number of atoms", TCL_STATIC);
return TCL_ERROR;
}
int print = ((last - first) / 10);
if (print < 10) print = 10;
if (print > 100) print = 100;
//Loop over frames, calculate COMS, set coordinates in target mol
for (int frame = first;
frame <= last && frame < nframes;
frame += stride) {
if (frame % print == 0) {
//Tcl_Obj *msg = Tcl_ObjPrintf ("puts \"Mapping frame %i\"", frame);
Tcl_Obj *msg = Tcl_ObjPrintf ("vmdcon -info \"CGit> Mapping frame %i\"", frame);
result = Tcl_EvalObjEx(interp, msg, TCL_EVAL_DIRECT);
if (result != TCL_OK) { return TCL_ERROR; }
}
//Update the frames
Tcl_Obj *mol_chgframe = Tcl_ObjPrintf ("molinfo top set frame %i", frame);
if (Tcl_EvalObjEx(interp, mol_chgframe, TCL_EVAL_DIRECT) != TCL_OK)
return TCL_ERROR;
// Get the coordinates of the molecules in the reference mol
Tcl_Obj *get_ts = Tcl_ObjPrintf("gettimestep %d %i", molid, frame);
if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC);
return TCL_ERROR;
}
bytes = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(bytes);
Tcl_InvalidateStringRep (bytes);
coords = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes, &length));
/** Create a new frame for append_mol **/
Tcl_ObjPrintf("animate dup %i", append_molid);
if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error adding frame to append mol", TCL_STATIC);
return TCL_ERROR;
}
append_frame++;
Tcl_Obj *setframe = Tcl_ObjPrintf("molinfo %i set frame %i; display update", molid, frame);
if (Tcl_EvalObjEx(interp, setframe, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error updating source frame", TCL_STATIC);
return TCL_ERROR;
}
// Copy PBC conditions
Tcl_Obj *setpbc = Tcl_ObjPrintf("molinfo %i set {a b c} [molinfo %i get {a b c}]", append_molid, molid);
if (Tcl_EvalObjEx(interp, setpbc, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error updating PBC", TCL_STATIC);
return TCL_ERROR;
}
// Get the coordinates of the molecules in the target (append) mol
get_ts = Tcl_ObjPrintf("gettimestep %d %i", append_molid, append_frame);
if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC);
return TCL_ERROR;
}
bytes_append = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(bytes_append);
Tcl_InvalidateStringRep(bytes_append);
coords_append = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes_append, &length));
//loop over coordinates and beads, calculate COMs
int current_bead, current_atom;
current_bead = current_atom = 0;
// Nested loop to work on each bead at a time
float w,x,y,z;
int j = 0;
for (int start_atom = 0; start_atom < natoms; ) {
current_bead = bead[start_atom];
w = x = y = z = 0;
// Calculate COM for each bead
for ( current_atom = start_atom;
current_atom < natoms && bead[current_atom] == current_bead;
current_atom++) {
//Lookup the atom index from the selection
unsigned int idx = index[current_atom];
float tw = weight[current_atom];
w += tw;
x += tw * coords[3*idx];
y += tw * coords[3*idx+1];
z += tw * coords[3*idx+2];
}
if (w == 0) {
Tcl_SetResult(interp, (char *) "Cgmap: Bad weight can't total zero", TCL_STATIC);
return TCL_ERROR;
}
// Insert calculated COMS into append_mols coordinate array
// Need to figure out some kind of bounds checking here...
coords_append[3 * j ] = x / w;
coords_append[3 * j + 1] = y / w;
coords_append[3 * j + 2] = z / w;
start_atom = current_atom;
j++;
} // bead loop
// call rawtimestep to set byte array for append_mol
Tcl_Obj *set_ts[5];
set_ts[0] = Tcl_NewStringObj("rawtimestep", -1);
set_ts[1] = Tcl_ObjPrintf("%d",append_molid);
set_ts[2] = bytes_append;
set_ts[3] = Tcl_NewStringObj("-frame", -1);
set_ts[4] = Tcl_NewIntObj(append_frame);
if (Tcl_EvalObjv (interp, 5, set_ts, 0) != TCL_OK)
return TCL_ERROR;
//Cleanup
Tcl_DecrRefCount(bytes);
Tcl_DecrRefCount(bytes_append);
} // Frame loop
//Cleanup
Tcl_DecrRefCount(atomselect);
Tcl_SetResult(interp, (char *) "", TCL_STATIC);
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_GetsObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
}
chanObjPtr = objv[1];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
/*
* TIP #219. Capture error messages put by the driver into the
* bypass area and put them into the regular interpreter result.
* Fall back to the regular message if nothing was found in the
* bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"",
TclGetString(chanObjPtr), "\": ",
Tcl_PosixError(interp), NULL);
}
return TCL_ERROR;
}
lineLen = -1;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
return TCL_OK;
} else {
Tcl_SetObjResult(interp, linePtr);
}
return TCL_OK;
}
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((ClientData) 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 != (Tcl_Channel) 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 == (Tcl_Channel) 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((int) 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,
(ClientData) 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 != (Tcl_Channel) NULL) {
Tcl_DeleteChannelHandler(isPtr->input, StdinProc,
(ClientData) 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((ClientData) interp);
Tcl_Exit(exitCode);
}
/* ARGSUSED */
int
Tcl_ReadObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
int toRead; /* How many bytes to read? */
int charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *resultPtr, *chanObjPtr;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
/*
* Do not append directly; that makes ensembles using this command as
* a subcommand produce the wrong message.
*/
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId");
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
return TCL_ERROR;
}
i = 1;
newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
newline = 1;
i++;
}
if (i == objc) {
goto argerror;
}
chanObjPtr = objv[i];
if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr),
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
i++; /* Consumed channel name. */
/*
* Compute how many bytes to read, and see whether the final newline
* should be dropped.
*/
toRead = -1;
if (i < objc) {
char *arg;
arg = TclGetString(objv[i]);
if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(arg, "nonewline") == 0) {
newline = 1;
} else {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", NULL);
return TCL_ERROR;
}
}
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"",
TclGetString(chanObjPtr), "\": ",
Tcl_PosixError(interp), NULL);
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
char *result;
int length;
result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* HtmlImageServerGet --
*
* Retrieve an HtmlImage2 object for the image at URL zUrl from
* an image-server. The caller should match this call with a single
* HtmlImageFree() when the image object is no longer required.
*
* If the image is not already in the cache, the Tcl script
* configured as the widget -imagecmd is invoked. If this command
* raises an error or returns an invalid result, then this function
* returns NULL. A Tcl back-ground error is propagated in this case
* also.
*
* Results:
* Pointer to HtmlImage2 object containing the image from zUrl, or
* NULL, if zUrl was invalid for some reason.
*
* Side effects:
* May invoke -imagecmd script.
*
*---------------------------------------------------------------------------
*/
HtmlImage2 *
HtmlImageServerGet (HtmlImageServer *p, const char *zUrl)
{
Tcl_Obj *pImageCmd = p->pTree->options.imagecmd;
Tcl_Interp *interp = p->pTree->interp;
Tcl_HashEntry *pEntry = 0;
HtmlImage2 *pImage = 0;
/* Try to find the requested image in the hash table. */
if (pImageCmd) {
int new_entry;
pEntry = Tcl_CreateHashEntry(&p->aImage, zUrl, &new_entry);
if (new_entry) {
Tcl_Obj *pEval;
Tcl_Obj *pResult;
int rc;
int nObj;
Tcl_Obj **apObj = 0;
Tk_Image img;
/* The image could not be found in the hash table and an
* -imagecmd callback is configured. The callback script
* must be executed to obtain an image. Build up a script
* in pEval and execute it. Put the result in variable pResult.
*/
pEval = Tcl_DuplicateObj(pImageCmd);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(interp, pEval, Tcl_NewStringObj(zUrl, -1));
rc = Tcl_EvalObjEx(interp, pEval, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(pEval);
if (rc != TCL_OK) {
goto image_get_out;
}
pResult = Tcl_GetObjResult(interp);
/* Read the result into array apObj. If the result was
* not a valid Tcl list, return NULL and raise a background
* error about the badly formed list.
*/
rc = Tcl_ListObjGetElements(interp, pResult, &nObj, &apObj);
if (rc != TCL_OK) {
goto image_get_out;
}
if (nObj==0) {
Tcl_DeleteHashEntry(pEntry);
goto image_unavailable;
}
pImage = HtmlNew(HtmlImage2);
if (nObj == 1 || nObj == 2) {
img = Tk_GetImage(
interp, p->pTree->tkwin, Tcl_GetString(apObj[0]),
imageChanged, pImage
);
}
if ((nObj != 1 && nObj != 2) || !img) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "-imagecmd returned bad value", 0);
HtmlFree(pImage);
pImage = 0;
goto image_get_out;
}
Tcl_SetHashValue(pEntry, (ClientData)pImage);
Tcl_IncrRefCount(apObj[0]);
pImage->pImageName = apObj[0];
if (nObj == 2) {
Tcl_IncrRefCount(apObj[1]);
pImage->pDelete = apObj[1];
}
pImage->pImageServer = p;
pImage->zUrl = Tcl_GetHashKey(&p->aImage, pEntry);
pImage->image = img;
Tk_SizeOfImage(pImage->image, &pImage->width, &pImage->height);
pImage->isValid = 1;
HtmlImagePixmap(pImage);
}
}
image_get_out:
pImage = (HtmlImage2 *)(pEntry ? Tcl_GetHashValue(pEntry) : 0);
HtmlImageRef(pImage);
if (!pImage && pImageCmd) {
Tcl_BackgroundError(interp);
Tcl_ResetResult(interp);
assert(pEntry);
Tcl_DeleteHashEntry(pEntry);
}
image_unavailable:
return pImage;
}
/* ARGSUSED */
int
Tcl_ExecObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* This function generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
Tcl_Obj *resultPtr;
const char **argv;
char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
static const char *options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum options {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
/*
* Check for any leading option arguments.
*/
keepNewline = 0;
ignoreStderr = 0;
for (skip = 1; skip < objc; skip++) {
string = TclGetString(objv[skip]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == EXEC_KEEPNEWLINE) {
keepNewline = 1;
} else if (index == EXEC_IGNORESTDERR) {
ignoreStderr = 1;
} else {
skip++;
break;
}
}
if (objc <= skip) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
return TCL_ERROR;
}
/*
* See if the command is to be run in background.
*/
background = 0;
string = TclGetString(objv[objc - 1]);
if ((string[0] == '&') && (string[1] == '\0')) {
objc--;
background = 1;
}
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
argv = (const char **)
TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
argv[i] = TclGetString(objv[i + skip]);
}
argv[argc] = NULL;
chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
(ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)));
/*
* Free the argv array.
*/
TclStackFree(interp, (void *)argv);
if (chan == NULL) {
return TCL_ERROR;
}
if (background) {
/*
* Store the list of PIDs from the pipeline in interp's result and
* detach the PIDs (instead of waiting for them).
*/
TclGetAndDetachPids(interp, chan);
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading output from command: ",
Tcl_PosixError(interp), NULL);
Tcl_DecrRefCount(resultPtr);
}
return TCL_ERROR;
}
}
/*
* If the process produced anything on stderr, it will have been returned
* in the interpreter result. It needs to be appended to the result
* string.
*/
result = Tcl_Close(interp, chan);
Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
string = TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
return result;
}
void
HtmlImageFree (HtmlImage2 *pImage)
{
if (!pImage) {
return;
}
assert(pImage->nRef > 0);
pImage->nRef--;
if (
pImage->nRef == 0 &&
(pImage->pUnscaled || !pImage->pImageServer->isSuspendGC)
) {
/* The reference count for this structure has reached zero.
* Really delete it. The assert() says that an original image
* cannot be deleted before all of it's scaled copies.
*/
assert(pImage->pUnscaled || 0 == pImage->pNext);
freeImageCompressed(pImage);
freeTile(pImage);
if (pImage->pixmap) {
HtmlTree *pTree = pImage->pImageServer->pTree;
Tk_FreePixmap(Tk_Display(pTree->tkwin), pImage->pixmap);
pImage->pixmap = 0;
}
if (pImage->image) {
Tk_FreeImage(pImage->image);
}
if (pImage->pImageName) {
Tcl_Interp *interp = pImage->pImageServer->pTree->interp;
Tcl_Obj *pEval;
if (!pImage->pDelete) {
pEval = Tcl_NewStringObj("image delete", -1);
Tcl_IncrRefCount(pEval);
} else {
pEval = pImage->pDelete;
}
Tcl_ListObjAppendElement(interp, pEval, pImage->pImageName);
Tcl_EvalObjEx(interp, pEval, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
Tcl_DecrRefCount(pEval);
Tcl_DecrRefCount(pImage->pImageName);
}
if (pImage->pUnscaled) {
HtmlImage2 *pIter;
for (
pIter = pImage->pUnscaled;
pIter->pNext != pImage;
pIter = pIter->pNext
) {
assert(pIter->pNext);
}
pIter->pNext = pIter->pNext->pNext;
HtmlImageFree(pImage->pUnscaled);
} else {
const char *zKey = pImage->zUrl;
Tcl_HashTable *paImage = &pImage->pImageServer->aImage;
Tcl_HashEntry *pEntry = Tcl_FindHashEntry(paImage, zKey);
assert(pEntry);
Tcl_DeleteHashEntry(pEntry);
}
HtmlFree(pImage);
Tcl_CancelIdleCall(asyncPixmapify, (ClientData)pImage);
}
}
/* ARGSUSED */
int
Tcl_AfterObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (objv[1]->typePtr == &tclIntType
#ifndef TCL_WIDE_INT_IS_LONG
|| objv[1]->typePtr == &tclWideIntType
#endif
|| objv[1]->typePtr == &tclBignumType
|| (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
&index) != TCL_OK)) {
index = -1;
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
}
}
/*
* At this point, either index = -1 and ms contains the number of ms
* to wait, or else index is the index of a subcommand.
*/
switch (index) {
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
/*
* The variable below is used to generate unique identifiers for after
* commands. This id can wrap around, which can potentially cause
* problems. However, there are not likely to be problems in practice,
* because after commands can only be requested to about a month in
* the future, and wrap-around is unlikely to occur in less than about
* 1-10 years. Thus it's unlikely that any old ids will still be
* around when wrap-around occurs.
*/
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
Tcl_GetTime(&wakeup);
wakeup.sec += (long)(ms / 1000);
wakeup.usec += ((long)(ms % 1000)) * 1000;
if (wakeup.usec > 1000000) {
wakeup.sec++;
wakeup.usec -= 1000000;
}
afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup,
AfterProc, afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
return TCL_OK;
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
const char *command, *tempCommand;
int tempLength;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
command = Tcl_GetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, (unsigned) length)) {
break;
}
}
if (afterPtr == NULL) {
afterPtr = GetAfterEvent(assocPtr, commandPtr);
}
if (objc != 3) {
Tcl_DecrRefCount(commandPtr);
}
if (afterPtr != NULL) {
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
FreeAfterPtr(afterPtr);
}
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
case AFTER_INFO:
if (objc == 2) {
Tcl_Obj *resultObj = Tcl_NewObj();
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
}
break;
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
return TCL_OK;
}
void
TkMacOSXHandleMenuSelect(
MenuID theMenu,
MenuItemIndex theItem,
int optionKeyPressed)
{
Tk_Window tkwin;
Window window;
TkDisplay *dispPtr;
Tcl_CmdInfo dummy;
int code;
if (theItem == 0) {
TkMacOSXClearMenubarActive();
return;
}
switch (theMenu) {
case kAppleMenu:
switch (theItem) {
case kAppleAboutItem:
if (optionKeyPressed || gInterp == NULL ||
Tcl_GetCommandInfo(gInterp, "tkAboutDialog", &dummy) == 0) {
TkAboutDlg();
} else {
code = Tcl_EvalEx(gInterp, "tkAboutDialog", -1,
TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_BackgroundException(gInterp, code);
}
Tcl_ResetResult(gInterp);
}
break;
}
break;
case kFileMenu:
switch (theItem) {
case kSourceItem:
if (gInterp) {
if (Tcl_EvalEx(gInterp, "tk_getOpenFile -filetypes {"
"{{TCL Scripts} {.tcl} TEXT} {{Text Files} {} TEXT}}",
-1, TCL_EVAL_GLOBAL) == TCL_OK) {
Tcl_Obj *path = Tcl_GetObjResult(gInterp);
int len;
Tcl_GetStringFromObj(path, &len);
if (len) {
Tcl_IncrRefCount(path);
code = Tcl_FSEvalFile(gInterp, path);
if (code != TCL_OK) {
Tcl_BackgroundException(gInterp, code);
}
Tcl_DecrRefCount(path);
}
}
Tcl_ResetResult(gInterp);
}
break;
case kDemoItem:
if (gInterp) {
Tcl_Obj *path = GetWidgetDemoPath(gInterp);
if (path) {
Tcl_IncrRefCount(path);
code = Tcl_FSEvalFile(gInterp, path);
if (code != TCL_OK) {
Tcl_BackgroundException(gInterp, code);
}
Tcl_DecrRefCount(path);
Tcl_ResetResult(gInterp);
}
}
break;
case kCloseItem:
/* Send close event */
window = TkMacOSXGetXWindow(ActiveNonFloatingWindow());
dispPtr = TkGetDisplayList();
tkwin = Tk_IdToWindow(dispPtr->display, window);
TkGenWMDestroyEvent(tkwin);
break;
}
break;
case kEditMenu:
/*
* This implementation just send the keysyms Tk thinks are associated
* with function keys that do Cut, Copy & Paste on a Sun keyboard.
*/
GenerateEditEvent(theItem);
break;
default:
TkMacOSXDispatchMenuEvent(theMenu, theItem);
break;
}
/*
* Finally we unhighlight the menu.
*/
HiliteMenu(0);
}
Tcl_Obj*
TnmSnmpNorm(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
{
int i, code, objc;
Tcl_Obj **objv;
Tcl_Obj *vbListPtr = NULL;
/*
* The following Tcl_Objs are allocated once and reused whenever
* we need to expand a varbind list containing object identifiers
* without any value or type elements.
*/
static Tcl_Obj *nullType = NULL;
static Tcl_Obj *zeroValue = NULL;
static Tcl_Obj *nullValue = NULL;
if (! nullType) {
nullType = Tcl_NewStringObj("NULL", 4);
Tcl_IncrRefCount(nullType);
}
if (! zeroValue) {
zeroValue = Tcl_NewIntObj(0);
Tcl_IncrRefCount(zeroValue);
}
if (! nullValue) {
nullValue = Tcl_NewStringObj(NULL, 0);
Tcl_IncrRefCount(nullValue);
}
/*
* Split the varbind list into a list of varbinds. Create a
* new Tcl list to hold the expanded varbind list.
*/
code = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
if (code != TCL_OK) {
goto errorExit;
}
vbListPtr = Tcl_NewListObj(0, NULL);
for (i = 0; i < objc; i++) {
int vbc, type;
Tcl_Obj **vbv, *vbPtr;
TnmOid* oidPtr;
Tcl_Obj *oidObjPtr, *typeObjPtr, *valueObjPtr;
TnmMibNode *nodePtr = NULL;
/*
* Create a new varbind element in the expanded result list
* for each varbind.
*/
vbPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, vbListPtr, vbPtr);
code = Tcl_ListObjGetElements(interp, objv[i], &vbc, &vbv);
if (code != TCL_OK) {
goto errorExit;
}
/*
* Get the object identifier value from the first list
* element. Check the number of list elements and assign
* them to the oid, type and value variables.
*/
switch (vbc) {
case 1:
oidObjPtr = vbv[0];
typeObjPtr = nullType;
valueObjPtr = nullValue;
break;
case 2:
oidObjPtr = vbv[0];
typeObjPtr = NULL;
valueObjPtr = vbv[1];
break;
case 3:
oidObjPtr = vbv[0];
typeObjPtr = vbv[1];
valueObjPtr = vbv[2];
break;
default: {
char msg[80];
sprintf(msg, "illegal number of elements in varbind %d", i);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
msg, (char *) NULL);
goto errorExit;
}
}
/*
* Check/resolve the object identifier and assign it to the
* result list. Make sure to make a deep copy if the object
* identifier value is shared since the string representation
* must be invalidated to ensure that hexadecimal
* sub-identifier are converted into decimal sub-identifier.
*/
oidPtr = TnmGetOidFromObj(interp, oidObjPtr);
if (! oidPtr) {
goto errorExit;
}
if (Tcl_IsShared(oidObjPtr)) {
oidObjPtr = Tcl_DuplicateObj(oidObjPtr);
}
TnmOidObjSetRep(oidObjPtr, TNM_OID_AS_OID);
Tcl_InvalidateStringRep(oidObjPtr);
Tcl_ListObjAppendElement(interp, vbPtr, oidObjPtr);
/*
* Lookup the type in the MIB if there is no type given in the
* varbind element.
*/
if (! typeObjPtr) {
int syntax;
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
if (! nodePtr) {
char msg[80];
sprintf(msg, "failed to lookup the type for varbind %d", i);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
msg, (char *) NULL);
goto errorExit;
}
syntax = (nodePtr->typePtr && nodePtr->typePtr->name)
? nodePtr->typePtr->syntax : nodePtr->syntax;
typeObjPtr = Tcl_NewStringObj(
TnmGetTableValue(tnmSnmpTypeTable, (unsigned) syntax), -1);
}
type = TnmGetTableKeyFromObj(NULL, tnmSnmpTypeTable,
typeObjPtr, NULL);
if (type == -1) {
type = TnmGetTableKeyFromObj(NULL, tnmSnmpExceptionTable,
typeObjPtr, NULL);
if (type == -1) {
char msg[80];
invalidType:
sprintf(msg, "illegal type in varbind %d", i);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
msg, (char *) NULL);
goto errorExit;
}
}
Tcl_ListObjAppendElement(interp, vbPtr, typeObjPtr);
/*
* Check the value and perform any conversions needed to
* convert the value into the base type representation.
*/
switch (type) {
case ASN1_INTEGER: {
long longValue;
code = Tcl_GetLongFromObj(interp, valueObjPtr, &longValue);
if (code != TCL_OK) {
if (! nodePtr) {
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
}
if (nodePtr) {
Tcl_Obj *value;
value = TnmMibScanValue(nodePtr->typePtr, nodePtr->syntax,
valueObjPtr);
if (! value) {
goto errorExit;
}
Tcl_ResetResult(interp);
code = Tcl_GetLongFromObj(interp, value, &longValue);
}
if (code != TCL_OK) {
goto errorExit;
}
valueObjPtr = Tcl_NewLongObj(longValue);
}
if (flags & TNM_SNMP_NORM_INT) {
if (! nodePtr) {
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
}
if (nodePtr && nodePtr->typePtr) {
Tcl_Obj *newPtr;
newPtr = TnmMibFormatValue(nodePtr->typePtr,
nodePtr->syntax,
valueObjPtr);
if (newPtr) {
valueObjPtr = newPtr;
}
}
}
break;
}
case ASN1_COUNTER32:
case ASN1_GAUGE32:
case ASN1_TIMETICKS: {
TnmUnsigned32 u;
code = TnmGetUnsigned32FromObj(interp, valueObjPtr, &u);
if (code != TCL_OK) {
goto errorExit;
}
break;
}
case ASN1_COUNTER64: {
TnmUnsigned64 u;
code = TnmGetUnsigned64FromObj(interp, valueObjPtr, &u);
if (code != TCL_OK) {
goto errorExit;
}
break;
}
case ASN1_IPADDRESS: {
if (TnmGetIpAddressFromObj(interp, valueObjPtr) == NULL) {
goto errorExit;
}
Tcl_InvalidateStringRep(valueObjPtr);
break;
}
case ASN1_OBJECT_IDENTIFIER:
if (! TnmGetOidFromObj(interp, valueObjPtr)) {
goto errorExit;
}
if (Tcl_IsShared(valueObjPtr)) {
valueObjPtr = Tcl_DuplicateObj(valueObjPtr);
}
if (flags & TNM_SNMP_NORM_OID) {
TnmOidObjSetRep(valueObjPtr, TNM_OID_AS_NAME);
} else {
TnmOidObjSetRep(valueObjPtr, TNM_OID_AS_OID);
}
Tcl_InvalidateStringRep(valueObjPtr);
break;
case ASN1_OCTET_STRING: {
int len;
if (! nodePtr) {
nodePtr = TnmMibNodeFromOid(oidPtr, NULL);
}
if (nodePtr) {
Tcl_Obj *scan;
scan = TnmMibScanValue(nodePtr->typePtr, nodePtr->syntax,
valueObjPtr);
if (scan) {
valueObjPtr = scan;
}
}
if (TnmGetOctetStringFromObj(interp, valueObjPtr, &len) == NULL) {
goto errorExit;
}
Tcl_InvalidateStringRep(valueObjPtr);
break;
}
case ASN1_NULL:
valueObjPtr = nullValue;
break;
default:
goto invalidType;
}
Tcl_ListObjAppendElement(interp, vbPtr, valueObjPtr);
}
return vbListPtr;
errorExit:
if (vbListPtr) {
Tcl_DecrRefCount(vbListPtr);
}
return NULL;
}
int
TclpMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive errors. */
Tcl_Obj *resultPtr, /* List object to lappend results. */
Tcl_Obj *pathPtr, /* Contains path to directory to search. */
CONST char *pattern, /* Pattern to match against. */
Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
CONST char *native;
Tcl_Obj *fileNamePtr;
int matchResult = 0;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
/*
* The native filesystem never adds mounts.
*/
return TCL_OK;
}
fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (fileNamePtr == NULL) {
return TCL_ERROR;
}
if (pattern == NULL || (*pattern == '\0')) {
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
CONST char *nativeTail;
native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = (CONST char*) Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
CONST char *dirName;
int dirLength;
int matchHidden, matchHiddenPat;
int nativeDirLen;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
* foo.c" would return "./foo.c".
*/
if (dirLength == 0) {
dirName = ".";
} else {
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
dirLength++;
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read directory \"",
Tcl_DStringValue(&dsOrig), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
nativeDirLen = Tcl_DStringLength(&ds);
/*
* Check to see if -type or the pattern requests hidden files.
*/
matchHiddenPat = (pattern[0] == '.')
|| ((pattern[0] == '\\') && (pattern[1] == '.'));
matchHidden = matchHiddenPat
|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */
Tcl_DString utfDs;
CONST char *utfname;
/*
* Skip this file if it doesn't agree with the hidden parameters
* requested by the user (via -type or pattern).
*/
if (*entryPtr->d_name == '.') {
if (!matchHidden) continue;
} else {
#ifdef MAC_OSX_TCL
if (matchHiddenPat) continue;
/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
#else
if (matchHidden) continue;
#endif
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
Tcl_DStringLength(&utfDs)));
}
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
closedir(d);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
}
if (matchResult < 0) {
return TCL_ERROR;
} else {
return TCL_OK;
}
}
static int
ConfigureScale(
Tcl_Interp *interp, /* Used for error reporting. */
register TkScale *scalePtr, /* Information about widget; may or may not
* already have values for some fields. */
int objc, /* Number of valid entries in objv. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tk_SavedOptions savedOptions;
Tcl_Obj *errorResult = NULL;
int error;
double varValue;
/*
* Eliminate any existing trace on a variable monitored by the scale.
*/
if (scalePtr->varNamePtr != NULL) {
Tcl_UntraceVar(interp, Tcl_GetString(scalePtr->varNamePtr),
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
ScaleVarProc, scalePtr);
}
for (error = 0; error <= 1; error++) {
if (!error) {
/*
* First pass: set options to new values.
*/
if (Tk_SetOptions(interp, (char *) scalePtr,
scalePtr->optionTable, objc, objv, scalePtr->tkwin,
&savedOptions, NULL) != TCL_OK) {
continue;
}
} else {
/*
* Second pass: restore options to old values.
*/
errorResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errorResult);
Tk_RestoreSavedOptions(&savedOptions);
}
/*
* If the scale is tied to the value of a variable, then set the
* scale's value from the value of the variable, if it exists and it
* holds a valid double value.
*/
if (scalePtr->varNamePtr != NULL) {
double value;
Tcl_Obj *valuePtr;
valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL,
TCL_GLOBAL_ONLY);
if ((valuePtr != NULL) &&
(Tcl_GetDoubleFromObj(NULL, valuePtr, &value) == TCL_OK)) {
scalePtr->value = TkRoundToResolution(scalePtr, value);
}
}
/*
* Several options need special processing, such as parsing the
* orientation and creating GCs.
*/
scalePtr->fromValue = TkRoundToResolution(scalePtr,
scalePtr->fromValue);
scalePtr->toValue = TkRoundToResolution(scalePtr, scalePtr->toValue);
scalePtr->tickInterval = TkRoundToResolution(scalePtr,
scalePtr->tickInterval);
/*
* Make sure that the tick interval has the right sign so that
* addition moves from fromValue to toValue.
*/
if ((scalePtr->tickInterval < 0)
^ ((scalePtr->toValue - scalePtr->fromValue) < 0)) {
scalePtr->tickInterval = -scalePtr->tickInterval;
}
ComputeFormat(scalePtr);
scalePtr->labelLength = scalePtr->label ? (int)strlen(scalePtr->label) : 0;
Tk_SetBackgroundFromBorder(scalePtr->tkwin, scalePtr->bgBorder);
if (scalePtr->highlightWidth < 0) {
scalePtr->highlightWidth = 0;
}
scalePtr->inset = scalePtr->highlightWidth + scalePtr->borderWidth;
break;
}
if (!error) {
Tk_FreeSavedOptions(&savedOptions);
}
/*
* Set the scale value to itself; all this does is to make sure that the
* scale's value is within the new acceptable range for the scale. We
* don't set the var here because we need to make special checks for
* possibly changed varNamePtr.
*/
TkScaleSetValue(scalePtr, scalePtr->value, 0, 1);
/*
* Reestablish the variable trace, if it is needed.
*/
if (scalePtr->varNamePtr != NULL) {
Tcl_Obj *valuePtr;
/*
* Set the associated variable only when the new value differs from
* the current value, or the variable doesn't yet exist.
*/
valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL,
TCL_GLOBAL_ONLY);
if ((valuePtr == NULL) || (Tcl_GetDoubleFromObj(NULL,
valuePtr, &varValue) != TCL_OK)) {
ScaleSetVariable(scalePtr);
} else {
char varString[TCL_DOUBLE_SPACE], scaleString[TCL_DOUBLE_SPACE];
sprintf(varString, scalePtr->format, varValue);
sprintf(scaleString, scalePtr->format, scalePtr->value);
if (strcmp(varString, scaleString)) {
ScaleSetVariable(scalePtr);
}
}
Tcl_TraceVar(interp, Tcl_GetString(scalePtr->varNamePtr),
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
ScaleVarProc, scalePtr);
}
ScaleWorldChanged(scalePtr);
if (error) {
Tcl_SetObjResult(interp, errorResult);
Tcl_DecrRefCount(errorResult);
return TCL_ERROR;
}
return TCL_OK;
}
static int
wlog_get_publishlog_lines(Tcl_Interp *interpreter, int fd,
uint32 start, uint32 end, Tcl_Obj **ret_list)
{
Tcl_Obj *list = NULL;
Tcl_Obj *line_obj = NULL;
tstring *line_buf = NULL;
char buf[wlog_log_buf_size];
uint32 cur_line = 0;
uint32 seg_start = 0;
uint32 i = 0;
int count = 0;
int err = 0;
char *cp;
bail_null(ret_list);
list = Tcl_NewListObj(0, NULL);
bail_null(list);
do {
if (cur_line + 1 >= end) {
break;
}
errno = 0;
count = read(fd, buf, wlog_log_buf_size);
if (count == -1 && errno == EINTR) {
continue;
}
bail_require_errno(count >= 0, I_("Reading log file '%s'"),
file_publishlog_path);
while (( cp = memchr(buf, '\0' , count )) != NULL )
*cp = ' ';
while (( cp = memchr(buf, '<' , count )) != NULL )
*cp = '[';
while (( cp = memchr(buf, '>' , count )) != NULL )
*cp = ']';
/* look for a newline inside the buffer */
seg_start = 0;
for (i = 0; i < (uint32)count; ++i) {
if (buf[i] == '\n') {
if (cur_line + 1 >= start && cur_line + 1 < end) {
if (!line_buf) {
err = ts_new(&line_buf);
bail_error(err);
}
err = ts_append_str_frag(line_buf, buf, seg_start,
i - seg_start);
bail_error(err);
line_obj = Tcl_NewStringObj(ts_str(line_buf),
ts_length(line_buf));
bail_null(line_obj);
err = Tcl_ListObjAppendElement(interpreter, list,
line_obj);
bail_require(err == TCL_OK);
err = 0;
ts_free(&line_buf);
}
seg_start = i + 1;
++cur_line;
}
}
if (seg_start < (uint32)count) {
if (cur_line + 1 >= start && cur_line + 1 < end) {
if (!line_buf) {
err = ts_new(&line_buf);
bail_error(err);
}
err = ts_append_str_frag(line_buf, buf, seg_start,
(uint32)count - seg_start);
bail_error(err);
}
}
} while (count > 0);
*ret_list = list;
list = NULL;
bail:
if (list) {
Tcl_DecrRefCount(list);
}
ts_free(&line_buf);
return(err);
}
/*
* putchan_raw <server_tag> <#chan> <text>
* Use this instead of putserv so that can see own message
*
* "raw" because putchan in Tcl will do some string fixing on text
*
* all command parameters should be using unicode (internal) encoding.
*/
int
putchan_raw(ClientData clientData, Tcl_Interp* interp, int objc,
Tcl_Obj* const objv[])
{
(void) clientData;
if (objc != 4) {
Tcl_Obj* str = Tcl_ObjPrintf("wrong # args: should be \"putchan_raw"
" server_tag channel text\"");
Tcl_SetObjResult(interp, str);
return TCL_ERROR;
}
Tcl_Obj* const server_tag = objv[1];
Tcl_Obj* const target = objv[2];
Tcl_Obj* const msg = objv[3];
// find the server in Irssi.
SERVER_REC* server_rec = server_find_tag(Tcl_GetString(server_tag));
if (server_rec == NULL) {
Tcl_Obj* str = Tcl_ObjPrintf("server with tag '%s' not found",
Tcl_GetString(server_tag));
Tcl_SetObjResult(interp, str);
return TCL_ERROR;
}
// find the channel on this server in Irssi.
CHANNEL_REC* channel_rec = channel_find(server_rec, Tcl_GetString(target));
if (channel_rec == NULL) {
Tcl_Obj* str = Tcl_ObjPrintf("channel '%s' not found on server '%s'",
Tcl_GetString(target), Tcl_GetString(server_tag));
Tcl_SetObjResult(interp, str);
return TCL_ERROR;
}
// create the full command string to send to the IRC server.
// PRIVMSG <target> :<msg>
// this is how we used to create the command but I am concerned it
// is not dealing with encoding correctly.
//Tcl_Obj* send_str = Tcl_ObjPrintf("PRIVMSG %s :%s", target, msg);
// try to be more careful with how we build the string.
// -1 means take everything up to first NULL.
Tcl_Obj* send_str = Tcl_NewStringObj("PRIVMSG ", -1);
if (!send_str) {
return TCL_ERROR;
}
Tcl_AppendObjToObj(send_str, target);
Tcl_AppendToObj(send_str, " :", strlen(" :"));
Tcl_AppendObjToObj(send_str, msg);
// send the command to the server.
// from ByteArrObj docs:
// "Obtaining the string representation of a byte-array object (by calling Tcl_GetStringFromObj) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the UTF-8 characters in the string representation."
irc_send_cmd((IRC_SERVER_REC*) server_rec, Tcl_GetString(send_str));
// this frees the object. unsure if I actually need to call this, but it
// seems like it doesn't matter if I do!
Tcl_DecrRefCount(send_str);
// write the message to Irssi so we see it ourselves.
print_message_public(server_rec, channel_rec, Tcl_GetString(target),
server_rec->nick, NULL, Tcl_GetString(msg));
//signal_emit("message own_public", 3, server, text, chan);
return TCL_OK;
}
static int
HandleTclCommand(
ClientData clientData, /* Information about command to execute. */
int offset, /* Return selection bytes starting at this
* offset. */
char *buffer, /* Place to store converted selection. */
int maxBytes) /* Maximum # of bytes to store at buffer. */
{
CommandInfo *cmdInfoPtr = clientData;
int length;
Tcl_Obj *command;
const char *string;
Tcl_Interp *interp = cmdInfoPtr->interp;
Tcl_InterpState savedState;
int extraBytes, charOffset, count, numChars, code;
const char *p;
/*
* We must also protect the interpreter and the command from being deleted
* too soon.
*/
Tcl_Preserve(clientData);
Tcl_Preserve(interp);
/*
* Compute the proper byte offset in the case where the last chunk split a
* character.
*/
if (offset == cmdInfoPtr->byteOffset) {
charOffset = cmdInfoPtr->charOffset;
extraBytes = strlen(cmdInfoPtr->buffer);
if (extraBytes > 0) {
strcpy(buffer, cmdInfoPtr->buffer);
maxBytes -= extraBytes;
buffer += extraBytes;
}
} else {
cmdInfoPtr->byteOffset = 0;
cmdInfoPtr->charOffset = 0;
extraBytes = 0;
charOffset = 0;
}
/*
* First, generate a command by taking the command string and appending
* the offset and maximum # of bytes.
*/
command = Tcl_ObjPrintf("%s %d %d",
cmdInfoPtr->command, charOffset, maxBytes);
Tcl_IncrRefCount(command);
/*
* Execute the command. Be sure to restore the state of the interpreter
* after executing the command.
*/
savedState = Tcl_SaveInterpState(interp, TCL_OK);
code = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(command);
if (code == TCL_OK) {
/*
* TODO: This assumes that bytes are characters; that's not true!
*/
string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
count = (length > maxBytes) ? maxBytes : length;
memcpy(buffer, string, (size_t) count);
buffer[count] = '\0';
/*
* Update the partial character information for the next retrieval if
* the command has not been deleted.
*/
if (cmdInfoPtr->interp != NULL) {
if (length <= maxBytes) {
cmdInfoPtr->charOffset += Tcl_NumUtfChars(string, -1);
cmdInfoPtr->buffer[0] = '\0';
} else {
p = string;
string += count;
numChars = 0;
while (p < string) {
p = Tcl_UtfNext(p);
numChars++;
}
cmdInfoPtr->charOffset += numChars;
length = p - string;
if (length > 0) {
strncpy(cmdInfoPtr->buffer, string, (size_t) length);
}
cmdInfoPtr->buffer[length] = '\0';
}
cmdInfoPtr->byteOffset += count + extraBytes;
}
count += extraBytes;
} else {
/*
* Something went wrong. Log errors as background errors, and silently
* drop everything else.
*/
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (command handling selection)");
Tcl_BackgroundException(interp, code);
}
count = -1;
}
(void) Tcl_RestoreInterpState(interp, savedState);
Tcl_Release(clientData);
Tcl_Release(interp);
return count;
}
static int
TextToPostscript(
Tcl_Interp *interp, /* Leave Postscript or error message here. */
Tk_Canvas canvas, /* Information about overall canvas. */
Tk_Item *itemPtr, /* Item for which Postscript is wanted. */
int prepass) /* 1 means this is a prepass to collect font
* information; 0 means final Postscript is
* being created. */
{
TextItem *textPtr = (TextItem *) itemPtr;
double x, y;
Tk_FontMetrics fm;
const char *justify;
XColor *color;
Pixmap stipple;
Tk_State state = itemPtr->state;
Tcl_Obj *psObj;
Tcl_InterpState interpState;
if (state == TK_STATE_NULL) {
state = Canvas(canvas)->canvas_state;
}
color = textPtr->color;
stipple = textPtr->stipple;
if (state == TK_STATE_HIDDEN || textPtr->color == NULL ||
textPtr->text == NULL || *textPtr->text == 0) {
return TCL_OK;
} else if (Canvas(canvas)->currentItemPtr == itemPtr) {
if (textPtr->activeColor != NULL) {
color = textPtr->activeColor;
}
if (textPtr->activeStipple != None) {
stipple = textPtr->activeStipple;
}
} else if (state == TK_STATE_DISABLED) {
if (textPtr->disabledColor != NULL) {
color = textPtr->disabledColor;
}
if (textPtr->disabledStipple != None) {
stipple = textPtr->disabledStipple;
}
}
/*
* Make our working space.
*/
psObj = Tcl_NewObj();
interpState = Tcl_SaveInterpState(interp, TCL_OK);
/*
* Generate postscript.
*/
Tcl_ResetResult(interp);
if (Tk_CanvasPsFont(interp, canvas, textPtr->tkfont) != TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
if (prepass != 0) {
goto done;
}
Tcl_ResetResult(interp);
if (Tk_CanvasPsColor(interp, canvas, color) != TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
if (stipple != None) {
Tcl_ResetResult(interp);
Tk_CanvasPsStipple(interp, canvas, stipple);
Tcl_AppendPrintfToObj(psObj, "/StippleText {\n %s} bind def\n",
Tcl_GetString(Tcl_GetObjResult(interp)));
}
x = 0; y = 0; justify = NULL; /* lint. */
switch (textPtr->anchor) {
case TK_ANCHOR_NW: x = 0; y = 0; break;
case TK_ANCHOR_N: x = 1; y = 0; break;
case TK_ANCHOR_NE: x = 2; y = 0; break;
case TK_ANCHOR_E: x = 2; y = 1; break;
case TK_ANCHOR_SE: x = 2; y = 2; break;
case TK_ANCHOR_S: x = 1; y = 2; break;
case TK_ANCHOR_SW: x = 0; y = 2; break;
case TK_ANCHOR_W: x = 0; y = 1; break;
case TK_ANCHOR_CENTER: x = 1; y = 1; break;
}
switch (textPtr->justify) {
case TK_JUSTIFY_LEFT: justify = "0"; break;
case TK_JUSTIFY_CENTER: justify = "0.5"; break;
case TK_JUSTIFY_RIGHT: justify = "1"; break;
}
Tk_GetFontMetrics(textPtr->tkfont, &fm);
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g [\n",
textPtr->angle, textPtr->x, Tk_CanvasPsY(canvas, textPtr->y));
Tcl_ResetResult(interp);
Tk_TextLayoutToPostscript(interp, textPtr->textLayout);
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
Tcl_AppendPrintfToObj(psObj,
"] %d %g %g %s %s DrawText\n",
fm.linespace, x / -2.0, y / 2.0, justify,
((stipple == None) ? "false" : "true"));
/*
* Plug the accumulated postscript back into the result.
*/
done:
(void) Tcl_RestoreInterpState(interp, interpState);
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
return TCL_OK;
error:
Tcl_DiscardInterpState(interpState);
Tcl_DecrRefCount(psObj);
return TCL_ERROR;
}
