add `file-truncate'

collects/mzlib/os.rkt

@@ -68,48 +68,6 @@
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; truncate-file
 
-;; From fcntl.h
-(define O_RDONLY #x0000)
-(define O_WRONLY #x0001)
-(define O_RDWR   #x0002)
-(define O_APPEND #x0008)
-(define O_CREAT  #x0100)
-(define O_TRUNC  #x0200)
-(define O_EXCL   #x0400)
-
-;; winize : string -> string
-(define (winize fn-name)
-  (if (eq? 'windows (system-type)) (string-append "_" fn-name) fn-name))
-
-;; open : string int -> int
-(define open
-  (delay-ffi-obj (winize "open") #f (_fun #:save-errno 'posix _string _int -> _int)))
-
-;; close : int -> int
-(define close
-  (delay-ffi-obj (winize "close") #f (_fun #:save-errno 'posix _int -> _int)))
-
-;; ftruncate : int int -> int
-(define ftruncate
-  (if (eq? 'windows (system-type))
-    (delay-ffi-obj "_chsize" #f (_fun #:save-errno 'posix _int _llong -> _int))
-    (delay-ffi-obj "ftruncate" #f (_fun #:save-errno 'posix _int _llong -> _int))))
-
-;; on-c-fail : int (-> X) int or X
-(define (on-c-fail thunk fail-k)
-  (let ([val (thunk)])
-    (cond
-     [(> val -1) val]
-     [(= (saved-errno) (lookup-errno 'EINTR))
-      ;; interrupted by a signal; retry
-      (on-c-fail thunk fail-k)]
-     [else (fail-k)])))
-
-(define scheme_security_check_file
-  (delay-ffi-obj "scheme_security_check_file" #f
-                 (_fun _string _string _int -> _void)))
-(define SCHEME_GUARD_FILE_WRITE #x2)
-
 ;; truncate-file : path int -> void
 (define truncate-file
   (opt-lambda (file [size 0])
@@ -119,25 +77,13 @@
     (when (not (integer? size))
       (error 'truncate-file
              "expects argument of type <integer>; given ~s" size))
-    ((force scheme_security_check_file)
-     "truncate-file"
-     (if (path? file) (path->string file) file)
-     SCHEME_GUARD_FILE_WRITE)
-    (let ([fd (on-c-fail
-               (lambda ()
-                 ((force open) file O_WRONLY))
-               (lambda ()
-                 (error 'truncate-file "could not open file")))])
-      (on-c-fail
-       (lambda ()
-         ((force ftruncate) fd size))
-       (lambda ()
-         ((force close) fd)
-         (error 'truncate-file "could not truncate file")))
-      (on-c-fail
-       (lambda ()
-         ((force close) fd))
-       void)
-      (void))))
+    (let ([c (make-custodian)]) ; avoid leaks on errors
+      (dynamic-wind
+          void
+          (lambda ()
+            (define out (open-output-file file 'update))
+            (file-truncate out size))
+          (lambda ()
+            (custodian-shutdown-all c))))))
 
 (provide truncate-file)

collects/mzlib/scribblings/os.scrbl

@@ -24,8 +24,7 @@ Truncates or extends the given @racket[file] so that it is
 does not have sufficient privilege to truncate the file, the
 @racket[exn:fail] exception is raised.
 
-@bold{WARNING:} on Unix, the implementation assumes that the
-platform's @tt{ftruncate} function accepts a @tt{long long} second
-argument.}
+The @racket[truncate-file] function is implemented in terms of
+@racketmodname[racket/base]'s @racket[file-truncate].}
 
 

collects/scribblings/reference/port-buffers.scrbl

@@ -118,3 +118,14 @@ port's buffer.}
 Like @racket[file-position] on a single argument, but returns
 @racket[#f] if the position is not known.}
 
+@defproc[(file-truncate [port (and/c output-port? file-stream-port?)]
+                        [size exact-nonnegative-integer?]) 
+         void?]{
+
+Sets the size of the file written by @racket[port] to @racket[size],
+assuming that the port is associated to a file whose size can be set.
+
+The new file size can be either larger or smaller than its current
+size, but ``truncate'' in this function's name reflects that it is
+normally used to decrease the size of a file, since writing to a file
+or using @racket[file-position] can extend a file's size.}

collects/tests/racket/file.rktl

@@ -418,6 +418,20 @@
 (write-char #\x out-p)
 (close-output-port out-p)
 (test 'hx with-input-from-file tempfilename read)
+
+(let ([o (open-output-file tempfilename #:exists 'truncate)])
+  (close-output-port o))
+(test 0 file-size tempfilename)
+(let ([o (open-output-file tempfilename #:exists 'update)])
+  (file-position o 899)
+  (write-byte 0 o)
+  (close-output-port o))
+(test 900 file-size tempfilename)
+(let ([o (open-output-file tempfilename #:exists 'update)])
+  (file-truncate o 399)
+  (close-output-port o))
+(test 399 file-size tempfilename)
+
 (delete-file tempfilename)
 
 (arity-test call-with-input-file 2 2)

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,10 @@
+Version 5.3.2.2
+Added file-truncate
+
+Version 5.3.2.1
+srfi/19: made compatible with date* structs, produces
+ lax-date struct for backwards compatibility
+
 Version 5.3.2, January 2013
 Changed case to use equal? instead of eqv?
 Changed log-message to support a name argument

src/racket/src/port.c

@@ -5440,6 +5440,83 @@ scheme_file_position_star(int argc, Scheme_Object *argv[])
   return do_file_position("file-position*", argc, argv, 1);
 }
 
+Scheme_Object *scheme_file_truncate(int argc, Scheme_Object *argv[])
+{
+  mzlonglong nll;
+  Scheme_Output_Port *op;
+  intptr_t fd;
+  int errid;
+
+  if (!SCHEME_OUTPUT_PORTP(argv[0])
+      || SCHEME_FALSEP(scheme_file_stream_port_p(1, argv)))
+    scheme_wrong_contract("file-truncate", "(and/c output-port? file-stream-port?)", 0, argc, argv);
+
+  if (!(SCHEME_INTP(argv[1]) && (SCHEME_INT_VAL(argv[1]) >= 0))
+      && !(SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1])))
+    scheme_wrong_contract("file-truncate", "exact-nonnegative-integer?", 1, argc, argv);
+
+  if (!scheme_get_long_long_val(argv[1], &nll)) {
+    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                     "file-truncate: size change failed\n"
+                     "  reason: size too large");
+  }
+
+  op = scheme_output_port_record(argv[0]);
+  
+  if (SAME_OBJ(op->sub_type, file_output_port_type)) {
+    fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
+#ifdef MZ_FDS
+  } else if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
+    fd = ((Scheme_FD *)op->port_data)->fd;
+#endif
+  } else
+    return scheme_void;
+
+  errid = -1;
+#ifdef WINDOWS_FILE_HANDLES
+  if (win_seekable(fd)) {
+    DWORD r;
+    LONG lo_w, hi_w, old_lo_w, old_hi_w;
+    old_hi_w = 0;
+    old_lo_w = SetFilePointer((HANDLE)fd, 0, &old_hi_w, FILE_CURRENT);
+    if ((old_lo_w == INVALID_SET_FILE_POINTER)
+        && GetLastError() != NO_ERROR) {
+      errid = GetLastError();
+    } else {
+      lo_w = (LONG)(nll & 0xFFFFFFFF);
+      hi_w = (LONG)(nll >> 32);
+      r = SetFilePointer((HANDLE)fd, lo_w, &hi_w, FILE_BEGIN);
+      if ((r == INVALID_SET_FILE_POINTER)
+	  && GetLastError() != NO_ERROR) {
+	errid = GetLastError();
+      } else {
+	if (SetEndOfFile((HANDLE)fd)) {
+	  /* we assume that this works: */
+	  (void)SetFilePointer((HANDLE)fd, lo_w, &hi_w, FILE_BEGIN);
+	  return scheme_void;
+	}
+        errid = GetLastError();
+      }
+    }
+  } else {
+    errid = ERROR_UNSUPPORTED_TYPE;
+  }
+#else
+# ifdef MZ_FDS
+  if (!BIG_OFF_T_IZE(ftruncate)(fd, nll))
+    return scheme_void;
+  errid = errno;
+# endif
+#endif
+
+  scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                   "file-truncate: size change failed\n"
+                   "  system error: " FILENAME_EXN_E,
+                   errid);
+
+  return NULL;
+}
+
 intptr_t scheme_set_file_position(Scheme_Object *port, intptr_t pos)
 {
   if (pos >= 0) {

src/racket/src/portfun.c

@@ -316,6 +316,7 @@ scheme_init_port_fun(Scheme_Env *env)
   GLOBAL_NONCM_PRIM("flush-output",                   flush_output,                   0, 1, env);
   GLOBAL_NONCM_PRIM("file-position",                  scheme_file_position,           1, 2, env);
   GLOBAL_NONCM_PRIM("file-position*",                 scheme_file_position_star,      1, 1, env);
+  GLOBAL_NONCM_PRIM("file-truncate",                  scheme_file_truncate,           2, 2, env);
   GLOBAL_NONCM_PRIM("file-stream-buffer-mode",        scheme_file_buffer,             1, 2, env);
   GLOBAL_NONCM_PRIM("port-try-file-lock?",            scheme_file_try_lock,           2, 2, env);
   GLOBAL_NONCM_PRIM("port-file-unlock",               scheme_file_unlock,             1, 1, env);

src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1084
+#define EXPECTED_PRIM_COUNT 1085
 #define EXPECTED_UNSAFE_COUNT 80
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_FUTURES_COUNT 15

src/racket/src/schpriv.h

@@ -3680,6 +3680,7 @@ Scheme_Object *scheme_do_open_output_file(char *name, int offset, int argc, Sche
                                           int internal, char **err, int *eerrno);
 Scheme_Object *scheme_file_position(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_file_position_star(int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_file_truncate(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_file_buffer(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_file_try_lock(int argc, Scheme_Object **argv);

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.2.1"
+#define MZSCHEME_VERSION "5.3.2.2"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 2
-#define MZSCHEME_VERSION_W 1
+#define MZSCHEME_VERSION_W 2
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)