suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

change (system-type 'machine) to use C-library uname

Browse Source 
Thanks to @LiberalArtist for pointer out that uname(3) exists!

Related to #3707
This commit is contained in:
Matthew Flatt 2021-03-02 17:26:24 -07:00
parent afe522ab9c
commit e615294e78
14 changed files with 293 additions and 522 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
racket/collects/racket/private/path-list.rkt
View File

@ -26,7 +26,7 @@
(unless (or (bytes? s)
(string? s))
(raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s))
(when (regexp-match? #rx"\0" s)
(when (regexp-match? #rx#"\0" s)
(let ([label (if (bytes? s) "byte string" "string")])
(raise-arguments-error 'path-list-string->path-list
(format "given ~a contains a nul character" label)

156
racket/src/bc/src/string.c
View File

@ -2400,8 +2400,6 @@ void scheme_set_cross_compile_mode(int v)
cross_compile_mode = v;
}
static void machine_details(char *s);
#include "systype.inc"
static Scheme_Object *system_type(int argc, Scheme_Object *argv[])
@ -2412,11 +2410,14 @@ static Scheme_Object *system_type(int argc, Scheme_Object *argv[])
}
if (SAME_OBJ(argv[0], machine_symbol)) {
char buff[1024];
machine_details(buff);
return scheme_make_utf8_string(buff);
char *s;
Scheme_Object *str;
s = rktio_uname(scheme_rktio);
str = scheme_make_utf8_string(s);
rktio_free(s);
return str;
}
if (SAME_OBJ(argv[0], gc_symbol)) {
@ -5477,147 +5478,6 @@ mzchar *scheme_utf16_to_ucs4(const unsigned short *text, intptr_t start, intptr_
return buf;
}
/**********************************************************************/
/* machine type details */
/**********************************************************************/
/*************************** Windows **********************************/
#ifdef DOS_FILE_SYSTEM
# include <windows.h>
void machine_details(char *buff)
{
OSVERSIONINFO info;
BOOL hasInfo;
char *p;
info.dwOSVersionInfoSize = sizeof(info);
GetVersionEx(&info);
hasInfo = FALSE;
p = info.szCSDVersion;
while (p < info.szCSDVersion + sizeof(info.szCSDVersion) &&
*p) {
if (*p != ' ') {
hasInfo = TRUE;
break;
}
p = p XFORM_OK_PLUS 1;
}
sprintf(buff,"Windows %s %ld.%ld (Build %ld)%s%s",
(info.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS) ?
"9x" :
(info.dwPlatformId == VER_PLATFORM_WIN32_NT) ?
"NT" : "Unknown platform",
info.dwMajorVersion,info.dwMinorVersion,
(info.dwPlatformId == VER_PLATFORM_WIN32_NT) ?
info.dwBuildNumber :
info.dwBuildNumber & 0xFFFF,
hasInfo ? " " : "",hasInfo ? info.szCSDVersion : "");
}
#endif
/***************************** Unix ***********************************/
#if !defined(DOS_FILE_SYSTEM)
READ_ONLY static char *uname_locations[] = { "/bin/uname",
"/usr/bin/uname",
/* The above should cover everything, but
just in case... */
"/sbin/uname",
"/usr/sbin/uname",
"/usr/local/bin/uname",
"/usr/local/uname",
NULL };
static int try_subproc(Scheme_Object *subprocess_proc, char *prog)
{
Scheme_Object *a[5];
mz_jmp_buf * volatile savebuf, newbuf;
savebuf = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
a[0] = scheme_false;
a[1] = scheme_false;
a[2] = scheme_false;
a[3] = scheme_make_locale_string(prog);
a[4] = scheme_make_locale_string("-a");
_scheme_apply_multi(subprocess_proc, 5, a);
scheme_current_thread->error_buf = savebuf;
return 1;
} else {
scheme_clear_escape();
scheme_current_thread->error_buf = savebuf;
return 0;
}
}
void machine_details(char *buff)
{
Scheme_Object *subprocess_proc;
int i;
Scheme_Config *config;
Scheme_Security_Guard *sg;
Scheme_Cont_Frame_Data cframe;
/* Use the root security guard so we can test for and run
executables. */
config = scheme_current_config();
sg = (Scheme_Security_Guard *)scheme_get_param(config, MZCONFIG_SECURITY_GUARD);
while (sg->parent) { sg = sg->parent; }
config = scheme_extend_config(config, MZCONFIG_SECURITY_GUARD, (Scheme_Object *)sg);
scheme_push_continuation_frame(&cframe);
scheme_install_config(config);
subprocess_proc = scheme_builtin_value("subprocess");
for (i = 0; uname_locations[i]; i++) {
if (scheme_file_exists(uname_locations[i])) {
/* Try running it. */
if (try_subproc(subprocess_proc, uname_locations[i])) {
Scheme_Object *sout, *sin, *serr;
intptr_t c;
sout = scheme_current_thread->ku.multiple.array[1];
sin = scheme_current_thread->ku.multiple.array[2];
serr = scheme_current_thread->ku.multiple.array[3];
scheme_close_output_port(sin);
scheme_close_input_port(serr);
/* Read result: */
strcpy(buff, "<unknown machine>");
c = scheme_get_bytes(sout, 1023, buff, 0);
buff[c] = 0;
scheme_close_input_port(sout);
/* Remove trailing whitespace (especially newlines) */
while (c && portable_isspace(((unsigned char *)buff)[c - 1])) {
buff[--c] = 0;
}
scheme_pop_continuation_frame(&cframe);
return;
}
}
}
strcpy(buff, "<unknown machine>");
scheme_pop_continuation_frame(&cframe);
}
#endif
/**********************************************************************/
/* Precise GC */
/**********************************************************************/

46
racket/src/cs/io.sls
View File

@ -456,51 +456,6 @@
;; ----------------------------------------
;; `#%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"))))])
;; ----------------------------------------
;; For glib logging, we need a function pointer that works across
;; places and logs to the main place's root logger. Although it's
;; kind of a hack, it's much simpler to implement that here and
@ -572,7 +527,6 @@
[(|#%pthread|) (hasheq)]
[(|#%thread|) |#%thread-instance|]
[(|#%rktio|) |#%rktio-instance|]
[(|#%windows-version|) |#%windows-version-instance|]
[else #f]))
(include "include.ss")

19
racket/src/cs/schemified/expander.scm
View File

@ -80,6 +80,7 @@
(define rx2623 (regexp "^\\\\\\\\"))
(define rx2947 (regexp "^[a-z]:"))
(define rx2199 (byte-regexp #vu8(34)))
(define rx2194 (byte-regexp #vu8(0)))
(define hash2725 (hash))
(define hash2610 (hasheq))
(define hash2589 (hasheqv))
@ -1093,6 +1094,14 @@
'path-list-string->path-list
"(or/c bytes? string?)"
s_0))
(if (regexp-match? rx2194 s_0)
(let ((label_0 (if (bytes? s_0) "byte string" "string")))
(raise-arguments-error
'path-list-string->path-list
(format "given ~a contains a nul character" label_0)
label_0
s_0))
(void))
(if (if (list? default_0)
(andmap
(lambda (p_0)
@ -1183,7 +1192,7 @@
((base_0 name_0 dir?_0) (eq? base_0 'relative))
(args (raise-binding-result-arity-error 3 args))))
#f)
(let ((paths-str_0
(let ((paths-bstr_0
(environment-variables-ref
(current-environment-variables)
#vu8(80 65 84 72))))
@ -1195,7 +1204,7 @@
(if (eq? (system-type) 'windows)
(cons (bytes->path #vu8(46)) s_0)
s_0))))))
(let ((paths-str_1 paths-str_0))
(let ((paths-bstr_1 paths-bstr_0))
(letrec*
((loop_0
(|#%name|
@ -1211,10 +1220,8 @@
(loop_0 (cdr paths_0)))))))))))
(loop_0
(win-add_0
(if paths-str_1
(path-list-string->path-list
(bytes->string/locale paths-str_1 '#\x3f)
null)
(if paths-bstr_1
(path-list-string->path-list paths-bstr_1 null)
null)))))))
(let ((p_0 (path->complete-path program_0)))
(if (file-exists? p_0) (found-exec_0 p_0) #f))))))

412
racket/src/cs/schemified/io.scm
View File

File diff suppressed because it is too large Load Diff

2
racket/src/io/demo.rkt
View File

@ -15,6 +15,8 @@
(path->string (current-directory))
(set-string->number?! string->number)
(get-machine-info)
(let ()
(define-values (i o) (make-pipe 4096))

7
racket/src/io/host/bootstrap.rkt
View File

@ -156,10 +156,3 @@
'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)"))))

11
racket/src/io/host/windows-version.rkt
View File

@ -1,11 +0,0 @@
#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))

57
racket/src/io/machine/main.rkt
View File

@ -1,53 +1,14 @@
#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")
(require "../host/rktio.rkt"
"../host/thread.rkt"
"../string/convert.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)))])))))))
"<unknown machine>")]))
(bytes->string/utf-8
(atomically
(define v (rktio_uname rktio))
(begin0
(rktio_to_bytes v)
(rktio_free v)))))

2
racket/src/rktio/rktio.def
View File

@ -157,6 +157,7 @@ rktio_copy_file_finish_permissions
rktio_copy_file_stop
rktio_system_path
rktio_expand_user_tilde
rktio_uname
rktio_get_signal_handle
rktio_signal_received_at
rktio_signal_received
@ -164,6 +165,7 @@ rktio_wait_until_signal_received
rktio_flush_signals_received
rktio_install_os_signal_handler
rktio_poll_os_signal
rktio_will_modify_os_signal_handler
rktio_get_milliseconds
rktio_get_inexact_milliseconds
rktio_get_process_milliseconds

6
racket/src/rktio/rktio.h
View File

@ -972,6 +972,12 @@ RKTIO_EXTERN char *rktio_expand_user_tilde(rktio_t *rktio, rktio_const_string_t
Other possible errors are `RKTIO_ERROR_ILL_FORMED_USER` and
`RKTIO_ERROR_UNKNOWN_USER`. */
RKTIO_EXTERN_NOERR char *rktio_uname(rktio_t *rktio);
/* Returns a string describing the current machine and installation,
similar to the return of `uname -a` on Unix. If machine information
cannot be obtained for some reason, the result is a copy of
"<unknown machine>". */
/*************************************************/
/* Sleep and signals */

2
racket/src/rktio/rktio.inc
View File

@ -157,6 +157,7 @@ Sforeign_symbol("rktio_copy_file_finish_permissions", (void *)rktio_copy_file_fi
Sforeign_symbol("rktio_copy_file_stop", (void *)rktio_copy_file_stop);
Sforeign_symbol("rktio_system_path", (void *)rktio_system_path);
Sforeign_symbol("rktio_expand_user_tilde", (void *)rktio_expand_user_tilde);
Sforeign_symbol("rktio_uname", (void *)rktio_uname);
Sforeign_symbol("rktio_get_signal_handle", (void *)rktio_get_signal_handle);
Sforeign_symbol("rktio_signal_received_at", (void *)rktio_signal_received_at);
Sforeign_symbol("rktio_signal_received", (void *)rktio_signal_received);
@ -164,6 +165,7 @@ Sforeign_symbol("rktio_wait_until_signal_received", (void *)rktio_wait_until_sig
Sforeign_symbol("rktio_flush_signals_received", (void *)rktio_flush_signals_received);
Sforeign_symbol("rktio_install_os_signal_handler", (void *)rktio_install_os_signal_handler);
Sforeign_symbol("rktio_poll_os_signal", (void *)rktio_poll_os_signal);
Sforeign_symbol("rktio_will_modify_os_signal_handler", (void *)rktio_will_modify_os_signal_handler);
Sforeign_symbol("rktio_get_milliseconds", (void *)rktio_get_milliseconds);
Sforeign_symbol("rktio_get_inexact_milliseconds", (void *)rktio_get_inexact_milliseconds);
Sforeign_symbol("rktio_get_process_milliseconds", (void *)rktio_get_process_milliseconds);

2
racket/src/rktio/rktio.rktl
View File

@ -1171,6 +1171,7 @@
(ref char)
rktio_expand_user_tilde
(((ref rktio_t) rktio) (rktio_const_string_t filename)))
(define-function () (ref char) rktio_uname (((ref rktio_t) rktio)))
(define-function
()
(ref rktio_signal_handle_t)
@ -1194,6 +1195,7 @@
rktio_install_os_signal_handler
(((ref rktio_t) rktio)))
(define-function () int rktio_poll_os_signal (((ref rktio_t) rktio)))
(define-function () void rktio_will_modify_os_signal_handler ((int sig_id)))
(define-function () uintptr_t rktio_get_milliseconds ())
(define-function () double rktio_get_inexact_milliseconds ())
(define-function

91
racket/src/rktio/rktio_fs.c
View File

@ -13,8 +13,10 @@
# include <grp.h>
# include <dirent.h>
# include <sys/time.h>
# include <sys/utsname.h>
#endif
#ifdef RKTIO_SYSTEM_WINDOWS
# include <windows.h>
# include <shlobj.h>
# include <direct.h>
# include <sys/stat.h>
@ -2236,3 +2238,92 @@ char *rktio_system_path(rktio_t *rktio, int which)
}
#endif
}
/*========================================================================*/
/* system information as a string */
/*========================================================================*/
#ifdef RKTIO_SYSTEM_UNIX
char *rktio_uname(rktio_t *rktio) {
char *s;
struct utsname u;
int ok, len;
int syslen, nodelen, rellen, verlen, machlen;
do {
ok = uname(&u);
} while ((ok == -1) && (errno == EINTR));
if (ok != 0)
return strdup("<unknown machine>");
syslen = strlen(u.sysname);
nodelen = strlen(u.nodename);
rellen = strlen(u.release);
verlen = strlen(u.version);
machlen = strlen(u.machine);
len = (syslen + 1 + nodelen + 1 + rellen + 1 + verlen + 1 + machlen + 1);
s = malloc(len);
# define ADD_UNAME_STR(sn, slen) do { \
memcpy(s + len, sn, slen); \
len += slen; \
s[len++] = ' '; \
} while (0)
len = 0;
ADD_UNAME_STR(u.sysname, syslen);
ADD_UNAME_STR(u.nodename, nodelen);
ADD_UNAME_STR(u.release, rellen);
ADD_UNAME_STR(u.version, verlen);
ADD_UNAME_STR(u.machine, machlen);
s[len - 1] = 0;
# undef ADD_UNAME_STR
return s;
}
#endif
#ifdef RKTIO_SYSTEM_WINDOWS
char *rktio_uname(rktio_t *rktio) {
char buff[1024], *r;
OSVERSIONINFO info;
BOOL hasInfo;
char *p;
int len;
info.dwOSVersionInfoSize = sizeof(info);
GetVersionEx(&info);
hasInfo = FALSE;
p = info.szCSDVersion;
while (p < info.szCSDVersion + sizeof(info.szCSDVersion) &&
*p) {
if (*p != ' ') {
hasInfo = TRUE;
break;
}
p = p + 1;
}
sprintf(buff,"Windows %s %ld.%ld (Build %ld)%s%s",
(info.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS) ?
"9x" :
(info.dwPlatformId == VER_PLATFORM_WIN32_NT) ?
"NT" : "Unknown platform",
info.dwMajorVersion,info.dwMinorVersion,
(info.dwPlatformId == VER_PLATFORM_WIN32_NT) ?
info.dwBuildNumber :
info.dwBuildNumber & 0xFFFF,
hasInfo ? " " : "",hasInfo ? info.szCSDVersion : "");
return strdup(buff);
}
#endif