1#lang racket/base 2 3;; Provides additional functions for querying OS information 4 5(require (prefix-in c: racket/contract) 6 racket/promise 7 ffi/unsafe 8 ffi/cvector 9 ffi/winapi) 10 11(provide (c:contract-out [getpid (c:-> exact-integer?)] 12 [gethostname (c:-> string?)])) 13 14(define kernel32 15 (delay (and (eq? 'windows (system-type)) (ffi-lib "kernel32")))) 16 17(define (delay-ffi-obj name lib type) 18 (delay (get-ffi-obj name lib type))) 19 20;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21;; gethostname 22 23(define BUFFER-SIZE 1024) 24(define (extract-terminated-string proc) 25 (let ([s (make-bytes BUFFER-SIZE)]) 26 (if (proc s BUFFER-SIZE) 27 (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" s))) 28 (error 'gethostname "could not get hostname")))) 29 30(define unix-gethostname 31 (delay-ffi-obj "gethostname" #f (_fun _bytes _int -> _int))) 32 33(define windows-getcomputername 34 (delay-ffi-obj "GetComputerNameExA" (force kernel32) 35 (_fun #:abi winapi _int _bytes _cvector -> _int))) 36 37(define (gethostname) 38 (case (system-type) 39 [(unix macosx) 40 (let ([ghn (force unix-gethostname)]) 41 (extract-terminated-string (lambda (s sz) (zero? (ghn s sz)))))] 42 [(windows) 43 (let ([gcn (force windows-getcomputername)] 44 [DNS_FULLY_QUALIFIED 3]) 45 (extract-terminated-string 46 (lambda (s sz) 47 (let ([sz_ptr (cvector _int sz)]) 48 (and (not (zero? (gcn DNS_FULLY_QUALIFIED s sz_ptr))) 49 (let ([sz (cvector-ref sz_ptr 0)]) 50 (when (sz . < . (bytes-length s)) (bytes-set! s sz 0)) 51 #t))))))] 52 [else #f])) 53 54;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55;; getpid 56 57(define unix-getpid 58 (delay-ffi-obj "getpid" #f (_fun -> _int))) 59 60(define windows-getpid 61 (delay-ffi-obj "GetCurrentProcessId" (force kernel32) 62 (_fun #:abi winapi -> _int))) 63 64(define (getpid) 65 ((force (case (system-type) 66 [(macosx unix) unix-getpid] 67 [(windows) windows-getpid] 68 [else (error 'getpid "unknown platform ~e" (system-type))])))) 69