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;
}
示例#2
0
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);
}
示例#3
0
文件: tkConsole.c 项目: tcltk/tk
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;
}
示例#4
0
文件: tcltk.c 项目: kmillar/rho
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;
}
示例#5
0
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);
}
示例#6
0
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);
}
示例#7
0
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);
    }
}
示例#8
0
文件: tclConfig.c 项目: smh377/tcl
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;
}
示例#9
0
/* 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;
}
示例#10
0
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;
}
示例#11
0
/*
 * 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;
		}
	}
}
示例#12
0
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;
}
示例#13
0
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;
}
示例#14
0
文件: tclAEInit.c 项目: aosm/tcl
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;
}
示例#15
0
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);
}
示例#16
0
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;
}
示例#17
0
文件: tclUnixFile.c 项目: smh377/tcl
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
}
示例#18
0
	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");
	}