/*
* Make the executable exit due to some error with the error code expected by
* S-N.
*/
void sn_exit()
{
if (encoding) {
Tcl_FreeEncoding(encoding);
Tcl_Finalize();
}
exit(1);
}
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;
}
void Destroy(void) {
CallBinds(Type_Unload, NULL, NULL, 0, NULL);
Tcl_FreeEncoding(g_Encoding);
Tcl_DeleteInterp(g_Interp);
Tcl_Release(g_Interp);
g_Interp = NULL;
Tcl_Finalize();
int i = 0;
while (hash_t<CTclSocket*>* p = g_TclListeners->Iterate(i)) {
static_cast<CSocketEvents*>(p->Value)->Destroy();
}
delete g_TclListeners;
i = 0;
while (hash_t<CTclClientSocket*>* p = g_TclClientSockets->Iterate(i++)) {
p->Value->Destroy();
}
delete g_TclClientSockets;
for (int a = 0; a < g_TimerCount; a++) {
if (g_Timers[a]) {
g_Timers[a]->timer->Destroy();
free(g_Timers[a]->proc);
free(g_Timers[a]->param);
}
}
delete this;
}
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
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;
}
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;
}
