[Git][cmucl/cmucl][master] 2 commits: Fix #120: software-version in C
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Wed Apr 19 14:14:50 UTC 2023
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/b2aee0f70567e3e36579517cee771e753ada80b4...501ca8372fad88d693c8b9ce9a6d60ad604e5774
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b2aee0f70567e3e36579517cee771e753ada80b4...501ca8372fad88d693c8b9ce9a6d60ad604e5774
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230419/599f27a4/attachment-0001.html>
More information about the cmucl-cvs
mailing list