TIP#208 implementation

It's crude (especially in the tests and docs department) and incomplete (no truncation on non-POSIX platforms).

6 files changed, 196 insertions, 13 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index 82219aa..6dd904e 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 # 
-# RCS: @(#) $Id: tcl.decls,v 1.111 2005/05/10 18:34:04 kennykb Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.112 2005/06/06 23:45:42 dkf Exp $
 
 library tcl
 
@@ -2004,6 +2004,15 @@ declare 558 generic {
     int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
 }
 
+# TIP #208:
+declare 559 generic {
+    int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
+}
+declare 560 generic {
+    Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
+	    Tcl_ChannelType *chanTypePtr)
+}
+
 ##############################################################################
 
 # Define the platform specific public Tcl interface.  These functions are
diff --git a/generic/tcl.h b/generic/tcl.h
index bdb8e10..ffbb166 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tcl.h,v 1.198 2005/05/10 18:34:05 kennykb Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.199 2005/06/06 23:45:42 dkf Exp $
  */
 
 #ifndef _TCL
@@ -1461,6 +1461,7 @@ typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData cli
 #define TCL_CHANNEL_VERSION_2	((Tcl_ChannelTypeVersion) 0x2)
 #define TCL_CHANNEL_VERSION_3	((Tcl_ChannelTypeVersion) 0x3)
 #define TCL_CHANNEL_VERSION_4	((Tcl_ChannelTypeVersion) 0x4)
+#define TCL_CHANNEL_VERSION_5	((Tcl_ChannelTypeVersion) 0x5)
 
 /*
  * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc
@@ -1504,8 +1505,11 @@ typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
 		    int mode, int *errorCodePtr));
 
 /* TIP #218, Channel Thread Actions */
-typedef void     (Tcl_DriverThreadActionProc) _ANSI_ARGS_ ((
+typedef void	(Tcl_DriverThreadActionProc) _ANSI_ARGS_ ((
 		    ClientData instanceData, int action));
+/* TIP #208, File Truncation (etc.) */
+typedef int	(Tcl_DriverTruncateProc) _ANSI_ARGS_((
+		    ClientData instanceData, Tcl_WideInt length));
 
 /*
  * The following declarations either map ckalloc and ckfree to
@@ -1596,16 +1600,24 @@ typedef struct Tcl_ChannelType {
 					 * handle 64-bit offsets. May be
 					 * NULL, and must be NULL if
 					 * seekProc is NULL. */
-
-     /*
-      * Only valid in TCL_CHANNEL_VERSION_4 channels or later
-      * TIP #218, Channel Thread Actions
-      */
-     Tcl_DriverThreadActionProc *threadActionProc;
+    /*
+     * Only valid in TCL_CHANNEL_VERSION_4 channels or later
+     * TIP #218, Channel Thread Actions
+     */
+    Tcl_DriverThreadActionProc *threadActionProc;
  					/* Procedure to call to notify
  					 * the driver of thread specific
  					 * activity for a channel.
 					 * May be NULL. */
+    /*
+     * Only valid TCL_CHANNEL_VERSION_5 channels or later
+     * TIP#208 (part relating to truncation)
+     */
+    Tcl_DriverTruncateProc *truncateProc;
+					/* Procedure to call to truncate the
+					 * underlying file to a particular
+					 * length. May be NULL if the channel
+					 * does not support truncation. */
 } Tcl_ChannelType;
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index bc1ff3d..6935782 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.159 2005/06/01 21:38:40 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.160 2005/06/06 23:45:43 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -527,6 +527,9 @@ Tcl_CreateInterp()
     Tcl_CreateObjCommand(interp,	"::tcl::clock::Oldscan",
 	    TclClockOldscanObjCmd,	(ClientData) NULL,
 	    (Tcl_CmdDeleteProc*) NULL);
+    Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate",
+	    TclChanTruncateObjCmd, (ClientData) NULL,
+	    (Tcl_CmdDeleteProc*) NULL);
 
     /*
      * Register the built-in functions
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
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index abd789c..ebc5c77 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.24 2005/05/10 18:34:40 kennykb Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.25 2005/06/06 23:45:46 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1538,3 +1538,77 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
 
     return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ChanTruncateObjCmd --
+ *
+ *	This procedure is invoked to process the "chan truncate" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Truncates a channel (or rather a file underlying a channel).
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChanTruncateObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    Tcl_Channel chan;
+    Tcl_Obj *cmdPtr;
+    int mode;
+    Tcl_WideInt targetLength;
+    char *chanName;
+
+    if ((objc < 2) || (objc > 3)) {
+	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?");
+	return TCL_ERROR;
+    }
+    chanName = TclGetString(objv[1]);
+    chan = Tcl_GetChannel(interp, chanName, &mode);
+    if (chan == NULL) {
+	return TCL_ERROR;
+    }
+
+    if (objc == 3) {
+	/*
+	 * User is supplying an explicit length.
+	 */
+	if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (length < 0) {
+	    Tcl_AppendResult(interp,
+		    "cannot truncate to negative length of file", NULL);
+	    return TCL_ERROR;
+	}
+    } else {
+	/*
+	 * User wants to truncate to the current file position.
+	 */
+	length = Tcl_Tell(chan);
+	if (length == Tcl_WideAsLong(-1)) {
+	    Tcl_AppendResult(interp,
+		    "could not determine current location in \"", chanName,
+		    "\": ", Tcl_PosixError(interp), NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    if (Tcl_TruncateChannel(chan, length) != TCL_OK) {
+	Tcl_AppendResult(interp, "error during truncate on \"", chanName,
+		"\": ", Tcl_PosixError(interp), (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    return TCL_OK;
+}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7efd7c1..0e075bb 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.232 2005/05/30 00:04:47 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.233 2005/06/06 23:45:44 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -2141,6 +2141,9 @@ MODULE_SCOPE int	Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
 MODULE_SCOPE int	Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]));
+MODULE_SCOPE int	TclChanTruncateObjCmd _ANSI_ARGS_((
+			    ClientData clientData, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *CONST objv[]));
 MODULE_SCOPE int	TclClockClicksObjCmd _ANSI_ARGS_((
 			    ClientData clientData, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *CONST objv[]));