TIP#183 IMPLEMENTATION [Patch 577093]

        * generic/tclIOUtil.c (TclGetOpenModeEx):       New routine.
        * generic/tclInt.h:

        * generic/tclIO.c (Tcl_OpenObjCmd):     Support for "b" and
        * doc/open.n:           "BINARY" in "access" argument to [open].
        * tests/ioCmd.test:

6 files changed, 152 insertions, 38 deletions

diff --git a/ChangeLog b/ChangeLog
index f52336a..343e2e1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2005-04-27  Don Porter  <dgp@users.sourceforge.net>
+
+	TIP#183 IMPLEMENTATION	[Patch 577093]
+
+	* generic/tclIOUtil.c (TclGetOpenModeEx):	New routine.
+	* generic/tclInt.h:
+
+	* generic/tclIO.c (Tcl_OpenObjCmd):	Support for "b" and
+	* doc/open.n:		"BINARY" in "access" argument to [open].
+	* tests/ioCmd.test:
+
 2005-04-25  Daniel Steffen  <das@users.sourceforge.net>
 
 	* compat/string.h: fixed memchr() protoype for __APPLE__ so that we
diff --git a/doc/open.n b/doc/open.n
index 8751834..81335a1 100644
--- a/doc/open.n
+++ b/doc/open.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: open.n,v 1.23 2005/04/06 20:55:23 dkf Exp $
+'\" RCS: @(#) $Id: open.n,v 1.24 2005/04/27 18:48:24 dgp Exp $
 '\" 
 .so man.macros
 .TH open n 8.3 Tcl "Tcl Built-In Commands"
@@ -61,6 +61,14 @@ Set the initial access position  to the end of the file.
 Open the file for reading and writing.  If the file doesn't exist,
 create a new empty file.
 Set the initial access position  to the end of the file.
+.VS 8.5
+.PP
+All of the legal \fIaccess\fR values above may have the character
+\fBb\fR added as the second or third character in the value to
+indicate that the opened channel should be configured with the
+\fB-translation binary\fR option, making the channel suitable for 
+reading or writing of binary data.
+.VE 8.5
 .PP
 In the second form, \fIaccess\fR consists of a list of any of the
 following flags, all of which have the standard POSIX meanings.
@@ -78,6 +86,11 @@ Open the file for both reading and writing.
 \fBAPPEND\fR
 Set the file pointer to the end of the file prior to each write.
 .TP 15
+.VS 8.5
+\fBBINARY\fR
+Configure the opened channed with the \fB-translation binary\fR option.
+.VE 8.5
+.TP 15
 \fBCREAT\fR
 Create the file if it doesn't already exist (without this flag it
 is an error for the file not to exist).
@@ -106,14 +119,6 @@ If a new file is created as part of opening it, \fIpermissions\fR
 (an integer) is used to set the permissions for the new file in
 conjunction with the process's file mode creation mask.
 \fIPermissions\fR defaults to 0666.
-.PP
-Note that if you are going to be reading or writing binary data from
-the channel created by this command, you should use the
-\fBfconfigure\fR command to change the \fB-translation\fR option of
-the channel to \fBbinary\fR before transferring any binary data.  This
-is in contrast to the ``b'' character passed as part of the equivalent
-of the \fIaccess\fR parameter to some versions of the C library
-\fIfopen()\fR function.
 
 .SH "COMMAND PIPELINES"
 .PP
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 732b162..fc14619 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIOCmd.c,v 1.22 2004/10/07 00:24:49 dgp Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.23 2005/04/27 18:48:25 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -960,14 +960,14 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv)
     if (!pipeline) {
         chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
     } else {
-	int mode, seekFlag, cmdObjc;
+	int mode, seekFlag, cmdObjc, binary;
 	CONST char **cmdArgv;
 
         if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
             return TCL_ERROR;
         }
 
-        mode = TclGetOpenMode(interp, modeString, &seekFlag);
+        mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
         if (mode == -1) {
 	    chan = NULL;
         } else {
@@ -987,6 +987,9 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv)
 		    break;
 	    }
 	    chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
+	    if (binary) {
+		Tcl_SetChannelOption(interp, chan, "-translation", "binary");
+	    }
 	}
         ckfree((char *) cmdArgv);
     }
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 6fc27f0..17d6efa 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIOUtil.c,v 1.116 2005/04/16 08:04:56 vasiljevic Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.117 2005/04/27 18:48:25 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1412,9 +1412,43 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
  * TclGetOpenMode --
  *
  * Description:
