Tcl Source Code

    }

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    Tcl_Preserve(chanPtr);

    bufPtr = statePtr->inQueueHead;
    encoding = statePtr->encoding;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.

     */

  gotEOL:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    /*
    chanPtr = statePtr->topChanPtr;
     */

    bufPtr = gs.bufPtr;
    if (bufPtr == NULL) {
	Tcl_Panic("Tcl_GetsObj: gotEOL reached with bufPtr==NULL");
    }
    statePtr->inputEncodingState = gs.state;
    Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead,

     */

  restore:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    /*
    chanPtr = statePtr->topChanPtr;
     */
    bufPtr = statePtr->inQueueHead;
    if (bufPtr == NULL) {
	Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL");
    }
    bufPtr->nextRemoved = oldRemoved;

    for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {

     */

  done:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    /*
    chanPtr = statePtr->topChanPtr;
     */
    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetsObjBinary --

    unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    Tcl_Preserve(chanPtr);

    bufPtr = statePtr->inQueueHead;

    /*
     * Preserved so we can restore the channel's state in case we don't find a
     * newline in the available input.
     */

    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copiedTotal;
}

/*
 *---------------------------------------------------------------------------
 *
 * FreeBinaryEncoding --

    /*
     * Check for information in the push-back buffers. If there is some, use
     * it. Go to the driver only if there is none (anymore) and the caller
     * requests more bytes.
     */

    Tcl_Preserve(chanPtr);
    for (copied = 0; copied < bytesToRead; copied += copiedNow) {
	copiedNow = CopyBuffer(chanPtr, bufPtr + copied,
		bytesToRead - copied);
	if (copiedNow == 0) {
	    if (GotFlag(statePtr, CHANNEL_EOF)) {
		goto done;
	    }

		if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
		    if (copied > 0) {
			/*
			 * Information that was copied earlier has precedence
			 * over EAGAIN/WOULDBLOCK handling.
			 */

			goto done;
		    }

		    SetFlag(statePtr, CHANNEL_BLOCKED);
		    result = EAGAIN;
		}

		Tcl_SetErrno(result);
		copied = -1;
		goto done;
	    }

	    copied += nread;
	    goto done;
	}
    }

  done:
    Tcl_Release(chanPtr);
    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_ReadChars --

    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    encoding = statePtr->encoding;
    factor = UTF_EXPANSION_FACTOR;
    Tcl_Preserve(chanPtr);

    if (appendFlag == 0) {
	if (encoding == NULL) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);

     */

  done:
    /*
     * Regenerate the top channel, in case it was changed due to
     * self-modifying reflected transforms.
     */
    /*
    chanPtr = statePtr->topChanPtr;
     */
    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --

static void
UpdateInterest(
    Channel *chanPtr)		/* Channel to update. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    int mask = statePtr->interestMask;

    if (chanPtr->typePtr == NULL) {
	/* Do not update interest on a closed channel */
	return;
    }

    /*
     * If there are flushed buffers waiting to be written, then we need to
     * watch for the channel to become writable.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {

    /*
     * If we have not encountered a sticky EOF, clear the EOF bit. Either way
     * clear the BLOCKED bit. We want to discover these anew during each
     * operation.
     */

    Tcl_Preserve(chanPtr);
    if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
	ResetFlag(statePtr, CHANNEL_EOF);
    }
    ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);

    for (copied = 0; copied < toRead; copied += copiedNow) {
	copiedNow = CopyAndTranslateBuffer(statePtr, bufPtr + copied,

    /*
     * Update the notifier state so we don't block while there is still data
     * in the buffers.
     */

  done:
    UpdateInterest(chanPtr);
    Tcl_Release(chanPtr);
    return copied;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyAndTranslateBuffer --

     */

    rcId = NextHandle();
    rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId);
    chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr,
	    mode);
    rcPtr->chan = chan;
    Tcl_Preserve(chan);
    chanPtr = (Channel *) chan;

    /*
     * Invoke 'initialize' and validate that the handler is present and ok.
     * Squash the channel if not.
     *
     * Note: The conversion of 'mode' back into a Tcl_Obj ensures that

	/*
	 * Delete a cloned ChannelType structure.
	 */

	ckfree(chanPtr->typePtr);
	chanPtr->typePtr = NULL;
    }
    Tcl_Release(chanPtr);

    FreeReflectedChannelArgs(rcPtr);

    ckfree(rcPtr->argv);
    ckfree(rcPtr);
}


    note [eof $c]
    set res
} -cleanup {
    close $c
    rename foo {}
    unset res
} -result {{read rc* 4096} {} 0}
test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	set args [lassign $args sub id]
	if {$sub ne "read"} {return}
	close $id
	return {}
    }
    set c [chan create {r} foo]
    note [read $c]
    rename foo {}
    set res
} -result {{read rc* 4096} {}}

