From 7becde46d4868851709c8dd84e375591169e60a6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 4 Sep 2008 22:12:14 +0000 Subject: [PATCH] mostly just a re-indentation svn: r11544 --- collects/mzlib/os.ss | 230 +++++++++++++++++++++---------------------- 1 file changed, 110 insertions(+), 120 deletions(-) diff --git a/collects/mzlib/os.ss b/collects/mzlib/os.ss index cf775f07cc..06bdb543d9 100644 --- a/collects/mzlib/os.ss +++ b/collects/mzlib/os.ss @@ -1,139 +1,129 @@ -(module os mzscheme - (require mzlib/etc mzlib/foreign) (unsafe!) +#lang mzscheme - (define kernel32 - (delay (and (eq? 'windows (system-type)) - (ffi-lib "kernel32")))) +(require mzlib/etc mzlib/foreign) (unsafe!) - (define (delay-ffi-obj name lib type) - (delay (get-ffi-obj name lib type))) +(define kernel32 + (delay (and (eq? 'windows (system-type)) (ffi-lib "kernel32")))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; gethostbyname - - (define BUFFER-SIZE 1024) - (define (extract-terminated-string proc) - (let ([s (make-bytes BUFFER-SIZE)]) - (if (proc s BUFFER-SIZE) - (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" s))) - (error 'gethostname - "could not get hostname")))) +(define (delay-ffi-obj name lib type) + (delay (get-ffi-obj name lib type))) - (define unix-gethostname - (delay-ffi-obj "gethostname" #f - (_fun _bytes _int -> _int))) - - (define windows-getcomputername - (delay-ffi-obj "GetComputerNameExA" (force kernel32) - (_fun #:abi 'stdcall _int _bytes _cvector -> _int))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; gethostbyname - (define (gethostname) - (case (system-type) - [(unix macosx) - (let ([ghn (force unix-gethostname)]) - (extract-terminated-string - (lambda (s sz) - (zero? (ghn s sz)))))] - [(windows) - (let ([gcn (force windows-getcomputername)] - [DNS_FULLY_QUALIFIED 3]) - (extract-terminated-string - (lambda (s sz) - (let ([sz_ptr (cvector _int sz)]) - (and (not (zero? (gcn DNS_FULLY_QUALIFIED s sz_ptr))) - (let ([sz (cvector-ref sz_ptr 0)]) - (when (sz . < . (bytes-length s)) - (bytes-set! s sz 0)) - #t))))))] - [else #f])) +(define BUFFER-SIZE 1024) +(define (extract-terminated-string proc) + (let ([s (make-bytes BUFFER-SIZE)]) + (if (proc s BUFFER-SIZE) + (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" s))) + (error 'gethostname "could not get hostname")))) - (provide gethostname) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; getpid +(define unix-gethostname + (delay-ffi-obj "gethostname" #f (_fun _bytes _int -> _int))) - (define unix-getpid - (delay-ffi-obj "getpid" #f (_fun -> _int))) +(define windows-getcomputername + (delay-ffi-obj "GetComputerNameExA" (force kernel32) + (_fun #:abi 'stdcall _int _bytes _cvector -> _int))) - (define windows-getpid - (delay-ffi-obj "GetCurrentProcessId" (force kernel32) - (_fun #:abi 'stdcall -> _int))) +(define (gethostname) + (case (system-type) + [(unix macosx) + (let ([ghn (force unix-gethostname)]) + (extract-terminated-string (lambda (s sz) (zero? (ghn s sz)))))] + [(windows) + (let ([gcn (force windows-getcomputername)] + [DNS_FULLY_QUALIFIED 3]) + (extract-terminated-string + (lambda (s sz) + (let ([sz_ptr (cvector _int sz)]) + (and (not (zero? (gcn DNS_FULLY_QUALIFIED s sz_ptr))) + (let ([sz (cvector-ref sz_ptr 0)]) + (when (sz . < . (bytes-length s)) (bytes-set! s sz 0)) + #t))))))] + [else #f])) - (define (getpid) - (case (system-type) - [(macosx unix) ((force unix-getpid))] - [(windows) ((force windows-getpid))])) +(provide gethostname) - (provide getpid) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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) +(define unix-getpid + (delay-ffi-obj "getpid" #f (_fun -> _int))) - ;; winize : string -> string - (define (winize fn-name) - (if (eq? 'windows (system-type)) - (string-append "_" fn-name) - fn-name)) +(define windows-getpid + (delay-ffi-obj "GetCurrentProcessId" (force kernel32) + (_fun #:abi 'stdcall -> _int))) - ;; open : string int -> int - (define open - (delay-ffi-obj (winize "open") #f - (_fun _string _int -> _int))) +(define (getpid) + ((force (case (system-type) + [(macosx unix) unix-getpid] + [(windows) windows-getpid] + [else (error 'getpid "unknown platform ~e" (system-type))])))) - ;; close : int -> int - (define close - (delay-ffi-obj (winize "close") #f - (_fun _int -> _int))) +(provide getpid) - ;; ftruncate : int int -> int - (define ftruncate - (if (eq? 'windows (system-type)) - (delay-ffi-obj "_chsize" #f - (_fun _int _llong -> _int)) - (delay-ffi-obj "ftruncate" #f - (_fun _int _llong -> _int)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; truncate-file - ;; on-c-fail : int (-> X) int or X - (define (on-c-fail val fail-k) - (if (> val -1) - val - (fail-k))) +;; 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) - (define scheme_security_check_file - (delay-ffi-obj "scheme_security_check_file" #f - (_fun _string _string _int -> _void))) - (define SCHEME_GUARD_FILE_WRITE #x2) +;; winize : string -> string +(define (winize fn-name) + (if (eq? 'windows (system-type)) (string-append "_" fn-name) fn-name)) - ;; 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 or ; given ~s" file)) - (when (not (integer? size)) - (error 'truncate-file "expects argument of type ; 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 - ((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)))) +;; open : string int -> int +(define open + (delay-ffi-obj (winize "open") #f (_fun _string _int -> _int))) - (provide truncate-file)) +;; close : int -> int +(define close + (delay-ffi-obj (winize "close") #f (_fun _int -> _int))) + +;; ftruncate : int int -> int +(define ftruncate + (if (eq? 'windows (system-type)) + (delay-ffi-obj "_chsize" #f (_fun _int _llong -> _int)) + (delay-ffi-obj "ftruncate" #f (_fun _int _llong -> _int)))) + +;; on-c-fail : int (-> X) int or X +(define (on-c-fail val fail-k) + (if (> val -1) val (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]) + (when (not (path-string? file)) + (error 'truncate-file + "expects argument of type or ; given ~s" file)) + (when (not (integer? size)) + (error 'truncate-file + "expects argument of type ; 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 + ((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)