truncate-file

svn: r279

original commit: 6d9aa4cab7b0f774f2a988145b528d8d5444b2a8

collects/mzlib/os.ss

@@ -1,6 +1,12 @@
 (module os mzscheme
-  (require (lib "foreign.ss")) (unsafe!)
-  
+  (require (lib "etc.ss")
+	   (lib "foreign.ss")) (unsafe!)
+     
+  (define msvcrt
+    (if (eq? 'windows (system-type))
+	(delay (ffi-lib "msvcrt"))
+	(delay #f)))
+
   (define kernel32 
     (delay (and (eq? 'windows (system-type))
 		(ffi-lib "kernel32"))))
@@ -65,4 +71,68 @@
       [(macosx unix) ((force unix-getpid))]
       [(windows) ((force windows-getpid))]))
 
-  (provide getpid))
+  (provide getpid)
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; 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") (force msvcrt)
+		   (_fun _string _int -> _int)))
+
+  ;; close : int -> int
+  (define close
+    (delay-ffi-obj (winize "close") (force msvcrt)
+		   (_fun _int -> _int)))
+
+  ;; ftruncate : int int -> int
+  (define ftruncate
+    (if (eq? 'windows (system-type))
+	(delay-ffi-obj "_chsize" (force msvcrt)
+		       (_fun _int _long -> _int))
+	(delay-ffi-obj "ftruncate" #f
+		       (_fun _int _long -> _int))))
+
+  ;; on-c-fail : int (-> X) int or X
+  (define (on-c-fail val fail-k)
+    (if (> val -1)
+	val
+	(fail-k)))
+
+  ;; truncate-file : path int -> void
+  (define truncate-file
+    (opt-lambda (file [size 0])
+      (when (not (path-string? file))
+	(error 'truncate-file "expects argument of type <string> or <path>; given ~s" file))
+      (when (not (integer? size))
+	(error 'truncate-file "expects argument of type <integer>; given ~s" size))
+      (let ([fd (on-c-fail 
+		 ((force open) file O_WRONLY)
+		 (lambda () 
+		   (error 'truncate-file "could not open file")))])
+	#;
+	(on-c-fail
+	 ((force ftruncate) fd size)
+	 (lambda ()
+	   ((force close) fd)
+	   (error 'truncate-file "could not truncate file")))
+	((force close) fd)
+	(void))))
+
+  (provide truncate-file))