1 files changed, 83 insertions, 1 deletions
diff --git a/generic/tclIO.c b/generic/tclIO.c
index ee37035..06fd55b 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIO.c,v 1.86 2005/05/10 18:34:38 kennykb Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.87 2005/06/06 23:45:45 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -5777,6 +5777,77 @@ Tcl_TellOld(chan)
 /*
  *---------------------------------------------------------------------------
  *
+ * Tcl_TruncateChannel --
+ *
+ *	Truncate a channel to the given length.
+ *
+ * Results:
+ *	TCL_OK on success, TCL_ERROR if the operation failed (e.g. is
+ *	not supported by the type of channel, or the underlying OS
+ *	operation failed in some way).
+ *
+ * Side effects:
+ *	Seeks the channel to the current location. Sets errno on OS
+ *	error.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_TruncateChannel(chan, length)
+    Tcl_Channel chan;
+    Tcl_WideInt length;
+{
+    Channel *chanPtr = (Channel *) chan;
+    Tcl_DriverTruncateProc *truncateProc =
+	    Tcl_ChannelTruncateProc(chanPtr->typePtr);
+    int result;
+
+    if (truncateProc == NULL) {
+	/*
+	 * Feature not supported and it's not emulatable. Pretend it's
+	 * returned an EINVAL, a very generic error!
+	 */
+	Tcl_SetErrno(EINVAL);
+	return TCL_ERROR;
+    }
+
+    if (!(chanPtr->stateptr->flags & TCL_WRITABLE)) {
+	/*
+	 * We require that the file was opened of writing. Do that
+	 * check now so that we only flush if we think we're going to
+	 * succeed.
+	 */
+	Tcl_SetErrno(EINVAL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Seek first to force a total flush of all pending buffers and
+     * ditch any pre-read input data.
+     */
+
+    if (Tcl_Seek(chan, 0, SEEK_CUR) == Tcl_LongAsWide(-1)) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * We're all flushed to disk now and we also don't have any
+     * unfortunate input baggage around either; can truncate with
+     * impunity.
+     */
+
+    result = truncateProc(chanPtr->instanceData, length);
+    if (result != 0) {
+	Tcl_SetErrno(result);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * CheckChannelErrors --
  *
  *	See if the channel is in an ready state and can perform the
@@ -9367,6 +9438,17 @@ Tcl_ChannelThreadActionProc(chanTypePtr)
     }
 }
 
+Tcl_DriverTruncateProc *
+Tcl_ChannelTruncateProc(chanTypePtr)
+    Tcl_ChannelType *chanTypePtr;	/* Pointer to channel type. */
+{
+    if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_5)) {
+	return chanTypePtr->truncateProc;
+    } else {
+	return NULL;
+    }
+}
+
 #if 0
 /*
  * For future debugging work, a simple function to print the flags of