From a729c028a6578fab54b908062d7688dd4a83e67e Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 29 May 2015 16:57:31 -0400
Subject: [PATCH] Add racket/os library.

For now this just contains two functions from mzlib/os.
---
 .../scribblings/reference/os-lib.scrbl        | 18 +++++
 .../racket-doc/scribblings/reference/os.scrbl |  1 +
 racket/collects/racket/os.rkt                 | 68 +++++++++++++++++++
 3 files changed, 87 insertions(+)
 create mode 100644 pkgs/racket-doc/scribblings/reference/os-lib.scrbl
 create mode 100644 racket/collects/racket/os.rkt

diff --git a/pkgs/racket-doc/scribblings/reference/os-lib.scrbl b/pkgs/racket-doc/scribblings/reference/os-lib.scrbl
new file mode 100644
index 0000000000..dfa6827575
--- /dev/null
+++ b/pkgs/racket-doc/scribblings/reference/os-lib.scrbl
@@ -0,0 +1,18 @@
+#lang scribble/doc
+@(require "mz.rkt"
+          (for-label racket/os))
+
+@title[#:tag "os-lib"]{Additional Operating System Functions}
+
+@defmodule[racket/os]{The @racketmodname[racket/os] library
+  additional functions for querying the operating system.}
+
+@history[#:added "6.2.900.17"]
+
+@defproc[(gethostname) string?]{
+  Returns a string for the current machine's hostname (including its domain).
+}
+
+@defproc[(getpid) exact-integer?]{
+  Returns an integer identifying the current process within the operating system.
+}
diff --git a/pkgs/racket-doc/scribblings/reference/os.scrbl b/pkgs/racket-doc/scribblings/reference/os.scrbl
index 6bd6586204..4cac9878d0 100644
--- a/pkgs/racket-doc/scribblings/reference/os.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/os.scrbl
@@ -14,3 +14,4 @@
 @include-section["envvars.scrbl"]
 @include-section["runtime.scrbl"]
 @include-section["cmdline.scrbl"]
+@include-section["os-lib.scrbl"]
diff --git a/racket/collects/racket/os.rkt b/racket/collects/racket/os.rkt
new file mode 100644
index 0000000000..05d8a059f0
--- /dev/null
+++ b/racket/collects/racket/os.rkt
@@ -0,0 +1,68 @@
+#lang racket/base
+
+;; Provides additional functions for querying OS information
+
+(require (prefix-in c: racket/contract)
+         racket/promise
+         ffi/unsafe
+         ffi/cvector
+         ffi/winapi)
+
+(provide (c:contract-out [getpid (c:-> exact-integer?)]
+                         [gethostname (c:-> string?)]))
+
+(define kernel32
+  (delay (and (eq? 'windows (system-type)) (ffi-lib "kernel32"))))
+
+(define (delay-ffi-obj name lib type)
+  (delay (get-ffi-obj name lib type)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gethostname
+
+(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 unix-gethostname
+  (delay-ffi-obj "gethostname" #f (_fun _bytes _int -> _int)))
+
+(define windows-getcomputername
+  (delay-ffi-obj "GetComputerNameExA" (force kernel32)
+                 (_fun #:abi winapi _int _bytes _cvector -> _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]))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; getpid
+
+(define unix-getpid
+  (delay-ffi-obj "getpid" #f (_fun -> _int)))
+
+(define windows-getpid
+  (delay-ffi-obj "GetCurrentProcessId" (force kernel32)
+                 (_fun #:abi winapi -> _int)))
+
+(define (getpid)
+  ((force (case (system-type)
+            [(macosx unix) unix-getpid]
+            [(windows) windows-getpid]
+            [else (error 'getpid "unknown platform ~e" (system-type))]))))