tcliocmd.c

tcl是工具命令语言

/* 
 * tclIOCmd.c --
 *
 *	Contains the definitions of most of the Tcl commands relating to IO.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOCmd.c,v 1.15 2002/02/15 14:28:49 dkf Exp $
 */

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

/*
 * 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. */
    Tcl_Obj *string;			/* String to write. */
    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. */

    switch (objc) {
    case 2: /* puts $x */
	string = objv[1];
	newline = 1;
	channelId = "stdout";
	break;

    case 3: /* puts -nonewline $x  or  puts $chan $x */ 
	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	    newline = 0;
	    channelId = "stdout";
	} else {
	    newline = 1;
	    channelId = Tcl_GetString(objv[1]);
	}
	string = objv[2];
	break;

    case 4: /* puts -nonewline $chan $x  or  puts $chan $x nonewline */
	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	    channelId = Tcl_GetString(objv[2]);
	    string = objv[3];
	} else {
	    /*
	     * The code below provides backwards compatibility with an
	     * old form of the command that is no longer recommended
	     * or documented.
	     */

	    char *arg;
	    int length;

	    arg = Tcl_GetStringFromObj(objv[3], &length);
	    if (strncmp(arg, "nonewline", (size_t) length) != 0) {
		Tcl_AppendResult(interp, "bad argument \"", arg,
				 "\": should be \"nonewline\"",
				 (char *) NULL);
		return TCL_ERROR;
	    }
	    channelId = Tcl_GetString(objv[1]);
	    string = objv[2];
	}
	newline = 0;
	break;

    default: /* puts  or  puts some bad number of arguments... */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
	return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
                "\" wasn't opened for writing", (char *) NULL);
        return TCL_ERROR;
    }

    result = Tcl_WriteObj(chan, string);
    if (result < 0) {
        goto error;
    }
    if (newline != 0) {
        result = Tcl_WriteChars(chan, "\n", 1);
        if (result < 0) {
            goto error;
        }
    }
    return TCL_OK;

    error:
    Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
	    Tcl_PosixError(interp), (char *) NULL);
    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 *channelId;
    int mode;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }
    channelId = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, channelId, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_WRITABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", channelId,
		"\" wasn't opened for writing", (char *) NULL);
        return TCL_ERROR;
    }
    
    if (Tcl_Flush(chan) != TCL_OK) {
	Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
		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 *name;
    Tcl_Obj *resultPtr, *linePtr;

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

    linePtr = Tcl_NewObj();

    lineLen = Tcl_GetsObj(chan, linePtr);
    if (lineLen < 0) {
        if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
	    Tcl_DecrRefCount(linePtr);
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading \"", name, "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
            return TCL_ERROR;
        }
        lineLen = -1;
    }
    if (objc == 3) {
	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
		TCL_LEAVE_ERR_MSG) == NULL) {
	    Tcl_DecrRefCount(linePtr);
            return TCL_ERROR;
        }
	resultPtr = Tcl_GetObjResult(interp);
	Tcl_SetIntObj(resultPtr, lineLen);
        return TCL_OK;
    } else {
	Tcl_SetObjResult(interp, linePtr);
    }
    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 charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    char *name;
    Tcl_Obj *resultPtr;

    if ((objc != 2) && (objc != 3)) {
	argerror:
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
	Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),
		" ?-nonewline? channelId\"", (char *) NULL);
	return TCL_ERROR;
    }

    i = 1;
    newline = 0;
    if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
	newline = 1;
	i++;
    }

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

    name = Tcl_GetString(objv[i]);
    chan = Tcl_GetChannel(interp, name, &mode);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendResult(interp, "channel \"", name, 
                "\" 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 = -1;
    if (i < objc) {
	char *arg;
	
	arg = Tcl_GetString(objv[i]);
	if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
	    if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
                return TCL_ERROR;
	    }
	} else if (strcmp(arg, "nonewline") == 0) {
	    newline = 1;
	} else {
	    Tcl_AppendResult(interp, "bad argument \"", arg,
		    "\": should be \"nonewline\"", (char *) NULL);
	    return TCL_ERROR;
        }
    }

    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);
    charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
    if (charactersRead < 0) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "error reading \"", name, "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	Tcl_DecrRefCount(resultPtr);
	return TCL_ERROR;
    }
    
    /*
     * If requested, remove the last newline in the channel if at EOF.
     */
    
    if ((charactersRead > 0) && (newline != 0)) {
	char *result;
	int length;

	result = Tcl_GetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SeekObjCmd --
 *
 *	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_SeekObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to tell on. */
    Tcl_WideInt offset;			/* Where to seek? */
    int mode;				/* How to seek? */
    Tcl_WideInt result;			/* Of calling Tcl_Seek. */
    char *chanName;
    int optionIndex;
    static CONST char *originOptions[] = {
	"start", "current", "end", (char *) NULL
    };
    static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};

    if ((objc != 3) && (objc != 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
	return TCL_ERROR;
    }
    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
	return TCL_ERROR;
    }
    mode = SEEK_SET;
    if (objc == 4) {
	if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
		&optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	mode = modeArray[optionIndex];
    }

    result = Tcl_Seek(chan, offset, mode);
    if (result == Tcl_LongAsWide(-1)) {
        Tcl_AppendResult(interp, "error during seek on \"", 
		chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
        return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TellObjCmd --
 *
 *	This procedure is invoked to process the Tcl "tell" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_TellObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to tell on. */
    char *chanName;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }
    /*
     * Try to find a channel with the right name and permissions in
     * the IO channel table of this interpreter.
     */
    
    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }
    Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CloseObjCmd --
 *
 *	This procedure is invoked to process the Tcl "close" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May discard queued input; may flush queued output.
 *
 *----------------------------------------------------------------------