コード例 #1
0
ファイル: tclUnixSock.c プロジェクト: AlexShiLucky/bitkeeper
void *
TclpMakeTcpClientChannelMode(
    void *sock,		/* The socket to wrap up into a channel. */
    int mode)			/* ORed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
    TcpState *statePtr;
    char channelName[SOCK_CHAN_LENGTH];

    statePtr = ckalloc(sizeof(TcpState));
    memset(statePtr, 0, sizeof(TcpState));
    statePtr->fds.fd = PTR2INT(sock);
    statePtr->flags = 0;

    sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);

    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
	    statePtr, mode);
    if (Tcl_SetChannelOption(NULL, statePtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close(NULL, statePtr->channel);
	return NULL;
    }
    return statePtr->channel;
}
コード例 #2
0
ファイル: tnmInit.c プロジェクト: flightaware/scotty
static int
SourceRcFile(Tcl_Interp *interp, char *fileName)
{
    Tcl_DString temp;
    char *fullName;
    int result = 0;

    if (! fileName) {
	return 0;
    }

    Tcl_DStringInit(&temp);
    fullName = Tcl_TranslateFileName(interp, fileName, &temp);
    if (fullName == NULL) {
	TnmWriteMessage(Tcl_GetStringResult(interp));
	TnmWriteMessage("\n");
    } else {
	Tcl_Channel channel;
	channel = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
	if (channel) {
	    Tcl_Close((Tcl_Interp *) NULL, channel);
	    result = 1;
	    if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
		TnmWriteMessage(Tcl_GetStringResult(interp));
		TnmWriteMessage("\n");
	    }
	}
    }
    Tcl_DStringFree(&temp);

    return result;
}
コード例 #3
0
ファイル: tclMain.c プロジェクト: smh377/tcl
void
Tcl_SourceRCFile(
    Tcl_Interp *interp)		/* Interpreter to source rc file into. */
{
    Tcl_DString temp;
    const char *fileName;
    Tcl_Channel chan;

    fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
    if (fileName != NULL) {
	Tcl_Channel c;
	const char *fullName;

	Tcl_DStringInit(&temp);
	fullName = Tcl_TranslateFileName(interp, fileName, &temp);
	if (fullName == NULL) {
	    /*
	     * Couldn't translate the file name (e.g. it referred to a bogus
	     * user or there was no HOME environment variable). Just do
	     * nothing.
	     */
	} else {
	    /*
	     * Test for the existence of the rc file before trying to read it.
	     */

	    c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
	    if (c != NULL) {
		Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1);

		Tcl_Close(NULL, c);
		Tcl_IncrRefCount(fullNameObj);
		if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) {
		    chan = Tcl_GetStdChannel(TCL_STDERR);
		    if (chan) {
			Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
			Tcl_WriteChars(chan, "\n", 1);
		    }
		}
		Tcl_DecrRefCount(fullNameObj);
	    }
	}
	Tcl_DStringFree(&temp);
    }
}
コード例 #4
0
ファイル: TkCximage.cpp プロジェクト: Kjir/amsn
int LoadFromFile(Tcl_Interp * interp, CxImage * image, char * fileName, int Type) {

    Tcl_Obj *data = Tcl_NewObj();
    Tcl_Channel chan = Tcl_OpenFileChannel(interp, fileName, "r", 0);
    BYTE * FileData = NULL;
    int length = 0;
    int retVal;

    if (chan == NULL)
        return FALSE;


    if (Type == CXIMAGE_FORMAT_UNKNOWN) {
        Type = GetFileTypeFromFileName((char *)fileName);
    }

    if (Type == CXIMAGE_FORMAT_UNKNOWN) {
        Type = CXIMAGE_FORMAT_GIF;
    }

    Tcl_SetChannelOption(interp, chan, "-encoding", "binary");
    Tcl_SetChannelOption(interp, chan, "-translation", "binary");

    Tcl_ReadChars(chan, data, -1, 0);

    Tcl_Close(interp, chan);

    FileData = Tcl_GetByteArrayFromObj(data, &length);


    if (! image->Decode(FileData, length, Type) &&
            ! image->Decode(FileData, length, CXIMAGE_FORMAT_GIF) &&
            ! image->Decode(FileData, length, CXIMAGE_FORMAT_PNG) &&
            ! image->Decode(FileData, length, CXIMAGE_FORMAT_JPG) &&
            ! image->Decode(FileData, length, CXIMAGE_FORMAT_TGA) &&
            ! image->Decode(FileData, length, CXIMAGE_FORMAT_BMP))
        retVal = FALSE;
    else
        retVal = TRUE;

    Tcl_DecrRefCount(data);
    return retVal;

}
コード例 #5
0
ファイル: tclMain85.cpp プロジェクト: aceskpark/osfeo
void
Tcl_SourceRCFile(
    Tcl_Interp *interp)		/* Interpreter to source rc file into. */
{
    Tcl_DString temp;
    CONST char *fileName;
    Tcl_Channel errChannel;

    fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
    if (fileName != NULL) {
	Tcl_Channel c;
	CONST char *fullName;

	Tcl_DStringInit(&temp);
	fullName = Tcl_TranslateFileName(interp, fileName, &temp);
	if (fullName == NULL) {
	    /*
	     * Couldn't translate the file name (e.g. it referred to a bogus
	     * user or there was no HOME environment variable). Just do
	     * nothing.
	     */
	} else {
	    /*
	     * Test for the existence of the rc file before trying to read it.
	     */

	    c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
	    if (c != (Tcl_Channel) NULL) {
		Tcl_Close(NULL, c);
		if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
		    errChannel = Tcl_GetStdChannel(TCL_STDERR);
		    if (errChannel) {
			Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
			Tcl_WriteChars(errChannel, "\n", 1);
 		    }
 		}
 	    }
	}
	Tcl_DStringFree(&temp);
    }
}
コード例 #6
0
ファイル: TkCximage.cpp プロジェクト: Kjir/amsn
int SaveToFile(Tcl_Interp * interp, CxImage * image, char * fileName, int Type) {

    Tcl_Channel chan = Tcl_OpenFileChannel(interp, fileName, "w", 0644);
    BYTE * FileData = NULL;
    long length = 0;

    if (chan == NULL)
        return FALSE;


    if (Type == CXIMAGE_FORMAT_UNKNOWN) {
        Type = GetFileTypeFromFileName((char *)fileName);
    }

    if (Type == CXIMAGE_FORMAT_UNKNOWN) {
        Type = CXIMAGE_FORMAT_GIF;
    }

    Tcl_SetChannelOption(interp, chan, "-encoding", "binary");
    Tcl_SetChannelOption(interp, chan, "-translation", "binary");


    if (!image->Encode(FileData, length, Type) ) {
        Tcl_AppendResult(interp, image->GetLastError(), NULL);
        return TCL_ERROR;
    }

    Tcl_WriteObj(chan, Tcl_NewByteArrayObj(FileData, length));

    image->FreeMemory(FileData);

    Tcl_ResetResult(interp);

    if (Tcl_Close(interp, chan) == TCL_ERROR)
        return FALSE;
    else
        return TRUE;

}
コード例 #7
0
ファイル: tclUnixSock.c プロジェクト: AlexShiLucky/bitkeeper
Tcl_Channel
Tcl_OpenTcpClient(
    Tcl_Interp *interp,		/* For error reporting; can be NULL. */
    int port,			/* Port number to open. */
    const char *host,		/* Host on which to open port. */
    const char *myaddr,		/* Client-side address */
    int myport,			/* Client-side port */
    int async)			/* If nonzero, attempt to do an asynchronous
				 * connect. Otherwise we do a blocking
				 * connect. */
{
    TcpState *statePtr;
    const char *errorMsg = NULL;
    struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
    char channelName[SOCK_CHAN_LENGTH];

    /*
     * Do the name lookups for the local and remote addresses.
     */

    if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
            || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
                    &errorMsg)) {
        if (addrlist != NULL) {
            freeaddrinfo(addrlist);
        }
        if (interp != NULL) {
            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                    "couldn't open socket: %s", errorMsg));
        }
        return NULL;
    }

    /*
     * Allocate a new TcpState for this socket.
     */
    statePtr = ckalloc(sizeof(TcpState));
    memset(statePtr, 0, sizeof(TcpState));
    statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
    statePtr->cachedBlocking = TCL_MODE_BLOCKING;
    statePtr->addrlist = addrlist;
    statePtr->myaddrlist = myaddrlist;
    statePtr->fds.fd = -1;

    /*
     * Create a new client socket and wrap it in a channel.
     */
    if (TcpConnect(interp, statePtr) != TCL_OK) {
        TcpCloseProc(statePtr, NULL);
        return NULL;
    }

    sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);

    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr,
            (TCL_READABLE | TCL_WRITABLE));
    if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
	    "auto crlf") == TCL_ERROR) {
	Tcl_Close(NULL, statePtr->channel);
	return NULL;
    }
    return statePtr->channel;
}
コード例 #8
0
	/* ARGSUSED */
