Merge tip-597

3 files changed, 108 insertions, 7 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index e1b6066..dfb4c3a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -717,6 +717,11 @@ typedef void (Tcl_ServiceModeHookProc) (int mode);
 typedef ClientData (Tcl_InitNotifierProc) (void);
 typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData);
 typedef void (Tcl_MainLoopProc) (void);
+
+/* Undocumented. To be formalized by TIP #595 */
+#define Tcl_LibraryInitProc Tcl_PackageInitProc
+#define Tcl_LibraryUnloadProc Tcl_PackageUnloadProc
+#define Tcl_StaticLibrary Tcl_StaticPackage
 
 /*
  *----------------------------------------------------------------------------
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 6cf0d76..b7c0a4f 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -511,7 +511,7 @@ FillEncodingFileMap(void)
  */
 
 /* Since TCL_ENCODING_MODIFIED is only used for utf-8/wtf-8/cesu-8 and
- * TCL_ENCODING_LE is only used for  utf-16/wtf-16/ucs-2. re-use the same value */
+ * TCL_ENCODING_LE is only used for  utf-16/wtf-16/ucs-2, re-use the same value */
 #define TCL_ENCODING_LE		TCL_ENCODING_MODIFIED	/* Little-endian encoding */
 /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */
 #define TCL_ENCODING_WTF	0x100	/* For WTF-8 encoding, don't check for surrogates/noncharacters */
@@ -1117,7 +1117,7 @@ Tcl_CreateEncoding(
  * Results:
  *	The converted bytes are stored in the DString, which is then NULL
  *	terminated. The return value is a pointer to the value stored in the
- *	DString resp. an error code.
+ *	DString resp. the index of the first erratic byte in 'src'.
  *
  * Side effects:
  *	None.
@@ -1326,7 +1326,8 @@ Tcl_ExternalToUtf(
  * Results:
  *	The converted bytes are stored in the DString, which is then NULL
  *	terminated in an encoding-specific manner. The return value is a
- *	pointer to the value stored in the DString resp. an error code.
+ *	pointer to the value stored in the DString resp. the index of the
+ *	first erratic byte in 'src'.
  *
  * Side effects:
  *	None.
@@ -2319,7 +2320,8 @@ UtfToUtfProc(
 	    int low;
 	    const char *saveSrc = src;
 	    size_t len = TclUtfToUCS4(src, &ch);
-	    if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) && (flags & TCL_ENCODING_MODIFIED)) {
+	    if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR)
+		    && (flags & TCL_ENCODING_MODIFIED)) {
 		result = TCL_CONVERT_SYNTAX;
 		break;
 	    }
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 8da8049..88f6de8 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -56,6 +56,8 @@ static int		ReflectGetOption(ClientData clientData,
 static int		ReflectSetOption(ClientData clientData,
 			    Tcl_Interp *interp, const char *optionName,
 			    const char *newValue);
+static int		ReflectTruncate(ClientData clientData,
+			    long long length);
 static void     TimerRunRead(ClientData clientData);
 static void     TimerRunWrite(ClientData clientData);
 
@@ -88,7 +90,7 @@ static const Tcl_ChannelType tclRChannelType = {
 #else
 	NULL,		   /* thread action */
 #endif
-    NULL		   /* truncate */
+    ReflectTruncate	   /* Truncate.				NULL'able */
 };
 
 /*
@@ -186,6 +188,7 @@ static const char *const methodNames[] = {
     "initialize",	/*     */
     "read",		/* OPT */
     "seek",		/* OPT */
+    "truncate",		/* OPT */
     "watch",		/*     */
     "write",		/* OPT */
     NULL
@@ -199,6 +202,7 @@ typedef enum {
     METH_INIT,
     METH_READ,
     METH_SEEK,
+    METH_TRUNCATE,
     METH_WATCH,
     METH_WRITE
 } MethodName;
@@ -208,7 +212,8 @@ typedef enum {
 	(FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH))
 #define NULLABLE_METHODS \
 	(FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \
-	FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL))
+	FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \
+	FLAG(METH_CGETALL)   | FLAG(METH_TRUNCATE))
 
 #define RANDW \
 	(TCL_READABLE | TCL_WRITABLE)
