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 | ||||
| -rw-r--r-- | tests/cmdAH.test | 2 |
6 files changed, 89 insertions, 1 deletions
@@ -540,6 +540,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 caf0e3a..cd925b5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7628,6 +7628,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 || (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 71dc54e..68e79bd 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -864,6 +864,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; +} /* *---------------------------------------------------------------------- @@ -2055,6 +2095,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 9e956dc..c2f52b3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3126,6 +3126,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 d818a62..700df87 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -120,6 +120,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 { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ed55c24..6432ad4 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -23,7 +23,7 @@ testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint time64bit [expr { - ([llength [info command testsize]] ? + ([llength [info command testsize]] ? [testsize st_mtime] : $::tcl_platform(pointerSize)) >= 8 }] testConstraint linkDirectory [expr { |