# --- === *** ###########################
# method write

test iocmd-24.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} {

	chan pop $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
    lappend res [read $c]
    #lappend res [gets $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} file*}
test iortrans-4.8.1 {chan read, bug 721ec69271} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	# Kill and recreate transform while it is operating
	chan pop $fd
	chan push $fd [list foo $fd]
    }
    set c [chan push [set c [tempchan]] [list foo $c]]
    chan configure $c -buffersize 2
    lappend res [read $c]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} file*}
test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
    set res {}
} -match glob -body {

    #catch {puts stdout "\t>* $res" ; flush stdout}
    #catch {puts stdout "x$res"} msg

    lappend trail [list $op $data $res]
    return $res
}

proc id_torture {chan op data} {
    switch -- $op {
	create/write -
	create/read  -
	delete/write -
	delete/read  -
	clear_read   {;#ignore}
	flush/write -
	flush/read  -
	write       -
	read        {
	    testchannel unstack $chan
	    testchannel transform $chan \
		-command [namespace code [list id_torture $chan]]
	    return $data
	}
	query/maxRead {return -1}
    }
}

proc counter {var op data} {
    namespace upvar [namespace current] $var n

    switch -- $op {
	create/write - create/read - delete/write - delete/read - clear_read {
	    #ignore

}
proc audit_ops {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_optrail $var]]
}
proc audit_flow {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}

proc torture {-attach channel} {
    testchannel transform $channel -command [namespace code [list id_torture $channel]]
}

proc stopafter {var n -attach channel} {
    namespace upvar [namespace current] $var vn
    set vn $n
    testchannel transform $channel -command [namespace code [list counter $var]]
}
proc stopafter_audit {var trail n -attach channel} {
    namespace upvar [namespace current] $var vn

write %^&*()_+-= %^&*()_+-=
write {
} {
}
delete/read {} *ignored*
flush/write {} {}
delete/write {} *ignored*}

test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
    set fh [open $path(dummy) r]
    torture -attach $fh
    chan configure $fh -buffersize 2
    set x [read $fh]
    testchannel unstack $fh
    close   $fh
    set x
} {}