int
Tcl_ExecObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    /*
     * This function generates an argv array for the string arguments. It
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */

    Tcl_Obj *resultPtr;
    const char **argv;
    char *string;
    Tcl_Channel chan;
    int argc, background, i, index, keepNewline, result, skip, length;
    int ignoreStderr;
    static const char *options[] = {
	"-ignorestderr", "-keepnewline", "--", NULL
    };
    enum options {
	EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
    };

    /*
     * Check for any leading option arguments.
     */

    keepNewline = 0;
    ignoreStderr = 0;
    for (skip = 1; skip < objc; skip++) {
	string = TclGetString(objv[skip]);
	if (string[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == EXEC_KEEPNEWLINE) {
	    keepNewline = 1;
	} else if (index == EXEC_IGNORESTDERR) {
	    ignoreStderr = 1;
	} else {
	    skip++;
	    break;
	}
    }
    if (objc <= skip) {
	Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * See if the command is to be run in background.
     */

    background = 0;
    string = TclGetString(objv[objc - 1]);
    if ((string[0] == '&') && (string[1] == '\0')) {
	objc--;
	background = 1;
    }

    /*
     * Create the string argument array "argv". Make sure argv is large enough
     * to hold the argc arguments plus 1 extra for the zero end-of-argv word.
     */

    argc = objc - skip;
    argv = (const char **)
	    TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));

    /*
     * Copy the string conversions of each (post option) object into the
     * argument vector.
     */

    for (i = 0; i < argc; i++) {
	argv[i] = TclGetString(objv[i + skip]);
    }
    argv[argc] = NULL;
    chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
	    (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)));

    /*
     * Free the argv array.
     */

    TclStackFree(interp, (void *)argv);

    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (background) {
	/*
	 * Store the list of PIDs from the pipeline in interp's result and
	 * detach the PIDs (instead of waiting for them).
	 */

	TclGetAndDetachPids(interp, chan);
	if (Tcl_Close(interp, chan) != TCL_OK) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    resultPtr = Tcl_NewObj();
    if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
	if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
	    /*
	     * TIP #219.
	     * Capture error messages put by the driver into the bypass area
	     * and put them into the regular interpreter result. Fall back to
	     * the regular message if nothing was found in the bypass.
	     */

	    if (!TclChanCaughtErrorBypass(interp, chan)) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "error reading output from command: ",
			Tcl_PosixError(interp), NULL);
		Tcl_DecrRefCount(resultPtr);
	    }
	    return TCL_ERROR;
	}
    }

    /*
     * If the process produced anything on stderr, it will have been returned
     * in the interpreter result. It needs to be appended to the result
     * string.
     */

    result = Tcl_Close(interp, chan);
    Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));

    /*
     * If the last character of the result is a newline, then remove the
     * newline character.
     */

    if (keepNewline == 0) {
	string = TclGetStringFromObj(resultPtr, &length);
	if ((length > 0) && (string[length - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);

    return result;
}
コード例 #9
0
static void
AcceptCallbackProc(
    ClientData callbackData,	/* The data stored when the callback was
				 * created in the call to
				 * Tcl_OpenTcpServer. */
    Tcl_Channel chan,		/* Channel for the newly accepted
				 * connection. */
    char *address,		/* Address of client that was accepted. */
    int port)			/* Port of client that was accepted. */
{
    AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData;

    /*
     * Check if the callback is still valid; the interpreter may have gone
     * away, this is signalled by setting the interp field of the callback
     * data to NULL.
     */

    if (acceptCallbackPtr->interp != NULL) {
	char portBuf[TCL_INTEGER_SPACE];
	char *script = acceptCallbackPtr->script;
	Tcl_Interp *interp = acceptCallbackPtr->interp;
	int result;

	Tcl_Preserve(script);
	Tcl_Preserve(interp);

	TclFormatInt(portBuf, port);
	Tcl_RegisterChannel(interp, chan);

	/*
	 * Artificially bump the refcount to protect the channel from being
	 * deleted while the script is being evaluated.
	 */

	Tcl_RegisterChannel(NULL, chan);

	result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
		" ", address, " ", portBuf, NULL);
	if (result != TCL_OK) {
	    TclBackgroundException(interp, result);
	    Tcl_UnregisterChannel(interp, chan);
	}

	/*
	 * Decrement the artificially bumped refcount. After this it is not
	 * safe anymore to use "chan", because it may now be deleted.
	 */

	Tcl_UnregisterChannel(NULL, chan);

	Tcl_Release(interp);
	Tcl_Release(script);
    } else {
	/*
	 * The interpreter has been deleted, so there is no useful way to
	 * utilize the client socket - just close it.
	 */

	Tcl_Close(NULL, chan);
    }
}
コード例 #10
0
ファイル: tclUnixChan.c プロジェクト: smh377/tcl
Tcl_Channel
TclpOpenFileChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting; can be
				 * NULL. */
    Tcl_Obj *pathPtr,		/* Name of file to open. */
    int mode,			/* POSIX open mode. */
    int permissions)		/* If the open involves creating a file, with
				 * what modes to create it? */
{
    int fd, channelPermissions;
    FileState *fsPtr;
    const char *native, *translation;
    char channelName[16 + TCL_INTEGER_SPACE];
    const Tcl_ChannelType *channelTypePtr;

    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
    case O_RDONLY:
	channelPermissions = TCL_READABLE;
	break;
    case O_WRONLY:
	channelPermissions = TCL_WRITABLE;
	break;
    case O_RDWR:
	channelPermissions = (TCL_READABLE | TCL_WRITABLE);
	break;
    default:
	/*
	 * This may occurr if modeString was "", for example.
	 */

	Tcl_Panic("TclpOpenFileChannel: invalid mode value");
	return NULL;
    }

    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"",
	    TclGetString(pathPtr), "\": filename is invalid on this platform",
	    NULL);
	}
	return NULL;
    }

