SEXP RTcl_ObjAsCharVector(SEXP args)
{
int count;
Tcl_Obj **elem, *obj;
int ret, i;
SEXP ans;
obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));
ret = Tcl_ListObjGetElements(RTcl_interp, obj, &count, &elem);
if (ret != TCL_OK)
return RTcl_StringFromObj(args);
PROTECT(ans = allocVector(STRSXP, count));
for (i = 0 ; i < count ; i++) {
char *s;
Tcl_DString s_ds;
Tcl_DStringInit(&s_ds);
/* FIXME: could use UTF-8 here */
s = Tcl_UtfToExternalDString(NULL,
(Tcl_GetStringFromObj(elem[i], NULL)),
-1, &s_ds);
SET_STRING_ELT(ans, i, mkChar(s));
Tcl_DStringFree(&s_ds);
}
UNPROTECT(1);
return ans;
}
Tcl_PackageInitProc *
TclpFindSymbol(
Tcl_Interp *interp, /* Place to put error messages. */
Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */
const char *symbol) /* Symbol to look up. */
{
const char *native;
Tcl_DString newName, ds;
void *handle = (void *) loadHandle;
Tcl_PackageInitProc *proc;
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again with
* the underscore.
*/
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
native);
if (proc == NULL) {
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
native = Tcl_DStringAppend(&newName, native, -1);
proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
native);
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
return proc;
}
TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
int fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, NULL);
if (fd == -1) {
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
if (contents != NULL) {
Tcl_DString dstring;
char *native;
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
}
return MakeFile(fd);
}
static Tcl_Obj * tk_eval(const char *cmd)
{
char *cmd_utf8;
Tcl_DString cmd_utf8_ds;
Tcl_DStringInit(&cmd_utf8_ds);
cmd_utf8 = Tcl_ExternalToUtfDString(NULL, cmd, -1, &cmd_utf8_ds);
if (Tcl_Eval(RTcl_interp, cmd_utf8) == TCL_ERROR)
{
char p[512];
if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500)
strcpy(p, _("tcl error.\n"));
else {
char *res;
Tcl_DString res_ds;
Tcl_DStringInit(&res_ds);
res = Tcl_UtfToExternalDString(NULL,
Tcl_GetStringResult(RTcl_interp),
-1, &res_ds);
snprintf(p, sizeof(p), "[tcl] %s.\n", res);
Tcl_DStringFree(&res_ds);
}
error(p);
}
Tcl_DStringFree(&cmd_utf8_ds);
return Tcl_GetObjResult(RTcl_interp);
}
int
TclSockGetPort(
Tcl_Interp *interp,
const char *string, /* Integer or service name */
const char *proto, /* "tcp" or "udp", typically */
int *portPtr) /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
Tcl_DString ds;
const char *native;
if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
/*
* Don't bother translating 'proto' to native.
*/
native = Tcl_UtfToExternalDString(NULL, string, -1, &ds);
sp = getservbyname(native, proto); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (sp != NULL) {
*portPtr = ntohs((unsigned short) sp->s_port);
return TCL_OK;
}
}
if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
return TCL_ERROR;
}
if (*portPtr > 0xFFFF) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't open socket: port number too high", -1));
return TCL_ERROR;
}
return TCL_OK;
}
char *
TclpReadlink(
const char *path, /* Path of file to readlink (UTF-8). */
Tcl_DString *linkPtr) /* Uninitialized or free DString filled with
* contents of link (UTF-8). */
{
#ifndef DJGPP
char link[MAXPATHLEN];
int length;
const char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
#else
return NULL;
#endif /* !DJGPP */
}
TclFile
TclpOpenFile(
const char *fname, /* The name of the file to open. */
int mode) /* In what mode to open the file? */
{
int fd;
const char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
fd = TclOSopen(native, mode, 0666); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (fd != -1) {
fcntl(fd, F_SETFD, FD_CLOEXEC);
/*
* If the file is being opened for writing, seek to the end so we can
* append to any data already in the file.
*/
if ((mode & O_WRONLY) && !(mode & O_APPEND)) {
TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
}
/*
* Increment the fd so it can't be 0, which would conflict with the
* NULL return for errors.
*/
return MakeFile(fd);
}
return NULL;
}
int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
{
shl_t handle;
CONST char *native;
char *fileName = Tcl_GetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at the
* suggestion of Wolfgang Kechel ([email protected]): "This enables
* verbosity for missing symbols when loading a shared lib and allows to
* load libtk8.0.sl into tclsh8.0 without problems. In general, this
* delays resolving symbols until they are actually needed. Shared libs
* do no longer need all libraries linked in when they are build."
*/
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE, 0L);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
*loadHandle = (Tcl_LoadHandle) handle;
*unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
SEXP dotTclObjv(SEXP args)
{
SEXP t,
avec = CADR(args),
nm = getAttrib(avec, R_NamesSymbol);
int objc, i, result;
Tcl_Obj **objv;
const void *vmax = vmaxget();
for (objc = 0, i = 0; i < length(avec); i++){
if (!isNull(VECTOR_ELT(avec, i)))
objc++;
if (!isNull(nm) && strlen(translateChar(STRING_ELT(nm, i))))
objc++;
}
objv = (Tcl_Obj **) R_alloc(objc, sizeof(Tcl_Obj *));
for (objc = i = 0; i < length(avec); i++){
const char *s;
char *tmp;
if (!isNull(nm) && strlen(s = translateChar(STRING_ELT(nm, i)))){
tmp = calloc(strlen(s)+2, sizeof(char));
*tmp = '-';
strcpy(tmp+1, s);
objv[objc++] = Tcl_NewStringObj(tmp, -1);
free(tmp);
}
if (!isNull(t = VECTOR_ELT(avec, i)))
objv[objc++] = (Tcl_Obj *) R_ExternalPtrAddr(t);
}
for (i = objc; i--; ) Tcl_IncrRefCount(objv[i]);
result = Tcl_EvalObjv(RTcl_interp, objc, objv, 0);
for (i = objc; i--; ) Tcl_DecrRefCount(objv[i]);
if (result == TCL_ERROR)
{
char p[512];
if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500)
strcpy(p, _("tcl error.\n"));
else {
char *res;
Tcl_DString res_ds;
Tcl_DStringInit(&res_ds);
res = Tcl_UtfToExternalDString(NULL,
Tcl_GetStringResult(RTcl_interp),
-1, &res_ds);
snprintf(p, sizeof(p), "[tcl] %s.\n", res);
Tcl_DStringFree(&res_ds);
}
error(p);
}
SEXP res = makeRTclObject(Tcl_GetObjResult(RTcl_interp));
vmaxset(vmax);
return res;
}
int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
{
void *handle;
const char *native;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
const char *errorStr = dlerror();
Tcl_AppendResult(interp, "couldn't load file \"",
Tcl_GetString(pathPtr), "\": ", errorStr, NULL);
return TCL_ERROR;
}
*unloadProcPtr = &TclpUnloadFile;
*loadHandle = (Tcl_LoadHandle) handle;
return TCL_OK;
}
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;
}
int
Ns_ConnFlush(Ns_Conn *conn, char *buf, int len, int stream)
{
Conn *connPtr = (Conn *) conn;
NsServer *servPtr = connPtr->servPtr;
Tcl_Encoding encoding;
Tcl_DString enc, gzip;
char *ahdr;
int status;
Tcl_DStringInit(&enc);
Tcl_DStringInit(&gzip);
if (len < 0) {
len = strlen(buf);
}
/*
* Encode content to the expected charset.
*/
encoding = Ns_ConnGetEncoding(conn);
if (encoding != NULL) {
Tcl_UtfToExternalDString(encoding, buf, len, &enc);
buf = enc.string;
len = enc.length;
}
/*
* GZIP the content when not streaming if enabled and the content
* length is above the minimum.
*/
if (!stream
&& (conn->flags & NS_CONN_GZIP)
&& (servPtr->opts.flags & SERV_GZIP)
&& (len > (int) servPtr->opts.gzipmin)
&& (ahdr = Ns_SetIGet(conn->headers, "Accept-Encoding")) != NULL
&& strstr(ahdr, "gzip") != NULL
&& Ns_Gzip(buf, len, servPtr->opts.gziplevel, &gzip) == NS_OK) {
buf = gzip.string;
len = gzip.length;
Ns_ConnCondSetHeaders(conn, "Content-Encoding", "gzip");
}
/*
* Flush content.
*/
status = Ns_ConnFlushDirect(conn, buf, len, stream);
Tcl_DStringFree(&enc);
Tcl_DStringFree(&gzip);
return status;
}
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
if (!winTCharEncoding) {
winTCharEncoding = Tcl_GetEncoding(0, "unicode");
}
return Tcl_UtfToExternalDString(winTCharEncoding,
string, len, dsPtr);
}
ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
char *nativePathPtr;
const char *str;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
size_t len;
if (TclFSCwdIsNative()) {
/*
* The cwd is native, which means we can use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetString(validPathPtr);
len = validPathPtr->length;
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = ckalloc(len);
memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return nativePathPtr;
}
static void *
FindSymbol(
Tcl_Interp *interp, /* Place to put error messages. */
Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */
const char *symbol) /* Symbol to look up. */
{
const char *native; /* Name of the library to be loaded, in
* system encoding */
Tcl_DString newName, ds; /* Buffers for converting the name to
* system encoding and prepending an
* underscore*/
void *handle = (void *) loadHandle->clientData;
/* Native handle to the loaded library */
void *proc; /* Address corresponding to the resolved
* symbol */
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again with
* the underscore.
*/
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
proc = dlsym(handle, native); /* INTL: Native. */
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
if (proc == NULL) {
const char *errorStr = dlerror();
if (interp) {
if (!errorStr) {
errorStr = "unknown";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errorStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
}
return proc;
}
char *
Ns_EncodeUrlWithEncoding(Ns_DString *dsPtr, char *string, Tcl_Encoding encoding)
{
register int i, n;
register char *p, *q;
Tcl_DString ds;
Tcl_DStringInit(&ds);
if (encoding != NULL) {
string = Tcl_UtfToExternalDString(encoding, string, -1, &ds);
}
/*
* Determine and set the required dstring length.
*/
p = string;
n = 0;
while ((i = UCHAR(*p)) != 0) {
n += enc[i].len;
++p;
}
i = dsPtr->length;
Ns_DStringSetLength(dsPtr, dsPtr->length + n);
/*
* Copy the result directly to the pre-sized dstring.
*/
q = dsPtr->string + i;
p = string;
while ((i = UCHAR(*p)) != 0) {
if (UCHAR(*p) == ' ') {
*q++ = '+';
} else if (enc[i].str == NULL) {
*q++ = *p;
} else {
*q++ = '%';
*q++ = enc[i].str[0];
*q++ = enc[i].str[1];
}
++p;
}
Tcl_DStringFree(&ds);
return dsPtr->string;
}
int
Ns_WriteCharConn(Ns_Conn *conn, char *buf, int len)
{
Tcl_Encoding encoding;
Tcl_DString enc;
int status;
Tcl_DStringInit(&enc);
encoding = Ns_ConnGetEncoding(conn);
if (encoding != NULL) {
Tcl_UtfToExternalDString(encoding, buf, len, &enc);
buf = enc.string;
len = enc.length;
}
status = Ns_WriteConn(conn, buf, len);
Tcl_DStringFree(&enc);
return status;
}
SEXP RTcl_StringFromObj(SEXP args)
{
char *str;
SEXP so;
char *s;
Tcl_DString s_ds;
Tcl_Obj *obj;
obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));
Tcl_DStringInit(&s_ds);
str = Tcl_GetStringFromObj(obj, NULL);
/* FIXME: could use UTF-8 here */
s = Tcl_UtfToExternalDString(NULL, str, -1, &s_ds);
so = mkString(s);
Tcl_DStringFree(&s_ds);
return(so);
}
ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
{
char *nativePathPtr;
Tcl_DString ds;
Tcl_Obj *validPathPtr;
int len;
char *str;
if (TclFSCwdIsNative()) {
/*
* The cwd is native, which means we can use the translated path
* without worrying about normalization (this will also usually be
* shorter so the utf-to-external conversion will be somewhat faster).
*/
validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
} else {
/*
* Make sure the normalized path is set.
*/
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = ckalloc((unsigned) len);
memcpy((void*)nativePathPtr, (void*)Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
const char *
TclpGetUserHome(
const char *name, /* User name for desired home directory. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
struct passwd *pwPtr;
Tcl_DString ds;
const char *native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr);
return Tcl_DStringValue(bufferPtr);
}
SEXP dotTclcallback(SEXP args)
{
SEXP ans, callback = CADR(args), env;
char buff[BUFFLEN];
char *s;
Tcl_DString s_ds;
if (isFunction(callback))
callback_closure(buff, BUFFLEN, callback);
else if (isLanguage(callback)) {
env = CADDR(args);
callback_lang(buff, BUFFLEN, callback, env);
}
else
error(_("argument is not of correct type"));
Tcl_DStringInit(&s_ds);
s = Tcl_UtfToExternalDString(NULL, buff, -1, &s_ds);
ans = mkString(s);
Tcl_DStringFree(&s_ds);
return ans;
}
TclFile
TclpCreateTempFile(
const char *contents) /* String to write into temp file, or NULL. */
{
char fileName[L_tmpnam + 9];
const char *native;
Tcl_DString dstring;
int fd;
/*
* We should also check against making more then TMP_MAX of these.
*/
strcpy(fileName, P_tmpdir); /* INTL: Native. */
if (fileName[strlen(fileName) - 1] != '/') {
strcat(fileName, "/"); /* INTL: Native. */
}
strcat(fileName, "tclXXXXXX");
fd = mkstemp(fileName); /* INTL: Native. */
if (fd == -1) {
return NULL;
}
fcntl(fd, F_SETFD, FD_CLOEXEC);
unlink(fileName); /* INTL: Native. */
if (contents != NULL) {
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
if (write(fd, native, strlen(native)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
}
return MakeFile(fd);
}
void
TkSuspendClipboard()
{
TkClipboardTarget *targetPtr;
TkClipboardBuffer *cbPtr;
TkDisplay *dispPtr;
char *buffer, *p, *endPtr, *buffPtr;
long length;
dispPtr = TkGetDisplayList();
if ((dispPtr == NULL) || !dispPtr->clipboardActive) {
return;
}
for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL;
targetPtr = targetPtr->nextPtr) {
if (targetPtr->type == XA_STRING)
break;
}
if (targetPtr != NULL) {
Tcl_DString encodedText;
length = 0;
for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL;
cbPtr = cbPtr->nextPtr) {
length += cbPtr->length;
}
buffer = ckalloc(length);
buffPtr = buffer;
for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL;
cbPtr = cbPtr->nextPtr) {
for (p = cbPtr->buffer, endPtr = p + cbPtr->length;
p < endPtr; p++) {
if (*p == '\n') {
*buffPtr++ = '\r';
} else {
*buffPtr++ = *p;
}
}
}
ZeroScrap();
Tcl_UtfToExternalDString(NULL, buffer, length, &encodedText);
PutScrap(Tcl_DStringLength(&encodedText), 'TEXT',
Tcl_DStringValue(&encodedText));
Tcl_DStringFree(&encodedText);
ckfree(buffer);
}
/*
* The system now owns the scrap. We tell Tk that it has
* lost the selection so that it will look for it the next time
* it needs it. (Window list NULL if quiting.)
*/
if (TkGetMainInfoList() != NULL) {
Tk_ClearSelection((Tk_Window) TkGetMainInfoList()->winPtr,
Tk_InternAtom((Tk_Window) TkGetMainInfoList()->winPtr,
"CLIPBOARD"));
}
return;
}
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
const char *src = Tcl_FSGetNativePath(pathPtr);
const char *target = NULL;
if (src == NULL) {
return NULL;
}
/*
* If we're making a symbolic link and the path is relative, then we
* must check whether it exists _relative_ to the directory in which
* the src is found (not relative to the current cwd which is just not
* relevant in this case).
*
* If we're making a hard link, then a relative path is just converted
* to absolute relative to the cwd.
*/
if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
Tcl_Obj *dirPtr, *absPtr;
dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return NULL;
}
absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
Tcl_IncrRefCount(absPtr);
if (Tcl_FSAccess(absPtr, F_OK) == -1) {
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
target = Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
if (access(target, F_OK) == -1) {
/*
* Target doesn't exist.
*/
errno = ENOENT;
return NULL;
}
}
if (access(src, F_OK) != -1) {
/*
* Src exists.
*/
errno = EEXIST;
return NULL;
}
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
int targetLen;
Tcl_DString ds;
Tcl_Obj *transPtr;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = TclGetStringFromObj(transPtr, &targetLen);
target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
toPtr = NULL;
}
Tcl_DStringFree(&ds);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
if (link(target, src) != 0) {
return NULL;
}
} else {
errno = ENODEV;
return NULL;
}
return toPtr;
} else {
Tcl_Obj *linkPtr = NULL;
char link[MAXPATHLEN];
int length;
Tcl_DString ds;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = TclDStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
return linkPtr;
}
}
int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
void *handle;
Tcl_LoadHandle newHandle;
const char *native;
int dlopenflags = 0;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
}
if (flags & TCL_LOAD_LAZY) {
dlopenflags |= RTLD_LAZY;
} else {
dlopenflags |= RTLD_NOW;
}
handle = dlopen(native, dlopenflags);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
const char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
handle = dlopen(native, dlopenflags);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
const char *errorStr = dlerror();
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
Tcl_GetString(pathPtr), errorStr));
}
return TCL_ERROR;
}
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
}
MODULE_SCOPE int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle;
#if TCL_DYLD_USE_DLFCN
void *dlHandle = NULL;
#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
const struct mach_header *dyldLibHeader = NULL;
Tcl_DyldModuleHandle *modulePtr = NULL;
#endif
#if TCL_DYLD_USE_NSMODULE
NSLinkEditErrors editError;
int errorNumber;
const char *errorName, *objFileImageErrMsg = NULL;
#endif
const char *errMsg = NULL;
int result;
Tcl_DString ds;
char *fileName = NULL;
const char *nativePath, *nativeFileName = NULL;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = Tcl_FSGetNativePath(pathPtr);
#if TCL_DYLD_USE_DLFCN
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
if (tclMacOSXDarwinRelease >= 8)
#endif
{
dlHandle = dlopen(nativePath, RTLD_NOW | RTLD_LOCAL);
if (!dlHandle) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
fileName = Tcl_GetString(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
dlHandle = dlopen(nativeFileName, RTLD_NOW | RTLD_LOCAL);
}
if (dlHandle) {
TclLoadDbgMsg("dlopen() successful");
} else {
errMsg = dlerror();
TclLoadDbgMsg("dlopen() failed: %s", errMsg);
}
}
if (!dlHandle)
#endif /* TCL_DYLD_USE_DLFCN */
{
#if TCL_DYLD_USE_NSMODULE
dyldLibHeader = NSAddImage(nativePath,
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
if (dyldLibHeader) {
TclLoadDbgMsg("NSAddImage() successful");
} else {
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
if (editError == NSLinkEditFileAccessError) {
/*
* The requested file was not found. Let the OS loader examine
* the binary search path for whatever string the user gave us
* which hopefully refers to a file on the binary path.
*/
if (!fileName) {
fileName = Tcl_GetString(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, fileName,
-1, &ds);
}
dyldLibHeader = NSAddImage(nativeFileName,
NSADDIMAGE_OPTION_WITH_SEARCHING |
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
if (dyldLibHeader) {
TclLoadDbgMsg("NSAddImage() successful");
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
TclLoadDbgMsg("NSAddImage() failed: %s", errMsg);
}
} else if ((editError == NSLinkEditFileFormatError
&& errorNumber == EBADMACHO)
|| editError == NSLinkEditOtherError){
NSObjectFileImageReturnCode err;
NSObjectFileImage dyldObjFileImage;
NSModule module;
/*
* The requested file was found but was not of type MH_DYLIB,
* attempt to load it as a MH_BUNDLE.
*/
err = NSCreateObjectFileImageFromFile(nativePath,
&dyldObjFileImage);
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
TclLoadDbgMsg("NSCreateObjectFileImageFromFile() "
"successful");
module = NSLinkModule(dyldObjFileImage, nativePath,
NSLINKMODULE_OPTION_BINDNOW
| NSLINKMODULE_OPTION_RETURN_ON_ERROR);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
modulePtr = (Tcl_DyldModuleHandle *)
ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
TclLoadDbgMsg("NSLinkModule() successful");
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
TclLoadDbgMsg("NSLinkModule() failed: %s", errMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
TclLoadDbgMsg("NSCreateObjectFileImageFromFile() failed: "
"%s", objFileImageErrMsg);
}
}
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
if (0
#if TCL_DYLD_USE_DLFCN
|| dlHandle
#endif
#if TCL_DYLD_USE_NSMODULE
|| dyldLibHeader || modulePtr
#endif
) {
dyldLoadHandle = (Tcl_DyldLoadHandle *)
ckalloc(sizeof(Tcl_DyldLoadHandle));
#if TCL_DYLD_USE_DLFCN
dyldLoadHandle->dlHandle = dlHandle;
#endif
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
#endif
*loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
*unloadProcPtr = &TclpUnloadFile;
result = TCL_OK;
} else {
Tcl_AppendResult(interp, errMsg, NULL);
#if TCL_DYLD_USE_NSMODULE
if (objFileImageErrMsg) {
Tcl_AppendResult(interp, "\nNSCreateObjectFileImageFromFile() "
"error: ", objFileImageErrMsg, NULL);
}
#endif
result = TCL_ERROR;
}
if(fileName) {
Tcl_DStringFree(&ds);
}
return result;
}
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
}
int
TclpMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive errors. */
Tcl_Obj *resultPtr, /* List object to lappend results. */
Tcl_Obj *pathPtr, /* Contains path to directory to search. */
const char *pattern, /* Pattern to match against. */
Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
const char *native;
Tcl_Obj *fileNamePtr;
int matchResult = 0;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
/*
* The native filesystem never adds mounts.
*/
return TCL_OK;
}
fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (fileNamePtr == NULL) {
return TCL_ERROR;
}
if (pattern == NULL || (*pattern == '\0')) {
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
const char *nativeTail;
native = Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
int dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = TclGetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
* foo.c" would return "./foo.c".
*/
if (dirLength == 0) {
dirName = ".";
} else {
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
dirName = TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read directory \"%s\": %s",
Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp)));
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
nativeDirLen = Tcl_DStringLength(&ds);
/*
* Check to see if -type or the pattern requests hidden files.
*/
matchHiddenPat = (pattern[0] == '.')
|| ((pattern[0] == '\\') && (pattern[1] == '.'));
matchHidden = matchHiddenPat
|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */
Tcl_DString utfDs;
const char *utfname;
/*
* Skip this file if it doesn't agree with the hidden parameters
* requested by the user (via -type or pattern).
*/
if (*entryPtr->d_name == '.') {
if (!matchHidden) {
continue;
}
} else {
#ifdef MAC_OSX_TCL
if (matchHiddenPat) {
continue;
}
/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
#else
if (matchHidden) {
continue;
}
#endif
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
Tcl_DStringLength(&utfDs)));
}
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
closedir(d);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
}
if (matchResult < 0) {
return TCL_ERROR;
}
return TCL_OK;
}
/* ARGSUSED */
int
TclpCreateProcess(
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 errorFile. */
int argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings in UTF-8.
* argv[0] contains the name of the executable
* translated using Tcl_TranslateFileName
* call). Additional arguments have not been
* converted. */
TclFile inputFile, /* If non-NULL, gives the file to use as input
* for the child process. If inputFile file is
* not readable or is NULL, the child will
* receive no standard input. */
TclFile outputFile, /* If non-NULL, gives the file that receives
* output from the child process. If
* outputFile file is not writeable or is
* NULL, output from the child will be
* discarded. */
TclFile errorFile, /* If non-NULL, gives the file that receives
* errors from the child process. If errorFile
* file is not writeable or is NULL, errors
* from the child will be discarded. errorFile
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *dsArray;
char **newArgv;
int pid, i;
errPipeIn = NULL;
errPipeOut = NULL;
pid = -1;
/*
* Create a pipe that the child can use to return error information if
* anything goes wrong.
*/
if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) {
Tcl_AppendResult(interp, "couldn't create pipe: ",
Tcl_PosixError(interp), NULL);
goto error;
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
dsArray = (Tcl_DString *)
TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = (char **) TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
#ifdef USE_VFORK
/*
* After vfork(), do not call code in the child that changes global state,
* because it is using the parent's memory space at that point and writes
* might corrupt the parent: so ensure standard channels are initialized in
* the parent, otherwise SetupStdFile() might initialize them in the child.
*/
if (!inputFile) {
Tcl_GetStdChannel(TCL_STDIN);
}
if (!outputFile) {
Tcl_GetStdChannel(TCL_STDOUT);
}
if (!errorFile) {
Tcl_GetStdChannel(TCL_STDERR);
}
#endif
pid = fork();
if (pid == 0) {
int joinThisError = errorFile && (errorFile == outputFile);
fd = GetFd(errPipeOut);
/*
* Set up stdio file handles for the child process.
*/
if (!SetupStdFile(inputFile, TCL_STDIN)
|| !SetupStdFile(outputFile, TCL_STDOUT)
|| (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
|| (joinThisError &&
((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) {
sprintf(errSpace,
"%dforked process couldn't set up input/output: ", errno);
(void)write(fd, errSpace, (size_t) strlen(errSpace));
_exit(1);
}
/*
* Close the input side of the error pipe.
*/
RestoreSignals();
execvp(newArgv[0], newArgv); /* INTL: Native. */
sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]);
(void)write(fd, errSpace, (size_t) strlen(errSpace));
_exit(1);
}
/*
* Free the mem we used for the fork
*/
for (i = 0; i < argc; i++) {
Tcl_DStringFree(&dsArray[i]);
}
TclStackFree(interp, newArgv);
TclStackFree(interp, dsArray);
if (pid == -1) {
Tcl_AppendResult(interp, "couldn't fork child process: ",
Tcl_PosixError(interp), 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.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(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), NULL);
goto error;
}
TclpCloseFile(errPipeIn);
*pidPtr = (Tcl_Pid) INT2PTR(pid);
return TCL_OK;
error:
if (pid != -1) {
/*
* Reap the child process now if an error occurred during its startup.
* We don't call this with WNOHANG because that can lead to defunct
* processes on an MP system. We shouldn't have to worry about hanging
* here, since this is the error case. [Bug: 6148]
*/
Tcl_WaitPid((Tcl_Pid) INT2PTR(pid), &status, 0);
}
if (errPipeIn) {
TclpCloseFile(errPipeIn);
}
if (errPipeOut) {
TclpCloseFile(errPipeOut);
}
return TCL_ERROR;
}
MODULE_SCOPE Tcl_PackageInitProc *
TclpFindSymbol(
Tcl_Interp *interp, /* For error reporting. */
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
CONST char *symbol) /* Symbol name to look up. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
Tcl_PackageInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
#if TCL_DYLD_USE_DLFCN
if (dyldLoadHandle->dlHandle) {
proc = dlsym(dyldLoadHandle->dlHandle, native);
if (proc) {
TclLoadDbgMsg("dlsym() successful");
} else {
errMsg = dlerror();
TclLoadDbgMsg("dlsym() failed: %s", errMsg);
}
} else
#endif /* TCL_DYLD_USE_DLFCN */
{
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
Tcl_DString newName;
/*
* dyld adds an underscore to the beginning of symbol names.
*/
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
native = Tcl_DStringAppend(&newName, native, -1);
if (dyldLoadHandle->dyldLibHeader) {
nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader,
native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
if (nsSymbol) {
TclLoadDbgMsg("NSLookupSymbolInImage() successful");
#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING
/*
* Until dyld supports unloading of MY_DYLIB binaries, the
* following is not needed.
*/
NSModule module = NSModuleForSymbol(nsSymbol);
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
modulePtr = (Tcl_DyldModuleHandle *)
ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = dyldLoadHandle->modulePtr;
dyldLoadHandle->modulePtr = modulePtr;
}
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
TclLoadDbgMsg("NSLookupSymbolInImage() failed: %s", errMsg);
}
} else if (dyldLoadHandle->modulePtr) {
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
if (nsSymbol) {
TclLoadDbgMsg("NSLookupSymbolInModule() successful");
} else {
TclLoadDbgMsg("NSLookupSymbolInModule() failed");
}
}
if (nsSymbol) {
proc = NSAddressOfSymbol(nsSymbol);
if (proc) {
TclLoadDbgMsg("NSAddressOfSymbol() successful");
} else {
TclLoadDbgMsg("NSAddressOfSymbol() failed");
}
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
}
Tcl_DStringFree(&ds);
if (errMsg) {
Tcl_AppendResult(interp, errMsg, NULL);
}
return proc;
}
