Raymond Toy pushed to branch master at cmucl / cmucl Commits: fbb742ae by Raymond Toy at 2023-04-19T14:14:39+00:00 Fix #120: software-version in C - - - - - 501ca837 by Raymond Toy at 2023-04-19T14:14:40+00:00 Merge branch 'issue-120-software-type-in-c' into 'master' Fix #120: software-version in C Closes #120, #130, #146, #136, #142, #134, and #132 See merge request cmucl/cmucl!93 - - - - - 8 changed files: - src/code/bsd-os.lisp - src/code/linux-os.lisp - src/code/misc.lisp - src/code/sunos-os.lisp - src/general-info/release-21e.md - src/i18n/locale/cmucl-linux-os.pot - src/i18n/locale/cmucl.pot - src/lisp/os-common.c Changes: ===================================== src/code/bsd-os.lisp ===================================== @@ -48,19 +48,6 @@ #+Darwin "Darwin" #-(or freebsd NetBSD OpenBSD Darwin) "BSD") -(defvar *software-version* nil "Version string for supporting software") - -(defun software-version () - "Returns a string describing version of the supporting software." - (unless *software-version* - (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (run-program "/usr/bin/uname" - '("-r") - :output stream))))) - *software-version*) -  ;;; OS-Init initializes our operating-system interface. It sets the values ;;; of the global port variables to what they should be and calls the functions ===================================== src/code/linux-os.lisp ===================================== @@ -28,20 +28,10 @@ (setq *software-type* "Linux") -;;; Instead of reading /proc/version (which has some bugs with -;;; select() in Linux kernel 2.6.x) and instead of running uname -r, -;;; let's just get the info from uname(). -(defun software-version () - "Returns a string describing version of the supporting software." - (multiple-value-bind (sysname nodename release version) - (unix:unix-uname) - (declare (ignore sysname nodename)) - (concatenate 'string release " " version))) - - ;;; OS-Init initializes our operating-system interface. ;;; -(defun os-init () nil) +(defun os-init () + (setf *software-version* nil)) ;;; GET-PAGE-SIZE -- Interface ===================================== src/code/misc.lisp ===================================== @@ -17,7 +17,7 @@ (in-package "LISP") (intl:textdomain "cmucl") -(export '(documentation *features* variable room +(export '(*features* variable room lisp-implementation-type lisp-implementation-version machine-type machine-version machine-instance software-type software-version short-site-name long-site-name dribble compiler-macro)) @@ -81,12 +81,32 @@ (unix:unix-gethostname)) (defvar *software-type* "Unix" - "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") + _N"The value of SOFTWARE-TYPE. Set in FOO-os.lisp.") (defun software-type () "Returns a string describing the supporting software." *software-type*) +(defvar *software-version* nil + _N"Version string for supporting software") + +(defun software-version () + _N"Returns a string describing version of the supporting software." + (unless *software-version* + (setf *software-version* + (let (version result) + (unwind-protect + (progn + (setf version + (alien:alien-funcall + (alien:extern-alien "os_software_version" + (function (alien:* c-call:c-string))))) + (setf result (alien:cast version c-call:c-string)))) + (if (zerop (length result)) + "Unknown" + result))) + *software-version*)) + (defvar *short-site-name* nil "The value of SHORT-SITE-NAME. Set in library:site-init.lisp.") ===================================== src/code/sunos-os.lisp ===================================== @@ -33,19 +33,6 @@ (setq *software-type* "SunOS") -(defvar *software-version* nil "Version string for supporting software") - -(defun software-version () - "Returns a string describing version of the supporting software." - (unless *software-version* - (setf *software-version* - (multiple-value-bind (sysname nodename release version) - (unix:unix-uname) - (declare (ignore sysname nodename)) - (concatenate 'string release " " version)))) - *software-version*) - - ;;; OS-INIT -- interface. ;;; ;;; Other OS dependent initializations. ===================================== src/general-info/release-21e.md ===================================== @@ -49,10 +49,11 @@ public domain. * ~~#108~~ Update ASDF. * ~~#112~~ CLX can't connect to X server via inet sockets. * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF. - * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM. - * ~~#122~~ gcc 11 can't build cmucl. - * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories. - * ~~#125~~ Linux `unix-stat` returning incorrect values. + * ~~#120~~ `SOFTWARE-VERSION` is implemented in C. + * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM + * ~~#122~~ gcc 11 can't build cmucl + * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories + * ~~#125~~ Linux `unix-stat` returning incorrect values * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid. * ~~#128~~ `QUIT` accepts an exit code. * ~~#130~~ Move file-author to C. ===================================== src/i18n/locale/cmucl-linux-os.pot ===================================== @@ -15,10 +15,6 @@ msgstr "" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" -#: src/code/linux-os.lisp -msgid "Returns a string describing version of the supporting software." -msgstr "" - #: src/code/linux-os.lisp msgid "Unix system call getrusage failed: ~A." msgstr "" ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5646,6 +5646,14 @@ msgstr "" msgid "Returns a string describing the supporting software." msgstr "" +#: src/code/misc.lisp +msgid "Version string for supporting software" +msgstr "" + +#: src/code/misc.lisp +msgid "Returns a string describing version of the supporting software." +msgstr "" + #: src/code/misc.lisp msgid "The value of SHORT-SITE-NAME. Set in library:site-init.lisp." msgstr "" ===================================== src/lisp/os-common.c ===================================== @@ -17,6 +17,7 @@ #include <string.h> #include <sys/resource.h> #include <sys/stat.h> +#include <sys/utsname.h> #include <unistd.h> #include <time.h> @@ -830,4 +831,27 @@ os_get_system_info(int64_t* utime, int64_t* stime, long* major_fault) return rc; } +/* + * Get the software version. This is the same as "uname -r", the release. + * A pointer to a static string is returned. If uname fails, an empty + * string is returned. + */ +char* +os_software_version(void) +{ + struct utsname uts; + int status; + + /* + * Buffer large enough to hold the release. + */ + static char result[sizeof(uts.release)]; + result[0] = '\0'; + + status = uname(&uts); + if (status == 0) { + strcpy(result, uts.release); + } + return result; +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b2aee0f70567e3e36579517... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b2aee0f70567e3e36579517... You're receiving this email because of your account on gitlab.common-lisp.net.