From 430458069be438b22d0f204e0564346eea4e2c06 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sun, 23 Jun 2024 20:26:43 +0000
Subject: Add "chan isbinary" for checking whether a _channel_ is binary.

---
 doc/chan.n         |  8 ++++++++
 generic/tclIO.c    | 28 ++++++++++++++++++++++++++++
 generic/tclIOCmd.c | 41 +++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h   |  1 +
 tests/chan.test    | 10 ++++++++++
 5 files changed, 88 insertions(+)

diff --git a/doc/chan.n b/doc/chan.n
index c08c7e3..8c35fee 100644
--- a/doc/chan.n
+++ b/doc/chan.n
@@ -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 75a9025..2df5da5 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 {
-- 
cgit v0.12