int Ow_Init(Tcl_Interp * interp)
{
int i;
/* This defines the static chars tkTable(Safe)InitScript */
#include "owtclInitScript.h"
if (
#ifdef USE_TCL_STUBS
Tcl_InitStubs(interp, "8.1", 0)
#else
Tcl_PkgRequire(interp, "Tcl", "8.1", 0)
#endif
== NULL)
return TCL_ERROR;
OwtclState.used = 0;
/* Initialize the new Tcl commands */
i = 0;
while (OwtclCmdList[i].name != NULL) {
Tcl_CreateObjCommand(interp, OwtclCmdList[i].name, (Tcl_ObjCmdProc *) OwtclCmdList[i].func,
(ClientData) & OwtclState, (Tcl_CmdDeleteProc *) NULL);
i++;
}
/* Callback - clean up procs left open on interpreter deletetion. */
Tcl_CallWhenDeleted(interp, (Tcl_InterpDeleteProc *) Owtcl_Delete, (ClientData) & OwtclState);
/* Announce successful package loading to "package require". */
if (Tcl_PkgProvide(interp, "ow", OWTCL_VERSION) != TCL_OK)
return TCL_ERROR;
/*
* The init script can't make certain calls in a safe interpreter,
* so we always have to use the embedded runtime for it
*/
return Tcl_Eval(interp, Tcl_IsSafe(interp) ? owtclSafeInitScript : owtclInitScript);
}
char *
Tk_SetAppName(
Tk_Window tkwin, /* Token for any window in the application
* to be named: it is just used to identify
* the application and the display. */
char *name) /* The name that will be used to
* refer to the interpreter in later
* "send" commands. Must be globally
* unique. */
{
TkWindow *winPtr = (TkWindow *) tkwin;
Tcl_Interp *interp = winPtr->mainPtr->interp;
int i, suffix, offset, result;
int createCommand = 0;
RegisteredInterp *riPtr, *prevPtr;
char *actualName;
Tcl_DString dString;
Tcl_Obj *resultObjPtr, *interpNamePtr;
char *interpName;
if (!initialized) {
SendInit(interp);
}
/*
* See if the application is already registered; if so, remove its
* current name from the registry. The deletion of the command
* will take care of disposing of this entry.
*/
for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL;
prevPtr = riPtr, riPtr = riPtr->nextPtr) {
if (riPtr->interp == interp) {
if (prevPtr == NULL) {
interpListPtr = interpListPtr->nextPtr;
} else {
prevPtr->nextPtr = riPtr->nextPtr;
}
break;
}
}
/*
* Pick a name to use for the application. Use "name" if it's not
* already in use. Otherwise add a suffix such as " #2", trying
* larger and larger numbers until we eventually find one that is
* unique.
*/
actualName = name;
suffix = 1;
offset = 0;
Tcl_DStringInit(&dString);
TkGetInterpNames(interp, tkwin);
resultObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultObjPtr);
for (i = 0; ; ) {
result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr);
if (interpNamePtr == NULL) {
break;
}
interpName = Tcl_GetStringFromObj(interpNamePtr, NULL);
if (strcmp(actualName, interpName) == 0) {
if (suffix == 1) {
Tcl_DStringAppend(&dString, name, -1);
Tcl_DStringAppend(&dString, " #", 2);
offset = Tcl_DStringLength(&dString);
Tcl_DStringSetLength(&dString, offset + 10);
actualName = Tcl_DStringValue(&dString);
}
suffix++;
sprintf(actualName + offset, "%d", suffix);
i = 0;
} else {
i++;
}
}
Tcl_DecrRefCount(resultObjPtr);
Tcl_ResetResult(interp);
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = ckalloc(strlen(actualName) + 1);
riPtr->nextPtr = interpListPtr;
interpListPtr = riPtr;
strcpy(riPtr->name, actualName);
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd,
(ClientData) riPtr, NULL /* TODO: DeleteProc */);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_DStringFree(&dString);
return riPtr->name;
}
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;
}
}
const char *
Tk_SetAppName(
Tk_Window tkwin, /* Token for any window in the application to
* be named: it is just used to identify the
* application and the display. */
const char *name) /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
{
#ifndef TK_SEND_ENABLED_ON_WINDOWS
/*
* Temporarily disabled for bug #858822
*/
return name;
#else /* TK_SEND_ENABLED_ON_WINDOWS */
ThreadSpecificData *tsdPtr = NULL;
TkWindow *winPtr = (TkWindow *) tkwin;
RegisteredInterp *riPtr = NULL;
Tcl_Interp *interp;
HRESULT hr = S_OK;
interp = winPtr->mainPtr->interp;
tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
/*
* Initialise the COM library for this interpreter just once.
*/
if (tsdPtr->initialized == 0) {
hr = CoInitialize(0);
if (FAILED(hr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"failed to initialize the COM library", -1));
Tcl_SetErrorCode(interp, "TK", "SEND", "COM", NULL);
return "";
}
tsdPtr->initialized = 1;
TRACE("Initialized COM library for interp 0x%08X\n", (long)interp);
}
/*
* If the interp hasn't been registered before then we need to create the
* registration structure and the COM object. If it has been registered
* already then we can reuse all and just register the new name.
*/
riPtr = Tcl_GetAssocData(interp, "tkWinSend::ri", NULL);
if (riPtr == NULL) {
LPUNKNOWN *objPtr;
riPtr = ckalloc(sizeof(RegisteredInterp));
memset(riPtr, 0, sizeof(RegisteredInterp));
riPtr->interp = interp;
objPtr = &riPtr->obj;
hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown,
(void **) objPtr);
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr,
CmdDeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, riPtr);
} else {
RevokeObjectRegistration(riPtr);
}
RegisterInterp(name, riPtr);
return (const char *) riPtr->name;
#endif /* TK_SEND_ENABLED_ON_WINDOWS */
}
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 =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (!dispPtr->bitmapInit) {
BitmapInit(dispPtr);
}
nameHashPtr = Tcl_CreateHashEntry(&dispPtr->bitmapNameTable, string,
&isNew);
if (!isNew) {
existingBitmapPtr = 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_SetObjResult(interp, Tcl_NewStringObj(
"can't specify bitmap with '@' in a safe interpreter",
-1));
Tcl_SetErrorCode(interp, "TK", "SAFE", "BITMAP_FILE", 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_SetObjResult(interp, Tcl_ObjPrintf(
"error reading bitmap file \"%s\"", string));
Tcl_SetErrorCode(interp, "TK", "BITMAP", "FILE_ERROR", 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_SetObjResult(interp, Tcl_ObjPrintf(
"bitmap \"%s\" not defined", string));
Tcl_SetErrorCode(interp, "TK", "LOOKUP", "BITMAP", string,
NULL);
}
goto error;
}
} else {
predefPtr = 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 = 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;
}
/*++
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
)
{
ExtState *statePtr;
StateList *stateListPtr;
// Wide integer support was added in Tcl 8.4.
#ifdef USE_TCL_STUBS
if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
return TCL_ERROR;
}
#else // USE_TCL_STUBS
if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) {
return TCL_ERROR;
}
#endif // USE_TCL_STUBS
if (Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION) != TCL_OK) {
return TCL_ERROR;
}
//
// Check if the library is already initialised before locking
// the global initialisation mutex (improves loading time).
//
if (!initialised) {
Tcl_MutexLock(&initMutex);
// Check initialisation status again now that we're in the mutex.
if (!initialised) {
#ifdef _WINDOWS
// Initialise the OS version structure.
osVersion.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osVersion);
ZeroMemory(&winProcs, sizeof(WinProcs));
winProcs.module = LoadLibraryA("kernel32.dll");
if (winProcs.module != NULL) {
//
// These functions must be resolved on run-time for backwards
// compatibility on older Windows systems (earlier than NT v5).
//
winProcs.getDiskFreeSpaceEx = (GetDiskFreeSpaceExProc)
GetProcAddress(winProcs.module, "GetDiskFreeSpaceExA");
winProcs.findFirstVolumeMountPoint = (FindFirstVolumeMountPointProc)
GetProcAddress(winProcs.module, "FindFirstVolumeMountPointA");
winProcs.findNextVolumeMountPoint = (FindNextVolumeMountPointProc)
GetProcAddress(winProcs.module, "FindNextVolumeMountPointA");
winProcs.findVolumeMountPointClose = (FindVolumeMountPointCloseProc)
GetProcAddress(winProcs.module, "FindVolumeMountPointClose");
winProcs.getVolumeNameForVolumeMountPoint = (GetVolumeNameForVolumeMountPointProc)
GetProcAddress(winProcs.module, "GetVolumeNameForVolumeMountPointA");
}
//
// If GetVolumeInformation() is called on a floppy drive or a CD-ROM
// drive that does not have a disk inserted, the system will display
// a message box asking the user to insert one.
//
SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
#endif // _WINDOWS
// An exit handler must only be registered once.
Tcl_CreateExitHandler(ExitHandler, NULL);
// Register ciphers, hashes, and PRNGs for LibTomCrypt.
register_cipher(&des3_desc);
register_cipher(&aes_desc);
register_cipher(&anubis_desc);
register_cipher(&blowfish_desc);
register_cipher(&cast5_desc);
register_cipher(&des_desc);
register_cipher(&khazad_desc);
register_cipher(&noekeon_desc);
register_cipher(&rc2_desc);
register_cipher(&rc5_desc);
register_cipher(&rc6_desc);
register_cipher(&saferp_desc);
register_cipher(&safer_k128_desc);
register_cipher(&safer_k64_desc);
register_cipher(&safer_sk128_desc);
register_cipher(&safer_sk64_desc);
register_cipher(&skipjack_desc);
register_cipher(&twofish_desc);
register_cipher(&xtea_desc);
register_hash(&md2_desc);
register_hash(&md4_desc);
register_hash(&md5_desc);
register_hash(&rmd128_desc);
register_hash(&rmd160_desc);
register_hash(&sha1_desc);
register_hash(&sha224_desc);
register_hash(&sha256_desc);
register_hash(&sha384_desc);
register_hash(&sha512_desc);
register_hash(&tiger_desc);
register_hash(&whirlpool_desc);
register_prng(&fortuna_desc);
register_prng(&rc4_desc);
register_prng(&sober128_desc);
register_prng(&sprng_desc);
register_prng(&yarrow_desc);
initialised = 1;
}
Tcl_MutexUnlock(&initMutex);
}
// Allocate state structures.
stateListPtr = (StateList *)ckalloc(sizeof(StateList));
statePtr = (ExtState *)ckalloc(sizeof(ExtState));
statePtr->cryptTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(statePtr->cryptTable, TCL_STRING_KEYS);
#ifndef _WINDOWS
statePtr->glftpdTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(statePtr->glftpdTable, TCL_STRING_KEYS);
#endif // !_WINDOWS
//
// Since callbacks registered with Tcl_CallWhenDeleted() are not executed in
// certain situations (calling Tcl_Finalize() or invoking the "exit" command),
// these resources must be freed by an exit handler registered with
// Tcl_CreateExitHandler().
//
stateListPtr->interp = interp;
stateListPtr->state = statePtr;
stateListPtr->next = NULL;
stateListPtr->prev = NULL;
Tcl_MutexLock(&stateMutex);
// Insert at the list head.
if (stateListHead == NULL) {
stateListHead = stateListPtr;
} else {
stateListPtr->next = stateListHead;
stateListHead->prev = stateListPtr;
stateListHead = stateListPtr;
}
Tcl_MutexUnlock(&stateMutex);
// Clean up state on interpreter deletion.
Tcl_CallWhenDeleted(interp, InterpDeleteHandler, (ClientData)statePtr);
// Create Tcl commands.
Tcl_CreateObjCommand(interp, "::alcoholicz::compress", CompressObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "::alcoholicz::crypt", CryptObjCmd,
(ClientData)statePtr, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "::alcoholicz::decode", EncodingObjCmd,
(ClientData)decodeFuncts, (Tcl_CmdDeleteProc *)NULL);
Tcl_CreateObjCommand(interp, "::alcoholicz::encode", EncodingObjCmd,
(ClientData)encodeFuncts, (Tcl_CmdDeleteProc *)NULL);
//
// These commands are not created for safe interpreters because
// they interact with the file system and/or other processes.
//
if (!Tcl_IsSafe(interp)) {
Tcl_CreateObjCommand(interp, "::alcoholicz::volume", VolumeObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#ifdef _WINDOWS
Tcl_CreateObjCommand(interp, "::alcoholicz::ioftpd", IoFtpdObjCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
#else // _WINDOWS
Tcl_CreateObjCommand(interp, "::alcoholicz::glftpd", GlFtpdObjCmd,
(ClientData)statePtr, (Tcl_CmdDeleteProc *)NULL);
#endif // _WINDOWS
}
Tcl_Eval(interp, "namespace eval ::alcoholicz {"
"namespace export compress crypt encode decode volume "
#ifdef _WINDOWS
"ioftpd"
#else
"glftpd"
#endif // _WINDOWS
"}"
);
return TCL_OK;
}
char *
TkGetBitmapData(
Tcl_Interp *interp, /* For reporting errors, or NULL. */
const char *string, /* String describing bitmap. May be NULL. */
const char *fileName, /* Name of file containing bitmap description.
* Used only if string is NULL. Must not be
* NULL if string is NULL. */
int *widthPtr, int *heightPtr,
/* Dimensions of bitmap get returned here. */
int *hotXPtr, int *hotYPtr) /* Position of hot spot or -1,-1. */
{
int width, height, numBytes, hotX, hotY;
const char *expandedFileName;
char *p, *end;
ParseInfo pi;
char *data = NULL;
Tcl_DString buffer;
pi.string = string;
if (string == NULL) {
if ((interp != NULL) && Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't get bitmap data from a file in a",
" safe interpreter", NULL);
return NULL;
}
expandedFileName = Tcl_TranslateFileName(interp, fileName, &buffer);
if (expandedFileName == NULL) {
return NULL;
}
pi.chan = Tcl_OpenFileChannel(interp, expandedFileName, "r", 0);
Tcl_DStringFree(&buffer);
if (pi.chan == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read bitmap file \"",
fileName, "\": ", Tcl_PosixError(interp), NULL);
}
return NULL;
}
if (Tcl_SetChannelOption(interp, pi.chan, "-translation", "binary")
!= TCL_OK) {
return NULL;
}
if (Tcl_SetChannelOption(interp, pi.chan, "-encoding", "binary")
!= TCL_OK) {
return NULL;
}
} else {
pi.chan = NULL;
}
/*
* Parse the lines that define the dimensions of the bitmap, plus the
* first line that defines the bitmap data (it declares the name of a data
* variable but doesn't include any actual data). These lines look
* something like the following:
*
* #define foo_width 16
* #define foo_height 16
* #define foo_x_hot 3
* #define foo_y_hot 3
* static char foo_bits[] = {
*
* The x_hot and y_hot lines may or may not be present. It's important to
* check for "char" in the last line, in order to reject old X10-style
* bitmaps that used shorts.
*/
width = 0;
height = 0;
hotX = -1;
hotY = -1;
while (1) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
&& (strcmp(pi.word+pi.wordLength-6, "_width") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
width = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.wordLength >= 7) && (pi.word[pi.wordLength-7] == '_')
&& (strcmp(pi.word+pi.wordLength-7, "_height") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
height = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
&& (strcmp(pi.word+pi.wordLength-6, "_x_hot") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
hotX = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
&& (strcmp(pi.word+pi.wordLength-6, "_y_hot") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
hotY = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.word[0] == 'c') && (strcmp(pi.word, "char") == 0)) {
while (1) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
if ((pi.word[0] == '{') && (pi.word[1] == 0)) {
goto getData;
}
}
} else if ((pi.word[0] == '{') && (pi.word[1] == 0)) {
if (interp != NULL) {
Tcl_AppendResult(interp, "format error in bitmap data; ",
"looks like it's an obsolete X10 bitmap file", NULL);
}
goto errorCleanup;
}
}
/*
* Now we've read everything but the data. Allocate an array and read in
* the data.
*/
getData:
if ((width <= 0) || (height <= 0)) {
goto error;
}
numBytes = ((width+7)/8) * height;
data = ckalloc((unsigned) numBytes);
for (p = data; numBytes > 0; p++, numBytes--) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
*p = (char) strtol(pi.word, &end, 0);
if (end == pi.word) {
goto error;
}
}
/*
* All done. Clean up and return.
*/
if (pi.chan != NULL) {
Tcl_Close(NULL, pi.chan);
}
*widthPtr = width;
*heightPtr = height;
*hotXPtr = hotX;
*hotYPtr = hotY;
return data;
error:
if (interp != NULL) {
Tcl_SetResult(interp, "format error in bitmap data", TCL_STATIC);
}
errorCleanup:
if (data != NULL) {
ckfree(data);
}
if (pi.chan != NULL) {
Tcl_Close(NULL, pi.chan);
}
return NULL;
}
static int
ReadOptionFile(
Tcl_Interp *interp, /* Interpreter to use for reporting results. */
Tk_Window tkwin, /* Token for window: options are entered for
* this window's main window. */
const char *fileName, /* Name of file containing options. */
int priority) /* Priority level to use for options in this
* file, such as TK_USER_DEFAULT_PRIO or
* TK_INTERACTIVE_PRIO. Must be between 0 and
* TK_MAX_PRIO. */
{
const char *realName;
char *buffer;
int result, bufferSize;
Tcl_Channel chan;
Tcl_DString newName;
/*
* Prevent file system access in a safe interpreter.
*/
if (Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't read options from a file in a",
" safe interpreter", NULL);
return TCL_ERROR;
}
realName = Tcl_TranslateFileName(interp, fileName, &newName);
if (realName == NULL) {
return TCL_ERROR;
}
chan = Tcl_OpenFileChannel(interp, realName, "r", 0);
Tcl_DStringFree(&newName);
if (chan == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't open \"", fileName,
"\": ", Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
/*
* Compute size of file by seeking to the end of the file. This will
* overallocate if we are performing CRLF translation.
*/
bufferSize = (int) Tcl_Seek(chan, (Tcl_WideInt) 0, SEEK_END);
Tcl_Seek(chan, (Tcl_WideInt) 0, SEEK_SET);
if (bufferSize < 0) {
Tcl_AppendResult(interp, "error seeking to end of file \"",
fileName, "\":", Tcl_PosixError(interp), NULL);
Tcl_Close(NULL, chan);
return TCL_ERROR;
}
buffer = ckalloc((unsigned) bufferSize+1);
bufferSize = Tcl_Read(chan, buffer, bufferSize);
if (bufferSize < 0) {
Tcl_AppendResult(interp, "error reading file \"", fileName, "\":",
Tcl_PosixError(interp), NULL);
Tcl_Close(NULL, chan);
return TCL_ERROR;
}
Tcl_Close(NULL, chan);
buffer[bufferSize] = 0;
result = AddFromString(interp, tkwin, buffer, priority);
ckfree(buffer);
return result;
}
/*++
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;
}
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;
}