#ifdef DJGPP
    SET_BITS(mode, O_BINARY);
#endif

    fd = TclOSopen(native, mode, permissions);

    if (fd < 0) {
	if (interp != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "couldn't open \"%s\": %s",
		    TclGetString(pathPtr), Tcl_PosixError(interp)));
	}
	return NULL;
    }

    /*
     * Set close-on-exec flag on the fd so that child processes will not
     * inherit this fd.
     */

    fcntl(fd, F_SETFD, FD_CLOEXEC);

    sprintf(channelName, "file%d", fd);

#ifdef SUPPORTS_TTY
    if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
	/*
	 * Initialize the serial port to a set of sane parameters. Especially
	 * important if the remote device is set to echo and the serial port
	 * driver was also set to echo -- as soon as a char were sent to the
	 * serial port, the remote device would echo it, then the serial
	 * driver would echo it back to the device, etc.
	 *
	 * Note that we do not do this if we're dealing with /dev/tty itself,
	 * as that tends to cause Bad Things To Happen when you're working
	 * interactively. Strictly a better check would be to see if the FD
	 * being set up is a device and has the same major/minor as the
	 * initial std FDs (beware reopening!) but that's nearly as messy.
	 */

	translation = "auto crlf";
	channelTypePtr = &ttyChannelType;
	TtyInit(fd);
    } else
