int lexinput_tktext(char *buf, int max_size, int buf_size, void *index1, void *index2)
{
int length, nbytes;
Tcl_DString internal, temp;
static int first = 1;
static Tcl_DString external;
static Tcl_Encoding encoding;
if(first) {
/* The lexers require ASCII encoding. */
encoding = Tcl_GetEncoding(NULL, "ascii");
if(encoding == NULL) {
/* No ASCII encoding available. */
return 0;
}
Tcl_DStringInit(&external);
first = 0;
}
Tcl_DStringInit(&internal);
if(Tcl_DStringLength(&external) == 0) {
/* Translate the text to `external'. */
if(tk_text_buffer(&internal, buf_size, index1, index2) > 0) {
Tcl_UtfToExternalDString(encoding, Tcl_DStringValue(&internal), Tcl_DStringLength(&internal), &external);
} else {
return 0;
}
}
/* Fill up the user-provided buffer as much as possible. */
length = Tcl_DStringLength(&external);
nbytes = (length > max_size) ? max_size : length;
memcpy(buf, Tcl_DStringValue(&external), nbytes);
/* I wish DStrings had a copy constructor. In fact, sometimes I wish
Tcl was written in C++. */
if(length > nbytes) {
Tcl_DStringInit(&temp);
Tcl_DStringAppend(&temp, Tcl_DStringValue(&external) + nbytes, length - nbytes);
Tcl_DStringFree(&external);
Tcl_DStringInit(&external);
Tcl_DStringAppend(&external, Tcl_DStringValue(&temp), Tcl_DStringLength(&temp));
Tcl_DStringFree(&temp);
} else {
Tcl_DStringFree(&external);
Tcl_DStringInit(&external);
}
/* Clean up. */
Tcl_DStringFree(&internal);
return nbytes;
}
char *
Tcl_WinTCharToUtf(
const char *string,
int len,
Tcl_DString *dsPtr)
{
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_ExternalToUtfDString(winTCharEncoding,
string, len, dsPtr);
}
static int
ConsoleOutput(
ClientData instanceData, /* Indicates which device to use. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ChannelData *data = instanceData;
ConsoleInfo *info = data->info;
*errorCode = 0;
Tcl_SetErrno(0);
if (info) {
Tcl_Interp *consoleInterp = info->consoleInterp;
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_DString ds;
Tcl_Encoding utf8 = Tcl_GetEncoding(NULL, "utf-8");
/*
* Not checking for utf8 == NULL. Did not check for TCL_ERROR
* from Tcl_SetChannelOption() in Tk_InitConsoleChannels() either.
* Assumption is utf-8 Tcl_Encoding is reliably present.
*/
const char *bytes
= Tcl_ExternalToUtfDString(utf8, buf, toWrite, &ds);
int numBytes = Tcl_DStringLength(&ds);
Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);
Tcl_FreeEncoding(utf8);
if (data->type == TCL_STDERR) {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stderr", -1));
} else {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stdout", -1));
}
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj(bytes, numBytes));
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(consoleInterp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
}
return toWrite;
}
SEXP RTcl_ObjFromCharVector(SEXP args)
{
char *s;
Tcl_DString s_ds;
int count;
Tcl_Obj *tclobj, *elem;
int i;
SEXP val, drop;
Tcl_Encoding encoding;
const void *vmax = vmaxget();
val = CADR(args);
drop = CADDR(args);
tclobj = Tcl_NewObj();
count = length(val);
encoding = Tcl_GetEncoding(RTcl_interp, "utf-8");
if (count == 1 && LOGICAL(drop)[0]) {
Tcl_DStringInit(&s_ds);
s = Tcl_ExternalToUtfDString(encoding,
translateCharUTF8(STRING_ELT(val, 0)),
-1, &s_ds);
Tcl_SetStringObj(tclobj, s, -1);
Tcl_DStringFree(&s_ds);
} else
for ( i = 0 ; i < count ; i++) {
elem = Tcl_NewObj();
Tcl_DStringInit(&s_ds);
s = Tcl_ExternalToUtfDString(encoding,
translateCharUTF8(STRING_ELT(val, i)),
-1, &s_ds);
Tcl_SetStringObj(elem, s, -1);
Tcl_DStringFree(&s_ds);
Tcl_ListObjAppendElement(RTcl_interp, tclobj, elem);
}
Tcl_FreeEncoding(encoding);
SEXP res = makeRTclObject(tclobj);
vmaxset(vmax);
return res;
}
CONST char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
{
CONST char *encoding;
CONST char *knownEncoding;
Tcl_DStringInit(bufPtr);
/*
* Determine the current encoding from the LC_* or LANG environment
* variables. We previously used setlocale() to determine the locale, but
* this does not work on some systems (e.g. Linux/i386 RH 5.0).
*/
#ifdef HAVE_LANGINFO
if (
#ifdef WEAK_IMPORT_NL_LANGINFO
nl_langinfo != NULL &&
#endif
setlocale(LC_CTYPE, "") != NULL) {
Tcl_DString ds;
/*
* Use a DString so we can modify case.
*/
Tcl_DStringInit(&ds);
encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, -1);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
Tcl_DStringAppend(bufPtr, encoding, -1);
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
return Tcl_DStringValue(bufPtr);
}
}
#endif /* HAVE_LANGINFO */
/*
* Classic fallback check. This tries a homebrew algorithm to determine
* what encoding should be used based on env vars.
*/
encoding = getenv("LC_ALL");
if (encoding == NULL || encoding[0] == '\0') {
encoding = getenv("LC_CTYPE");
}
if (encoding == NULL || encoding[0] == '\0') {
encoding = getenv("LANG");
}
if (encoding == NULL || encoding[0] == '\0') {
encoding = NULL;
}
if (encoding != NULL) {
CONST char *p;
Tcl_DString ds;
Tcl_DStringInit(&ds);
p = encoding;
encoding = Tcl_DStringAppend(&ds, p, -1);
Tcl_UtfToLower(Tcl_DStringValue(&ds));
knownEncoding = SearchKnownEncodings(encoding);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, -1);
} else if (NULL != Tcl_GetEncoding(NULL, encoding)) {
Tcl_DStringAppend(bufPtr, encoding, -1);
}
if (Tcl_DStringLength(bufPtr)) {
Tcl_DStringFree(&ds);
return Tcl_DStringValue(bufPtr);
}
/*
* We didn't recognize the full value as an encoding name. If there is
* an encoding subfield, we can try to guess from that.
*/
for (p = encoding; *p != '\0'; p++) {
if (*p == '.') {
p++;
break;
}
}
if (*p != '\0') {
knownEncoding = SearchKnownEncodings(p);
if (knownEncoding != NULL) {
Tcl_DStringAppend(bufPtr, knownEncoding, -1);
} else if (NULL != Tcl_GetEncoding(NULL, p)) {
Tcl_DStringAppend(bufPtr, p, -1);
}
}
Tcl_DStringFree(&ds);
if (Tcl_DStringLength(bufPtr)) {
return Tcl_DStringValue(bufPtr);
}
}
return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1);
}
void
TclpInitLibraryPath(
char **valuePtr,
int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
CONST char *str;
Tcl_DString buffer;
pathPtr = Tcl_NewObj();
/*
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
str = getenv("TCL_LIBRARY"); /* INTL: Native. */
Tcl_ExternalToUtfDString(NULL, str, -1, &buffer);
str = Tcl_DStringValue(&buffer);
if ((str != NULL) && (str[0] != '\0')) {
Tcl_DString ds;
int pathc;
CONST char **pathv;
char installLib[LIBRARY_SIZE];
Tcl_DStringInit(&ds);
/*
* Initialize the substrings used when locating an executable. The
* installLib variable computes the path as though the executable is
* installed.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
/*
* If TCL_LIBRARY is set, search there.
*/
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_SplitPath(str, &pathc, &pathv);
if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
/*
* If TCL_LIBRARY is set but refers to a different tcl
* installation than the current version, try fiddling with the
* specified directory to make it refer to this installation by
* removing the old "tclX.Y" and substituting the current version
* string.
*/
pathv[pathc - 1] = installLib + 4;
str = Tcl_JoinPath(pathc, pathv, &ds);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) pathv);
}
/*
* Finally, look for the library relative to the compiled-in path. This is
* needed when users install Tcl with an exec-prefix that is different
* from the prefix.
*/
{
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
str = tclLibPath;
} else
#endif /* HAVE_COREFOUNDATION */
{
/*
* TODO: Pull this value from the TIP 59 table.
*/
str = defaultLibraryDir;
}
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
*valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1);
Tcl_DecrRefCount(pathPtr);
}
static void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
0, NULL);
if (length == 0) {
char *msgPtr;
length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
0, NULL);
if (length > 0) {
wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
length + 1);
LocalFree(msgPtr);
}
}
if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
strcpy(msgBuf, "function not supported under Win32s");
} else {
sprintf(msgBuf, "unknown error: %ld", error);
}
msg = msgBuf;
} else {
Tcl_Encoding encoding;
char *msgPtr;
encoding = Tcl_GetEncoding(NULL, "unicode");
Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
Tcl_FreeEncoding(encoding);
LocalFree(wMsgPtr);
msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
*/
if (msgPtr[length-1] == '\n') {
--length;
}
if (msgPtr[length-1] == '\r') {
--length;
}
msgPtr[length] = 0;
msg = msgPtr;
}
sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
Tcl_AppendToObj(resultPtr, msg, length);
Tcl_SetObjResult(interp, resultPtr);
if (length != 0) {
Tcl_DStringFree(&ds);
}
}
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
};
Tcl_DString conv;
Tcl_Encoding venc = NULL;
const char *value;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
pDB = GetConfigDict(interp);
if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK
|| pkgDict == NULL) {
/*
* Maybe a Tcl_Panic is better, because the package data has to be
* present.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
TclGetString(pkgName), NULL);
return TCL_ERROR;
}
switch ((enum subcmds) index) {
case CFG_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return TCL_ERROR;
}
if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
if (cdPtr->encoding) {
venc = Tcl_GetEncoding(interp, cdPtr->encoding);
if (!venc) {
return TCL_ERROR;
}
}
/*
* Value is stored as-is in a byte array, see Bug [9b2e636361],
* so we have to decode it first.
*/
value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
Tcl_DStringLength(&conv)));
Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
if (n) {
Tcl_DictSearch s;
Tcl_Obj *key;
int done;
for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
!done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
Tcl_ListObjAppendElement(NULL, listPtr, key);
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
default:
Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen");
break;
}
return TCL_ERROR;
}
/* ARGSUSED */
static int
CreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to stderrFd. */
int argc, /* Number of arguments in following array. */
char **argv, /* Array of argument strings. argv[0]
* contains the name of the executable
* converted to native format (using the
* Tcl_TranslateFileName call). Additional
* arguments have not been converted. */
int stdinFd, /* The file to use as input for the child
* process. If stdinFd file is -1, input is
* read from the standard input channel. If
* the file isn't readable, the child will
* receive no standard input. */
int stdoutFd, /* The file that receives output from the
* child process. If stdoutFd is -1, output
* is sent to the standard output channel. If
* the file is not writeable, output from the
* child will be discarded. */
int stderrFd, /* The file that receives errors from the
* child process. If stderrFd file is -1,
* errors will be sent to the standard error
* channel. If the file isn't writeable,
* errors from the child will be discarded.
* stderrFd may be the same as stdoutFd. */
int *pidPtr) /* (out) If this procedure is successful,
* pidPtr is filled with the process id of the
* child process. */
{
#if (_TCL_VERSION >= _VERSION(8,1,0))
Tcl_DString *dsArr;
Tcl_Encoding encoding;
#endif
char errSpace[200];
int errPipeIn, errPipeOut;
int i;
int joinThisError, status, fd;
long pid;
size_t count;
errPipeIn = errPipeOut = -1;
pid = -1;
#if (_TCL_VERSION >= _VERSION(8,1,0))
dsArr = Blt_AssertMalloc(argc * sizeof(Tcl_DString));
encoding = Tcl_GetEncoding(interp, NULL);
for(i = 0; i < argc; i++) {
argv[i] = Tcl_UtfToExternalDString(encoding, argv[i],
strlen(argv[i]), dsArr + i);
}
#endif
/*
* Create a pipe that the child can use to return error information if
* anything goes wrong.
*/
if (CreatePipe(interp, &errPipeIn, &errPipeOut) != TCL_OK) {
goto error;
}
joinThisError = (stderrFd == stdoutFd);
pid = fork();
if (pid == 0) {
ssize_t nWritten;
fd = errPipeOut;
/*
* Set up stdio file handles for the child process.
*/
if (!SetupStdFile(stdinFd, TCL_STDIN) ||
!SetupStdFile(stdoutFd, TCL_STDOUT) ||
(!joinThisError && !SetupStdFile(stderrFd, TCL_STDERR)) ||
(joinThisError &&
((dup2(1, 2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf_s(errSpace, 200,
"%dforked process can't set up input/output: ", errno);
nWritten = write(fd, errSpace, (size_t) strlen(errSpace));
_exit(1);
}
/*
* Close the input side of the error pipe.
*/
RestoreSignals();
execvp(argv[0], &argv[0]);
sprintf_s(errSpace, 200, "%dcan't execute \"%.150s\": ", errno, argv[0]);
nWritten = write(fd, errSpace, (size_t)strlen(errSpace));
_exit(1);
}
if (pid == -1) {
Tcl_AppendResult(interp, "can't fork child process: ",
Tcl_PosixError(interp), (char *)NULL);
goto error;
}
/*
* Read back from the error pipe to see if the child started up OK. The
* info in the pipe (if any) consists of a decimal errno value followed by
* an error message.
*/
CloseFile(errPipeOut);
errPipeOut = -1;
fd = errPipeIn;
count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
if (count > 0) {
char *end;
errSpace[count] = 0;
errno = strtol(errSpace, &end, 10);
Tcl_AppendResult(interp, end, Tcl_PosixError(interp), (char *)NULL);
goto error;
}
#if (_TCL_VERSION >= _VERSION(8,1,0))
for(i = 0; i < argc; i++) {
Tcl_DStringFree(dsArr + i);
}
Blt_Free(dsArr);
#endif
CloseFile(errPipeIn);
*pidPtr = pid;
return TCL_OK;
error:
if (pid != -1) {
/*
* Reap the child process now if an error occurred during its startup.
*/
Tcl_WaitPid((Tcl_Pid)pid, &status, WNOHANG);
}
if (errPipeIn >= 0) {
CloseFile(errPipeIn);
}
if (errPipeOut >= 0) {
CloseFile(errPipeOut);
}
#if (_TCL_VERSION >= _VERSION(8,1,0))
for(i = 0; i < argc; i++) {
Tcl_DStringFree(dsArr + i);
}
Blt_Free(dsArr);
#endif
return TCL_ERROR;
}
static int
AddClause(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
FileFilter *filterPtr, /* Stores the new filter clause */
Tcl_Obj *patternsObj, /* A Tcl list of glob patterns. */
Tcl_Obj *ostypesObj, /* A Tcl list of Mac OSType strings. */
int isWindows) /* True if we are running on Windows; False if
* we are running on the Mac; Glob patterns
* need to be processed differently on these
* two platforms */
{
Tcl_Obj **globList = NULL, **ostypeList = NULL;
int globCount, ostypeCount, i, code = TCL_OK;
FileFilterClause *clausePtr;
Tcl_Encoding macRoman = NULL;
if (Tcl_ListObjGetElements(interp, patternsObj,
&globCount, &globList) != TCL_OK) {
code = TCL_ERROR;
goto done;
}
if (ostypesObj != NULL) {
if (Tcl_ListObjGetElements(interp, ostypesObj,
&ostypeCount, &ostypeList) != TCL_OK) {
code = TCL_ERROR;
goto done;
}
/*
* We probably need this encoding now...
*/
macRoman = Tcl_GetEncoding(NULL, "macRoman");
/*
* Might be cleaner to use 'Tcl_GetOSTypeFromObj' but that is actually
* static to the MacOS X/Darwin version of Tcl, and would therefore
* require further code refactoring.
*/
for (i=0; i<ostypeCount; i++) {
int len;
const char *strType = Tcl_GetStringFromObj(ostypeList[i], &len);
/*
* If len is < 4, it is definitely an error. If equal or longer,
* we need to use the macRoman encoding to determine the correct
* length (assuming there may be non-ascii characters, e.g.,
* embedded nulls or accented characters in the string, the
* macRoman length will be different).
*
* If we couldn't load the encoding, then we can't actually check
* the correct length. But here we assume we're probably operating
* on unix/windows with a minimal set of encodings and so don't
* care about MacOS types. So we won't signal an error.
*/
if (len >= 4 && macRoman != NULL) {
Tcl_DString osTypeDS;
/*
* Convert utf to macRoman, since MacOS types are defined to
* be 4 macRoman characters long
*/
Tcl_UtfToExternalDString(macRoman, strType, len, &osTypeDS);
len = Tcl_DStringLength(&osTypeDS);
Tcl_DStringFree(&osTypeDS);
}
if (len != 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad Macintosh file type \"%s\"",
Tcl_GetString(ostypeList[i])));
Tcl_SetErrorCode(interp, "TK", "VALUE", "MAC_TYPE", NULL);
code = TCL_ERROR;
goto done;
}
}
}
/*
* Add the clause into the list of clauses
*/
clausePtr = ckalloc(sizeof(FileFilterClause));
clausePtr->patterns = NULL;
clausePtr->patternsTail = NULL;
clausePtr->macTypes = NULL;
clausePtr->macTypesTail = NULL;
if (filterPtr->clauses == NULL) {
filterPtr->clauses = filterPtr->clausesTail = clausePtr;
} else {
filterPtr->clausesTail->next = clausePtr;
filterPtr->clausesTail = clausePtr;
}
clausePtr->next = NULL;
if (globCount > 0 && globList != NULL) {
for (i=0; i<globCount; i++) {
GlobPattern *globPtr = ckalloc(sizeof(GlobPattern));
int len;
const char *str = Tcl_GetStringFromObj(globList[i], &len);
len = (len + 1) * sizeof(char);
if (str[0] && str[0] != '*') {
/*
* Prepend a "*" to patterns that do not have a leading "*"
*/
globPtr->pattern = ckalloc(len + 1);
globPtr->pattern[0] = '*';
strcpy(globPtr->pattern+1, str);
} else if (isWindows) {
if (strcmp(str, "*") == 0) {
globPtr->pattern = ckalloc(4);
strcpy(globPtr->pattern, "*.*");
} else if (strcmp(str, "") == 0) {
/*
* An empty string means "match all files with no
* extensions"
* TODO: "*." actually matches with all files on Win95
*/
globPtr->pattern = ckalloc(3);
strcpy(globPtr->pattern, "*.");
} else {
globPtr->pattern = ckalloc(len);
strcpy(globPtr->pattern, str);
}
} else {
globPtr->pattern = ckalloc(len);
strcpy(globPtr->pattern, str);
}
/*
* Add the glob pattern into the list of patterns.
*/
if (clausePtr->patterns == NULL) {
clausePtr->patterns = clausePtr->patternsTail = globPtr;
} else {
clausePtr->patternsTail->next = globPtr;
clausePtr->patternsTail = globPtr;
}
globPtr->next = NULL;
}
}
if (ostypeList != NULL && ostypeCount > 0) {
if (macRoman == NULL) {
macRoman = Tcl_GetEncoding(NULL, "macRoman");
}
for (i=0; i<ostypeCount; i++) {
Tcl_DString osTypeDS;
int len;
MacFileType *mfPtr = ckalloc(sizeof(MacFileType));
const char *strType = Tcl_GetStringFromObj(ostypeList[i], &len);
char *string;
/*
* Convert utf to macRoman, since MacOS types are defined to be 4
* macRoman characters long
*/
Tcl_UtfToExternalDString(macRoman, strType, len, &osTypeDS);
string = Tcl_DStringValue(&osTypeDS);
mfPtr->type = (OSType) string[0] << 24 | (OSType) string[1] << 16 |
(OSType) string[2] << 8 | (OSType) string[3];
Tcl_DStringFree(&osTypeDS);
/*
* Add the Mac type pattern into the list of Mac types
*/
if (clausePtr->macTypes == NULL) {
clausePtr->macTypes = clausePtr->macTypesTail = mfPtr;
} else {
clausePtr->macTypesTail->next = mfPtr;
clausePtr->macTypesTail = mfPtr;
}
mfPtr->next = NULL;
}
}
done:
if (macRoman != NULL) {
Tcl_FreeEncoding(macRoman);
}
return code;
}
/*
* Process the command line options and set the relevant static variables
* for later reference using sn_getopt().
*/
void sn_process_options(int argc, char *argv[])
{
int opt;
/* Character set encoding (as defined by Tcl). */
Tcl_FindExecutable(argv[0]);
while ((opt = getopt(argc, argv, "I:n:s:hy:g:x:i:luB:e:tCrDS:O:T:")) != EOF)
{
switch (opt)
{
case 'B':
/* silently ignore according to zkoppany */
break;
case 'C':
treat_as_cplusplus = 1;
break;
case 'D':
/* silently ignore according to zkoppany */
break;
case 'e':
if ((encoding = Tcl_GetEncoding(NULL, optarg)) == NULL)
{
sn_error("Unable to locate `%s' encoding\n", optarg);
sn_exit();
}
break;
case 'g':
group = optarg;
break;
case 'h':
highlight = 1;
break;
case 'i':
incl_to_pipe = optarg;
break;
case 'I':
includename = optarg;
break;
case 'l':
report_local_vars = 1;
break;
case 'n':
/* FIXME: Remove db prefix option later */
break;
case 'r':
comment_database = 1;
break;
case 's':
if ((outfp = fopen(optarg, "a")) == NULL)
{
sn_error("could not create %s\n", optarg);
sn_exit();
}
break;
case 'S':
/* silently ignore according to zkoppany */
break;
case 'T':
/* Dump tokens to a file and exit */
dump_tokens_file = optarg;
break;
case 't':
drop_usr_headers = 1;
break;
case 'u':
case_sensitive = 0;
break;
case 'x':
xref_filename = optarg;
break;
case 'y':
listfp = fopen(optarg, "r");
if (listfp == NULL)
{
sn_error("Could not open \"%s\", %s\n", optarg, strerror(errno));
sn_panic();
}
break;
default:
assert(0);
break;
}
}
}
Pixmap
TkpGetNativeAppBitmap(
Display *display, /* The display. */
CONST char *name, /* The name of the bitmap. */
int *width, /* The width & height of the bitmap. */
int *height)
{
Pixmap pix;
CGrafPtr savePort;
Boolean portChanged;
Rect destRect;
Handle resource;
int type = -1, destWrote;
Str255 nativeName;
Tcl_Encoding encoding;
/*
* macRoman is the encoding that the resource fork uses.
*/
encoding = Tcl_GetEncoding(NULL, "macRoman");
Tcl_UtfToExternal(NULL, encoding, name, strlen(name), 0, NULL,
(char *) &nativeName[1], 255, NULL, &destWrote, NULL);
nativeName[0] = destWrote;
Tcl_FreeEncoding(encoding);
resource = GetNamedResource('cicn', nativeName);
if (resource != NULL) {
type = TYPE3;
} else {
resource = GetNamedResource('ICON', nativeName);
if (resource != NULL) {
type = TYPE2;
}
}
if (resource == NULL) {
return (Pixmap) NULL;
}
pix = Tk_GetPixmap(display, None, 32, 32, 0);
portChanged = QDSwapPort(TkMacOSXGetDrawablePort(pix), &savePort);
SetRect(&destRect, 0, 0, 32, 32);
if (type == TYPE2) {
RGBColor black = {0, 0, 0};
RGBForeColor(&black);
PlotIcon(&destRect, resource);
ReleaseResource(resource);
} else if (type == TYPE3) {
RGBColor white = {0xFFFF, 0xFFFF, 0xFFFF};
short id;
ResType theType;
Str255 dummy;
/*
* We need to first paint the background white. Also, for some reason
* we *must* use GetCIcon instead of GetNamedResource for PlotCIcon to
* work - so we use GetResInfo to get the id.
*/
RGBForeColor(&white);
PaintRect(&destRect);
GetResInfo(resource, &id, &theType, dummy);
ReleaseResource(resource);
resource = (Handle) GetCIcon(id);
PlotCIcon(&destRect, (CIconHandle) resource);
DisposeCIcon((CIconHandle) resource);
}
*width = 32;
*height = 32;
if (portChanged) {
QDSwapPort(savePort, NULL);
}
return pix;
}
int
TkSelGetSelection(
Tcl_Interp *interp, /* Interpreter to use for reporting errors. */
Tk_Window tkwin, /* Window on whose behalf to retrieve the
* selection (determines display from which to
* retrieve). */
Atom selection, /* Selection to retrieve. */
Atom target, /* Desired form in which selection is to be
* returned. */
Tk_GetSelProc *proc, /* Procedure to call to process the selection,
* once it has been retrieved. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
char *data, *destPtr;
Tcl_DString ds;
HGLOBAL handle;
Tcl_Encoding encoding;
int result, locale;
if ((selection != Tk_InternAtom(tkwin, "CLIPBOARD"))
|| (target != XA_STRING)
|| !OpenClipboard(NULL)) {
goto error;
}
/*
* Attempt to get the data in Unicode form if available as this is less
* work that CF_TEXT.
*/
result = TCL_ERROR;
if (IsClipboardFormatAvailable(CF_UNICODETEXT)) {
handle = GetClipboardData(CF_UNICODETEXT);
if (!handle) {
CloseClipboard();
goto error;
}
data = GlobalLock(handle);
Tcl_DStringInit(&ds);
Tcl_UniCharToUtfDString((Tcl_UniChar *)data,
Tcl_UniCharLen((Tcl_UniChar *)data), &ds);
GlobalUnlock(handle);
} else if (IsClipboardFormatAvailable(CF_TEXT)) {
/*
* Determine the encoding to use to convert this text.
*/
if (IsClipboardFormatAvailable(CF_LOCALE)) {
handle = GetClipboardData(CF_LOCALE);
if (!handle) {
CloseClipboard();
goto error;
}
/*
* Get the locale identifier, determine the proper code page to
* use, and find the corresponding encoding.
*/
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "cp######", -1);
data = GlobalLock(handle);
/*
* Even though the documentation claims that GetLocaleInfo expects
* an LCID, on Windows 9x it really seems to expect a LanguageID.
*/
locale = LANGIDFROMLCID(*((int*)data));
GetLocaleInfoA(locale, LOCALE_IDEFAULTANSICODEPAGE,
Tcl_DStringValue(&ds)+2, Tcl_DStringLength(&ds)-2);
GlobalUnlock(handle);
encoding = Tcl_GetEncoding(NULL, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
} else {
encoding = NULL;
}
/*
* Fetch the text and convert it to UTF.
*/
handle = GetClipboardData(CF_TEXT);
if (!handle) {
if (encoding) {
Tcl_FreeEncoding(encoding);
}
CloseClipboard();
goto error;
}
data = GlobalLock(handle);
Tcl_ExternalToUtfDString(encoding, data, -1, &ds);
GlobalUnlock(handle);
if (encoding) {
Tcl_FreeEncoding(encoding);
}
} else {
CloseClipboard();
goto error;
}
/*
* Translate CR/LF to LF.
*/
data = destPtr = Tcl_DStringValue(&ds);
while (*data) {
if (data[0] == '\r' && data[1] == '\n') {
data++;
} else {
*destPtr++ = *data++;
}
}
*destPtr = '\0';
/*
* Pass the data off to the selection procedure.
*/
result = proc(clientData, interp, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
CloseClipboard();
return result;
error:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s selection doesn't exist or form \"%s\" not defined",
Tk_GetAtomName(tkwin, selection), Tk_GetAtomName(tkwin, target)));
Tcl_SetErrorCode(interp, "TK", "SELECTION", "EXISTS", NULL);
return TCL_ERROR;
}
int
Tclae_Init(Tcl_Interp *interp)
{
OSErr err;
SInt32 attr;
//Check for AppleEvents
err = Gestalt(gestaltAppleEventsAttr, &attr);
if ((err != noErr)
|| !(attr & (1 << gestaltAppleEventsPresent))) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "The AppleEvent Manager is either missing or misbehaving",
(char *) NULL);
}
err = AEObjectInit();
if (Tcl_InitStubs(interp, "8.0", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) {
if (TCL_VERSION[0] == '7') {
if (Tcl_PkgRequire(interp, "Tcl", "8.0", 0) == NULL) {
return TCL_ERROR;
}
}
}
if (Tcl_PkgProvide(interp, TCLAE_NAME, TCLAE_BASIC_VERSION) != TCL_OK) {
return TCL_ERROR;
}
/* Why?!? */
Tcl_SetVar(interp, "tclAE_version", TCLAE_VERSION, TCL_GLOBAL_ONLY);
tclAE_macRoman_encoding = Tcl_GetEncoding(interp,"macRoman");
TclaeInitAEAddresses();
TclaeInitAEDescs();
TclaeInitEventHandlers(interp);
TclaeInitCoercionHandlers(interp);
TclaeInitObjectAccessors(interp);
/* Define Tcl commands */
Tcl_CreateObjCommand(interp, "tclAE::build", Tclae_BuildCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::send", Tclae_SendCmd, NULL, 0L);
/* Handler commands */
Tcl_CreateObjCommand(interp, "tclAE::getCoercionHandler", Tclae_GetCoercionHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getEventHandler", Tclae_GetEventHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::installCoercionHandler", Tclae_InstallCoercionHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::installEventHandler", Tclae_InstallEventHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::removeCoercionHandler", Tclae_RemoveCoercionHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::removeEventHandler", Tclae_RemoveEventHandlerCmd, NULL, 0L);
/* Target commands */
#if !TARGET_API_MAC_CARBON && !defined(TCLAE_NO_EPPC) // das 25/10/00: Carbonization
Tcl_CreateObjCommand(interp, "tclAE::IPCListPorts", Tclae_IPCListPortsCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::PPCBrowser", Tclae_PPCBrowserCmd, NULL, 0L);
#endif
#if TARGET_API_MAC_CARBON
Tcl_CreateObjCommand(interp, "tclAE::getPOSIXPath", Tclae_GetPOSIXPathCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getHFSPath", Tclae_GetHFSPathCmd, NULL, 0L);
#endif
Tcl_CreateObjCommand(interp, "tclAE::launch", Tclae_LaunchCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::processes", Tclae_ProcessesCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::remoteProcessResolverGetProcesses", Tclae_RemoteProcessResolverGetProcessesCmd, NULL, 0L);
/* AEDesc commands */
Tcl_CreateObjCommand(interp, "tclAE::coerceData", Tclae_CoerceDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::coerceDesc", Tclae_CoerceDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::countItems", Tclae_CountItemsCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::createDesc", Tclae_CreateDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::createList", Tclae_CreateListCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::deleteItem", Tclae_DeleteItemCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::deleteKeyDesc", Tclae_DeleteKeyDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::duplicateDesc", Tclae_DuplicateDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getAttributeData", Tclae_GetAttributeDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getAttributeDesc", Tclae_GetAttributeDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getData", Tclae_GetDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getDescType", Tclae_GetDescTypeCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getKeyData", Tclae_GetKeyDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getKeyDesc", Tclae_GetKeyDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getNthData", Tclae_GetNthDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getNthDesc", Tclae_GetNthDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putData", Tclae_PutDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putDesc", Tclae_PutDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putKeyData", Tclae_PutKeyDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putKeyDesc", Tclae_PutKeyDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::replaceDescData", Tclae_ReplaceDescDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::setDescType", Tclae_SetDescTypeCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::_private::_getAEDesc", Tclae__GetAEDescCmd, NULL, 0L);
/* Object commands */
Tcl_CreateObjCommand(interp, "tclAE::setObjectCallbacks", Tclae_SetObjectCallbacksCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::resolve", Tclae_ResolveCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::callObjectAccessor", Tclae_CallObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getObjectAccessor", Tclae_GetObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::installObjectAccessor", Tclae_InstallObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::removeObjectAccessor", Tclae_RemoveObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::disposeToken", Tclae_DisposeTokenCmd, NULL, 0L);
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);
}
int sn_encoded_input(char *buf, int max_size)
{
char *rawbuf, *utf8buf;
int srcRead, dstWrote, nbytes, flags = 0;
static Tcl_EncodingState utf8_state, ascii_state;
if(encoding == NULL) {
/*
No translation necessary. Just look for CRLF
sequences and remove the CR character.
*/
size_t read = fread(buf, sizeof(char), max_size, yyin);
read -= translate_crlf(buf, read);
return read;
}
if(ascii == NULL) {
ascii = Tcl_GetEncoding(NULL, "ascii");
if(ascii == NULL) {
fprintf(stderr, "Unable to locate `ascii' encoding\n");
return 0;
}
}
if(start_of_file) {
flags |= TCL_ENCODING_START;
}
if((rawbuf = (char *) ckalloc(max_size)) == NULL) {
/* Insufficient memory. */
return 0;
}
/* FIXME: This ought to do it. */
if((utf8buf = (char *) ckalloc(2 * max_size)) == NULL) {
/* Insufficient memory. */
return 0;
}
/* Read max_size bytes from disk. */
nbytes = fread(rawbuf, sizeof(unsigned char), sizeof(rawbuf), yyin);
if(nbytes == 0) {
/*
Continue on with an empty buffer; this allows the Tcl
encoding routines to do any necessary finalisation.
See the Encoding(n) man page.
*/
flags = TCL_ENCODING_END;
}
/* Translate encoded file data into UTF-8. */
Tcl_ExternalToUtf(NULL, encoding, rawbuf, nbytes, flags,
&utf8_state, utf8buf, 2 * max_size,
&srcRead, &dstWrote, NULL);
/* Look for CRLF sequences and remove the CR characters */
dstWrote -= translate_crlf(utf8buf, dstWrote);
/*
FIXME This code assumes that an encoded stream `n' bytes long
will always reduce down to an ASCII stream no longer than `n'
bytes. This is a reasonable assumption, but probably not
foolproof.
*/
/* Translate this from UTF-8 to ASCII. */
Tcl_UtfToExternal(NULL, ascii, utf8buf, dstWrote, flags,
&ascii_state, buf, max_size,
&srcRead, &dstWrote, NULL);
if(dstWrote > 0 && start_of_file) {
start_of_file = 0;
}
ckfree(utf8buf);
ckfree(rawbuf);
return dstWrote;
}
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
#ifdef __CYGWIN__
int length;
char buf[PATH_MAX * 2];
char name[PATH_MAX * TCL_UTF_MAX + 1];
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
/* Strip '.exe' part. */
length -= 4;
}
encoding = Tcl_GetEncoding(NULL, NULL);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), encoding);
#else
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
if (argv0 == NULL) {
return;
}
Tcl_DStringInit(&buffer);
name = argv0;
for (p = name; *p != '\0'; p++) {
if (*p == '/') {
/*
* The name contains a slash, so use the name directly without
* doing a path search.
*/
goto gotName;
}
}
p = getenv("PATH"); /* INTL: Native. */
if (p == NULL) {
/*
* There's no PATH environment variable; use the default that is used
* by sh.
*/
p = ":/bin:/usr/bin";
} else if (*p == '\0') {
/*
* An empty path is equivalent to ".".
*/
p = "./";
}
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
while (TclIsSpaceProc(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
TclDStringClear(&buffer);
if (p != name) {
Tcl_DStringAppend(&buffer, name, p - name);
if (p[-1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
}
name = Tcl_DStringAppend(&buffer, argv0, -1);
/*
* INTL: The following calls to access() and stat() should not be
* converted to Tclp routines because they need to operate on native
* strings directly.
*/
if ((access(name, X_OK) == 0) /* INTL: Native. */
&& (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */
&& S_ISREG(statBuf.st_mode)) {
goto gotName;
}
if (*p == '\0') {
break;
} else if (*(p+1) == 0) {
p = "./";
} else {
p++;
}
}
TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
goto done;
/*
* If the name starts with "/" then just store it
*/
gotName:
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDString(encoding, name, -1, &utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
goto done;
}
if (TclpGetCwd(NULL, &cwd) == NULL) {
TclSetObjNameOfExecutable(Tcl_NewObj(), NULL);
goto done;
}
/*
* The name is relative to the current working directory. First strip off
* a leading "./", if any, then add the full path name of the current
* working directory.
*/
if ((name[0] == '.') && (name[1] == '/')) {
name += 2;
}
Tcl_DStringInit(&nameString);
Tcl_DStringAppend(&nameString, name, -1);
Tcl_DStringFree(&buffer);
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), &buffer);
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
encoding = Tcl_GetEncoding(NULL, NULL);
Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1,
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
#endif
}
void Init(CCore* Root) {
const char * const *argv;
CModuleImplementation::Init(Root);
g_Bouncer = Root;
const char *ConfigFile = g_Bouncer->BuildPathConfig("sbnc.tcl");
struct stat statbuf;
if (stat(ConfigFile, &statbuf) < 0) {
FILE *ConfigFd = fopen(ConfigFile, "wb");
if (ConfigFd == NULL) {
g_Bouncer->Log("Could not create 'sbnc.tcl' file.");
g_Bouncer->Fatal();
}
const char *ConfigDistFile = g_Bouncer->BuildPathShared("scripts/sbnc.tcl.dist");
FILE *ConfigDistFd = fopen(ConfigDistFile, "rb");
if (ConfigDistFd == NULL) {
ConfigFile = g_Bouncer->BuildPathConfig("sbnc.tcl");
unlink(ConfigFile);
g_Bouncer->Log("Could not open 'sbnc.tcl.dist' file.");
g_Bouncer->Fatal();
}
while (!feof(ConfigDistFd) && !ferror(ConfigDistFd)) {
size_t Count;
char Buffer[1024];
Count = fread(Buffer, 1, sizeof(Buffer), ConfigDistFd);
if (fwrite(Buffer, 1, Count, ConfigFd) < Count) {
g_Bouncer->Log("Could not write to 'sbnc.tcl' file.");
g_Bouncer->Fatal();
}
}
fclose(ConfigDistFd);
fclose(ConfigFd);
}
const char *ScriptsDir = g_Bouncer->BuildPathConfig("scripts");
if (mkdir(ScriptsDir) < 0 && errno != EEXIST) {
g_Bouncer->Log("Could not create 'scripts' directory.");
g_Bouncer->Fatal();
}
g_TclListeners = new CHashtable<CTclSocket*, false>();
g_TclClientSockets = new CHashtable<CTclClientSocket*, false>();
argv = GetCore()->GetArgV();
Tcl_FindExecutable(argv[0]);
Tcl_SetSystemEncoding(NULL, "ISO8859-1");
g_Encoding = Tcl_GetEncoding(g_Interp, "ISO8859-1");
g_Interp = Tcl_CreateInterp();
Tcl_InitMemory(g_Interp);
Tcl_SetVar(g_Interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
Tcl_AppInit(g_Interp);
Tcl_Preserve(g_Interp);
Tcl_Eval(g_Interp,
"rename source tcl_source\n"
"\n"
"# TODO: add support for -rsrc and -rsrcid\n"
"proc source {args} {\n"
" set file [lindex $args end]\n"
"\n"
" set has_shared_file [file isfile [file join [bncshareddir] $file]]\n"
" set has_user_file [file isfile [file join [bncconfigdir] $file]]\n"
"\n"
" if {!$has_user_file && $has_shared_file} {\n"
" set file [file join [bncshareddir] $file]\n"
" }\n"
"\n"
" uplevel 1 tcl_source [lreplace $args end end $file]\n"
"}");
Tcl_EvalFile(g_Interp, "./sbnc.tcl");
}