@@ -238,7 +243,8 @@ typedef enum {
     ForwardedBlock,
     ForwardedSetOpt,
     ForwardedGetOpt,
-    ForwardedGetOptAll
+    ForwardedGetOptAll,
+    ForwardedTruncate
 } ForwardedOperation;
 
 /*
@@ -301,6 +307,10 @@ struct ForwardParamGetOpt {
     const char *name;		/* Name of option to get, maybe NULL */
     Tcl_DString *value;		/* Result */
 };
+struct ForwardParamTruncate {
+    ForwardParamBase base;	/* "Supertype". MUST COME FIRST. */
+    Tcl_WideInt length;		/* I: Length of file. */
+};
 
 /*
  * Now join all these together in a single union for convenience.
@@ -315,6 +325,7 @@ typedef union ForwardParam {
     struct ForwardParamBlock block;
     struct ForwardParamSetOpt setOpt;
     struct ForwardParamGetOpt getOpt;
+    struct ForwardParamTruncate truncate;
 } ForwardParam;
 
 /*
@@ -705,6 +716,9 @@ TclChanCreateObjCmd(
 #endif
 	    clonePtr->wideSeekProc = NULL;
 	}
+	if (!(methods & FLAG(METH_TRUNCATE))) {
+	    clonePtr->truncateProc = NULL;
+	}
 
 	chanPtr->typePtr = clonePtr;
     }
@@ -2047,6 +2061,73 @@ ReflectGetOption(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * ReflectTruncate --
+ *
+ *	This function is invoked to truncate a channel's file size.
+ *
+ * Results:
+ *	A standard Tcl result code.
+ *
+ * Side effects:
+ *	Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectTruncate(
+    ClientData clientData,	/* Channel to query */
+    long long length)		/* Length to truncate to. */
+{
+    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+    Tcl_Obj *lenObj;
+    int errorNum;		/* EINVAL or EOK (success). */
+    Tcl_Obj *resObj;		/* Result for 'truncate' */
+
+    /*
+     * Are we in the correct thread?
+     */
+
+#ifdef TCL_THREADS
+    if (rcPtr->thread != Tcl_GetCurrentThread()) {
+	ForwardParam p;
+
+	p.truncate.length = length;
+
+	ForwardOpToHandlerThread(rcPtr, ForwardedTruncate, &p);
+
+	if (p.base.code != TCL_OK) {
+	    PassReceivedError(rcPtr->chan, &p);
+	    return EINVAL;
+	}
+
+	return EOK;
+    }
+#endif
+
+    /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */
+
+    Tcl_Preserve(rcPtr);
+
+    lenObj  = Tcl_NewIntObj(length);
+    Tcl_IncrRefCount(lenObj);
+
+    if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) {
+	Tcl_SetChannelError(rcPtr->chan, resObj);
+	errorNum = EINVAL;
+    } else {
+	errorNum = EOK;
+    }
+
+    Tcl_DecrRefCount(lenObj);
+    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
+    Tcl_Release(rcPtr);
+    return errorNum;
+}
+
+/*
  * Helpers. =========================================================
  */
 
@@ -3277,6 +3358,19 @@ ForwardProc(
         Tcl_Release(rcPtr);
 	break;
 
+    case ForwardedTruncate: {
+	Tcl_Obj *lenObj = Tcl_NewIntObj(paramPtr->truncate.length);
+
+	Tcl_IncrRefCount(lenObj);
+	Tcl_Preserve(rcPtr);
+	if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) {
+	    ForwardSetObjError(paramPtr, resObj);
+	}
+	Tcl_Release(rcPtr);
+	Tcl_DecrRefCount(lenObj);
+	break;
+    }
+
     default:
 	/*
 	 * Bad operation code.