From c2e9dac276543c87f90a314405d70427e7a9e642 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 7 Jun 2005 21:31:46 +0000
Subject: Added (untested!) implementation of truncation for Windows

---
 ChangeLog        |  5 ++++
 tests/chan.test  |  7 +++---
 win/tclWinChan.c | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 83 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 145e740..cbe2c25 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2005-06-07  Donal K. Fellows  <dkf@users.sf.net>
+
+	* win/tclWinChan.c (FileTruncateProc): Added implementation of
+	file truncation for Windows.
+
 2005-06-07  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclObj.c:	Restored registration of the "procbody"
diff --git a/tests/chan.test b/tests/chan.test
index cf83820..dd2fea6 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: chan.test,v 1.3 2005/06/07 20:52:25 dkf Exp $
+# RCS: @(#) $Id: chan.test,v 1.4 2005/06/07 21:31:53 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -76,11 +76,12 @@ test chan-14.1 {chan command: tell subcommand} -body {
 test chan-15.1 {chan command: truncate subcommand} -body {
     chan truncate foo bar foo bar
 } -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\""
-test chan-15.2 {chan command: truncate subcommand} -constraints unix -setup {
+test chan-15.2 {chan command: truncate subcommand} -setup {
     set file [makeFile {} testTruncate]
     set f [open $file w+]
-} -body {
     fconfigure $f -translation binary
+} -body {
+    seek $f 0
     puts -nonewline $f 12345
     seek $f 0
     chan truncate $f 2
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 7cee496..673cd6a 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclWinChan.c,v 1.40 2005/05/10 18:35:37 kennykb Exp $
+ * RCS: @(#) $Id: tclWinChan.c,v 1.41 2005/06/07 21:31:53 dkf Exp $
  */
 
 #include "tclWinInt.h"
@@ -100,6 +100,8 @@ static void		FileWatchProc _ANSI_ARGS_((ClientData instanceData,
 		            int mask));
 static void             FileThreadActionProc _ANSI_ARGS_ ((
 			   ClientData instanceData, int action));
+static void		FileTruncateProc _ANSI_ARGS_ ((
+			   ClientData instanceData, Tcl_WideInt length));
 
 /*
  * This structure describes the channel type structure for file based IO.
@@ -122,6 +124,7 @@ static Tcl_ChannelType fileChannelType = {
     NULL,			/* handler proc. */
     FileWideSeekProc,		/* Wide seek proc. */
     FileThreadActionProc,	/* Thread action proc. */
+    FileTruncateProc,		/* Truncate proc. */
 };
 
 #if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG)
@@ -577,6 +580,76 @@ FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
 /*
  *----------------------------------------------------------------------
  *
+ * FileTruncateProc --
+ *
+ *	Truncates a file-based channel. Returns the error code.
+ *
+ * Results:
+ *	0 if successful, POSIX-y error code if it failed.
+ *
+ * Side effects:
+ *	Truncates the file, may move file pointers too.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileTruncateProc(instanceData, length)
+    ClientData instanceData;		/* File state. */
+    Tcl_WideInt length;			/* Length to truncate at. */
+{
+    FileInfo *infoPtr = (FileInfo *) instanceData;
+    LONG newPos, newPosHigh, oldPos, oldPosHigh;
+
+    /*
+     * Save where we were...
+     */
+    oldPosHigh = 0;
+    oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT);
+    if (oldPos == INVALID_SET_FILE_POINTER) {
+	DWORD winError = GetLastError();
+	if (winError != NO_ERROR) {
+	    TclWinConvertError(winError);
+	    return errno;
+	}
+    }
+
+    /*
+     * Move to where we want to truncate
+     */
+    newPosHigh = Tcl_WideAsLong(length >> 32);
+    newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length),
+	    &newPosHigh, FILE_BEGIN);
+    if (newPos == INVALID_SET_FILE_POINTER) {
+	DWORD winError = GetLastError();
+	if (winError != NO_ERROR) {
+	    TclWinConvertError(winError);
+	    return errno;
+	}
+    }
+
+    /*
+     * Perform the truncation (unlike POSIX ftruncate(), we needed to
+     * move to the location to truncate at first).
+     */
+    if (!SetEndOfFile(infoPtr->handle)) {
+	TclWinConvertError(GetLastError());
+	return errno;
+    }
+
+    /*
+     * Move back. If this last step fails, we don't care; it's just a
+     * "best effort" attempt to restore our file pointer to where it
+     * was.
+     */
+    SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
+
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * FileInputProc --
  *
  *	Reads input from the IO channel into the buffer given. Returns
-- 
cgit v0.12