+ * 	This routine is an obsolete, limited version of
+ * 	TclGetOpenModeEx() below.  It exists only to satisfy any
+ * 	extensions imprudently using it via Tcl's internal stubs table.
+ *
+ * Results:
+ * 	Same as TclGetOpenModeEx().
+ *
+ * Side effects:
+ * 	Same as TclGetOpenModeEx().
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclGetOpenMode(interp, modeString, seekFlagPtr)
+    Tcl_Interp *interp;			/* Interpreter to use for error
+					 * reporting - may be NULL. */
+    CONST char *modeString;		/* Mode string, e.g. "r+" or
+					 * "RDONLY CREAT". */
+    int *seekFlagPtr;			/* Set this to 1 if the caller
+                                         * should seek to EOF during the
+                                         * opening of the file. */
+{
+    int binary = 0;
+    return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclGetOpenModeEx --
+ *
+ * Description:
  *	Computes a POSIX mode mask for opening a file, from a given string,
- *	and also sets a flag to indicate whether the caller should seek to
- *	EOF after opening the file.
+ *	and also sets flags to indicate whether the caller should seek to
+ *	EOF after opening the file, and whether the caller should
+ *	configure the channel for binary data.
  *
  * Results:
  *	On success, returns mode to pass to "open". If an error occurs, the
@@ -1423,7 +1457,9 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
  *
  * Side effects:
  *	Sets the integer referenced by seekFlagPtr to 1 to tell the caller
- *	to seek to EOF after opening the file.
+ *	to seek to EOF after opening the file, or to 0 otherwise.  Sets the
+ *	integer referenced by binaryPtr to 1 to tell the caller	to seek to
+ *	configure the channel for binary data, or to 0 otherwise.
  *
  * Special note:
  *	This code is based on a prototype implementation contributed
@@ -1431,16 +1467,18 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
  *
  *---------------------------------------------------------------------------
  */
-
 int
-TclGetOpenMode(interp, string, seekFlagPtr)
+TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr)
     Tcl_Interp *interp;			/* Interpreter to use for error
 					 * reporting - may be NULL. */
-    CONST char *string;			/* Mode string, e.g. "r+" or
+    CONST char *modeString;		/* Mode string, e.g. "r+" or
 					 * "RDONLY CREAT". */
     int *seekFlagPtr;			/* Set this to 1 if the caller
                                          * should seek to EOF during the
                                          * opening of the file. */