#endif	/* SUPPORTS_TTY */
    {
	translation = NULL;
	channelTypePtr = &fileChannelType;
    }

    fsPtr = ckalloc(sizeof(FileState));
    fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
    fsPtr->fd = fd;

    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    fsPtr, channelPermissions);

    if (translation != NULL) {
	/*
	 * Gotcha. Most modems need a "\r" at the end of the command sequence.
	 * If you just send "at\n", the modem will not respond with "OK"
	 * because it never got a "\r" to actually invoke the command. So, by
	 * default, newlines are translated to "\r\n" on output to avoid "bug"
	 * reports that the serial port isn't working.
	 */

	if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation",
		translation) != TCL_OK) {
	    Tcl_Close(NULL, fsPtr->channel);
	    return NULL;
	}
    }

    return fsPtr->channel;
}
コード例 #11
0
ファイル: TclTextInterp.C プロジェクト: Eigenstate/vmd-python
int TclTextInterp::evalString(const char *s) {
#if defined(VMD_NANOHUB)
  if (Tcl_Eval(interp, s) != TCL_OK) {
#else
  if (Tcl_RecordAndEval(interp, s, 0) != TCL_OK) {
#endif
    // Don't print error message if there's nothing to show.
    if (strlen(Tcl_GetStringResult(interp))) 
      msgErr << Tcl_GetStringResult(interp) << sendmsg;
    return FALSE;
  }
  return TRUE;
}

void TclTextInterp::setString(const char *name, const char *val) {
  if (interp)
    Tcl_SetVar(interp, name, val, 
      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
}

void TclTextInterp::setMap(const char *name, const char *key, 
                           const char *val) { 
  if (interp)
    Tcl_SetVar2(interp, name, key, val, 
      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
    
}

// There's a fair amount of code duplication between doEvent and evalFile,
// maybe these could be combined somehow, say by having TclTextInterp keep 
// track of its Tcl_Channel objects.
// 
// Side note: Reading line-by-line gives different Tcl semantics than 
// just calling Tcl_EvalFile. Shell commands (e.g., stty) are properly
// parsed when read line-by-line and passed to Tcl_RecordAndEval, but are
// unrecognized when contained in a file read by Tcl_EvalFile.  I would 
// consider this a bug.  

int TclTextInterp::evalFile(const char *fname) {
  Tcl_Channel inchannel = Tcl_OpenFileChannel(interp, fname, "r", 0644);
  Tcl_Channel outchannel = Tcl_GetStdChannel(TCL_STDOUT);
  if (inchannel == NULL) {
    msgErr << "Error opening file " << fname << sendmsg;
    msgErr << Tcl_GetStringResult(interp) << sendmsg;
    return 1;
  }

  Tcl_Obj *cmdPtr = Tcl_NewObj();
  Tcl_IncrRefCount(cmdPtr);
  int length = 0;
  while ((length = Tcl_GetsObj(inchannel, cmdPtr)) >= 0) {
    Tcl_AppendToObj(cmdPtr, "\n", 1);
    char *stringrep = Tcl_GetStringFromObj(cmdPtr, NULL);
    if (!Tcl_CommandComplete(stringrep)) {
      continue;
    }

    // check if "exit" was called
    if (app->exitFlag) break;

#if defined(VMD_NANOHUB)
    Tcl_EvalObjEx(interp, cmdPtr, 0);
#else
    Tcl_RecordAndEvalObj(interp, cmdPtr, 0);
#endif

#if TCL_MINOR_VERSION >= 4
    Tcl_DecrRefCount(cmdPtr);
    cmdPtr = Tcl_NewObj();
    Tcl_IncrRefCount(cmdPtr);
#else
    // XXX this crashes Tcl 8.5.[46] with an internal panic
    Tcl_SetObjLength(cmdPtr, 0);
#endif

    // XXX this makes sure the display is updated 
    // after each line read from the file or pipe
    // So, this is also where we'd optimise reading multiple
    // lines at once
    //
    // In VR modes (CAVE, FreeVR, VR Juggler) the draw method will 
    // not be called from app->display_update(), so multiple lines
    // of input could be combined in one frame, if possible
    app->display_update();

    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
    char *bytes = Tcl_GetStringFromObj(resultPtr, &length);
#if defined(VMDTKCON)
    if (length > 0) {
      vmdcon_append(VMDCON_ALWAYS, bytes,length);
      vmdcon_append(VMDCON_ALWAYS, "\n", 1);
    }
    vmdcon_purge();
#else
    if (length > 0) {
#if TCL_MINOR_VERSION >= 4
      Tcl_WriteChars(outchannel, bytes, length);
      Tcl_WriteChars(outchannel, "\n", 1);
#else
      Tcl_Write(outchannel, bytes, length);
      Tcl_Write(outchannel, "\n", 1);
#endif
    }
    Tcl_Flush(outchannel);
#endif
  }
  Tcl_Close(interp, inchannel);
  Tcl_DecrRefCount(cmdPtr);
  return 0;
}
コード例 #12
0
static int
FileWritePPM(
    Tcl_Interp *interp,
    CONST char *fileName,
    Tcl_Obj *format,
    Tk_PhotoImageBlock *blockPtr)
{
    Tcl_Channel chan;
    int w, h, greenOffset, blueOffset, nBytes;
    unsigned char *pixelPtr, *pixLinePtr;
    char header[16 + TCL_INTEGER_SPACE * 2];

    chan = Tcl_OpenFileChannel(interp, fileName, "w", 0666);
    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (Tcl_SetChannelOption(interp, chan, "-translation", "binary")
	    != TCL_OK) {
	Tcl_Close(NULL, chan);
	return TCL_ERROR;
    }
    if (Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
	    != TCL_OK) {
	Tcl_Close(NULL, chan);
	return TCL_ERROR;
    }

    sprintf(header, "P6\n%d %d\n255\n", blockPtr->width, blockPtr->height);
    Tcl_Write(chan, header, -1);

    pixLinePtr = blockPtr->pixelPtr + blockPtr->offset[0];
    greenOffset = blockPtr->offset[1] - blockPtr->offset[0];
    blueOffset = blockPtr->offset[2] - blockPtr->offset[0];

    if ((greenOffset == 1) && (blueOffset == 2) && (blockPtr->pixelSize == 3)
	    && (blockPtr->pitch == (blockPtr->width * 3))) {
	nBytes = blockPtr->height * blockPtr->pitch;
	if (Tcl_Write(chan, (char *) pixLinePtr, nBytes) != nBytes) {
	    goto writeerror;
	}
    } else {
	for (h = blockPtr->height; h > 0; h--) {
	    pixelPtr = pixLinePtr;
	    for (w = blockPtr->width; w > 0; w--) {
		if (    Tcl_Write(chan,(char *)&pixelPtr[0], 1) == -1 ||
			Tcl_Write(chan,(char *)&pixelPtr[greenOffset],1)==-1 ||
			Tcl_Write(chan,(char *)&pixelPtr[blueOffset],1) ==-1) {
		    goto writeerror;
		}
		pixelPtr += blockPtr->pixelSize;
	    }
	    pixLinePtr += blockPtr->pitch;
	}
    }

    if (Tcl_Close(NULL, chan) == 0) {
	return TCL_OK;
    }
    chan = NULL;

  writeerror:
    Tcl_AppendResult(interp, "error writing \"", fileName, "\": ",
	    Tcl_PosixError(interp), NULL);
    if (chan != NULL) {
	Tcl_Close(NULL, chan);
    }
    return TCL_ERROR;
}
コード例 #13
0
ファイル: tkImgBmap.c プロジェクト: das/tcltk
char *
TkGetBitmapData(
    Tcl_Interp *interp,		/* For reporting errors, or NULL. */
    const char *string,		/* String describing bitmap. May be NULL. */
    const char *fileName,		/* Name of file containing bitmap description.
				 * Used only if string is NULL. Must not be
				 * NULL if string is NULL. */
    int *widthPtr, int *heightPtr,
				/* Dimensions of bitmap get returned here. */
    int *hotXPtr, int *hotYPtr)	/* Position of hot spot or -1,-1. */
{
    int width, height, numBytes, hotX, hotY;
    const char *expandedFileName;
    char *p, *end;
    ParseInfo pi;
    char *data = NULL;
    Tcl_DString buffer;

    pi.string = string;
    if (string == NULL) {
	if ((interp != NULL) && Tcl_IsSafe(interp)) {
	    Tcl_AppendResult(interp, "can't get bitmap data from a file in a",
		    " safe interpreter", NULL);
	    return NULL;
	}
	expandedFileName = Tcl_TranslateFileName(interp, fileName, &buffer);
	if (expandedFileName == NULL) {
	    return NULL;
	}
	pi.chan = Tcl_OpenFileChannel(interp, expandedFileName, "r", 0);
	Tcl_DStringFree(&buffer);
	if (pi.chan == NULL) {
	    if (interp != NULL) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "couldn't read bitmap file \"",
			fileName, "\": ", Tcl_PosixError(interp), NULL);
	    }
	    return NULL;
	}

	if (Tcl_SetChannelOption(interp, pi.chan, "-translation", "binary")
		!= TCL_OK) {
	    return NULL;
	}
	if (Tcl_SetChannelOption(interp, pi.chan, "-encoding", "binary")
		!= TCL_OK) {
	    return NULL;
	}
    } else {
	pi.chan = NULL;
    }

    /*
     * Parse the lines that define the dimensions of the bitmap, plus the
     * first line that defines the bitmap data (it declares the name of a data
     * variable but doesn't include any actual data). These lines look
     * something like the following:
     *
     *		#define foo_width 16
     *		#define foo_height 16
     *		#define foo_x_hot 3
     *		#define foo_y_hot 3
     *		static char foo_bits[] = {
     *
     * The x_hot and y_hot lines may or may not be present. It's important to
     * check for "char" in the last line, in order to reject old X10-style
     * bitmaps that used shorts.
     */

    width = 0;
    height = 0;
    hotX = -1;
    hotY = -1;
    while (1) {
	if (NextBitmapWord(&pi) != TCL_OK) {
	    goto error;
	}
	if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
		&& (strcmp(pi.word+pi.wordLength-6, "_width") == 0)) {
	    if (NextBitmapWord(&pi) != TCL_OK) {
		goto error;
	    }
	    width = strtol(pi.word, &end, 0);
	    if ((end == pi.word) || (*end != 0)) {
		goto error;
	    }
	} else if ((pi.wordLength >= 7) && (pi.word[pi.wordLength-7] == '_')
		&& (strcmp(pi.word+pi.wordLength-7, "_height") == 0)) {
	    if (NextBitmapWord(&pi) != TCL_OK) {
		goto error;
	    }
	    height = strtol(pi.word, &end, 0);
	    if ((end == pi.word) || (*end != 0)) {
		goto error;
	    }
	} else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
		&& (strcmp(pi.word+pi.wordLength-6, "_x_hot") == 0)) {
	    if (NextBitmapWord(&pi) != TCL_OK) {
		goto error;
	    }
	    hotX = strtol(pi.word, &end, 0);
	    if ((end == pi.word) || (*end != 0)) {
		goto error;
	    }
	} else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
		&& (strcmp(pi.word+pi.wordLength-6, "_y_hot") == 0)) {
	    if (NextBitmapWord(&pi) != TCL_OK) {
		goto error;
	    }
	    hotY = strtol(pi.word, &end, 0);
	    if ((end == pi.word) || (*end != 0)) {
		goto error;
	    }
	} else if ((pi.word[0] == 'c') && (strcmp(pi.word, "char") == 0)) {
	    while (1) {
		if (NextBitmapWord(&pi) != TCL_OK) {
		    goto error;
		}
		if ((pi.word[0] == '{') && (pi.word[1] == 0)) {
		    goto getData;
		}
	    }
	} else if ((pi.word[0] == '{') && (pi.word[1] == 0)) {
	    if (interp != NULL) {
		Tcl_AppendResult(interp, "format error in bitmap data; ",
			"looks like it's an obsolete X10 bitmap file", NULL);
	    }
	    goto errorCleanup;
	}
    }

    /*
     * Now we've read everything but the data. Allocate an array and read in
     * the data.
     */

  getData:
    if ((width <= 0) || (height <= 0)) {
	goto error;
    }
    numBytes = ((width+7)/8) * height;
    data = ckalloc((unsigned) numBytes);
    for (p = data; numBytes > 0; p++, numBytes--) {
	if (NextBitmapWord(&pi) != TCL_OK) {
	    goto error;
	}
	*p = (char) strtol(pi.word, &end, 0);
	if (end == pi.word) {
	    goto error;
	}
    }

    /*
     * All done. Clean up and return.
     */

    if (pi.chan != NULL) {
	Tcl_Close(NULL, pi.chan);
    }
    *widthPtr = width;
    *heightPtr = height;
    *hotXPtr = hotX;
    *hotYPtr = hotY;
    return data;

  error:
    if (interp != NULL) {
	Tcl_SetResult(interp, "format error in bitmap data", TCL_STATIC);
    }

  errorCleanup:
    if (data != NULL) {
	ckfree(data);
    }
    if (pi.chan != NULL) {
	Tcl_Close(NULL, pi.chan);
    }
    return NULL;
}
コード例 #14
0
ファイル: tkOption.c プロジェクト: das/tcltk
static int
ReadOptionFile(
    Tcl_Interp *interp,		/* Interpreter to use for reporting results. */
    Tk_Window tkwin,		/* Token for window: options are entered for
				 * this window's main window. */
    const char *fileName,		/* Name of file containing options. */
    int priority)		/* Priority level to use for options in this
				 * file, such as TK_USER_DEFAULT_PRIO or
				 * TK_INTERACTIVE_PRIO. Must be between 0 and
				 * TK_MAX_PRIO. */
{
    const char *realName;
    char *buffer;
    int result, bufferSize;
    Tcl_Channel chan;
    Tcl_DString newName;

    /*
     * Prevent file system access in a safe interpreter.
     */

    if (Tcl_IsSafe(interp)) {
	Tcl_AppendResult(interp, "can't read options from a file in a",
		" safe interpreter", NULL);
	return TCL_ERROR;
    }

    realName = Tcl_TranslateFileName(interp, fileName, &newName);
    if (realName == NULL) {
	return TCL_ERROR;
    }
    chan = Tcl_OpenFileChannel(interp, realName, "r", 0);
    Tcl_DStringFree(&newName);
    if (chan == NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "couldn't open \"", fileName,
		"\": ", Tcl_PosixError(interp), NULL);
	return TCL_ERROR;
    }

    /*
     * Compute size of file by seeking to the end of the file. This will
     * overallocate if we are performing CRLF translation.
     */

    bufferSize = (int) Tcl_Seek(chan, (Tcl_WideInt) 0, SEEK_END);
    Tcl_Seek(chan, (Tcl_WideInt) 0, SEEK_SET);

    if (bufferSize < 0) {
	Tcl_AppendResult(interp, "error seeking to end of file \"",
		fileName, "\":", Tcl_PosixError(interp), NULL);
	Tcl_Close(NULL, chan);
	return TCL_ERROR;

    }
    buffer = ckalloc((unsigned) bufferSize+1);
    bufferSize = Tcl_Read(chan, buffer, bufferSize);
    if (bufferSize < 0) {
	Tcl_AppendResult(interp, "error reading file \"", fileName, "\":",
		Tcl_PosixError(interp), NULL);
	Tcl_Close(NULL, chan);
	return TCL_ERROR;
    }
    Tcl_Close(NULL, chan);
    buffer[bufferSize] = 0;
    result = AddFromString(interp, tkwin, buffer, priority);
    ckfree(buffer);
    return result;
}