.

original commit: aa844c648e056314cd4f52d0866b27eab85ef40c

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))])))