tclio.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,110 行 · 第 1/5 页

	    /* We don't want to re-enter Tcl_Close */
	    if (!(statePtr->flags & CHANNEL_CLOSED)) {
		if (Tcl_Close(interp, chan) != TCL_OK) {
		    statePtr->flags |= CHANNEL_CLOSED;
		    Tcl_Release((ClientData)statePtr);
		    return TCL_ERROR;
		}
	    }
        }
        statePtr->flags |= CHANNEL_CLOSED;
	Tcl_Release((ClientData)statePtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  Even if the ref count drops to zero, the 
 *	channel is NOT closed or cleaned up.  This allows a channel to
 *	be detached from an interpreter and left in the same state it
 *	was in when it was originally returned by 'Tcl_OpenFileChannel',
 *	for example.
 *	
 *	This function cannot be used on the standard channels, and
 *	will return TCL_ERROR if that is attempted.
 *	
 *	This function should only be necessary for special purposes
 *	in which you need to generate a pristine channel from one
 *	that has already been used.  All ordinary purposes will almost
 *	always want to use Tcl_UnregisterChannel instead.
 *	
 *	Provided the channel is not attached to any other interpreter,
 *	it can then be closed with Tcl_Close, rather than with 
 *	Tcl_UnregisterChannel.
 *
 * Results:
 *	A standard Tcl result.  If the channel is not currently registered
 *	with the given interpreter, TCL_ERROR is returned, otherwise
 *	TCL_OK.  However no error messages are left in the interp's result.
 *
 * Side effects:
 *	Deletes the hash entry for a channel associated with an 
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DetachChannel(interp, chan)
    Tcl_Interp *interp;		/* Interpreter in which channel is defined. */
    Tcl_Channel chan;		/* Channel to delete. */
{
    if (Tcl_IsStandardChannel(chan)) {
        return TCL_ERROR;
    }
    
    return DetachChannel(interp, chan);
}

/*
 *----------------------------------------------------------------------
 *
 * DetachChannel --
 *
 *	Deletes the hash entry for a channel associated with an interpreter.
 *	If the interpreter given as argument is NULL, it only decrements the
 *	reference count.  Even if the ref count drops to zero, the 
 *	channel is NOT closed or cleaned up.  This allows a channel to
 *	be detached from an interpreter and left in the same state it
 *	was in when it was originally returned by 'Tcl_OpenFileChannel',
 *	for example.
 *
 * Results:
 *	A standard Tcl result.  If the channel is not currently registered
 *	with the given interpreter, TCL_ERROR is returned, otherwise
 *	TCL_OK.  However no error messages are left in the interp's result.
 *
 * Side effects:
 *	Deletes the hash entry for a channel associated with an 
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
DetachChannel(interp, chan)
    Tcl_Interp *interp;		/* Interpreter in which channel is defined. */
    Tcl_Channel chan;		/* Channel to delete. */
{
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    Channel *chanPtr;		/* The real IO channel. */
    ChannelState *statePtr;	/* State of the real channel. */

    /*
     * Always (un)register bottom-most channel in the stack.  This makes
     * management of the channel list easier because no manipulation is
     * necessary during (un)stack operation.
     */
    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    statePtr = chanPtr->state;

    if (interp != (Tcl_Interp *) NULL) {
	hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
	if (hTblPtr == (Tcl_HashTable *) NULL) {
	    return TCL_ERROR;
	}
	hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
	if (hPtr == (Tcl_HashEntry *) NULL) {
	    return TCL_ERROR;
	}
	if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
	    return TCL_ERROR;
	}
	Tcl_DeleteHashEntry(hPtr);

	/*
	 * Remove channel handlers that refer to this interpreter, so that they
	 * will not be present if the actual close is delayed and more events
	 * happen on the channel. This may occur if the channel is shared
	 * between several interpreters, or if the channel has async
	 * flushing active.
	 */
    
	CleanupChannelHandlers(interp, chanPtr);
    }

    statePtr->refCount--;
    
    return TCL_OK;
}


