diff options
| -rw-r--r-- | doc/chan.n | 8 | ||||
| -rw-r--r-- | generic/tclIO.c | 28 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 41 | ||||
| -rw-r--r-- | generic/tclInt.h | 1 | ||||
| -rw-r--r-- | tests/chan.test | 10 |
5 files changed, 88 insertions, 0 deletions
@@ -527,6 +527,14 @@ errors are encountered in the channel input data. The file pointer remains unchanged and it is possible to introspect, and in some cases recover, by changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE +.\" METHOD: isbinary +.TP +\fBchan isbinary \fIchannel\fR +. +Test whether the channel called \fIchannel\fR is a binary channel, +returning 1 if it is and, and 0 otherwise. A binary channel is +a channel with iso8859-1 encoding, -eofchar set to {} and +-translation set to cr. .\" METHOD: names .TP \fBchan names\fR ?\fIpattern\fR? diff --git a/generic/tclIO.c b/generic/tclIO.c index fa75804..23b0bc3 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7537,6 +7537,34 @@ CheckChannelErrors( /* *---------------------------------------------------------------------- * + * TclChanIsBinary -- + * + * Returns 1 if the channel is a binary channel, 0 otherwise. + * + * Results: + * 1 or 0, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclChanIsBinary( + Tcl_Channel chan) /* Does this channel have EOF? */ +{ + ChannelState *statePtr = ((Channel *) chan)->state; + /* State of real channel structure. */ + + return ((statePtr->encoding == GetBinaryEncoding()) && !statePtr->inEofChar + && (!GotFlag(statePtr, TCL_READABLE) || (statePtr->inputTranslation == TCL_TRANSLATE_LF)) + && (!GotFlag(statePtr, TCL_WRITABLE) || (statePtr->outputTranslation == TCL_TRANSLATE_LF))); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Eof -- * * Returns 1 if the channel is at EOF, 0 otherwise. diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 0357471..a31b64f 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -837,6 +837,46 @@ Tcl_EofObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan))); return TCL_OK; } + +/* + *--------------------------------------------------------------------------- + * + * ChanIsBinaryCmd -- + * + * This function is invoked to process the Tcl "chan isbinary" command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp's result to boolean true or false depending on whether the + * specified channel is a binary channel. + * + *--------------------------------------------------------------------------- + */ + +static int +ChanIsBinaryCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Channel chan; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channel"); + return TCL_ERROR; + } + + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclChanIsBinary(chan))); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -2033,6 +2073,7 @@ TclInitChanCmd( {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"isbinary",ChanIsBinaryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */ {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 7f0e842..da8581a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3291,6 +3291,7 @@ MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; +MODULE_SCOPE int TclChanIsBinary(Tcl_Channel chan); MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); diff --git a/tests/chan.test b/tests/chan.test index ea85e45..bbb9ec5 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -123,6 +123,16 @@ test chan-15.2 {chan command: truncate subcommand} -setup { catch {close $f} catch {removeFile $file} } +test chan-15.3 {chan command: isbinary subcommand} -setup { + set file [makeFile {} testIsBinary] + set f [open $file w+] + fconfigure $f -translation binary +} -body { + chan isbinary $f +} -result 1 -cleanup { + catch {close $f} + catch {removeFile $file} +} # TIP 287: chan pending test chan-16.1 {chan command: pending subcommand} -body { |