test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
    proc DoneCopy {n {err {}}} {
	variable copy 1
    }
} -constraints {testchannel hangs} -body {
    # This test to check the validity of aquired Tcl_Channel references is not

# tcl pkg-config source file

prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@

Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
Version: @TCL_VERSION@
Requires:
Conflicts:
Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_LIBS@
Cflags: -I${includedir}

static int		SetOwnerAttribute(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
static int		SetPermissionsAttribute(Tcl_Interp *interp,
			    int objIndex, Tcl_Obj *fileName,
			    Tcl_Obj *attributePtr);
static int		GetModeFromPermString(Tcl_Interp *interp,
			    const char *modeStringPtr, mode_t *modePtr);
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
static int		GetUnixFileAttributes(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr);
static int		SetUnixFileAttributes(Tcl_Interp *interp, int objIndex,
			    Tcl_Obj *fileName, Tcl_Obj *attributePtr);
#endif

/*
 * Prototype for the TraverseUnixTree callback function.
 */

 */

extern TclFileAttrProcs tclpFileAttrProcs[];
extern const char *const tclpFileAttrStrings[];

#else /* !DJGPP */
enum {
#if defined(__CYGWIN__)
    UNIX_ARCHIVE_ATTRIBUTE,
#endif
    UNIX_GROUP_ATTRIBUTE,
#if defined(__CYGWIN__)
    UNIX_HIDDEN_ATTRIBUTE,
#endif
    UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE,
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
    UNIX_READONLY_ATTRIBUTE,
#endif
#if defined(__CYGWIN__)
    UNIX_SYSTEM_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
    MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,
    MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
    UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */
};

MODULE_SCOPE const char *const tclpFileAttrStrings[];
const char *const tclpFileAttrStrings[] = {
#if defined(__CYGWIN__)
    "-archive",
#endif
    "-group",
#if defined(__CYGWIN__)
    "-hidden",
#endif
    "-owner", "-permissions",
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
    "-readonly",
#endif
#if defined(__CYGWIN__)
    "-system",
#endif
#ifdef MAC_OSX_TCL
    "-creator", "-type", "-hidden", "-rsrclength",
#endif
    NULL
};

MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
const TclFileAttrProcs tclpFileAttrProcs[] = {
#if defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
    {GetGroupAttribute, SetGroupAttribute},
#if defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
    {GetOwnerAttribute, SetOwnerAttribute},
    {GetPermissionsAttribute, SetPermissionsAttribute},
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
#if defined(__CYGWIN__)
    {GetUnixFileAttributes, SetUnixFileAttributes},
#endif
#ifdef MAC_OSX_TCL
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
    {TclMacOSXGetFileAttribute,	TclMacOSXSetFileAttribute},
#endif

     * an existing writable directory; we've no recovery mechanism if it
     * isn't.
     */

    return TCL_TEMPORARY_FILE_DIRECTORY;
}

#if defined(__CYGWIN__)

static void
StatError(
    Tcl_Interp *interp,		/* The interp that has the error */
    Tcl_Obj *fileName)		/* The name of the file which caused the
				 * error. */
{
    TclWinConvertError(GetLastError());
    Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
	    TclGetString(fileName), Tcl_PosixError(interp)));
}

static WCHAR *
winPathFromObj(
    Tcl_Obj *fileName)
{
    int size;
    const char *native =  Tcl_FSGetNativePath(fileName);
    WCHAR *winPath;

    size = cygwin_conv_path(1, native, NULL, 0);
    winPath = ckalloc(size);
    cygwin_conv_path(1, native, winPath, size);

    return winPath;
}

static const int attributeArray[] = {
    0x20, 0, 2, 0, 0, 1, 4};

/*
 *----------------------------------------------------------------------
 *
 * GetUnixFileAttributes
 *
 *	Gets the readonly attribute of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    int fileAttributes;
    WCHAR *winPath = winPathFromObj(fileName);

    fileAttributes = GetFileAttributesW(winPath);
    ckfree(winPath);

    if (fileAttributes == -1) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    *attributePtrPtr = Tcl_NewIntObj((fileAttributes&attributeArray[objIndex])!=0);

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes
 *
 *	Sets the readonly attribute of a file.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The readonly attribute of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetUnixFileAttributes(
    Tcl_Interp *interp,	    /* The interp we are using for errors. */
    int objIndex,           /* The index of the attribute. */
    Tcl_Obj *fileName,      /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)  /* The attribute to set. */
{
    int yesNo, fileAttributes, old;
    WCHAR *winPath;

    if (Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo) != TCL_OK) {
	return TCL_ERROR;
    }

    winPath = winPathFromObj(fileName);

    fileAttributes = old = GetFileAttributesW(winPath);

    if (fileAttributes == -1) {
	ckfree(winPath);
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    if (yesNo) {
	fileAttributes |= attributeArray[objIndex];
    } else {
	fileAttributes &= ~attributeArray[objIndex];
    }

    if ((fileAttributes != old)
	    && !SetFileAttributesW(winPath, fileAttributes)) {
	ckfree(winPath);
	StatError(interp, fileName);
	return TCL_ERROR;
    }

	ckfree(winPath);
    return TCL_OK;
}
#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
 *----------------------------------------------------------------------
 *
 * GetUnixFileAttributes
 *
 *	Gets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:
 *	A new object is allocated.
 *
 *----------------------------------------------------------------------
 */

