tcliocmd.c

linux系统下的音频通信

/* 
 * tclIOCmd.c --
 *
 *	Contains the definitions of most of the Tcl commands relating to IO.
 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tclIOCmd.c 1.119 97/07/25 20:49:23
 */

#include	"tclInt.h"
#include	"tclPort.h"

/*
 * Return at most this number of bytes in one call to Tcl_Read:
 */

#define	TCL_READ_CHUNK_SIZE	4096

/*
 * Callback structure for accept callback in a TCP server.
 */

typedef struct AcceptCallback {
    char *script;			/* Script to invoke. */
    Tcl_Interp *interp;			/* Interpreter in which to run it. */
} AcceptCallback;

/*
 * Static functions for this file:
 */

static void	AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
	            Tcl_Channel chan, char *address, int port));
static void	RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
	            AcceptCallback *acceptCallbackPtr));
static void	TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
		    ClientData clientData, Tcl_Interp *interp));
static void	TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
static void	UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
		    Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutsObjCmd --
 *
 *	This procedure is invoked to process the "puts" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Produces output on a channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PutsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to puts on. */
    int i;				/* Counter. */
    int newline;			/* Add a newline at end? */
    char *channelId;			/* Name of channel for puts. */
    int result;				/* Result of puts operation. */
    int mode;				/* Mode in which channel is opened. */
    char *arg;
    int length;
    Tcl_Obj *resultPtr;

    i = 1;
    newline = 1;
    if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL),
	    "-nonewline") == 0)) {
	newline = 0;
	i++;
    }
    if ((i < (objc-3)) || (i >= objc)) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
	return TCL_ERROR;
    }

    /*
     * The code below provides backwards compatibility with an old
     * form of the command that is no longer recommended or documented.
     */

    resultPtr = Tcl_NewObj();
    if (i == (objc-3)) {
	arg = Tcl_GetStringFromObj(objv[i+2], &length);
	if (strncmp(arg, "nonewline", (size_t) length) != 0) {
	    Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
		    "\": should be \"nonewline\"", (char *) NULL);
            Tcl_SetObjResult(interp, resultPtr);
	    return TCL_ERROR;
	}
	newline = 0;
    }
    if (i == (objc-1)) {
	channelId = "stdout";
    } else {
	channelId = Tcl_GetStringFromObj(objv[i], NULL);
	i++;
    }
    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
        Tcl_DecrRefCount(resultPtr);
        return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId,
                "\" wasn't opened for writing", (char *) NULL);
        Tcl_SetObjResult(interp, resultPtr);
        return TCL_ERROR;
    }

    arg = Tcl_GetStringFromObj(objv[i], &length);
    result = Tcl_Write(chan, arg, length);
    if (result < 0) {
        goto error;
    }
    if (newline != 0) {
        result = Tcl_Write(chan, "\n", 1);
        if (result < 0) {
            goto error;
        }
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
error:
    Tcl_AppendStringsToObj(resultPtr, "error writing \"",
	    Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
	    (char *) NULL);
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FlushObjCmd --
 *
 *	This procedure is called to process the Tcl "flush" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May cause output to appear on the specified channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FlushObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to flush on. */
    char *arg;
    Tcl_Obj *resultPtr;
    int mode;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }
    arg = Tcl_GetStringFromObj(objv[1], NULL);
    chan = Tcl_GetChannel(interp, arg, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    resultPtr = Tcl_GetObjResult(interp);
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendStringsToObj(resultPtr, "channel \"",
		Tcl_GetStringFromObj(objv[1], NULL), 
                "\" wasn't opened for writing", (char *) NULL);
        return TCL_ERROR;
    }
    
    if (Tcl_Flush(chan) != TCL_OK) {
	Tcl_AppendStringsToObj(resultPtr, "error flushing \"",
		Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
		(char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetsObjCmd --
 *
 *	This procedure is called to process the Tcl "gets" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May consume input from channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_GetsObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to read from. */
    int lineLen;			/* Length of line just read. */
    int mode;				/* Mode in which channel is opened. */
    char *arg;
    Tcl_Obj *resultPtr, *objPtr;

    if ((objc != 2) && (objc != 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
	return TCL_ERROR;
    }
    arg = Tcl_GetStringFromObj(objv[1], NULL);
    chan = Tcl_GetChannel(interp, arg, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    resultPtr = Tcl_NewObj();
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
                "\" wasn't opened for reading", (char *) NULL);
        Tcl_SetObjResult(interp, resultPtr);
        return TCL_ERROR;
    }

    lineLen = Tcl_GetsObj(chan, resultPtr);
    if (lineLen < 0) {
        if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_SetObjLength(resultPtr, 0);
	    Tcl_AppendStringsToObj(resultPtr, "error reading \"",
		    Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
		    (char *) NULL);
            Tcl_SetObjResult(interp, resultPtr);
            return TCL_ERROR;
        }
        lineLen = -1;
    }
    if (objc == 3) {
	Tcl_ResetResult(interp);
	objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
		resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
	if (objPtr == NULL) {
            Tcl_DecrRefCount(resultPtr);
            return TCL_ERROR;
        }
        Tcl_ResetResult(interp);
	Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen);
        return TCL_OK;
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReadObjCmd --
 *
 *	This procedure is invoked to process the Tcl "read" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May consume input from channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ReadObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to read from. */
    int newline, i;			/* Discard newline at end? */
    int toRead;				/* How many bytes to read? */
    int toReadNow;			/* How many bytes to attempt to
                                         * read in the current iteration? */
    int charactersRead;			/* How many characters were read? */
    int charactersReadNow;		/* How many characters were read
                                         * in this iteration? */
    int mode;				/* Mode in which channel is opened. */
    int bufSize;			/* Channel buffer size; used to decide
                                         * in what chunk sizes to read from
                                         * the channel. */
    char *arg;
    Tcl_Obj *resultPtr;

    if ((objc != 2) && (objc != 3)) {
argerror:
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?");
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"",
		Tcl_GetStringFromObj(objv[0], NULL),
		" ?-nonewline? channelId\"", (char *) NULL);
	return TCL_ERROR;
    }
    i = 1;
    newline = 0;
    if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) {
	newline = 1;
	i++;
    }

    if (i == objc) {
        goto argerror;
    }

    arg =  Tcl_GetStringFromObj(objv[i], NULL);
    chan = Tcl_GetChannel(interp, arg, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	resultPtr = Tcl_GetObjResult(interp);
	Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
                "\" wasn't opened for reading", (char *) NULL);
        return TCL_ERROR;
    }
    
    i++;	/* Consumed channel name. */

    /*
     * Compute how many bytes to read, and see whether the final
     * newline should be dropped.
     */

    toRead = INT_MAX;
    if (i < objc) {
	arg = Tcl_GetStringFromObj(objv[i], NULL);
	if (isdigit((unsigned char) (arg[0]))) {
	    if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
                return TCL_ERROR;
	    }
	    Tcl_ResetResult(interp);
	} else if (strcmp(arg, "nonewline") == 0) {
	    newline = 1;
	} else {
	    resultPtr = Tcl_GetObjResult(interp);
	    Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
		    "\": should be \"nonewline\"", (char *) NULL);
	    return TCL_ERROR;
        }
    }

    /*
     * Create a new object and use that instead of the interpreter
     * result. We cannot use the interpreter's result object because
     * it may get smashed at any time by recursive calls.
     */
    
    resultPtr = Tcl_NewObj();
    
    bufSize = Tcl_GetChannelBufferSize(chan);

    /*
     * If the caller specified a maximum length to read, then that is
     * a good size to preallocate.
     */
    
    if ((toRead != INT_MAX) && (toRead > bufSize)) {
        Tcl_SetObjLength(resultPtr, toRead);
    }
    
    for (charactersRead = 0; charactersRead < toRead; ) {
        toReadNow = toRead - charactersRead;
        if (toReadNow > bufSize) {
            toReadNow = bufSize;
        }

        /*
         * NOTE: This is a NOOP if we set the size (above) to the
         * number of bytes we expect to read. In the degenerate
         * case, however, it will grow the buffer by the channel
         * buffersize, which is 4K in most cases. This will result
         * in inefficient copying for large files. This will be
         * fixed in a future release.
         */
        
	Tcl_SetObjLength(resultPtr, charactersRead + toReadNow);
        charactersReadNow =
            Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL)
		    + charactersRead, toReadNow);
        if (charactersReadNow < 0) {
	    Tcl_SetObjLength(resultPtr, 0);
            Tcl_AppendStringsToObj(resultPtr, "error reading \"",
		    Tcl_GetChannelName(chan), "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
            Tcl_SetObjResult(interp, resultPtr);

            return TCL_ERROR;
        }

        /*
         * If we had a short read it means that we have either EOF
         * or BLOCKED on the channel, so break out.
         */
        
        charactersRead += charactersReadNow;

        /*
         * Do not call the driver again if we got a short read
         */
        
        if (charactersReadNow < toReadNow) {
            break;	/* Out of "for" loop. */
        }
    }
    
    /*
     * If requested, remove the last newline in the channel if at EOF.
     */
    
    if ((charactersRead > 0) && (newline) &&
          (Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) {
	charactersRead--;
    }
    Tcl_SetObjLength(resultPtr, charactersRead);

    /*
     * Now set the object into the interpreter result and release our
     * hold on it by decrrefing it.
     */

    Tcl_SetObjResult(interp, resultPtr);
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SeekCmd --
 *
 *	This procedure is invoked to process the Tcl "seek" command. See
 *	the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Moves the position of the access point on the specified channel.
 *	May flush queued output.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_SeekCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_Channel chan;			/* The channel to tell on. */
    int offset, mode;			/* Where to seek? */
    int result;				/* Of calling Tcl_Seek. */

    if ((argc != 3) && (argc != 4)) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" channelId offset ?origin?\"", (char *) NULL);
	return TCL_ERROR;
    }
    chan = Tcl_GetChannel(interp, argv[1], NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
	return TCL_ERROR;
    }
    mode = SEEK_SET;
    if (argc == 4) {
	size_t length;
	int c;

	length = strlen(argv[3]);
	c = argv[3][0];
	if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
	    mode = SEEK_SET;
	} else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
	    mode = SEEK_CUR;
	} else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
	    mode = SEEK_END;
	} else {
	    Tcl_AppendResult(interp, "bad origin \"", argv[3],
		    "\": should be start, current, or end", (char *) NULL);
	    return TCL_ERROR;
	}
    }

    result = Tcl_Seek(chan, offset, mode);
    if (result == -1) {
        Tcl_AppendResult(interp, "error during seek on \"",