char*
findfile (Tcl_Interp *interp, char *name)
{
int i;
char *library, *file;
static Tcl_DString *dsPtr = NULL;
static char *dirs[] = { "/bitmaps/", "/site/", "/apps/", "/", NULL };
if (! dsPtr) {
dsPtr = (Tcl_DString *) ckalloc(sizeof(Tcl_DString));
Tcl_DStringInit(dsPtr);
}
file = Tcl_TranslateFileName(interp, name, dsPtr);
if (file && access(file, R_OK) == 0) {
Tcl_ResetResult(interp);
return FixPath(file);
}
buffersize(strlen(name)+20);
strcpy(buffer, "~/.tkined/");
strcat(buffer, name);
file = Tcl_TranslateFileName(interp, buffer, dsPtr);
if (file && access(file, R_OK) == 0) {
Tcl_ResetResult(interp);
return FixPath(file);
}
library = Tcl_GetVar2(interp, "tkined", "library", TCL_GLOBAL_ONLY);
if (! library) {
Tcl_ResetResult(interp);
return (char *) NULL;
}
buffersize(strlen(library)+strlen(name)+20);
for (i = 0; dirs[i]; i++) {
strcpy(buffer, library);
strcat(buffer, dirs[i]);
strcat(buffer, name);
file = Tcl_TranslateFileName(interp, buffer, dsPtr);
if (file && access(file, R_OK) == 0) {
Tcl_ResetResult(interp);
return FixPath(file);
}
}
return (char *) NULL;
}
int tcl_pmepot_writedx(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
pmepot_data *data;
Tcl_DString fstring;
char *fname;
if ( objc != 3 ) {
Tcl_SetResult(interp,"args: handle filename",TCL_VOLATILE);
return TCL_ERROR;
}
data = Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), 0);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: unable to access handle.",TCL_VOLATILE);
return TCL_ERROR;
}
fname = Tcl_TranslateFileName(interp,Tcl_GetString(objv[2]),&fstring);
if ( 0 == fname ) {
return TCL_ERROR;
}
if ( pmepot_writedx(data,fname) ) {
Tcl_DStringFree(&fstring);
Tcl_SetResult(interp,"Pmepot bug: unable to write file.",TCL_VOLATILE);
return TCL_ERROR;
}
Tcl_DStringFree(&fstring);
return TCL_OK;
}
static int
SourceRcFile(Tcl_Interp *interp, char *fileName)
{
Tcl_DString temp;
char *fullName;
int result = 0;
if (! fileName) {
return 0;
}
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
if (fullName == NULL) {
TnmWriteMessage(Tcl_GetStringResult(interp));
TnmWriteMessage("\n");
} else {
Tcl_Channel channel;
channel = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (channel) {
Tcl_Close((Tcl_Interp *) NULL, channel);
result = 1;
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
TnmWriteMessage(Tcl_GetStringResult(interp));
TnmWriteMessage("\n");
}
}
}
Tcl_DStringFree(&temp);
return result;
}
void
Tcl_SourceRCFile(
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
const char *fileName;
Tcl_Channel chan;
fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
if (fullName == NULL) {
/*
* Couldn't translate the file name (e.g. it referred to a bogus
* user or there was no HOME environment variable). Just do
* nothing.
*/
} else {
/*
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1);
Tcl_Close(NULL, c);
Tcl_IncrRefCount(fullNameObj);
if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
Tcl_DecrRefCount(fullNameObj);
}
}
Tcl_DStringFree(&temp);
}
}
void
Tcl_SourceRCFile(
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
CONST char *fileName;
Tcl_Channel errChannel;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
CONST char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
if (fullName == NULL) {
/*
* Couldn't translate the file name (e.g. it referred to a bogus
* user or there was no HOME environment variable). Just do
* nothing.
*/
} else {
/*
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != (Tcl_Channel) NULL) {
Tcl_Close(NULL, c);
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
}
}
Tcl_DStringFree(&temp);
}
}
/*-----------------------------------------------------------------------------
* ChmodFileNameObj --
* Change the mode of a file by name.
*
* Parameters:
* o interp - Pointer to the current interpreter, error messages will be
* returned in the result.
* o modeInfo - Infomation with the mode to set the file to.
* o fileName - Name of the file to change.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
ChmodFileNameObj (Tcl_Interp *interp, modeInfo_t modeInfo, Tcl_Obj *fileNameObj)
{
char *filePath;
struct stat fileStat;
Tcl_DString pathBuf;
int newMode;
char *fileName;
Tcl_DStringInit (&pathBuf);
fileName = Tcl_GetStringFromObj (fileNameObj, NULL);
filePath = Tcl_TranslateFileName (interp, fileName, &pathBuf);
if (filePath == NULL) {
Tcl_DStringFree (&pathBuf);
return TCL_ERROR;
}
if (modeInfo.symMode != NULL) {
if (stat (filePath, &fileStat) != 0)
goto fileError;
newMode = ConvSymMode (interp, modeInfo.symMode,
fileStat.st_mode & 07777);
if (newMode < 0)
goto errorExit;
} else {
newMode = modeInfo.absMode;
}
if (TclXOSchmod (interp, filePath, (unsigned short) newMode) < 0)
return TCL_ERROR;
Tcl_DStringFree (&pathBuf);
return TCL_OK;
fileError:
TclX_AppendObjResult (interp, filePath, ": ",
Tcl_PosixError (interp), (char *) NULL);
errorExit:
Tcl_DStringFree (&pathBuf);
return TCL_ERROR;
}
static int
TestchmodCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int i, mode;
char *rest;
if (argc < 2) {
usage:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" mode file ?file ...?", NULL);
return TCL_ERROR;
}
mode = (int) strtol(argv[1], &rest, 8);
if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}
for (i = 2; i < argc; i++) {
Tcl_DString buffer;
const char *translated;
translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (TestplatformChmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
}
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;
}
/* ARGSUSED */
static int
MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
int argc,
const char *argv[])
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option [args..]\"", NULL);
return TCL_ERROR;
}
if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_AppendResult(interp, "error accessing ", argv[2], NULL);
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
if (argc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"objs") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" objs file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_AppendResult(interp, "cannot open output file", NULL);
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(argv[1],"onexit") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" onexit file\"", NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" tag string\"", NULL);
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
len = strlen(argv[2]);
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, argv[2], len + 1);
return TCL_OK;
}
if (strcmp(argv[1],"trace") == 0) {
if (argc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
if (argc != 3) {
goto argError;
}
if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(argv[1],"validate") == 0) {
if (argc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be active, break_on_malloc, info, init, objs, onexit, "
"tag, trace, trace_on_at_malloc, or validate", NULL);
return TCL_ERROR;
argError:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " count\"", NULL);
return TCL_ERROR;
bad_suboption:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ", argv[1], " on|off\"", NULL);
return TCL_ERROR;
}
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;
}
/*
*---------------------------------------------------------------------------
*
* Blt_CreatePipeline --
*
* Given an objc/objv array, instantiate a pipeline of processes as
* described by the objv.
*
* Results:
* The return value is a count of the number of new processes created, or
* -1 if an error occurred while creating the pipeline. *pidArrayPtr is
* filled in with the address of a dynamically allocated array giving the
* ids of all of the processes.
*
* It is up to the caller to free this array when it isn't needed
* anymore.
*
* If stdinPipePtr isn't NULL, then *stdinPipePtr is filled with the file
* id for the input pipe for the pipeline (if any): the caller must
* eventually close this file.
*
* If stdoutPipePtr isn't NULL, then *stdoutPipePtr is filled with the
* file id for the output pipe from the pipeline: the caller must close
* this file.
*
* If stderrPipePtr isn't NULL, then *stderrPipePtr is filled with a file
* id that may be used to read error output after the pipeline completes.
*
* Side effects:
* Processes and pipes are created.
*
*---------------------------------------------------------------------------
*/
int
Blt_CreatePipeline(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
int objc, /* Number of entries in objv. */
Tcl_Obj *const *objv, /* Array of strings describing commands in
* pipeline plus I/O redirection with <, <<,
* >, etc. Objv[objc] must be NULL. */
ProcessId **pidArrayPtr, /* (out) Word at *pidArrayPtr gets filled in
* with address of array of pids for processes
* in pipeline (first pid is first process in
* pipeline). */
int *stdinPipePtr, /* (out) If non-NULL, input to the pipeline
* comes from a pipe (unless overridden by
* redirection in the command). The file id
* with which to write to this pipe is stored
* at *stdinPipePtr. NULL means command
* specified its own input source. */
int *stdoutPipePtr, /* (out) If non-NULL, output to the pipeline
* goes to a pipe, unless overriden by
* redirection in the command. The file id
* with which to read frome this pipe is
* stored at *stdoutPipePtr. NULL means
* command specified its own output sink. */
int *stderrPipePtr) /* (out) If non-NULL, all stderr output from
* the pipeline will go to a temporary file
* created here, and a descriptor to read the
* file will be left at *stderrPipePtr. The
* file will be removed already, so closing
* this descriptor will be the end of the
* file. If this is NULL, then all stderr
* output goes to our stderr. If the pipeline
* specifies redirection then the file will
* still be created but it will never get any
* data. */
{
int *pids = NULL; /* Points to malloc-ed array holding all the
* pids of child processes. */
int nPids; /* Actual number of processes that exist at
* *pids right now. */
int cmdCount; /* Count of number of distinct commands found
* in objc/objv. */
char *inputLiteral = NULL; /* If non-null, then this points to a string
* containing input data (specified via <<) to
* be piped to the first process in the
* pipeline. */
char *p;
int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput;
Tcl_DString execBuffer;
int pipeIn;
int isOpen[3];
int curFd[3]; /* If non-zero, then fd should be closed
* when cleaning up. */
int fd[3];
char **argv;
fd[0] = fd[1] = fd[2] = -1;
isOpen[0] = isOpen[1] = isOpen[2] = FALSE;
if (stdinPipePtr != NULL) {
*stdinPipePtr = -1;
}
if (stdoutPipePtr != NULL) {
*stdoutPipePtr = -1;
}
if (stderrPipePtr != NULL) {
*stderrPipePtr = -1;
}
Tcl_DStringInit(&execBuffer);
pipeIn = curFd[0] = curFd[1] = -1;
nPids = 0;
/*
* First, scan through all the arguments to figure out the structure of
* the pipeline. Process all of the input and output redirection
* arguments and remove them from the argument list in the pipeline.
* Count the number of distinct processes (it's the number of "|"
* arguments plus one) but don't remove the "|" arguments because they'll
* be used in the second pass to seperate the individual child processes.
*
* Cannot start the child processes in this pass because the redirection
* symbols may appear anywhere in the command line -- e.g., the '<' that
* specifies the input to the entire pipe may appear at the very end of
* the argument list.
*/
/* Convert all the Tcl_Objs to strings. */
argv = Blt_AssertMalloc((objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[i] = NULL;
lastBar = -1;
cmdCount = 1;
for (i = 0; i < objc; i++) {
skip = 0;
p = argv[i];
switch (*p++) {
case '\\':
p++;
continue;
case '|':
if (*p == '&') {
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (objc - 1))) {
Tcl_AppendResult(interp,
"illegal use of | or |& in command", (char *)NULL);
goto error;
}
}
lastBar = i;
cmdCount++;
break;
case '<':
if (isOpen[0] != 0) {
isOpen[0] = FALSE;
CloseFile(fd[0]);
}
if (*p == '<') {
fd[0] = -1;
inputLiteral = p + 1;
skip = 1;
if (*inputLiteral == '\0') {
inputLiteral = argv[i + 1];
if (inputLiteral == NULL) {
Tcl_AppendResult(interp, "can't specify \"", argv[i],
"\" as last word in command", (char *)NULL);
goto error;
}
skip = 2;
}
} else {
inputLiteral = NULL;
fd[0] = FileForRedirect(interp, p, argv[i], TRUE, argv[i + 1],
O_RDONLY, &skip, &isOpen[0]);
if (fd[0] < 0) {
goto error;
}
}
break;
case '>':
atOK = TRUE;
flags = O_WRONLY | O_CREAT | O_TRUNC;
errorToOutput = FALSE;
if (*p == '>') {
p++;
atOK = FALSE;
flags = O_WRONLY | O_CREAT;
}
if (*p == '&') {
if (isOpen[2] != 0) {
isOpen[2] = FALSE;
CloseFile(fd[2]);
}
errorToOutput = TRUE;
p++;
}
if (isOpen[1] != 0) {
isOpen[1] = FALSE;
CloseFile(fd[1]);
}
fd[1] = FileForRedirect(interp, p, argv[i], atOK, argv[i + 1],
flags, &skip, &isOpen[1]);
if (fd[1] < 0) {
goto error;
}
if (errorToOutput) {
isOpen[2] = FALSE;
fd[2] = fd[1];
}
break;
case '2':
if (*p != '>') {
break;
}
p++;
atOK = TRUE;
flags = O_WRONLY | O_CREAT | O_TRUNC;
if (*p == '>') {
p++;
atOK = FALSE;
flags = O_WRONLY | O_CREAT;
}
if (isOpen[2] != 0) {
isOpen[2] = FALSE;
CloseFile(fd[2]);
}
fd[2] = FileForRedirect(interp, p, argv[i], atOK, argv[i + 1],
flags, &skip, &isOpen[2]);
if (fd[2] < 0) {
goto error;
}
break;
}
if (skip != 0) {
for (j = i + skip; j < objc; j++) {
argv[j - skip] = argv[j];
}
objc -= skip;
i -= 1;
}
}
if (fd[0] == -1) {
if (inputLiteral != NULL) {
/*
* The input for the first process is immediate data coming from
* Tcl. Create a temporary file for it and put the data into the
* file.
*/
fd[0] = CreateTempFile(inputLiteral);
if (fd[0] < 0) {
Tcl_AppendResult(interp,
"can't create input file for command: ",
Tcl_PosixError(interp), (char *)NULL);
goto error;
}
isOpen[0] = TRUE;
} else if (stdinPipePtr != NULL) {
/*
* The input for the first process in the pipeline is to come from
* a pipe that can be written from by the caller.
*/
if (CreatePipe(interp, &fd[0], stdinPipePtr) != TCL_OK) {
goto error;
}
isOpen[0] = TRUE;
} else {
/*
* The input for the first process comes from stdin.
*/
fd[0] = 0;
}
}
if (fd[1] == -1) {
if (stdoutPipePtr != NULL) {
/*
* Output from the last process in the pipeline is to go to a pipe
* that can be read by the caller.
*/
if (CreatePipe(interp, stdoutPipePtr, &fd[1]) != TCL_OK) {
goto error;
}
isOpen[1] = TRUE;
} else {
/*
* The output for the last process goes to stdout.
*/
fd[1] = 1;
}
}
if (fd[2] == -1) {
if (stderrPipePtr != NULL) {
/*
* Stderr from the last process in the pipeline is to go to a pipe
* that can be read by the caller.
*/
if (CreatePipe(interp, stderrPipePtr, &fd[2]) != TCL_OK) {
goto error;
}
isOpen[2] = TRUE;
} else {
/*
* Errors from the pipeline go to stderr.
*/
fd[2] = 2;
}
}
/*
* Scan through the objc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
pids = Blt_AssertMalloc(cmdCount * sizeof(int));
curFd[0] = fd[0];
lastArg = 0; /* Suppress compiler warning */
for (i = 0; i < objc; i = lastArg + 1) {
int joinThisError;
int pid;
/*
* Convert the program name into native form.
*/
argv[i] = Tcl_TranslateFileName(interp, argv[i], &execBuffer);
if (argv[i] == NULL) {
goto error;
}
/*
* Find the end of the curent segment of the pipeline.
*/
joinThisError = 0;
for (lastArg = i + 1; lastArg < objc; lastArg++) {
if (argv[lastArg][0] == '|') {
if (argv[lastArg][1] == '\0') {
break;
}
if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
joinThisError = 1;
break;
}
}
}
argv[lastArg] = NULL;
/*
* If this is the last segment, use the specified fd[1]. Otherwise
* create an intermediate pipe. pipeIn will become the curInFile for
* the next segment of the pipe.
*/
if (lastArg == objc) {
curFd[1] = fd[1];
} else {
if (CreatePipe(interp, &pipeIn, &curFd[1]) != TCL_OK) {
goto error;
}
}
if (joinThisError != 0) {
curFd[2] = curFd[1];
} else {
curFd[2] = fd[2];
}
if (CreateProcess(interp, lastArg - i, argv + i, curFd[0], curFd[1],
curFd[2], &pid) != TCL_OK) {
goto error;
}
Tcl_DStringFree(&execBuffer);
pids[nPids] = pid;
nPids++;
/*
* Close off our copies of file descriptors that were set up for this
* child, then set up the input for the next child.
*/
if ((curFd[0] >= 0) && (curFd[0] != fd[0])) {
CloseFile(curFd[0]);
}
curFd[0] = pipeIn;
pipeIn = -1;
if ((curFd[1] >= 0) && (curFd[1] != fd[1])) {
CloseFile(curFd[1]);
}
curFd[1] = -1;
}
*pidArrayPtr = pids;
/*
* All done. Cleanup open files lying around and then return.
*/
cleanup:
Tcl_DStringFree(&execBuffer);
for (i = 0; i < 3; i++) {
if (isOpen[i]) {
CloseFile(fd[i]);
}
}
if (argv != NULL) {
Blt_Free(argv);
}
return nPids;
/*
* An error occured. There could have been extra files open, such as
* pipes between children. Clean them all up. Detach any child processes
* that have been created.
*/
error:
if (pipeIn >= 0) {
CloseFile(pipeIn);
}
if ((curFd[2] >= 0) && (curFd[2] != fd[2])) {
CloseFile(curFd[2]);
}
if ((curFd[1] >= 0) && (curFd[1] != fd[1])) {
CloseFile(curFd[1]);
}
if ((curFd[0] >= 0) && (curFd[0] != fd[0])) {
CloseFile(curFd[0]);
}
if ((stdinPipePtr != NULL) && (*stdinPipePtr >= 0)) {
CloseFile(*stdinPipePtr);
*stdinPipePtr = -1;
}
if ((stdoutPipePtr != NULL) && (*stdoutPipePtr >= 0)) {
CloseFile(*stdoutPipePtr);
*stdoutPipePtr = -1;
}
if ((stderrPipePtr != NULL) && (*stderrPipePtr >= 0)) {
CloseFile(*stderrPipePtr);
*stderrPipePtr = -1;
}
if (pids != NULL) {
for (i = 0; i < nPids; i++) {
if (pids[i] != -1) {
Tcl_DetachPids(1, (Tcl_Pid *)(pids + i));
}
}
Blt_Free(pids);
}
nPids = -1;
goto cleanup;
}
static int
FileForRedirect(
Tcl_Interp *interp, /* Intepreter to use for error reporting. */
char *spec, /* Points to character just after redirection
* character. */
char *arg, /* Pointer to entire argument containing spec:
* used for error reporting. */
int atOK, /* Non-zero means that '@' notation can be
* used to specify a channel, zero means that
* it isn't. */
char *nextArg, /* Next argument in argc/argv array, if needed
* for file name or channel name. May be
* NULL. */
int flags, /* Flags to use for opening file or to specify
* mode for channel. */
int *skipPtr, /* (out) Filled with 1 if redirection target
* was in spec, 2 if it was in nextArg. */
int *closePtr) /* (out) Filled with one if the caller should
* close the file when done with it, zero
* otherwise. */
{
int writing = (flags & O_WRONLY);
int fd;
*skipPtr = 1;
if ((atOK != 0) && (*spec == '@')) {
int direction;
Tcl_Channel chan;
spec++;
if (*spec == '\0') {
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
chan = Tcl_GetChannel(interp, spec, NULL);
if (chan == NULL) {
return -1;
}
direction = (writing) ? TCL_WRITABLE : TCL_READABLE;
fd = GetFdFromChannel(chan, direction);
if (fd < 0) {
Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
"\" wasn't opened for ",
((writing) ? "writing" : "reading"), (char *)NULL);
return -1;
}
if (writing) {
/*
* Be sure to flush output to the file, so that anything
* written by the child appears after stuff we've already
* written.
*/
Tcl_Flush(chan);
}
} else {
char *name;
Tcl_DString nameString;
if (*spec == '\0') {
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
name = Tcl_TranslateFileName(interp, spec, &nameString);
if (name != NULL) {
fd = OpenFile(name, flags);
} else {
fd = -1;
}
Tcl_DStringFree(&nameString);
if (fd < 0) {
Tcl_AppendResult(interp, "can't ",
((writing) ? "write" : "read"), " file \"", spec, "\": ",
Tcl_PosixError(interp), (char *)NULL);
return -1;
}
*closePtr = TRUE;
}
return fd;
badLastArg:
Tcl_AppendResult(interp, "can't specify \"", arg,
"\" as last word in command", (char *)NULL);
return -1;
}
/* Implement the Windows version of the ide_get_directory command. */
static int
get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
BROWSEINFO bi;
char buf[MAX_PATH + 1];
Tk_Window parent;
int i, oldMode;
LPITEMIDLIST idlist;
char *p;
int atts;
Tcl_DString tempBuffPtr;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_DString titleDString;
Tcl_DString initialDirDString;
Tcl_DString resultDString;
Tcl_DStringInit(&titleDString);
Tcl_DStringInit(&initialDirDString);
#endif
Tcl_DStringInit(&tempBuffPtr);
bi.hwndOwner = NULL;
bi.pidlRoot = NULL;
bi.pszDisplayName = buf;
bi.lpszTitle = NULL;
bi.ulFlags = 0;
bi.lpfn = NULL;
bi.lParam = 0;
bi.iImage = 0;
parent = Tk_MainWindow (interp);
for (i = 1; i < argc; i += 2)
{
int v;
int len;
v = i + 1;
len = strlen (argv[i]);
if (strncmp (argv[i], "-parent", len) == 0)
{
if (v == argc)
goto arg_missing;
parent = Tk_NameToWindow (interp, argv[v],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else if (strncmp (argv[i], "-title", len) == 0)
{
if (v == argc)
goto arg_missing;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_UtfToExternalDString(NULL, argv[v], -1, &titleDString);
bi.lpszTitle = Tcl_DStringValue(&titleDString);
#else
bi.lpszTitle = argv[v];
#endif
}
else if (strncmp (argv[i], "-initialdir", len) == 0)
{
if (v == argc)
goto arg_missing;
/* bi.lParam will be passed to the callback function.(save the need for globals)*/
bi.lParam = (LPARAM) Tcl_TranslateFileName(interp, argv[v], &tempBuffPtr);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_UtfToExternalDString(NULL, (char *) bi.lParam, -1, &initialDirDString);
bi.lParam = (LPARAM) Tcl_DStringValue(&initialDirDString);
#endif
bi.lpfn = MyBrowseCallbackProc;
}
else
{
Tcl_AppendResult (interp, "unknown option \"", argv[i],
"\", must be -parent or -title", (char *) NULL);
return TCL_ERROR;
}
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
bi.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
idlist = SHBrowseForFolder (&bi);
Tcl_SetServiceMode(oldMode);
if (idlist == NULL)
{
/* User pressed the cancel button. */
return TCL_OK;
}
if (! SHGetPathFromIDList (idlist, buf))
{
Tcl_SetResult (interp, "could not get path for directory", TCL_STATIC);
return TCL_ERROR;
}
/* Ensure the directory exists. */
atts = GetFileAttributesA (buf);
if (atts == -1 || ! (atts & FILE_ATTRIBUTE_DIRECTORY))
{
Tcl_AppendResult (interp, "path \"", buf, "\" is not a directory",
(char *) NULL);
/* FIXME: free IDLIST. */
return TCL_ERROR;
}
/* FIXME: We are supposed to free IDLIST using the shell task
allocator, but cygwin32 doesn't define the required interfaces
yet. */
/* Normalize the path for Tcl. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, buf, -1, &resultDString);
p = Tcl_DStringValue(&resultDString);
#else
p = buf;
#endif
for (; *p != '\0'; ++p)
if (*p == '\\')
*p = '/';
Tcl_ResetResult(interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_SetResult(interp, Tcl_DStringValue(&resultDString), TCL_VOLATILE);
Tcl_DStringFree(&resultDString);
Tcl_DStringFree(&titleDString);
Tcl_DStringFree(&initialDirDString);
#else
Tcl_SetResult(interp, buf, TCL_VOLATILE);
#endif
Tcl_DStringFree(&tempBuffPtr);
return TCL_OK;
arg_missing:
Tcl_AppendResult(interp, "value for \"", argv[argc - 1], "\" missing",
NULL);
return TCL_ERROR;
}