static int
GetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    int result;

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetUnixFileAttributes
 *
 *	Sets the readonly attribute (user immutable flag) of a file.
 *
 * Results:
 *	Standard TCL result.
 *
 * Side effects:
 *	The readonly attribute of the file is changed.
 *
 *---------------------------------------------------------------------------
 */

static int
SetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr)	/* The attribute to set. */
{
    Tcl_StatBuf statBuf;
    int result, readonly;

    __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int);
    __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
	    const char *, int, const char *, const char *);
    __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
	    WCHAR *, int);
    __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
    __declspec(dllimport) extern __stdcall int IsDebuggerPresent();
    __declspec(dllimport) extern __stdcall int GetLastError();
    __declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
    __declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);

    __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
    __declspec(dllimport) extern int cygwin_conv_path_list(int, const void *, void *, int);
#   define USE_PUTENV 1
#   define USE_PUTENV_FOR_UNSET 1
/* On Cygwin, the environment is imported from the Cygwin DLL. */
#ifndef __x86_64__

{
    FileInfo *infoPtr = instanceData;
    DWORD bytesRead;

    *errorCode = 0;

    /*
     * TODO: This comment appears to be out of date.  We *do* have a
     * console driver, over in tclWinConsole.c.  After some Windows
     * developer confirms, this comment should be revised.
     *
     * Note that we will block on reads from a console buffer until a full
     * line has been entered. The only way I know of to get around this is to
     * write a console driver. We should probably do this at some point, but
     * for now, we just block. The same problem exists for files being read
     * over the network.
     */

     * Attempt to read bufSize bytes. The read will return immediately if
     * there is any data available. Otherwise it will block until at least one
     * byte is available or an EOF occurs.
     */

    if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize,
	    &count) == TRUE) {
	/*
	 * TODO: This potentially writes beyond the limits specified
	 * by the caller.  In practice this is harmless, since all writes
	 * are into ChannelBuffers, and those have padding, but still
	 * ought to remove this, unless some Windows wizard can give
	 * a reason not to.  
	 */
	buf[count] = '\0';
	return count;
    }

    return -1;
}


static int
SetWinFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj *attributePtr)	/* The new value of the attribute. */
{
    DWORD fileAttributes, old;
    int yesNo, result;
    const TCHAR *nativeName;

    nativeName = Tcl_FSGetNativePath(fileName);
    fileAttributes = old = GetFileAttributes(nativeName);

    if (fileAttributes == 0xffffffff) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
    if (result != TCL_OK) {
	return result;
    }

    if (yesNo) {
	fileAttributes |= (attributeArray[objIndex]);
    } else {
	fileAttributes &= ~(attributeArray[objIndex]);
    }

    if ((fileAttributes != old)
	    && !SetFileAttributes(nativeName, fileAttributes)) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    return result;
}


/*
 * Bit masks used in the sharedFlags field of the PipeInfo structure below.
 */

#define PIPE_EOF	(1<<2)	/* Pipe has reached EOF. */
#define PIPE_EXTRABYTE	(1<<3)	/* The reader thread has consumed one byte. */

/*
 * TODO: It appears the whole EXTRABYTE machinery is in place to support
 * outdated Win 95 systems.  If this can be confirmed, much code can be
 * deleted.
 */

/*
 * This structure describes per-instance data for a pipe based channel.
 */

typedef struct PipeInfo {
    struct PipeInfo *nextPtr;	/* Pointer to next registered pipe. */
    Tcl_Channel channel;	/* Pointer to channel structure. */