int
Tcl_RecordAndEvalObj(
Tcl_Interp *interp, /* Token for interpreter in which command will
* be executed. */
Tcl_Obj *cmdPtr, /* Points to object holding the command to
* record and execute. */
int flags) /* Additional flags. TCL_NO_EVAL means record
* only: don't execute the command.
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
histObjsPtr = (HistoryObjs *) ckalloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
Tcl_IncrRefCount(histObjsPtr->addObj);
Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs,
histObjsPtr);
}
/*
* Do not call [history] if it has been replaced by an empty proc
*/
result = Tcl_GetCommandInfo(interp, "::history", &info);
if (result && (info.deleteProc == TclProcDeleteProc)) {
Proc *procPtr = (Proc *) info.objClientData;
call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
}
if (call) {
Tcl_Obj *list[3];
/*
* Do recording by eval'ing a tcl history command: history add $cmd.
*/
list[0] = histObjsPtr->historyObj;
list[1] = histObjsPtr->addObj;
list[2] = cmdPtr;
Tcl_IncrRefCount(cmdPtr);
(void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdPtr);
/*
* One possible failure mode above: exceeding a resource limit.
*/
if (Tcl_LimitExceeded(interp)) {
return TCL_ERROR;
}
}
/*
* Execute the command.
*/
result = TCL_OK;
if (!(flags & TCL_NO_EVAL)) {
result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL);
}
return result;
}
int
paxwidget_cmd(ClientData data, Tcl_Interp * interp, int argc, char** argv)
{
Tk_Window tkmain = (Tk_Window) data;
Tk_Window tkwin;
PaxWidget * paxwidget;
char * class_name = NULL;
int i;
if (argc < 2)
{
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " pathName ?options?\"", (char *) NULL);
return TCL_ERROR;
}
/* look for the -class option */
for (i = 2; i < argc; i += 2)
{
int length;
char c;
char * arg;
arg = argv[i];
length = strlen(arg);
if (length < 2)
continue;
c = arg[1];
if ((c == 'c') && (strncmp(arg, "-class", strlen(arg)) == 0)
&& (length >= 3))
{
if (i < argc - 1)
class_name = argv[i+1];
else
fprintf(stderr,
"No argument for -class option, using defaults");
}
}
tkwin = Tk_CreateWindowFromPath(interp, tkmain, argv[1], (char*)NULL);
if (tkwin == NULL)
{
return TCL_ERROR;
}
if (class_name)
Tk_SetClass(tkwin, class_name);
else
Tk_SetClass(tkwin, "PaxWidget");
paxwidget = (PaxWidget*) ckalloc(sizeof(PaxWidget));
if (!paxwidget)
return TCL_ERROR;
paxwidget->tkwin = tkwin;
paxwidget->display = Tk_Display(tkwin);
paxwidget->interp = interp;
paxwidget->widget_cmd = Tcl_CreateCommand(interp, Tk_PathName(tkwin),
paxwidget_widget_cmd,
(ClientData) paxwidget, NULL);
paxwidget->obj = NULL;
paxwidget->width = paxwidget->height = 0;
paxwidget->background = NULL;
paxwidget->background_inited = 0;
paxwidget->cursor = None;
paxwidget->class_name = NULL;
paxwidget->update_pending = 0;
paxwidget->exposed_region = XCreateRegion();
Tk_CreateEventHandler(paxwidget->tkwin, ExposureMask|StructureNotifyMask,
PaxWidgetEventProc, (ClientData) paxwidget);
if (PaxWidgetConfigure(interp, paxwidget, argc - 2, argv + 2, 0) != TCL_OK)
{
Tk_DestroyWindow(paxwidget->tkwin);
return TCL_ERROR;
}
Tcl_SetResult(interp, Tk_PathName(paxwidget->tkwin), TCL_VOLATILE);
return TCL_OK;
}
/*++
Alcoext_Init
Initialises the extension for a regular interpreter.
Arguments:
interp - Current interpreter.
Return Value:
A standard Tcl result.
--*/
int
Alcoext_Init(
Tcl_Interp *interp
)
{
int i;
ExtState *state;
Tcl_CmdInfo cmdInfo;
DebugPrint("Init: interp=%p\n", interp);
// Wide integer support was added in Tcl 8.4.
if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION) != TCL_OK) {
return TCL_ERROR;
}
Initialise();
// Allocate state structure.
state = (ExtState *)ckalloc(sizeof(ExtState));
memset(state, 0, sizeof(ExtState));
state->interp = interp;
state->cryptTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(state->cryptTable, TCL_STRING_KEYS);
#ifndef _WINDOWS
state->glftpdTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(state->glftpdTable, TCL_STRING_KEYS);
#endif
Tcl_MutexLock(&stateListMutex);
// Insert at the list head.
if (stateHead == NULL) {
stateHead = state;
} else {
state->next = stateHead;
stateHead->prev = state;
stateHead = state;
}
Tcl_MutexUnlock(&stateListMutex);
// Clean up state on interpreter deletion.
Tcl_CallWhenDeleted(interp, InterpDeleted, (ClientData)state);
// Create Tcl commands.
state->cmds[0] = Tcl_CreateObjCommand(interp, "compress", CompressObjCmd, NULL, CmdDeleted);
state->cmds[1] = Tcl_CreateObjCommand(interp, "crypt", CryptObjCmd, (ClientData)state, CmdDeleted);
state->cmds[2] = Tcl_CreateObjCommand(interp, "decode", EncodingObjCmd, (ClientData)decodeFuncts, CmdDeleted);
state->cmds[3] = Tcl_CreateObjCommand(interp, "encode", EncodingObjCmd, (ClientData)encodeFuncts, CmdDeleted);
//
// These commands are not created for safe interpreters because
// they interact with the file system and/or other processes.
//
if (!Tcl_IsSafe(interp)) {
state->cmds[4] = Tcl_CreateObjCommand(interp, "volume", VolumeObjCmd, NULL, CmdDeleted);
#ifdef _WINDOWS
state->cmds[5] = Tcl_CreateObjCommand(interp, "ioftpd", IoFtpdObjCmd, NULL, CmdDeleted);
#else
state->cmds[5] = Tcl_CreateObjCommand(interp, "glftpd", GlFtpdObjCmd, (ClientData)state, CmdDeleted);
#endif
}
// Pass the address of the command token to the deletion handler.
for (i = 0; i < ARRAYSIZE(state->cmds); i++) {
if (Tcl_GetCommandInfoFromToken(state->cmds[i], &cmdInfo)) {
cmdInfo.deleteData = (ClientData)&state->cmds[i];
Tcl_SetCommandInfoFromToken(state->cmds[i], &cmdInfo);
}
}
return TCL_OK;
}
/* copy_string ---------------------- save string s somewhere; return address */
char *copy_string(const char *s)
{
char *p = ckalloc(strlen(s)+1); /* +1 to hold '\0' */
return strcpy(p, s);
}
static void
TextInsert(
Tk_Canvas canvas, /* Canvas containing text item. */
Tk_Item *itemPtr, /* Text item to be modified. */
int index, /* Character index before which string is to
* be inserted. */
Tcl_Obj *obj) /* New characters to be inserted. */
{
TextItem *textPtr = (TextItem *) itemPtr;
int byteIndex, byteCount, charsAdded;
char *newStr, *text;
const char *string;
Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr;
string = Tcl_GetStringFromObj(obj, &byteCount);
text = textPtr->text;
if (index < 0) {
index = 0;
}
if (index > textPtr->numChars) {
index = textPtr->numChars;
}
byteIndex = Tcl_UtfAtIndex(text, index) - text;
byteCount = strlen(string);
if (byteCount == 0) {
return;
}
newStr = ckalloc(textPtr->numBytes + byteCount + 1);
memcpy(newStr, text, (size_t) byteIndex);
strcpy(newStr + byteIndex, string);
strcpy(newStr + byteIndex + byteCount, text + byteIndex);
ckfree(text);
textPtr->text = newStr;
charsAdded = Tcl_NumUtfChars(string, byteCount);
textPtr->numChars += charsAdded;
textPtr->numBytes += byteCount;
/*
* Inserting characters invalidates indices such as those for the
* selection and cursor. Update the indices appropriately.
*/
if (textInfoPtr->selItemPtr == itemPtr) {
if (textInfoPtr->selectFirst >= index) {
textInfoPtr->selectFirst += charsAdded;
}
if (textInfoPtr->selectLast >= index) {
textInfoPtr->selectLast += charsAdded;
}
if ((textInfoPtr->anchorItemPtr == itemPtr)
&& (textInfoPtr->selectAnchor >= index)) {
textInfoPtr->selectAnchor += charsAdded;
}
}
if (textPtr->insertPos >= index) {
textPtr->insertPos += charsAdded;
}
ComputeTextBbox(canvas, textPtr);
}
TkScale *
TkpCreateScale(
Tk_Window tkwin)
{
return ckalloc(sizeof(TkScale));
}
/* ckallocz -------------------- allocate space; zero fill; check for success */
void *ckallocz(size_t amount)
{
void *p = ckalloc(amount);
memset(p, 0, amount);
return p;
}
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
DWORD bytesWritten, timeout;
*errorCode = 0;
timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
/*
* The writer thread is blocked waiting for a write to complete
* and the channel is in non-blocking mode.
*/
errno = EAGAIN;
goto error;
}
/*
* Check for a background error on the last write.
*/
if (infoPtr->writeError) {
TclWinConvertError(infoPtr->writeError);
infoPtr->writeError = 0;
goto error;
}
if (infoPtr->flags & CONSOLE_ASYNC) {
/*
* The console is non-blocking, so copy the data into the output
* buffer and restart the writer thread.
*/
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
SetEvent(infoPtr->startWriter);
bytesWritten = toWrite;
} else {
/*
* In the blocking case, just try to write the buffer directly.
* This avoids an unnecessary copy.
*/
if (WriteConsole(infoPtr->handle, buf, toWrite, &bytesWritten,
NULL) == FALSE) {
TclWinConvertError(GetLastError());
goto error;
}
}
return bytesWritten;
error:
*errorCode = errno;
return -1;
}
static void
setargv(
int *argcPtr, /* Filled with number of argument strings. */
char ***argvPtr) /* Filled with argument strings (malloc'd). */
{
char *cmdLine, *p, *arg, *argSpace;
char **argv;
int argc, size, inquote, copy, slashes;
cmdLine = GetCommandLine(); /* INTL: BUG */
/*
* Precompute an overly pessimistic guess at the number of arguments in
* the command line by counting non-space spans.
*/
size = 2;
for (p = cmdLine; *p != '\0'; p++) {
if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
size++;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
}
}
argSpace = (char *) ckalloc(
(unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
argv = (char **) argSpace;
argSpace += size * sizeof(char *);
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
argv[argc] = arg = argSpace;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
inquote = 0;
slashes = 0;
while (1) {
copy = 1;
while (*p == '\\') {
slashes++;
p++;
}
if (*p == '"') {
if ((slashes & 1) == 0) {
copy = 0;
if ((inquote) && (p[1] == '"')) {
p++;
copy = 1;
} else {
inquote = !inquote;
}
}
slashes >>= 1;
}
while (slashes) {
*arg = '\\';
arg++;
slashes--;
}
if ((*p == '\0') || (!inquote &&
((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
break;
}
if (copy != 0) {
*arg = *p;
arg++;
}
p++;
}
*arg = '\0';
argSpace = arg + 1;
}
argv[argc] = NULL;
*argcPtr = argc;
*argvPtr = argv;
}
int
Tk_ImageObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
static const char *const imageOptions[] = {
"create", "delete", "height", "inuse", "names", "type", "types",
"width", NULL
};
enum options {
IMAGE_CREATE, IMAGE_DELETE, IMAGE_HEIGHT, IMAGE_INUSE, IMAGE_NAMES,
IMAGE_TYPE, IMAGE_TYPES, IMAGE_WIDTH
};
TkWindow *winPtr = clientData;
int i, isNew, firstOption, index;
Tk_ImageType *typePtr;
ImageMaster *masterPtr;
Image *imagePtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
char idString[16 + TCL_INTEGER_SPACE];
TkDisplay *dispPtr = winPtr->dispPtr;
char *arg, *name;
ThreadSpecificData *tsdPtr =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], imageOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case IMAGE_CREATE: {
Tcl_Obj **args;
int oldimage = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"type ?name? ?-option value ...?");
return TCL_ERROR;
}
/*
* Look up the image type.
*/
arg = Tcl_GetString(objv[2]);
for (typePtr = tsdPtr->imageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
if ((*arg == typePtr->name[0])
&& (strcmp(arg, typePtr->name) == 0)) {
break;
}
}
if (typePtr == NULL) {
oldimage = 1;
for (typePtr = tsdPtr->oldImageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
if ((*arg == typePtr->name[0])
&& (strcmp(arg, typePtr->name) == 0)) {
break;
}
}
}
if (typePtr == NULL) {
Tcl_AppendResult(interp, "image type \"", arg, "\" doesn't exist",
NULL);
return TCL_ERROR;
}
/*
* Figure out a name to use for the new image.
*/
if ((objc == 3) || (*(arg = Tcl_GetString(objv[3])) == '-')) {
Tcl_CmdInfo dummy;
do {
dispPtr->imageId++;
sprintf(idString, "image%d", dispPtr->imageId);
name = idString;
} while (Tcl_GetCommandInfo(interp, name, &dummy) != 0);
firstOption = 3;
} else {
TkWindow *topWin;
name = arg;
firstOption = 4;
/*
* Need to check if the _command_ that we are about to create is
* the name of the current master widget command (normally "." but
* could have been renamed) and fail in that case before a really
* nasty and hard to stop crash happens.
*/
topWin = (TkWindow *) TkToplevelWindowForCommand(interp, name);
if (topWin != NULL && winPtr->mainPtr->winPtr == topWin) {
Tcl_AppendResult(interp, "images may not be named the ",
"same as the main window", NULL);
return TCL_ERROR;
}
}
/*
* Create the data structure for the new image.
*/
hPtr = Tcl_CreateHashEntry(&winPtr->mainPtr->imageTable, name, &isNew);
if (isNew) {
masterPtr = (ImageMaster *) ckalloc(sizeof(ImageMaster));
masterPtr->typePtr = NULL;
masterPtr->masterData = NULL;
masterPtr->width = masterPtr->height = 1;
masterPtr->tablePtr = &winPtr->mainPtr->imageTable;
masterPtr->hPtr = hPtr;
masterPtr->instancePtr = NULL;
masterPtr->deleted = 0;
masterPtr->winPtr = winPtr->mainPtr->winPtr;
Tcl_Preserve(masterPtr->winPtr);
Tcl_SetHashValue(hPtr, masterPtr);
} else {
/*
* An image already exists by this name. Disconnect the instances
* from the master.
*/
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->typePtr != NULL) {
for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
imagePtr = imagePtr->nextPtr) {
masterPtr->typePtr->freeProc(imagePtr->instanceData,
imagePtr->display);
imagePtr->changeProc(imagePtr->widgetClientData, 0, 0,
masterPtr->width, masterPtr->height,
masterPtr->width, masterPtr->height);
}
masterPtr->typePtr->deleteProc(masterPtr->masterData);
masterPtr->typePtr = NULL;
}
masterPtr->deleted = 0;
}
/*
* Call the image type manager so that it can perform its own
* initialization, then re-"get" for any existing instances of the
* image.
*/
objv += firstOption;
objc -= firstOption;
args = (Tcl_Obj **) objv;
if (oldimage) {
int i;
args = (Tcl_Obj **) ckalloc((objc+1) * sizeof(char *));
for (i = 0; i < objc; i++) {
args[i] = (Tcl_Obj *) Tcl_GetString(objv[i]);
}
args[objc] = NULL;
}
Tcl_Preserve(masterPtr);
if (typePtr->createProc(interp, name, objc, args, typePtr,
(Tk_ImageMaster)masterPtr, &masterPtr->masterData) != TCL_OK){
EventuallyDeleteImage(masterPtr, 0);
Tcl_Release(masterPtr);
if (oldimage) {
ckfree((char *) args);
}
return TCL_ERROR;
}
Tcl_Release(masterPtr);
if (oldimage) {
ckfree((char *) args);
}
masterPtr->typePtr = typePtr;
for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
imagePtr = imagePtr->nextPtr) {
imagePtr->instanceData = typePtr->getProc(imagePtr->tkwin,
masterPtr->masterData);
}
Tcl_SetResult(interp,
Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr),
TCL_STATIC);
break;
}
case IMAGE_DELETE:
for (i = 2; i < objc; i++) {
arg = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg);
if (hPtr == NULL) {
goto alreadyDeleted;
}
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
goto alreadyDeleted;
}
DeleteImage(masterPtr);
}
break;
case IMAGE_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
continue;
}
Tcl_AppendElement(interp, Tcl_GetHashKey(
&winPtr->mainPtr->imageTable, hPtr));
}
break;
case IMAGE_TYPES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
for (typePtr = tsdPtr->imageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
Tcl_AppendElement(interp, typePtr->name);
}
for (typePtr = tsdPtr->oldImageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
Tcl_AppendElement(interp, typePtr->name);
}
break;
case IMAGE_HEIGHT:
case IMAGE_INUSE:
case IMAGE_TYPE:
case IMAGE_WIDTH:
/*
* These operations all parse virtually identically. First check to
* see if three args are given. Then get a non-deleted master from the
* third arg.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
arg = Tcl_GetString(objv[2]);
hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg);
if (hPtr == NULL) {
goto alreadyDeleted;
}
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
goto alreadyDeleted;
}
/*
* Now we read off the specific piece of data we were asked for.
*/
switch ((enum options) index) {
case IMAGE_HEIGHT:
Tcl_SetObjResult(interp, Tcl_NewIntObj(masterPtr->height));
break;
case IMAGE_INUSE:
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
masterPtr->typePtr && masterPtr->instancePtr));
break;
case IMAGE_TYPE:
if (masterPtr->typePtr != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(masterPtr->typePtr->name, -1));
}
break;
case IMAGE_WIDTH:
Tcl_SetObjResult(interp, Tcl_NewIntObj(masterPtr->width));
break;
default:
Tcl_Panic("can't happen");
}
break;
}
return TCL_OK;
alreadyDeleted:
Tcl_AppendResult(interp, "image \"", arg, "\" doesn't exist", NULL);
return TCL_ERROR;
}
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);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
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);
}
void conv_td_reg(struct DotList *dots, int num, int id, int *t_list, int num_tandem, struct DotList *init_dots, int flag, int *val1, int *val2, int *val_org)
{
int i;
int cur_id, cmp_id;
struct DotList t1, t2;
struct DotList *cur_t;
int len_x, len_y;
int cur_len = 0;
int val_t1, val_t2, val_org_reg;
int init_id;
cur_t = (struct DotList *) ckalloc(sizeof(struct DotList));
for( i = 0; i < num_tandem; i++ )
{
if( flag == FIRST_RUN ) {
val_org_reg = -1;
val_t1 = -1;
val_t2 = -1;
}
else {
val_org_reg = val_org[i];
val_t1 = val1[i];
val_t2 = val2[i];
}
t1.x = assign_I(-1, 0);
t2.x = assign_I(-1, 0);
t1.y = assign_I(-1, 0);
t2.y = assign_I(-1, 0);
cmp_id = t_list[i];
if( i == 0 ) cur_id = id;
else cur_id = t_list[i-1];
if( dots[cmp_id].ctg_id1 != dots[cur_id].ctg_id1 ) {
fatalf("error: handling alignments from different contigs %s vs %s in handling_tandem_duplications.c\n", dots[cmp_id].name1, dots[cur_id].name1);
}
if( dots[cmp_id].ctg_id2 != dots[cur_id].ctg_id2 ) {
fatalf("error: handling alignments from different contigs %s vs %s in handling_tandem_duplications.c\n", dots[cmp_id].name2, dots[cur_id].name2);
}
if( ( strict_almost_equal( dots[cmp_id].x, dots[cur_id].x ) == true ) || ( strict_almost_equal( dots[cmp_id].y, dots[cur_id].y) == true ) ) {}
else if( ( strict_subset( dots[cmp_id].x, dots[cur_id].x ) == true ) && ( strict_subset( dots[cmp_id].y, dots[cur_id].y ) == true ) )
{
if( abs(dots[cur_id].x.upper - dots[cmp_id].x.upper) > abs(dots[cur_id].x.lower - dots[cmp_id].x.lower) )
{
if( ( dots[cur_id].x.upper - dots[cmp_id].x.upper ) <= 0 ) t1.x = assign_I(-1, 0);
else
{
len_x = width(dots[cur_id].x);
len_y = width(dots[cur_id].y);
t1.x = assign_I(dots[cmp_id].x.upper, dots[cur_id].x.upper);
cur_len = (int)(((float)(width(t1.x)) * ((float)len_y)/(float)len_x));
t1.y = assign_I(dots[cur_id].x.upper, dots[cur_id].x.upper + cur_len);
}
}
else
{
if( ( dots[cur_id].x.lower - dots[cmp_id].x.lower ) >= 0 ) t1.x = assign_I(-1, 0);
else
{
len_x = width(dots[cur_id].x);
len_y = width(dots[cur_id].y);
t1.x = assign_I(dots[cur_id].x.lower, dots[cmp_id].x.lower);
cur_len = (int)(((float)(width(t1.x)) * ((float)len_y)/(float)len_x));
t1.y = assign_I(dots[cmp_id].x.lower, dots[cmp_id].x.lower + cur_len);
}
}
if( abs(dots[cmp_id].y.lower - dots[cur_id].y.lower) > abs(dots[cur_id].y.upper - dots[cmp_id].y.upper) )
{
if( ( dots[cmp_id].y.lower - dots[cur_id].y.lower ) <= 0 ) t2.x = assign_I(-1, 0);
else
{
len_x = width(dots[cur_id].x);
len_y = width(dots[cur_id].y);
t2.y = assign_I(dots[cur_id].y.lower, dots[cmp_id].y.lower);
cur_len = (int)(((float)(width(t2.y)) * ((float)len_x)/(float)len_y));
t2.x = assign_I(dots[cur_id].y.lower - cur_len, dots[cur_id].y.lower);
}
}
else
{
if( ( dots[cur_id].y.upper - dots[cmp_id].y.upper ) <= 0 ) t2.x = assign_I(-1, 0);
else
{
len_x = width(dots[cur_id].x);
len_y = width(dots[cur_id].y);
t2.y = assign_I(dots[cmp_id].y.upper, dots[cur_id].y.upper);
cur_len = (int)(((float)(width(t2.y)) * ((float)len_x)/(float)len_y));
t2.x = assign_I(dots[cmp_id].y.upper - cur_len, dots[cmp_id].y.upper);
}
}
}
val_org_reg = -1;
if( !proper_overlap(dots[cur_id].x, dots[cur_id].y) ) {
val_org_reg = STRICT;
val_org_reg = check_tandem_reg( dots[cur_id], dots, num );
}
if( flag == FIRST_RUN ) {
if( (t1.x.lower >= 0) && (t1.y.lower >= 0) ) {
val_t1 = check_tandem_reg( t1, dots, num );
}
else val_t1 = -1;
if( (t2.x.lower >= 0) && (t2.y.lower >= 0)) {
val_t2 = check_tandem_reg( t2, dots, num );
}
else val_t2 = -1;
if( (val_t1 == -1) && (val_t2 == -1) ) {
if( t1.x.lower >= 0 ) val_t1 = LOOSE;
else if( t2.x.lower >= 0 ) val_t2 = LOOSE;
}
val_org[i] = val_org_reg;
val1[i] = val_t1;
val2[i] = val_t2;
}
if( val_org_reg != -1 ) {}
else if( (val_t1 != -1) && (val_t2 != -1) && (t1.x.lower >= 0) && (t1.y.lower >= 0) && (t2.x.lower >= 0) && (t2.y.lower >= 0))
{
if( val_t1 <= val_t2 )
{
init_id = dots[cur_id].index;
if( (flag == FIRST_RUN) && (init_dots[init_id].c_id == -1) && (init_dots[init_id].m_id == -1) ) {
// in order to get the original boundaries, offsets defined here should be just substrated.
adjust_init_offset(init_dots, init_id, t1, dots, cur_id);
}
dots[cur_id].x = assign_I(t1.x.lower, t1.x.upper);
dots[cur_id].y = assign_I(t1.y.lower, t1.y.upper);
dots[cur_id].rp1_id = 0;
}
else
{
init_id = dots[cur_id].index;
if( (flag == FIRST_RUN) && (init_dots[init_id].c_id == -1) && (init_dots[init_id].m_id == -1) ) {
adjust_init_offset(init_dots, init_id, t2, dots, cur_id);
}
dots[cur_id].x = assign_I(t2.x.lower, t2.x.upper);
dots[cur_id].y = assign_I(t2.y.lower, t2.y.upper);
dots[cur_id].rp1_id = 0;
init_id = dots[cur_id].index;
}
}
else if( (val_t1 != -1) && (t1.x.lower >= 0) && (t1.y.lower >= 0))
{
init_id = dots[cur_id].index;
if( (flag == FIRST_RUN) && (init_dots[init_id].c_id == -1) && (init_dots[init_id].m_id == -1) ) {
// in order to reflect the change of the boundaries, offsets defined here should be just added.
adjust_init_offset(init_dots, init_id, t1, dots, cur_id);
}
dots[cur_id].x = assign_I(t1.x.lower, t1.x.upper);
dots[cur_id].y = assign_I(t1.y.lower, t1.y.upper);
dots[cur_id].rp1_id = 0;
init_id = dots[cur_id].index;
}
else if( (val_t2 != -1) && (t2.x.lower >= 0) && (t2.y.lower >= 0))
{
init_id = dots[cur_id].index;
if( (flag == FIRST_RUN) && (init_dots[init_id].c_id == -1) && (init_dots[init_id].m_id == -1) ) {
adjust_init_offset(init_dots, init_id, t2, dots, cur_id);
}
dots[cur_id].x = assign_I(t2.x.lower, t2.x.upper);
dots[cur_id].y = assign_I(t2.y.lower, t2.y.upper);
dots[cur_id].rp1_id = 0;
init_id = dots[cur_id].index;
}
}
val_org_reg = -1;
cmp_id = t_list[num_tandem-1];
len_x = width(dots[cmp_id].x);
len_y = width(dots[cmp_id].y);
if( proper_overlap(dots[cmp_id].x, dots[cmp_id].y) ) {
t1.x = assign_I(dots[cmp_id].x.lower, dots[cmp_id].x.lower + (dots[cmp_id].y.upper - dots[cmp_id].x.lower)/2);
t1.y = assign_I(dots[cmp_id].x.lower, dots[cmp_id].x.lower + (dots[cmp_id].y.upper - dots[cmp_id].x.lower)/2);
}
else {
val_org_reg = STRICT;
t1.x = assign_I(dots[cmp_id].x.lower, dots[cmp_id].x.upper);
t1.y = assign_I(dots[cmp_id].y.lower, dots[cmp_id].y.upper);
}
cur_len = (int)(((float)(width(t1.x)) * ((float)len_y)/(float)len_x));
t1.y = assign_I(t1.x.upper, t1.x.upper + cur_len);
if( t2.y.lower != -1 ) {
cur_len = (int)(((float)(width(t2.y)) * ((float)len_x)/(float)len_y));
t2.x = assign_I(t2.y.lower - cur_len, t2.y.lower);
}
else t2.x = assign_I(-1,0);
if( flag == FIRST_RUN ) {
if( val_org_reg != -1 ) val_org_reg = check_tandem_reg(dots[cmp_id], dots, num);
if( (t1.x.lower >= 0) && (t1.y.lower >= 0) ) val_t1 = check_tandem_reg(t1, dots, num);
else val_t1 = -1;
if( (t2.x.lower < 0) || (t2.y.lower < 0) ) val_t2 = -1;
else val_t2 = check_tandem_reg(t2, dots, num);
val_org[num_tandem] = val_org_reg;
val1[num_tandem] = val_t1;
val2[num_tandem] = val_t2;
}
else {
val_org_reg = val_org[num_tandem];
val_t1 = val1[num_tandem];
val_t2 = val2[num_tandem];
}
if( (t1.x.lower < 0) && (t1.y.lower < 0) ) val_t1 = -1;
if( (t2.x.lower < 0) && (t2.y.lower < 0) ) val_t2 = -1;
if( val_org_reg != -1 ) {}
else if( (val_t1 != -1) && (val_t2 != -1) ) {
if( val_t1 < val_t2 ) {
assign_algn(cur_t, 0, t1);
}
else assign_algn(cur_t, 0, t2);
}
else if( val_t1 != -1 ) assign_algn(cur_t, 0, t1);
else if( val_t2 != -1 ) assign_algn(cur_t, 0, t2);
if( val_org_reg != -1 ) {}
else if( (val_t1 != -1) || (val_t2 != -1) ) {
init_id = dots[cmp_id].index;
if( (flag == FIRST_RUN) && (init_dots[init_id].c_id == -1) && (init_dots[init_id].m_id == -1) ) {
// in order to reflect the change of the boundaries, offsets defined here should be just added.
adjust_init_offset(init_dots, init_id, *cur_t, dots, cmp_id);
}
dots[cmp_id].x = assign_I((*cur_t).x.lower, (*cur_t).x.upper);
dots[cmp_id].y = assign_I((*cur_t).y.lower, (*cur_t).y.upper);
dots[cmp_id].rp1_id = 0;
}
free(cur_t);
}
void handle_tandem_dup(struct DotList *dots, int *num, struct DotList *init_dots)
{
struct slist *sorted;
int i = 0;
int cur_id = 0;
struct DotList *self;
int count = 0;
int j = 0;
int temp = 0;
int num_lines;
int *t_list; // a list of tandem dups
int *cur_tlist;
int *val1, *val2, *val_org;
int num_tandem = 0;
for( i = 0; i < *num; i++ )
{
if( dots[i].pair_self == SELF )
count++;
}
if( count > 0 ) {
self = (struct DotList *) ckalloc(count * (sizeof(struct DotList)));
sorted = (struct slist *) ckalloc(count * (sizeof(struct slist)));
t_list = (int *) ckalloc(count * (sizeof(int)));
cur_tlist = (int *) ckalloc(count * (sizeof(int)));
val1 = (int *) ckalloc(count * (sizeof(int)));
val2 = (int *) ckalloc(count * (sizeof(int)));
val_org = (int *) ckalloc(count * (sizeof(int)));
initialize_algns(self, 0, count);
initialize_slist(sorted, 0, count);
j = 0;
for( i = 0; i < *num; i++ )
{
if( dots[i].pair_self == SELF )
{
assign_algn(self, j, dots[i]);
self[j].c_id = i;
j++;
}
}
count = j;
num_lines = *num;
for( i = 0; i < count; i++ ) {
t_list[i] = 0;
cur_tlist[i] = 0;
val1[i] = -1;
val2[i] = -1;
val_org[i] = -1;
sorted[i].id = i;
}
sort_by_width(sorted, self, count);
for( i = 0; i < count; i++ )
{
cur_id = sorted[i].id;
if( (self[cur_id].sign == 2) || (self[cur_id].pair_self == PAIR) ) {}
else if( proper_overlap( self[cur_id].x, self[cur_id].y ) == true )
{
num_tandem = 0;
num_tandem = find_tandem_list(self, sorted, i, count, t_list);
if( num_tandem > 0 )
{
for( j = 0; j < num_tandem; j++ )
{
temp = t_list[j];
cur_tlist[j] = self[temp].c_id;
}
conv_td_reg(dots, num_lines, self[cur_id].c_id, cur_tlist, num_tandem, init_dots, FIRST_RUN, val1, val2, val_org);
conv_td_reg(self, count, cur_id, t_list, num_tandem, init_dots, SECOND_RUN, val1, val2, val_org);
}
}
}
free(val_org);
free(val1);
free(val2);
free(cur_tlist);
free(t_list);
free(sorted);
free(self);
}
}
TkCursor *
TkGetCursorByName(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tk_Window tkwin, /* Window in which cursor will be used. */
Tk_Uid string) /* Description of cursor. See manual entry for
* details on legal syntax. */
{
TkUnixCursor *cursorPtr = NULL;
Cursor cursor = None;
int argc;
const char **argv = NULL;
Display *display = Tk_Display(tkwin);
int inTkTable = 0;
const struct TkCursorName *tkCursorPtr = NULL;
if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) {
return NULL;
}
if (argc == 0) {
goto badString;
}
/*
* Check Tk specific table of cursor names. The cursor names don't overlap
* with cursors defined in the X table so search order does not matter.
*/
if (argv[0][0] != '@') {
for (tkCursorPtr = tkCursorNames; ; tkCursorPtr++) {
if (tkCursorPtr->name == NULL) {
tkCursorPtr = NULL;
break;
}
if ((tkCursorPtr->name[0] == argv[0][0]) &&
(strcmp(tkCursorPtr->name, argv[0]) == 0)) {
inTkTable = 1;
break;
}
}
}
if ((argv[0][0] != '@') && !inTkTable) {
XColor fg, bg;
unsigned int maskIndex;
register const struct CursorName *namePtr;
TkDisplay *dispPtr;
/*
* The cursor is to come from the standard cursor font. If one arg, it
* is cursor name (use black and white for fg and bg). If two args,
* they are name and fg color (ignore mask). If three args, they are
* name, fg, bg. Some of the code below is stolen from the
* XCreateFontCursor Xlib function.
*/
if (argc > 3) {
goto badString;
}
for (namePtr = cursorNames; ; namePtr++) {
if (namePtr->name == NULL) {
goto badString;
}
if ((namePtr->name[0] == argv[0][0])
&& (strcmp(namePtr->name, argv[0]) == 0)) {
break;
}
}
maskIndex = namePtr->shape + 1;
if (argc == 1) {
fg.red = fg.green = fg.blue = 0;
bg.red = bg.green = bg.blue = 65535;
} else {
if (TkParseColor(display, Tk_Colormap(tkwin), argv[1], &fg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", argv[1]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
if (argc == 2) {
bg.red = bg.green = bg.blue = 0;
maskIndex = namePtr->shape;
} else if (TkParseColor(display, Tk_Colormap(tkwin), argv[2],
&bg) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid color name \"%s\"", argv[2]));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL);
goto cleanup;
}
}
dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (dispPtr->cursorFont == None) {
dispPtr->cursorFont = XLoadFont(display, CURSORFONT);
if (dispPtr->cursorFont == None) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't load cursor font", -1));
Tcl_SetErrorCode(interp, "TK", "CURSOR", "FONT", NULL);
goto cleanup;
}
}
cursor = XCreateGlyphCursor(display, dispPtr->cursorFont,
dispPtr->cursorFont, namePtr->shape, maskIndex,
&fg, &bg);
} else {
/*
* Prevent file system access in safe interpreters.
*/
if (!inTkTable && Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't get cursor from a file in a safe interpreter",
-1));
Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", NULL);
cursorPtr = NULL;
goto cleanup;
}
/*
* If the cursor is to be created from bitmap files, then there should
* be either two elements in the list (source, color) or four (source
* mask fg bg). A cursor defined in the Tk table accepts the same
* arguments as an X cursor.
*/
if (inTkTable && (argc != 1) && (argc != 2) && (argc != 3)) {
goto badString;
}
if (!inTkTable && (argc != 2) && (argc != 4)) {
goto badString;
}
cursor = CreateCursorFromTableOrFile(interp, tkwin, argc, argv,
tkCursorPtr);
}
if (cursor != None) {
cursorPtr = ckalloc(sizeof(TkUnixCursor));
cursorPtr->info.cursor = (Tk_Cursor) cursor;
cursorPtr->display = display;
}
cleanup:
if (argv != NULL) {
ckfree(argv);
}
return (TkCursor *) cursorPtr;
badString:
if (argv) {
ckfree(argv);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad cursor spec \"%s\"", string));
Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", NULL);
return NULL;
}
static int
Initialize (
Tcl_Interp *interp)
{
Tcl_Namespace *nsPtr;
Tcl_Namespace *itclNs;
Tcl_HashEntry *hPtr;
Tcl_Obj *objPtr;
ItclObjectInfo *infoPtr;
const char * ret;
char *res_option;
int opt;
int isNew;
if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
return TCL_ERROR;
}
ret = TclOOInitializeStubs(interp, "1.0");
if (ret == NULL) {
return TCL_ERROR;
}
nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
}
nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::methodset",
NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Itcl: cannot create namespace: \"%s::methodset\" \n",
ITCL_NAMESPACE);
}
nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::internal::dicts",
NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
ITCL_NAMESPACE);
}
Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::finish", ItclFinishCmd,
NULL, NULL);
/* for debugging only !!! */
#ifdef OBJ_REF_COUNT_DEBUG
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::dumprefcountinfo",
ItclDumpRefCountInfo, NULL, NULL);
#endif
#ifdef ITCL_PRESERVE_DEBUG
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::dumppreserveinfo",
ItclDumpPreserveInfo, NULL, NULL);
#endif
/* END for debugging only !!! */
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::methodset::callCCommand",
ItclCallCCommand, NULL, NULL);
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::methodset::objectUnknownCommand",
ItclObjectUnknownCommand, NULL, NULL);
/*
* Create the top-level data structure for tracking objects.
* Store this as "associated data" for easy access, but link
* it to the itcl namespace for ownership.
*/
infoPtr = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo));
memset(infoPtr, 0, sizeof(ItclObjectInfo));
infoPtr->interp = interp;
infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc(
sizeof(Tcl_ObjectMetadataType));
infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT;
infoPtr->class_meta_type->name = "ItclClass";
infoPtr->class_meta_type->deleteProc = ItclDeleteClassMetadata;
infoPtr->class_meta_type->cloneProc = NULL;
infoPtr->object_meta_type = (Tcl_ObjectMetadataType *)ckalloc(
sizeof(Tcl_ObjectMetadataType));
infoPtr->object_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT;
infoPtr->object_meta_type->name = "ItclObject";
infoPtr->object_meta_type->deleteProc = ItclDeleteObjectMetadata;
infoPtr->object_meta_type->cloneProc = NULL;
Tcl_InitHashTable(&infoPtr->objects, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->objectCmds, TCL_ONE_WORD_KEYS);
Tcl_InitObjHashTable(&infoPtr->objectNames);
Tcl_InitHashTable(&infoPtr->classes, TCL_ONE_WORD_KEYS);
Tcl_InitObjHashTable(&infoPtr->nameClasses);
Tcl_InitHashTable(&infoPtr->namespaceClasses, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->procMethods, TCL_ONE_WORD_KEYS);
Tcl_InitObjHashTable(&infoPtr->instances);
Tcl_InitHashTable(&infoPtr->objectInstances, TCL_ONE_WORD_KEYS);
Tcl_InitObjHashTable(&infoPtr->classTypes);
infoPtr->ensembleInfo = (EnsembleInfo *)ckalloc(sizeof(EnsembleInfo));
memset(infoPtr->ensembleInfo, 0, sizeof(EnsembleInfo));
Tcl_InitHashTable(&infoPtr->ensembleInfo->ensembles, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->ensembleInfo->subEnsembles, TCL_ONE_WORD_KEYS);
infoPtr->ensembleInfo->numEnsembles = 0;
infoPtr->protection = ITCL_DEFAULT_PROTECT;
infoPtr->currClassFlags = 0;
infoPtr->buildingWidget = 0;
infoPtr->typeDestructorArgumentPtr = Tcl_NewStringObj("", -1);
Tcl_IncrRefCount(infoPtr->typeDestructorArgumentPtr);
infoPtr->lastIoPtr = NULL;
Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classes", "", 0);
Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::objects", "", 0);
Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", "", 0);
Tcl_SetVar(interp,
ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", "", 0);
Tcl_SetVar(interp,
ITCL_NAMESPACE"::internal::dicts::classComponents", "", 0);
Tcl_SetVar(interp,
ITCL_NAMESPACE"::internal::dicts::classVariables", "", 0);
Tcl_SetVar(interp,
ITCL_NAMESPACE"::internal::dicts::classFunctions", "", 0);
Tcl_SetVar(interp,
ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", "", 0);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("class", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_CLASS);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("type", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_TYPE);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("widget", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_WIDGET);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("widgetadaptor", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_WIDGETADAPTOR);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("extendedclass", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_ECLASS);
res_option = getenv("ITCL_USE_OLD_RESOLVERS");
if (res_option == NULL) {
opt = 1;
} else {
opt = atoi(res_option);
}
infoPtr->useOldResolvers = opt;
Itcl_InitStack(&infoPtr->clsStack);
Itcl_InitStack(&infoPtr->contextStack);
Itcl_InitStack(&infoPtr->constructorStack);
Tcl_SetAssocData(interp, ITCL_INTERP_DATA,
(Tcl_InterpDeleteProc*)FreeItclObjectInfo, (ClientData)infoPtr);
Itcl_PreserveData((ClientData)infoPtr);
#ifdef NEW_PROTO_RESOLVER
ItclVarsAndCommandResolveInit(interp);
#endif
/* first create the Itcl base class as root of itcl classes */
if (Tcl_EvalEx(interp, clazzClassScript, -1, 0) != TCL_OK) {
Tcl_Panic("cannot create Itcl root class ::itcl::clazz");
}
objPtr = Tcl_NewStringObj("::itcl::clazz", -1);
infoPtr->clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
/* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */
if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) {
Itcl_IncrObjectRefCount(infoPtr->clazzObjectPtr);
}
Tcl_DecrRefCount(objPtr);
if (infoPtr->clazzObjectPtr == NULL) {
Tcl_AppendResult(interp,
"ITCL: cannot get Object for ::itcl::clazz for class \"",
"::itcl::clazz", "\"", NULL);
return TCL_ERROR;
}
infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(infoPtr->clazzObjectPtr);
AddClassUnknowMethod(interp, infoPtr, infoPtr->clazzClassPtr);
/*
* Initialize the ensemble package first, since we need this
* for other parts of [incr Tcl].
*/
if (Itcl_EnsembleInit(interp) != TCL_OK) {
return TCL_ERROR;
}
Itcl_ParseInit(interp, infoPtr);
/*
* Create "itcl::builtin" namespace for commands that
* are automatically built into class definitions.
*/
if (Itcl_BiInit(interp, infoPtr) != TCL_OK) {
return TCL_ERROR;
}
/*
* Export all commands in the "itcl" namespace so that they
* can be imported with something like "namespace import itcl::*"
*/
itclNs = Tcl_FindNamespace(interp, "::itcl", (Tcl_Namespace*)NULL,
TCL_LEAVE_ERR_MSG);
/*
* This was changed from a glob export (itcl::*) to explicit
* command exports, so that the itcl::is command can *not* be
* exported. This is done for concern that the itcl::is command
* imported might be confusing ("is").
*/
if (!itclNs ||
(Tcl_Export(interp, itclNs, "body", /* reset */ 1) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "class", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "code", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "configbody", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "delete", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "delete_helper", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "ensemble", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "filter", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "find", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "forward", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "local", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "mixin", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "scope", 0) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::internal::commands::sethullwindowname",
ItclSetHullWindowName, infoPtr, NULL);
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::internal::commands::checksetitclhull",
ItclCheckSetItclHull, infoPtr, NULL);
/*
* Set up the variables containing version info.
*/
Tcl_SetVar(interp, "::itcl::version", ITCL_VERSION, TCL_NAMESPACE_ONLY);
Tcl_SetVar(interp, "::itcl::patchLevel", ITCL_PATCH_LEVEL,
TCL_NAMESPACE_ONLY);
#ifdef ITCL_DEBUG_C_INTERFACE
RegisterDebugCFunctions(interp);
#endif
/*
* Package is now loaded.
*/
Tcl_PkgProvideEx(interp, "Itcl", ITCL_PATCH_LEVEL, &itclStubs);
return Tcl_PkgProvideEx(interp, "itcl", ITCL_PATCH_LEVEL, &itclStubs);
}
void
TclSetEnv(
const char *name, /* Name of variable whose value is to be set
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
int index, length, nameLength;
char *p, *oldValue;
const char *p2;
/*
* Figure out where the entry is going to go. If the name doesn't already
* exist, enlarge the array if necessary to make room. If the name exists,
* free its old entry.
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
* outside our control. ourEnvironSize is only valid if the current
* environment is the one we allocated. [Bug 979640]
*/
if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) {
char **newEnviron = (char **)
ckalloc(((unsigned) length + 5) * sizeof(char *));
memcpy(newEnviron, environ, length * sizeof(char *));
if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
ckfree((char *) env.ourEnviron);
}
environ = env.ourEnviron = newEnviron;
env.ourEnvironSize = length + 5;
}
index = length;
environ[index + 1] = NULL;
#endif /* USE_PUTENV */
oldValue = NULL;
nameLength = strlen(name);
} else {
const char *env;
/*
* Compare the new value to the existing value. If they're the same
* then quit immediately (e.g. don't rewrite the value or propagate it
* to other interpreters). Otherwise, when there are N interpreters
* there will be N! propagations of the same value among the
* interpreters.
*/
env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
if (strcmp(value, env + (length + 1)) == 0) {
Tcl_DStringFree(&envString);
Tcl_MutexUnlock(&envMutex);
return;
}
Tcl_DStringFree(&envString);
oldValue = environ[index];
nameLength = length;
}
/*
* Create a new entry. Build a complete UTF string that contains a
* "name=value" pattern. Then convert the string to the native encoding,
* and set the environ array value.
*/
p = ckalloc((unsigned) nameLength + strlen(value) + 2);
strcpy(p, name);
p[nameLength] = '=';
strcpy(p+nameLength+1, value);
p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
p = ckrealloc(p, strlen(p2) + 1);
strcpy(p, p2);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
/*
* Update the system environment.
*/
putenv(p);
index = TclpFindVariable(name, &length);
#else
environ[index] = p;
#endif /* USE_PUTENV */
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if ((index != -1) && (environ[index] == p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(p);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
Tcl_MutexUnlock(&envMutex);
if (!strcmp(name, "HOME")) {
/*
* If the user's home directory has changed, we must invalidate the
* filesystem cache, because '~' expansions will now be incorrect.
*/
Tcl_FSMountsChanged(NULL);
}
}
/*
* ------------------------------------------------------------------------
* ItclFinishCmd()
*
* called when an interp is deleted to free up memory or called explicitly
* to check memory leaks
*
* ------------------------------------------------------------------------
*/
static int
ItclFinishCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch place;
Tcl_Namespace *nsPtr;
Tcl_Obj **newObjv;
Tcl_Obj *objPtr;
Tcl_Obj *ensObjPtr;
Tcl_Command cmdPtr;
Tcl_Obj *mapDict;
ItclObjectInfo *infoPtr;
ItclCmdsInfo *iciPtr;
int checkMemoryLeaks;
int i;
int result;
ItclShowArgs(1, "ItclFinishCmd", objc, objv);
result = TCL_OK;
infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
if (infoPtr == NULL) {
infoPtr = (ItclObjectInfo *)clientData;
}
checkMemoryLeaks = 0;
if (objc > 1) {
if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) {
/* if we have that option, the namespace of the Tcl ensembles
* is not teared down, so we have to simulate it here to
* have the correct reference counts for infoPtr->infoVars2Ptr
* infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr
*/
checkMemoryLeaks = 1;
}
}
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2);
newObjv[0] = Tcl_NewStringObj("my", -1);;
for (i = 0; ;i++) {
iciPtr = &itclCmds[i];
if (iciPtr->name == NULL) {
break;
}
if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) {
result = Itcl_RenameCommand(interp, iciPtr->name, "");
} else {
objPtr = Tcl_NewStringObj(iciPtr->name, -1);
newObjv[1] = objPtr;
Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv);
Tcl_DecrRefCount(objPtr);
}
iciPtr++;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *)newObjv);
/* remove the unknow handler, to free the reference to the
* Tcl_Obj with the name of it */
ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1);
cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG);
if (cmdPtr != NULL) {
Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL);
}
Tcl_DecrRefCount(ensObjPtr);
while (1) {
hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place);
if (hPtr == NULL) {
break;
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&infoPtr->instances);
while (1) {
hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place);
if (hPtr == NULL) {
break;
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&infoPtr->classTypes);
nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
mapDict = NULL;
ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1);
if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) {
Tcl_SetEnsembleUnknownHandler(NULL,
Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG),
NULL);
}
Tcl_DecrRefCount(ensObjPtr);
/* remove the itclinfo and vars entry from the info dict */
/* and replace it by the original one */
cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) {
Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict);
if (mapDict != NULL) {
objPtr = Tcl_NewStringObj("vars", -1);
Tcl_DictObjRemove(interp, mapDict, objPtr);
Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr);
Tcl_DecrRefCount(objPtr);
objPtr = Tcl_NewStringObj("itclinfo", -1);
Tcl_DictObjRemove(interp, mapDict, objPtr);
Tcl_DecrRefCount(objPtr);
Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict);
}
}
/* FIXME have to figure out why the refCount of
* ::itcl::builtin::Info
* and ::itcl::builtin::Info::vars and vars is 2 here !! */
/* seems to be as the tclOO commands are not yet deleted ?? */
Tcl_DecrRefCount(infoPtr->infoVars2Ptr);
Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
if (checkMemoryLeaks) {
Tcl_DecrRefCount(infoPtr->infoVars2Ptr);
Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
/* see comment above */
}
Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);
Tcl_EvalEx(infoPtr->interp,
"::oo::define ::itcl::clazz deletemethod unknown", -1, 0);
/* first have to look for the remaining memory leaks, then remove the next ifdef */
#ifdef LATER
Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", "");
/* tear down ::itcl namespace (this includes ::itcl::parser namespace) */
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::methodset", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
#endif
/* remove the unknown method from top class */
if (infoPtr->unknownNamePtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownNamePtr);
}
if (infoPtr->unknownArgumentPtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownArgumentPtr);
}
if (infoPtr->unknownBodyPtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownBodyPtr);
}
/* cleanup ensemble info */
ItclFinishEnsemble(infoPtr);
ckfree((char *)infoPtr->object_meta_type);
ckfree((char *)infoPtr->class_meta_type);
Itcl_DeleteStack(&infoPtr->clsStack);
Itcl_DeleteStack(&infoPtr->contextStack);
Itcl_DeleteStack(&infoPtr->constructorStack);
/* clean up list pool */
Itcl_FinishList();
Itcl_ReleaseData((ClientData)infoPtr);
return result;
}
void
TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
int length;
int index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif /* USE_PUTENV_FOR_UNSET */
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid doing
* needless work and to avoid recursion on the unset.
*/
if (index == -1) {
Tcl_MutexUnlock(&envMutex);
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
oldValue = environ[index];
/*
* Update the system environment. This must be done before we update the
* interpreters or we will recurse.
*/
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#if defined(__WIN32__) || defined(__CYGWIN__)
string = ckalloc((unsigned) length+2);
memcpy(string, name, (size_t) length);
string[length] = '=';
string[length+1] = '\0';
#else
string = ckalloc((unsigned) length+1);
memcpy(string, name, (size_t) length);
string[length] = '\0';
#endif /* WIN32 */
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
string = ckrealloc(string, (unsigned) Tcl_DStringLength(&envString)+1);
strcpy(string, Tcl_DStringValue(&envString));
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if (environ[index] == string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(string);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
#else /* !USE_PUTENV_FOR_UNSET */
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
}
}
ReplaceString(oldValue, NULL);
#endif /* USE_PUTENV_FOR_UNSET */
Tcl_MutexUnlock(&envMutex);
}
int main(int argc, char *argv[]) {
FILE *f;
char buf[10000], type[100];
// int sum = 0;
struct n_pair *gnames1, *gnames2;
int num_gnames1 = 0, num_gnames2 = 0;
int i = 0, j = 0, cur_id = 0;
bool is_in = false;
bool is_first = false;
if( argc == 4 ) {
is_first = true;
}
else if( argc != 3 ) {
fatal("common_gene_list two_columns_list single_column_list (or FIRST)\n");
}
strcpy(buf, "");
strcpy(type, "");
if((f = ckopen(argv[1], "r")) == NULL )
{
fatalf("Cannot open file %s\n", argv[1]);
}
else {
while(fgets(buf, 10000, f)) {
num_gnames1++;
}
}
if( num_gnames1 > 0 ) {
gnames1 = (struct n_pair *) ckalloc(num_gnames1 * sizeof(struct n_pair));
for( i = 0; i < num_gnames1; i++ ) {
strcpy(gnames1[i].name1, "");
strcpy(gnames1[i].name2, "");
strcpy(gnames1[i].name2, "");
gnames1[i].id = 0;
gnames1[i].len = 0;
}
}
fseek(f, 0, SEEK_SET);
i = 0;
while(fgets(buf, 10000, f)) {
if( sscanf(buf, "%s %s %*s", gnames1[i].name1, gnames1[i].name2) != 2 ) {
fatalf("wrong format in the gene list: %s", buf);
}
i++;
}
fclose(f);
if((f = ckopen(argv[2], "r")) == NULL )
{
fatalf("Cannot open file %s\n", argv[2]);
}
else {
while(fgets(buf, 10000, f)) {
num_gnames2++;
}
}
if( num_gnames2 > 0 ) {
gnames2 = (struct n_pair *) ckalloc(num_gnames2 * sizeof(struct n_pair));
for( i = 0; i < num_gnames2; i++ ) {
strcpy(gnames2[i].name1, "");
strcpy(gnames2[i].name2, "");
strcpy(gnames2[i].name2, "");
gnames2[i].id = 0;
gnames2[i].len = 0;
}
}
fseek(f, 0, SEEK_SET);
i = 0;
while(fgets(buf, 10000, f)) {
if( sscanf(buf, "%s %*s", gnames2[i].name1) != 1 ) {
fatalf("wrong format in the gene list: %s", buf);
}
i++;
}
fclose(f);
for( i = 0; i < num_gnames1; i++ ) {
j = 0;
is_in = false;
cur_id = -1;
while( (j < num_gnames2) && (is_in == false ) ) {
if(strcmp(gnames1[i].name1, gnames2[j].name1) == 0) {
is_in = true;
cur_id = j;
}
j++;
}
if( is_in == true ) {
if( cur_id == -1 ) {
fatalf("unexpected case: %s\n", gnames1[i].name1);
}
if( is_first == false ) {
printf("%s %s\n", gnames1[i].name1, gnames1[i].name2);
}
else {
printf("%s\n", gnames1[i].name1);
}
}
}
if( num_gnames1 > 0 ) {
free(gnames1);
}
if( num_gnames2 > 0 ) {
free(gnames2);
}
return EXIT_SUCCESS;
}
int
imfsample_cmd(ClientData cldata, Tcl_Interp *interp, int argc, char *argv[])
{
Tk_Window mainw = (Tk_Window) cldata;
Imfsample *imfsample;
Tk_Window tkwin;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " pathName ?options?\"", (char *) NULL);
return TCL_ERROR;
}
tkwin = Tk_CreateWindowFromPath(interp, mainw, argv[1], (char *) NULL);
if (tkwin == NULL)
return TCL_ERROR;
Tk_SetClass(tkwin, "Imfsample");
/* Allocate and initialize the widget record. */
imfsample = (Imfsample *) ckalloc(sizeof(Imfsample));
imfsample->tkwin = tkwin;
imfsample->display = Tk_Display(tkwin);
imfsample->interp = interp;
imfsample->widgetCmd =
Tcl_CreateCommand(interp,
Tk_PathName(imfsample->tkwin), imfsample_widget_cmd,
(ClientData) imfsample, imfsample_cmd_deleted_proc);
imfsample->border_width = 0;
imfsample->bg_border = NULL;
imfsample->fg_border = NULL;
imfsample->cu_border = NULL;
imfsample->relief = TK_RELIEF_FLAT;
imfsample->copygc = None;
imfsample->gc = None;
imfsample->double_buffer = 1;
imfsample->update_pending = 0;
imfsample->show_color = 1;
imfsample->show_names = 0;
imfsample->show_masks = 0;
imfsample->show_grid = 0;
imfsample->fill_color = NULL;
imfsample->with_terrain = -1;
imfsample->with_emblem = -1;
imfsample->main_imf_name = "";
imfsample->numimages = 0;
imfsample->imf_list =
(ImageFamily **) xmalloc(MAXIMAGEFAMILIES * sizeof(ImageFamily *));
imfsample->numvisrows = 0;
imfsample->firstvisrow = 0;
/* IMFApp-specific stuff. */
imfsample->imfapp = 0;
imfsample->selected = -1;
imfsample->previous = -1;
imfsample->oldfirst = 0;
imfsample->redraw = 0;
Tk_CreateEventHandler(imfsample->tkwin, ExposureMask|StructureNotifyMask,
imfsample_event_proc, (ClientData) imfsample);
if (imfsample_configure(interp, imfsample, argc-2, argv+2, 0) != TCL_OK) {
Tk_DestroyWindow(imfsample->tkwin);
return TCL_ERROR;
}
Tcl_SetResult(interp, Tk_PathName(imfsample->tkwin), TCL_VOLATILE);
return TCL_OK;
}
int
TclMacCreateEnv()
{
char ** sysEnv = NULL;
char ** pathEnv = NULL;
char ** fileEnv = NULL;
char ** rezEnv = NULL;
int count = 0;
int i, j;
sysEnv = SystemVariables();
if (sysEnv != NULL) {
for (i = 0; sysEnv[i] != NULL; count++, i++) {
/* Empty Loop */
}
}
pathEnv = PathVariables();
if (pathEnv != NULL) {
for (i = 0; pathEnv[i] != NULL; count++, i++) {
/* Empty Loop */
}
}
#ifdef kPrefsFile
fileEnv = FileRCVariables();
if (fileEnv != NULL) {
for (i = 0; fileEnv[i] != NULL; count++, i++) {
/* Empty Loop */
}
}
#endif
#ifdef REZ_ENV
rezEnv = RezRCVariables();
if (rezEnv != NULL) {
for (i = 0; rezEnv[i] != NULL; count++, i++) {
/* Empty Loop */
}
}
#endif
/*
* Create environ variable
*/
environ = (char **) ckalloc((count + 1) * sizeof(char *));
j = 0;
if (sysEnv != NULL) {
for (i = 0; sysEnv[i] != NULL;)
environ[j++] = sysEnv[i++];
ckfree((char *) sysEnv);
}
if (pathEnv != NULL) {
for (i = 0; pathEnv[i] != NULL;)
environ[j++] = pathEnv[i++];
ckfree((char *) pathEnv);
}
#ifdef kPrefsFile
if (fileEnv != NULL) {
for (i = 0; fileEnv[i] != NULL;)
environ[j++] = fileEnv[i++];
ckfree((char *) fileEnv);
}
#endif
#ifdef REZ_ENV
if (rezEnv != NULL) {
for (i = 0; rezEnv[i] != NULL;)
environ[j++] = rezEnv[i++];
ckfree((char *) rezEnv);
}
#endif
environ[j] = NULL;
return j;
}
Tcl_Channel
Tcl_OpenTcpClient(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
int port, /* Port number to open. */
const char *host, /* Host on which to open port. */
const char *myaddr, /* Client-side address */
int myport, /* Client-side port */
int async) /* If nonzero, attempt to do an asynchronous
* connect. Otherwise we do a blocking
* connect. */
{
TcpState *state;
const char *errorMsg = NULL;
struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
char channelName[SOCK_CHAN_LENGTH];
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
|| !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", errorMsg));
}
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
state = ckalloc(sizeof(TcpState));
memset(state, 0, sizeof(TcpState));
state->flags = async ? TCP_ASYNC_CONNECT : 0;
state->cachedBlocking = TCL_MODE_BLOCKING;
state->addrlist = addrlist;
state->myaddrlist = myaddrlist;
state->fds.fd = -1;
/*
* Create a new client socket and wrap it in a channel.
*/
if (CreateClientSocket(interp, state) != TCL_OK) {
TcpCloseProc(state, NULL);
return NULL;
}
sprintf(channelName, SOCK_TEMPLATE, (long) state);
state->channel = Tcl_CreateChannel(&tcpChannelType, channelName, state,
(TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(interp, state->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_Close(NULL, state->channel);
return NULL;
}
return state->channel;
}
static void
TextDeleteChars(
Tk_Canvas canvas, /* Canvas containing itemPtr. */
Tk_Item *itemPtr, /* Item in which to delete characters. */
int first, /* Character index of first character to
* delete. */
int last) /* Character index of last character to delete
* (inclusive). */
{
TextItem *textPtr = (TextItem *) itemPtr;
int byteIndex, byteCount, charsRemoved;
char *newStr, *text;
Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr;
text = textPtr->text;
if (first < 0) {
first = 0;
}
if (last >= textPtr->numChars) {
last = textPtr->numChars - 1;
}
if (first > last) {
return;
}
charsRemoved = last + 1 - first;
byteIndex = Tcl_UtfAtIndex(text, first) - text;
byteCount = Tcl_UtfAtIndex(text + byteIndex, charsRemoved)
- (text + byteIndex);
newStr = ckalloc(textPtr->numBytes + 1 - byteCount);
memcpy(newStr, text, (size_t) byteIndex);
strcpy(newStr + byteIndex, text + byteIndex + byteCount);
ckfree(text);
textPtr->text = newStr;
textPtr->numChars -= charsRemoved;
textPtr->numBytes -= byteCount;
/*
* Update indexes for the selection and cursor to reflect the renumbering
* of the remaining characters.
*/
if (textInfoPtr->selItemPtr == itemPtr) {
if (textInfoPtr->selectFirst > first) {
textInfoPtr->selectFirst -= charsRemoved;
if (textInfoPtr->selectFirst < first) {
textInfoPtr->selectFirst = first;
}
}
if (textInfoPtr->selectLast >= first) {
textInfoPtr->selectLast -= charsRemoved;
if (textInfoPtr->selectLast < first - 1) {
textInfoPtr->selectLast = first - 1;
}
}
if (textInfoPtr->selectFirst > textInfoPtr->selectLast) {
textInfoPtr->selItemPtr = NULL;
}
if ((textInfoPtr->anchorItemPtr == itemPtr)
&& (textInfoPtr->selectAnchor > first)) {
textInfoPtr->selectAnchor -= charsRemoved;
if (textInfoPtr->selectAnchor < first) {
textInfoPtr->selectAnchor = first;
}
}
}
if (textPtr->insertPos > first) {
textPtr->insertPos -= charsRemoved;
if (textPtr->insertPos < first) {
textPtr->insertPos = first;
}
}
ComputeTextBbox(canvas, textPtr);
return;
}
Tcl_Channel
Tcl_OpenTcpServer(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
int port, /* Port number to open. */
const char *myHost, /* Name of local host. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
ClientData acceptProcData) /* Data for the callback. */
{
int status = 0, sock = -1, reuseaddr = 1, chosenport = 0;
struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */
TcpState *statePtr = NULL;
char channelName[SOCK_CHAN_LENGTH];
const char *errorMsg = NULL;
TcpFdList *fds = NULL, *newfds;
/*
* Try to record and return the most meaningful error message, i.e. the
* one from the first socket that went the farthest before it failed.
*/
enum { LOOKUP, SOCKET, BIND, LISTEN } howfar = LOOKUP;
int my_errno = 0;
if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
my_errno = errno;
goto error;
}
for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
addrPtr->ai_protocol);
if (sock == -1) {
if (howfar < SOCKET) {
howfar = SOCKET;
my_errno = errno;
}
continue;
}
/*
* Set the close-on-exec flag so that the socket will not get
* inherited by child processes.
*/
fcntl(sock, F_SETFD, FD_CLOEXEC);
/*
* Set kernel space buffering
*/
TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE);
/*
* Set up to reuse server addresses automatically and bind to the
* specified port.
*/
(void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
(char *) &reuseaddr, sizeof(reuseaddr));
/*
* Make sure we use the same port number when opening two server
* sockets for IPv4 and IPv6 on a random port.
*
* As sockaddr_in6 uses the same offset and size for the port member
* as sockaddr_in, we can handle both through the IPv4 API.
*/
if (port == 0 && chosenport != 0) {
((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
htons(chosenport);
}
#ifdef IPV6_V6ONLY
/* Missing on: Solaris 2.8 */
if (addrPtr->ai_family == AF_INET6) {
int v6only = 1;
(void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY,
&v6only, sizeof(v6only));
}
#endif /* IPV6_V6ONLY */
status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
if (status == -1) {
if (howfar < BIND) {
howfar = BIND;
my_errno = errno;
}
close(sock);
continue;
}
if (port == 0 && chosenport == 0) {
address sockname;
socklen_t namelen = sizeof(sockname);
/*
* Synchronize port numbers when binding to port 0 of multiple
* addresses.
*/
if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
chosenport = ntohs(sockname.sa4.sin_port);
}
}
status = listen(sock, SOMAXCONN);
if (status < 0) {
if (howfar < LISTEN) {
howfar = LISTEN;
my_errno = errno;
}
close(sock);
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
statePtr = ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
newfds = &statePtr->fds;
} else {
newfds = ckalloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
newfds->statePtr = statePtr;
fds = newfds;
/*
* Set up the callback mechanism for accepting connections from new
* clients.
*/
Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds);
}
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
return statePtr->channel;
}
if (interp != NULL) {
Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1);
if (errorMsg == NULL) {
errno = my_errno;
Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1);
} else {
Tcl_AppendToObj(errorObj, errorMsg, -1);
}
Tcl_SetObjResult(interp, errorObj);
}
if (sock != -1) {
close(sock);
}
return NULL;
}
int nVarname; char *zVarname;
int nScript; char *zScript;
/* Parameters for thread creation */
const int nStack = TCL_THREAD_STACK_DEFAULT;
const int flags = TCL_THREAD_NOFLAGS;
assert(objc==4);
UNUSED_PARAMETER(clientData);
UNUSED_PARAMETER(objc);
zVarname = Tcl_GetStringFromObj(objv[2], &nVarname);
zScript = Tcl_GetStringFromObj(objv[3], &nScript);
pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2);
pNew->zVarname = (char *)&pNew[1];
pNew->zScript = (char *)&pNew->zVarname[nVarname+1];
memcpy(pNew->zVarname, zVarname, nVarname+1);
memcpy(pNew->zScript, zScript, nScript+1);
pNew->parent = Tcl_GetCurrentThread();
pNew->interp = interp;
rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags);
if( rc!=TCL_OK ){
Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0);
ckfree((char *)pNew);
return TCL_ERROR;
}
return TCL_OK;
static void
InitializeHostName(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *native = NULL;
#ifndef NO_UNAME
struct utsname u;
struct hostent *hp;
memset(&u, (int) 0, sizeof(struct utsname));
if (uname(&u) > -1) { /* INTL: Native. */
hp = TclpGetHostByName(u.nodename); /* INTL: Native. */
if (hp == NULL) {
/*
* Sometimes the nodename is fully qualified, but gets truncated
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
char *node = ckalloc(dot - u.nodename + 1);
memcpy(node, u.nodename, (size_t) (dot - u.nodename));
node[dot - u.nodename] = '\0';
hp = TclpGetHostByName(node);
ckfree(node);
}
}
if (hp != NULL) {
native = hp->h_name;
} else {
native = u.nodename;
}
}
if (native == NULL) {
native = tclEmptyStringRep;
}
#else /* !NO_UNAME */
/*
* Uname doesn't exist; try gethostname instead.
*
* There is no portable macro for the maximum length of host names
* returned by gethostbyname(). We should only trust SYS_NMLN if it is at
* least 255 + 1 bytes to comply with DNS host name limits.
*
* Note: SYS_NMLN is a restriction on "uname" not on gethostbyname!
*
* For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname() can
* return a fully qualified name from DNS of up to 255 bytes.
*
* Fix suggested by Viktor Dukhovni ([email protected])
*/
# if defined(SYS_NMLN) && (SYS_NMLEN >= 256)
char buffer[SYS_NMLEN];
# else
char buffer[256];
# endif
if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
*lengthPtr = strlen(native);
*valuePtr = ckalloc((*lengthPtr) + 1);
memcpy(*valuePtr, native, (size_t)(*lengthPtr)+1);
}
static TkBitmap *
GetBitmap(
Tcl_Interp *interp, /* Interpreter to use for error reporting,
* this may be NULL. */
Tk_Window tkwin, /* Window in which bitmap will be used. */
const char *string) /* Description of bitmap. See manual entry for
* details on legal syntax. */
{
Tcl_HashEntry *nameHashPtr, *predefHashPtr;
TkBitmap *bitmapPtr, *existingBitmapPtr;
TkPredefBitmap *predefPtr;
Pixmap bitmap;
int isNew, width, height, dummy2;
TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (!dispPtr->bitmapInit) {
BitmapInit(dispPtr);
}
nameHashPtr = Tcl_CreateHashEntry(&dispPtr->bitmapNameTable, string,
&isNew);
if (!isNew) {
existingBitmapPtr = (TkBitmap *) Tcl_GetHashValue(nameHashPtr);
for (bitmapPtr = existingBitmapPtr; bitmapPtr != NULL;
bitmapPtr = bitmapPtr->nextPtr) {
if ( (Tk_Display(tkwin) == bitmapPtr->display) &&
(Tk_ScreenNumber(tkwin) == bitmapPtr->screenNum) ) {
bitmapPtr->resourceRefCount++;
return bitmapPtr;
}
}
} else {
existingBitmapPtr = NULL;
}
/*
* No suitable bitmap exists. Create a new bitmap from the information
* contained in the string. If the string starts with "@" then the rest of
* the string is a file name containing the bitmap. Otherwise the string
* must refer to a bitmap defined by a call to Tk_DefineBitmap.
*/
if (*string == '@') { /* INTL: ISO char */
Tcl_DString buffer;
int result;
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't specify bitmap with '@' in a",
" safe interpreter", NULL);
goto error;
}
/*
* Note that we need to cast away the const from the string because
* Tcl_TranslateFileName is non-const, even though it doesn't modify
* the string.
*/
string = Tcl_TranslateFileName(interp, (char *) string + 1, &buffer);
if (string == NULL) {
goto error;
}
result = TkReadBitmapFile(Tk_Display(tkwin),
RootWindowOfScreen(Tk_Screen(tkwin)), string,
(unsigned int *) &width, (unsigned int *) &height,
&bitmap, &dummy2, &dummy2);
if (result != BitmapSuccess) {
if (interp != NULL) {
Tcl_AppendResult(interp, "error reading bitmap file \"",
string, "\"", NULL);
}
Tcl_DStringFree(&buffer);
goto error;
}
Tcl_DStringFree(&buffer);
} else {
predefHashPtr = Tcl_FindHashEntry(&tsdPtr->predefBitmapTable, string);
if (predefHashPtr == NULL) {
/*
* The following platform specific call allows the user to define
* bitmaps that may only exist during run time. If it returns None
* nothing was found and we return the error.
*/
bitmap = TkpGetNativeAppBitmap(Tk_Display(tkwin), string,
&width, &height);
if (bitmap == None) {
if (interp != NULL) {
Tcl_AppendResult(interp, "bitmap \"", string,
"\" not defined", NULL);
}
goto error;
}
} else {
predefPtr = (TkPredefBitmap *) Tcl_GetHashValue(predefHashPtr);
width = predefPtr->width;
height = predefPtr->height;
if (predefPtr->native) {
bitmap = TkpCreateNativeBitmap(Tk_Display(tkwin),
predefPtr->source);
if (bitmap == None) {
Tcl_Panic("native bitmap creation failed");
}
} else {
bitmap = XCreateBitmapFromData(Tk_Display(tkwin),
RootWindowOfScreen(Tk_Screen(tkwin)),
predefPtr->source, (unsigned)width, (unsigned)height);
}
}
}
/*
* Add information about this bitmap to our database.
*/
bitmapPtr = (TkBitmap *) ckalloc(sizeof(TkBitmap));
bitmapPtr->bitmap = bitmap;
bitmapPtr->width = width;
bitmapPtr->height = height;
bitmapPtr->display = Tk_Display(tkwin);
bitmapPtr->screenNum = Tk_ScreenNumber(tkwin);
bitmapPtr->resourceRefCount = 1;
bitmapPtr->objRefCount = 0;
bitmapPtr->nameHashPtr = nameHashPtr;
bitmapPtr->idHashPtr = Tcl_CreateHashEntry(&dispPtr->bitmapIdTable,
(char *) bitmap, &isNew);
if (!isNew) {
Tcl_Panic("bitmap already registered in Tk_GetBitmap");
}
bitmapPtr->nextPtr = existingBitmapPtr;
Tcl_SetHashValue(nameHashPtr, bitmapPtr);
Tcl_SetHashValue(bitmapPtr->idHashPtr, bitmapPtr);
return bitmapPtr;
error:
if (isNew) {
Tcl_DeleteHashEntry(nameHashPtr);
}
return NULL;
}
int
Tk_ClipboardAppend(
Tcl_Interp *interp, /* Used for error reporting. */
Tk_Window tkwin, /* Window that selects a display. */
Atom type, /* The desired conversion type for this
* clipboard item, e.g. STRING or LENGTH. */
Atom format, /* Format in which the selection information
* should be returned to the requestor. */
char* buffer) /* NULL terminated string containing the data
* to be added to the clipboard. */
{
TkWindow *winPtr = (TkWindow *) tkwin;
TkDisplay *dispPtr = winPtr->dispPtr;
TkClipboardTarget *targetPtr;
TkClipboardBuffer *cbPtr;
/*
* If this application doesn't already own the clipboard, clear the
* clipboard. If we don't own the clipboard selection, claim it.
*/
if (dispPtr->clipboardAppPtr != winPtr->mainPtr) {
Tk_ClipboardClear(interp, tkwin);
} else if (!dispPtr->clipboardActive) {
Tk_OwnSelection(dispPtr->clipWindow, dispPtr->clipboardAtom,
ClipboardLostSel, (ClientData) dispPtr);
dispPtr->clipboardActive = 1;
}
/*
* Check to see if the specified target is already present on the
* clipboard. If it isn't, we need to create a new target; otherwise, we
* just append the new buffer to the clipboard list.
*/
for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL;
targetPtr = targetPtr->nextPtr) {
if (targetPtr->type == type) {
break;
}
}
if (targetPtr == NULL) {
targetPtr = (TkClipboardTarget*) ckalloc(sizeof(TkClipboardTarget));
targetPtr->type = type;
targetPtr->format = format;
targetPtr->firstBufferPtr = targetPtr->lastBufferPtr = NULL;
targetPtr->nextPtr = dispPtr->clipTargetPtr;
dispPtr->clipTargetPtr = targetPtr;
Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom,
type, ClipboardHandler, (ClientData) targetPtr, format);
} else if (targetPtr->format != format) {
Tcl_AppendResult(interp, "format \"", Tk_GetAtomName(tkwin, format),
"\" does not match current format \"",
Tk_GetAtomName(tkwin, targetPtr->format),"\" for ",
Tk_GetAtomName(tkwin, type), NULL);
return TCL_ERROR;
}
/*
* Append a new buffer to the buffer chain.
*/
cbPtr = (TkClipboardBuffer*) ckalloc(sizeof(TkClipboardBuffer));
cbPtr->nextPtr = NULL;
if (targetPtr->lastBufferPtr != NULL) {
targetPtr->lastBufferPtr->nextPtr = cbPtr;
} else {
targetPtr->firstBufferPtr = cbPtr;
}
targetPtr->lastBufferPtr = cbPtr;
cbPtr->length = strlen(buffer);
cbPtr->buffer = (char *) ckalloc((unsigned) (cbPtr->length + 1));
strcpy(cbPtr->buffer, buffer);
TkSelUpdateClipboard((TkWindow*)(dispPtr->clipWindow), targetPtr);
return TCL_OK;
}
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
DWORD modes;
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
infoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
* channel names unique, since some may share handles (stdin/stdout/stderr
* for instance).
*/
sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
GetConsoleMode(infoPtr->handle, &modes);
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread);
}
if (permissions & TCL_WRITABLE) {
StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
#ifdef UNICODE
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
#else
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
#endif
return infoPtr->channel;
}
TkCursor *
TkGetCursorByName(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tk_Window tkwin, /* Window in which cursor will be used. */
Tk_Uid string) /* Description of cursor. See manual entry for
* details on legal syntax. */
{
struct CursorName *namePtr;
TkWinCursor *cursorPtr;
int argc;
CONST char **argv = NULL;
/*
* All cursor names are valid lists of one element (for
* Unix-compatability), even unadorned system cursor names.
*/
if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) {
return NULL;
}
if (argc == 0) {
goto badCursorSpec;
}
cursorPtr = (TkWinCursor *) ckalloc(sizeof(TkWinCursor));
cursorPtr->info.cursor = (Tk_Cursor) cursorPtr;
cursorPtr->winCursor = NULL;
cursorPtr->system = 0;
if (argv[0][0] == '@') {
/*
* Check for system cursor of type @<filename>, where only the name is
* allowed. This accepts any of:
* -cursor @/winnt/cursors/globe.ani
* -cursor @C:/Winnt/cursors/E_arrow.cur
* -cursor {@C:/Program\ Files/Cursors/bart.ani}
* -cursor {{@C:/Program Files/Cursors/bart.ani}}
* -cursor [list @[file join "C:/Program Files" Cursors bart.ani]]
*/
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't get cursor from a file in",
" a safe interpreter", NULL);
ckfree((char *) argv);
ckfree((char *) cursorPtr);
return NULL;
}
cursorPtr->winCursor = LoadCursorFromFile(&(argv[0][1]));
} else {
/*
* Check for the cursor in the system cursor set.
*/
for (namePtr = cursorNames; namePtr->name != NULL; namePtr++) {
if (strcmp(namePtr->name, argv[0]) == 0) {
cursorPtr->winCursor = LoadCursor(NULL, namePtr->id);
break;
}
}
if (cursorPtr->winCursor == NULL) {
/*
* Hmm, it is not in the system cursor set. Check to see if it is
* one of our application resources.
*/
cursorPtr->winCursor = LoadCursor(Tk_GetHINSTANCE(), argv[0]);
} else {
cursorPtr->system = 1;
}
}
if (cursorPtr->winCursor == NULL) {
ckfree((char *) cursorPtr);
badCursorSpec:
ckfree((char *) argv);
Tcl_AppendResult(interp, "bad cursor spec \"", string, "\"", NULL);
return NULL;
} else {
ckfree((char *) argv);
return (TkCursor *) cursorPtr;
}
}
