diff --git a/collects/mzlib/os.ss b/collects/mzlib/os.ss new file mode 100644 index 0000000..a9d31b3 --- /dev/null +++ b/collects/mzlib/os.ss @@ -0,0 +1,70 @@ +(module os mzscheme + (require (lib "foreign.ss")) (unsafe!) + + (provide gethostname + getpid) + + (define BUFFER-SIZE 1024) + (define (extract-terminated-string proc) + (let ([s (make-bytes BUFFER-SIZE)]) + (and (proc s BUFFER-SIZE) + (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" s)))))) + + (define kernel32 + (delay (and (eq? 'windows (system-type)) + (ffi-lib "kernel32")))) + + (define (delay-ffi-obj name lib type default-result) + (delay (get-ffi-obj name lib type (lambda () + (lambda () default-result))))) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; gethostbyname + + (define unix-gethostname + (delay-ffi-obj "gethostname" #f + (_fun _bytes _int -> _int) + -1)) + + (define windows-getcomputername + (delay-ffi-obj "GetComputerNameExA" (force kernel32) + (_fun _int _bytes _cvector -> _int) + 0)) + + (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])) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; getpid + + (define unix-getpid + (delay-ffi-obj "getpid" #f + (_fun -> _int) + #f)) + + (define windows-getpid + (delay-ffi-obj "GetCurrentProcessId" (force kernel32) + (_fun -> _int) + #f)) + + (define (getpid) + (case (system-type) + [(macosx unix) ((force unix-getpid))] + [(windows) ((force windows-getpid))])))