diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index 2d1774cdd8..d4e1b710d0 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -385,6 +385,51 @@ ;; ---------------------------------------- + ;; `#%windows-version-instance` is used for `(system-type 'machine)` + ;; (via `get-machine-info`) on Windows + (meta-cond + [(#%memq (machine-type) '(a6nt ta6nt i3nt ti3nt)) + (define |#%windows-version-instance| + (hash 'get-windows-version + (lambda () + (define-ftype DWORD integer-32) + (define-ftype BOOL int) + (define-ftype OSVERSIONINFOA + (|struct| + [dwOSVersionInfoSize DWORD] + [dwMajorVersion DWORD] + [dwMinorVersion DWORD] + [dwBuildNumber DWORD] + [dwPlatformId DWORD] + [szCSDVersion (array 128 unsigned-8)])) + (define GetVersionEx + (begin + (load-shared-object "Kernel32.dll") + (foreign-procedure "GetVersionExA" ((* OSVERSIONINFOA)) BOOL))) + (define v (make-ftype-pointer OSVERSIONINFOA + (foreign-alloc (ftype-sizeof OSVERSIONINFOA)))) + (ftype-set! OSVERSIONINFOA (dwOSVersionInfoSize) v (ftype-sizeof OSVERSIONINFOA)) + (cond + [(GetVersionEx v) + (values (ftype-ref OSVERSIONINFOA (dwMajorVersion) v) + (ftype-ref OSVERSIONINFOA (dwMinorVersion) v) + (ftype-ref OSVERSIONINFOA (dwBuildNumber) v) + (list->bytes + (let loop ([i 0]) + (define b (ftype-ref OSVERSIONINFOA (szCSDVersion i) v)) + (cond + [(fx= b 0) '()] + [else (cons b (loop (fx+ i 1)))]))))] + [else + (values 0 0 0 #vu8())]))))] + [else + (define |#%windows-version-instance| + (hash 'get-windows-version + (lambda () (raise-arguments-error 'get-windows-version + "not on Windows"))))]) + + ;; ---------------------------------------- + (export system-library-subpath) (define system-library-subpath (case-lambda @@ -410,6 +455,7 @@ [(|#%pthread|) (hasheq)] [(|#%thread|) |#%thread-instance|] [(|#%rktio|) |#%rktio-instance|] + [(|#%windows-version|) |#%windows-version-instance|] [else #f])) (include "include.ss") @@ -423,4 +469,5 @@ (set-error-display-eprintf! (lambda (fmt . args) (apply 1/fprintf (|#%app| 1/current-error-port) fmt args))) (set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ptr->address) - (set-async-callback-poll-wakeup! 1/unsafe-signal-received)) + (set-async-callback-poll-wakeup! 1/unsafe-signal-received) + (set-get-machine-info! get-machine-info)) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index f7af4ba259..6aa43982d0 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -477,6 +477,7 @@ system-type system-path-convention-type system-library-subpath-string ; not exported to Racket + set-get-machine-info! ; not exported to Racket unsafe-car unsafe-cdr diff --git a/racket/src/cs/rumble/system.ss b/racket/src/cs/rumble/system.ss index cc6543ffe8..2738a07a3d 100644 --- a/racket/src/cs/rumble/system.ss +++ b/racket/src/cs/rumble/system.ss @@ -22,7 +22,7 @@ [(word) (if (> (fixnum-width) 32) 64 32)] [(gc) 'cs] [(link) 'framework] - [(machine) "localhost info..."] + [(machine) (get-machine-info)] [(so-suffix) (case (machine-type) [(a6osx ta6osx i3osx ti3osx) (string->utf8 ".dylib")] [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] @@ -61,3 +61,7 @@ [(a6s2 ta6s2) "x86_64-solaris"] [(i3s2 ti3s2) "i386-solaris"] [else "unix"])) + +(define get-machine-info (lambda () "localhost info...")) +(define (set-get-machine-info! proc) + (set! get-machine-info proc)) diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt index 4327c5bfcf..5370dbaab2 100644 --- a/racket/src/io/demo.rkt +++ b/racket/src/io/demo.rkt @@ -15,6 +15,9 @@ (current-directory (host:path->string (host:current-directory))) (set-string->number?! string->number) +(get-machine-info) +(exit) + (define-syntax-rule (test expect rhs) (let ([e expect] [v rhs]) diff --git a/racket/src/io/host/bootstrap.rkt b/racket/src/io/host/bootstrap.rkt index 869ef11ff4..410965d402 100644 --- a/racket/src/io/host/bootstrap.rkt +++ b/racket/src/io/host/bootstrap.rkt @@ -140,3 +140,10 @@ 'unsafe-add-pre-poll-callback! (lambda (proc) (void)) 'set-get-subprocesses-time! void 'prop:place-message prop:place-message)) + +(primitive-table '#%windows-version + (hasheq 'get-windows-version (lambda () + (values 'major + 'minor + 'build-number + #"CSDVersion (possibly empty)")))) diff --git a/racket/src/io/host/windows-version.rkt b/racket/src/io/host/windows-version.rkt new file mode 100644 index 0000000000..c389926152 --- /dev/null +++ b/racket/src/io/host/windows-version.rkt @@ -0,0 +1,11 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table)) + +(provide get-windows-version) + +(define windows-version-table + (or (primitive-table '#%windows-version) + (error '#%windows-version "windows-version not supported by host"))) + +(define get-windows-version + (hash-ref windows-version-table 'get-windows-version)) diff --git a/racket/src/io/machine/main.rkt b/racket/src/io/machine/main.rkt new file mode 100644 index 0000000000..152e4ae46f --- /dev/null +++ b/racket/src/io/machine/main.rkt @@ -0,0 +1,53 @@ +#lang racket/base +(require "../subprocess/main.rkt" + "../security/main.rkt" + "../file/main.rkt" + "../port/main.rkt" + "../locale/main.rkt" + "../format/main.rkt" + "../host/windows-version.rkt") + +(provide get-machine-info) + +(define uname-paths + (list "/bin/uname" + "/usr/bin/uname" + "/sbin/uname" + "/usr/sbin/uname" + "/usr/local/bin/uname" + "/usr/local/uname")) + +(define (get-machine-info) + (case (system-type) + [(windows) + (define-values (major minor build-number CSD-vers) (get-windows-version)) + (format "Windows NT ~a.~a (Build ~a)~a~a" + major minor build-number + (if (equal? CSD-vers #"") "" " ") + CSD-vers)] + [else + (let/ec done + (parameterize ([current-security-guard + (unsafe-make-security-guard-at-root)]) + (for ([uname (in-list uname-paths)]) + (when (file-exists? uname) + (with-handlers (#;[exn:fail? void]) + (define-values (subproc stdout stdin stderr) (subprocess #f #f #f uname "-a")) + (close-output-port stdin) + (close-input-port stderr) + (define bstr (read-bytes 1024 stdout)) + (close-input-port stdout) + (subprocess-wait subproc) + (when (bytes? bstr) + ;; Strip trailing whitespace, especially newlines + (let loop ([i (bytes-length bstr)]) + (cond + [(zero? i) (done "")] + [(char-whitespace? (integer->char (bytes-ref bstr (sub1 i)))) + (loop (sub1 i))] + [else + (done (bytes->string/locale (subbytes bstr 0 i)))]))))))) + "")])) + + + diff --git a/racket/src/io/main.rkt b/racket/src/io/main.rkt index 94d3d911a2..06a24c5189 100644 --- a/racket/src/io/main.rkt +++ b/racket/src/io/main.rkt @@ -20,6 +20,7 @@ "network/main.rkt" "foreign/main.rkt" "unsafe/main.rkt" + "machine/main.rkt" "run/main.rkt" "port/parameter.rkt" (only-in "host/rktio.rkt" @@ -46,6 +47,7 @@ (all-from-out "network/main.rkt") (all-from-out "foreign/main.rkt") (all-from-out "unsafe/main.rkt") + (all-from-out "machine/main.rkt") (all-from-out "run/main.rkt") make-place-ports+fds io-place-init!)