+    int *binaryPtr;			/* Set this to 1 if the caller
+					 * should configure the opened
+					 * channel for binary operations */
 {
     int mode, modeArgc, c, i, gotRW;
     CONST char **modeArgv, *flag;
@@ -1453,6 +1491,7 @@ TclGetOpenMode(interp, string, seekFlagPtr)
      */
 
     *seekFlagPtr = 0;
+    *binaryPtr = 0;
     mode = 0;
 
     /*
@@ -1460,9 +1499,9 @@ TclGetOpenMode(interp, string, seekFlagPtr)
      * routines.
      */
 
-    if (!(string[0] & 0x80)
-	    && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
-	switch (string[0]) {
+    if (!(modeString[0] & 0x80)
+	    && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */
+	switch (modeString[0]) {
 	    case 'r':
 		mode = O_RDONLY;
 		break;
@@ -1475,20 +1514,33 @@ TclGetOpenMode(interp, string, seekFlagPtr)
 		break;
 	    default:
 		error:
+                *seekFlagPtr = 0;
+		*binaryPtr = 0;
                 if (interp != (Tcl_Interp *) NULL) {
                     Tcl_AppendResult(interp,
-                            "illegal access mode \"", string, "\"",
+                            "illegal access mode \"", modeString, "\"",
                             (char *) NULL);
                 }
 		return -1;
 	}
-	if (string[1] == '+') {
-	    mode &= ~(O_RDONLY|O_WRONLY);
-	    mode |= O_RDWR;
-	    if (string[2] != 0) {
+	i=1;
+	while (i<3 && modeString[i]) {
+	    if (modeString[i] == modeString[i-1]) {
 		goto error;
 	    }
-	} else if (string[1] != 0) {
+	    switch (modeString[i++]) {
+		case '+':
+		    mode &= ~(O_RDONLY|O_WRONLY);
+		    mode |= O_RDWR;
+		    break;
+		case 'b':
+		    *binaryPtr = 1;
+		    break;
+		default:
+		    goto error;
+	    }
+	}
+	if (modeString[i] != 0) {
 	    goto error;
 	}
         return mode;
@@ -1502,11 +1554,11 @@ TclGetOpenMode(interp, string, seekFlagPtr)
      * a NULL interpreter is passed in.
      */
 
-    if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
+    if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
         if (interp != (Tcl_Interp *) NULL) {
             Tcl_AddErrorInfo(interp,
                     "\n    while processing open access modes \"");
-            Tcl_AddErrorInfo(interp, string);
+            Tcl_AddErrorInfo(interp, modeString);
             Tcl_AddErrorInfo(interp, "\"");
         }
         return -1;
@@ -1560,11 +1612,14 @@ TclGetOpenMode(interp, string, seekFlagPtr)
 #endif
 	} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
 	    mode |= O_TRUNC;
+	} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
+	    *binaryPtr = 1;
 	} else {
             if (interp != (Tcl_Interp *) NULL) {
                 Tcl_AppendResult(interp, "invalid access mode \"", flag,
-                        "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
-                        " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
+			"\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
+			"CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC",
+			(char *) NULL);
             }
 	    ckfree((char *) modeArgv);
 	    return -1;
@@ -2086,8 +2141,8 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
     if (fsPtr != NULL) {
 	Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
 	if (proc != NULL) {
-	    int mode, seekFlag;
-	    mode = TclGetOpenMode(interp, modeString, &seekFlag);
+	    int mode, seekFlag, binary;
+	    mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
 	    if (mode == -1) {
 	        return NULL;
 	    }
@@ -2106,6 +2161,10 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
 			return NULL;
 		    }
 		}
+		if (binary) {
+		    Tcl_SetChannelOption(interp, retVal,
+			    "-translation", "binary");
+		}
 	    }
 	    return retVal;
 	}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 727b879..e0779ef 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.225 2005/04/22 15:46:57 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.226 2005/04/27 18:48:25 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1889,7 +1889,9 @@ MODULE_SCOPE int	TclGetEncodingFromObj _ANSI_ARGS_((Tcl_Interp *interp,
 MODULE_SCOPE int        TclGetNamespaceFromObj _ANSI_ARGS_((
 			    Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    Tcl_Namespace **nsPtrPtr));
-
+MODULE_SCOPE int	TclGetOpenModeEx _ANSI_ARGS_((Tcl_Interp *interp,
+			    CONST char *modeString, int *seekFlagPtr,
+			    int *binaryPtr));
 MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue _ANSI_ARGS_ ((
 			    ProcessGlobalValue *pgvPtr));
 MODULE_SCOPE int	TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 45f889d..49da62e 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: ioCmd.test,v 1.21 2004/06/23 15:36:57 dkf Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.22 2005/04/27 18:48:26 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -426,11 +426,36 @@ unmatched open brace in list
 \"open \$path(test3) \"FOO \\{BAR BAZ\"\""
 test iocmd-12.7 {POSIX open access modes: errors} {
   list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
-} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
+} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}}
 test iocmd-12.8 {POSIX open access modes: errors} {
     list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
 } {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
 close [open $path(test3) w]
+test iocmd-12.9 {POSIX open access modes: BINARY} {
+    list [catch {open $path(test1) BINARY} msg] $msg
+} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
+test iocmd-12.10 {POSIX open access modes: BINARY} {
+    set f [open $path(test1) {WRONLY BINARY TRUNC}]
+    puts $f a
+    puts $f b
+    puts -nonewline $f c	;# contents are now 5 bytes: a\nb\nc
+    close $f
+    set f [open $path(test1) r]
+    fconfigure $f -translation binary
+    set result [string length [read $f]]
+    close $f
+    set result
+} 5
+test iocmd-12.11 {POSIX open access modes: BINARY} {
+    set f [open $path(test1) {WRONLY BINARY TRUNC}]
+    puts $f \u0248	;# gets truncated to \u0048
+    close $f
+    set f [open $path(test1) r]
+    fconfigure $f -translation binary
+    set result [read -nonewline $f]
+    close $f
+    set result
+} \u0048
 
 test iocmd-13.1 {errors in open command} {
     list [catch {open} msg] $msg
@@ -452,6 +477,15 @@ test iocmd-13.6 {errors in open command} {
     regsub [file join {} _non_existent_] $msg "_non_existent_" msg
 	string tolower $msg
 } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
+test iocmd-13.7 {errors in open command} {
+    list [catch {open $path(test1) b} msg] $msg
+} {1 {illegal access mode "b"}}
+test iocmd-13.8 {errors in open command} {
+    list [catch {open $path(test1) rbb} msg] $msg
+} {1 {illegal access mode "rbb"}}
+test iocmd-13.9 {errors in open command} {
+    list [catch {open $path(test1) r++} msg] $msg
+} {1 {illegal access mode "r++"}}
 
 test iocmd-14.1 {file id parsing errors} {
     list [catch {eof gorp} msg] $msg $errorCode