/*
 *---------------------------------------------------------------------------
 *
 * Tcl_GetChannel --
 *
 *	Finds an existing Tcl_Channel structure by name in a given
 *	interpreter. This function is public because it is used by
 *	channel-type-specific functions.
 *
 * Results:
 *	A Tcl_Channel or NULL on failure. If failed, interp's result
 *	object contains an error message.  *modePtr is filled with the
 *	modes in which the channel was opened.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Channel
Tcl_GetChannel(interp, chanName, modePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find or create
                                 * the channel. */
    CONST char *chanName;	/* The name of the channel. */
    int *modePtr;		/* Where to store the mode in which the
                                 * channel was opened? Will contain an ORed
                                 * combination of TCL_READABLE and
                                 * TCL_WRITABLE, if non-NULL. */
{
    Channel *chanPtr;		/* The actual channel. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    CONST char *name;		/* Translated name. */

    /*
     * Substitute "stdin", etc.  Note that even though we immediately
     * find the channel using Tcl_GetStdChannel, we still need to look
     * it up in the specified interpreter to ensure that it is present
     * in the channel table.  Otherwise, safe interpreters would always
     * have access to the standard channels.
     */

    name = chanName;
    if ((chanName[0] == 's') && (chanName[1] == 't')) {
	chanPtr = NULL;
	if (strcmp(chanName, "stdin") == 0) {
	    chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDIN);
	} else if (strcmp(chanName, "stdout") == 0) {
	    chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDOUT);
	} else if (strcmp(chanName, "stderr") == 0) {
	    chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDERR);
	}
	if (chanPtr != NULL) {
	    name = chanPtr->state->channelName;
	}
    }

    hTblPtr = GetChannelTable(interp);
    hPtr = Tcl_FindHashEntry(hTblPtr, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendResult(interp, "can not find channel named \"",
                chanName, "\"", (char *) NULL);
        return NULL;
    }

    /*
     * Always return bottom-most channel in the stack.  This one lives
     * the longest - other channels may go away unnoticed.
     * The other APIs compensate where necessary to retrieve the
     * topmost channel again.
     */
    chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
    chanPtr = chanPtr->state->bottomChanPtr;
    if (modePtr != NULL) {
        *modePtr = (chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE));
    }
    
    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannel --
 *
 *	Creates a new entry in the hash table for a Tcl_Channel
 *	record.
 *
 * Results:
 *	Returns the new Tcl_Channel.
 *
 * Side effects:
 *	Creates a new Tcl_Channel instance and inserts it into the
 *	hash table.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
    Tcl_ChannelType *typePtr;	/* The channel type record. */
    CONST char *chanName;	/* Name of channel to record. */
    ClientData instanceData;	/* Instance specific data. */
    int mask;			/* TCL_READABLE & TCL_WRITABLE to indicate
                                 * if the channel is readable, writable. */
{
    Channel *chanPtr;		/* The channel structure newly created. */
    ChannelState *statePtr;	/* The stack-level independent state info
				 * for the channel. */
    CONST char *name;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * With the change of the Tcl_ChannelType structure to use a version in
     * 8.3.2+, we have to make sure that our assumption that the structure
     * remains a binary compatible size is true.
     *
     * If this assertion fails on some system, then it can be removed
     * only if the user recompiles code with older channel drivers in
     * the new system as well.
     */

    assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*));

    /*
     * JH: We could subsequently memset these to 0 to avoid the
     * numerous assignments to 0/NULL below.
     */
    chanPtr  = (Channel *) ckalloc((unsigned) sizeof(Channel));
    statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState));
    chanPtr->state = statePtr;

    chanPtr->instanceData	= instanceData;
    chanPtr->typePtr		= typePtr;

    /*
     * Set all the bits that are part of the stack-independent state
     * information for the channel.
     */

    if (chanName != (char *) NULL) {
	char *tmp = ckalloc((unsigned) (strlen(chanName) + 1));
        statePtr->channelName = tmp;
        strcpy(tmp, chanName);
    } else {
        panic("Tcl_CreateChannel: NULL channel name");
    }

    statePtr->flags		= mask;

    /*
     * Set the channel to system default encoding.
     */

    statePtr->encoding = NULL;
    name = Tcl_GetEncodingName(NULL);
    if (strcmp(name, "binary") != 0) {
    	statePtr->encoding = Tcl_GetEncoding(NULL, name);
    }
    statePtr->inputEncodingState	= NULL;
    statePtr->inputEncodingFlags	= TCL_ENCODING_START;
    statePtr->outputEncodingState	= NULL;
    statePtr->outputEncodingFlags	= TCL_ENCODING_START;

    /*
     * Set the channel up initially in AUTO input translation mode to
     * accept "\n", "\r" and "\r\n". Output translation mode is set to
     * a platform specific default value. The eofChar is set to 0 for both
     * input and output, so that Tcl does not look for an in-file EOF
     * indicator (e.g. ^Z) and does not append an EOF indicator to files.
     */

    statePtr->inputTranslation	= TCL_TRANSLATE_AUTO;
    statePtr->outputTranslation	= TCL_PLATFORM_TRANSLATION;
    statePtr->inEofChar		= 0;
    statePtr->outEofChar	= 0;

    statePtr->unreportedError	= 0;
    statePtr->refCount		= 0;
    statePtr->closeCbPtr	= (CloseCallback *) NULL;
    statePtr->curOutPtr		= (ChannelBuffer *) NULL;
    statePtr->outQueueHead	= (ChannelBuffer *) NULL;
    statePtr->outQueueTail	= (ChannelBuffer *) NULL;
    statePtr->saveInBufPtr	= (ChannelBuffer *) NULL;
    statePtr->inQueueHead	= (ChannelBuffer *) NULL;
    statePtr->inQueueTail	= (ChannelBuffer *) NULL;
    statePtr->chPtr		= (ChannelHandler *) NULL;
    statePtr->interestMask	= 0;
    statePtr->scriptRecordPtr	= (EventScriptRecord *) NULL;
    statePtr->bufSize		= CHANNELBUFFER_DEFAULT_SIZE;
    statePtr->timer		= NULL;
    statePtr->csPtr		= NULL;

    statePtr->outputStage	= NULL;
    if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) {
	statePtr->outputStage = (char *)
	    ckalloc((unsigned) (statePtr->bufSize + 2));
    }

    /*
     * As we are creating the channel, it is obviously the top for now
     */
    statePtr->topChanPtr	= chanPtr;
    statePtr->bottomChanPtr	= chanPtr;
    chanPtr->downChanPtr	= (Channel *) NULL;
    chanPtr->upChanPtr		= (Channel *) NULL;
    chanPtr->inQueueHead        = (ChannelBuffer*) NULL;
    chanPtr->inQueueTail        = (ChannelBuffer*) NULL;

    /*
     * Link the channel into the list of all channels; create an on-exit
     * handler if there is not one already, to close off all the channels
     * in the list on exit.
     *
     * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
     */

    statePtr->nextCSPtr	= tsdPtr->firstCSPtr;
    tsdPtr->firstCSPtr	= statePtr;

    /*
     * TIP #10. Mark the current thread as the one managing the new
     *          channel. Note: 'Tcl_GetCurrentThread' returns sensible
     *          values even for a non-threaded core.
     */

    statePtr->managingThread = Tcl_GetCurrentThread ();

    /*
     * Install this channel in the first empty standard channel slot, if
     * the channel was previously closed explicitly.
     */

    if ((tsdPtr->stdinChannel == NULL) &&
	    (tsdPtr->stdinInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN);
        Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } else if ((tsdPtr->stdoutChannel == NULL) &&
	    (tsdPtr->stdoutInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT);
        Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } else if ((tsdPtr->stderrChannel == NULL) &&
	    (tsdPtr->stderrInitialized == 1)) {
	Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR);
        Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
    } 
    return (Tcl_Channel) chanPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StackChannel --
 *
 *	Replaces an entry in the hash table for a Tcl_Channel
 *	record. The replacement is a new channel with same name,
 *	it supercedes the replaced channel. Input and output of
 *	the superceded channel is now going through the newly
 *	created channel and allows the arbitrary filtering/manipulation
 *	of the dataflow.
 *
 *	Andreas Kupries <[e-mail]>, 12/13/1998
 *	"Trf-Patch for filtering channels"
 *
 * Results:
 *	Returns the new Tcl_Channel, which actually contains the
 *      saved information about prevChan.
 *
 * Side effects:
 *    A new channel structure is allocated and linked below
 *    the existing channel.  The channel operations and client
 *    data of the existing channel are copied down to the newly
 *    created channel, and the current channel has its operations
 *    replaced by the new typePtr.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan)
    Tcl_Interp	    *interp;	   /* The interpreter we are working in */
    Tcl_ChannelType *typePtr;	   /* The channel type record for the new
				    * channel. */