Implement Unix.truncate and Unix.ftruncate on Windows (#2023)

Changes

@@ -172,6 +172,9 @@ Working version
 
 ### Other libraries:
 
+- #1939, #2023: Implement Unix.truncate and Unix.ftruncate on Windows.
+  (Florent Monnier and Nicolás Ojeda Bär, review by David Allsopp)
+
 - #7903, #2306: Make Thread.delay interruptible by signals again
   (Xavier Leroy, review by Jacques-Henri Jourdan and Edwin Török)
 

otherlibs/unix/unix.mli

@@ -398,15 +398,11 @@ val lseek : file_descr -> int -> seek_command -> int
     offset (from the beginning of the file). *)
 
 val truncate : string -> int -> unit
-(** Truncates the named file to the given size.
-
-  On Windows: not implemented. *)
+(** Truncates the named file to the given size. *)
 
 val ftruncate : file_descr -> int -> unit
 (** Truncates the file corresponding to the given descriptor
-   to the given size.
-
-  On Windows: not implemented. *)
+   to the given size. *)
 
 
 (** {1 File status} *)

otherlibs/win32unix/Makefile

@@ -25,8 +25,8 @@ WIN_FILES = accept.c bind.c channels.c close.c \
   mkdir.c mmap.c open.c pipe.c read.c readlink.c rename.c \
   select.c sendrecv.c \
   shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
-  symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
-  winlist.c winworker.c windbug.c utimes.c
+  symlink.c system.c times.c truncate.c unixsupport.c windir.c winwait.c \
+  write.c winlist.c winworker.c windbug.c utimes.c
 
 # Files from the ../unix directory
 UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \

otherlibs/win32unix/truncate.c

@@ -0,0 +1,125 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                            Florent Monnier                             */
+/*                       Nicolas Ojeda Bar, LexiFi                        */
+/*                                                                        */
+/*   Copyright 2019 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <sys/types.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include <caml/io.h>
+#include <caml/osdeps.h>
+#include "unixsupport.h"
+#include <windows.h>
+
+static int win_truncate_handle(HANDLE fh, __int64 len)
+{
+  LARGE_INTEGER fp;
+  fp.QuadPart = len;
+  if (SetFilePointerEx(fh, fp, NULL, FILE_BEGIN) == 0 ||
+      SetEndOfFile(fh) == 0) {
+    return -1;
+  }
+  return 0;
+}
+
+static int win_ftruncate(HANDLE fh, __int64 len)
+{
+  HANDLE dupfh, currproc;
+  int ret;
+  currproc = GetCurrentProcess();
+  /* Duplicate the handle, so we are free to modify its file position. */
+  if (DuplicateHandle(currproc, fh, currproc, &dupfh, 0, FALSE,
+                      DUPLICATE_SAME_ACCESS) == 0) {
+     return -1;
+  }
+  ret = win_truncate_handle(dupfh, len);
+  CloseHandle(dupfh);
+  return ret;
+}
+
+static int win_truncate(WCHAR * path, __int64 len)
+{
+  HANDLE fh;
+  int ret;
+  fh = CreateFile(path, GENERIC_WRITE, 0, NULL,
+                  OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+  if (fh == INVALID_HANDLE_VALUE) {
+    return -1;
+  }
+  ret = win_truncate_handle(fh, len);
+  CloseHandle(fh);
+  return ret;
+}
+
+CAMLprim value unix_truncate(value path, value len)
+{
+  CAMLparam2(path, len);
+  WCHAR * p;
+  int ret;
+  caml_unix_check_path(path, "truncate");
+  p = caml_stat_strdup_to_utf16(String_val(path));
+  caml_enter_blocking_section();
+  ret = win_truncate(p, Long_val(len));
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("truncate", path);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value unix_truncate_64(value path, value vlen)
+{
+  CAMLparam2(path, vlen);
+  WCHAR * p;
+  int ret;
+  __int64 len = Int64_val(vlen);
+  caml_unix_check_path(path, "truncate");
+  p = caml_stat_strdup_to_utf16(String_val(path));
+  caml_enter_blocking_section();
+  ret = win_truncate(p, len);
+  caml_leave_blocking_section();
+  caml_stat_free(p);
+  if (ret == -1)
+    uerror("truncate", path);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value unix_ftruncate(value fd, value len)
+{
+  int ret;
+  HANDLE h = Handle_val(fd);
+  caml_enter_blocking_section();
+  ret = win_ftruncate(h, Long_val(len));
+  caml_leave_blocking_section();
+  if (ret == -1)
+    uerror("ftruncate", Nothing);
+  return Val_unit;
+}
+
+CAMLprim value unix_ftruncate_64(value fd, value vlen)
+{
+  int ret;
+  HANDLE h = Handle_val(fd);
+  __int64 len = Int64_val(vlen);
+  caml_enter_blocking_section();
+  ret = win_ftruncate(h, len);
+  caml_leave_blocking_section();
+  if (ret == -1)
+    uerror("ftruncate", Nothing);
+  return Val_unit;
+}

otherlibs/win32unix/unix.ml

@@ -229,8 +229,8 @@ type seek_command =
 
 external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
 
-let truncate _name _len = invalid_arg "Unix.truncate not implemented"
-let ftruncate _fd _len = invalid_arg "Unix.ftruncate not implemented"
+external truncate : string -> int -> unit = "unix_truncate"
+external ftruncate : file_descr -> int -> unit = "unix_ftruncate"
 
 (* File statistics *)
 
@@ -274,10 +274,8 @@ module LargeFile =
   struct
     external lseek : file_descr -> int64 -> seek_command -> int64
        = "unix_lseek_64"
-    let truncate _name _len =
-      invalid_arg "Unix.LargeFile.truncate not implemented"
-    let ftruncate _name _len =
-      invalid_arg "Unix.LargeFile.ftruncate not implemented"
+    external truncate : string -> int64 -> unit = "unix_truncate_64"
+    external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
     type stats =
       { st_dev : int;
         st_ino : int;

testsuite/tests/lib-unix/common/ocamltests

@@ -10,3 +10,4 @@ utimes.ml
 wait_nohang.ml
 getaddrinfo.ml
 process_pid.ml
+truncate.ml

testsuite/tests/lib-unix/common/truncate.ml

@@ -0,0 +1,30 @@
+(* TEST
+include unix
+*)
+
+let str = "Hello, OCaml!"
+let txt = "truncate.txt"
+
+let test file openfile stat truncate delta close =
+  let () =
+    let c = open_out_bin file in
+    output_string c str;
+    close_out c
+  in
+  let size file =
+    (stat file).Unix.st_size
+  in
+  let file = openfile file in
+  Printf.printf "initial size: %d\n%!" (size file);
+  truncate file (size file - delta);
+  Printf.printf "new size: %d\n%!" (size file);
+  truncate file 0;
+  Printf.printf "final size: %d\n%!" (size file);
+  close file
+
+let () =
+  test "truncate.txt" (fun x -> x) Unix.stat Unix.truncate 2 ignore
+
+let () =
+  let open_it file = Unix.openfile file [O_RDWR] 0 in
+  test "ftruncate.txt" open_it Unix.fstat Unix.ftruncate 3 Unix.close

testsuite/tests/lib-unix/common/truncate.reference

@@ -0,0 +1,6 @@
+initial size: 13
+new size: 11
+final size: 0
+initial size: 13
+new size: 10
+final size: 0