Read Windows OS info for report-emacs-bug from Registry

* lisp/w32-fns.el (w32--os-description): New function.
* lisp/mail/emacsbug.el (report-emacs-bug--os-description):
Use 'w32--os-description' instead of launching the
'systeminfo' program, which can be very slow, and is also
missing on versions of Windows before XP Professional.

2 files changed, 75 insertions, 41 deletions

diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 92b005d47d2..8cacad8726d 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -134,22 +134,7 @@ This requires either the macOS \"open\" command, or the freedesktop
            os))
         ((eq system-type 'windows-nt)
          (or report-emacs-bug--os-description
-             (setq
-              report-emacs-bug--os-description
-              (let (os)
-                (with-temp-buffer
-                  ;; Seems like this command can be slow, because it
-                  ;; unconditionally queries a bunch of other stuff
-                  ;; we don't care about.
-                  (when (eq 0 (ignore-errors
-                                (call-process "systeminfo" nil '(t nil) nil)))
-                    (dolist (s '("OS Name" "OS Version"))
-                      (goto-char (point-min))
-                      (if (re-search-forward
-                           (format "^%s\\s-*:\\s-+\\(.*\\)$" s)
-                           nil t)
-                          (setq os (concat os " " (match-string 1)))))))
-                os))))
+             (setq report-emacs-bug--os-description (w32--os-description))))
         ((eq system-type 'berkeley-unix)
          (with-temp-buffer
            (when
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index a8a41c453a0..91fe5186bc9 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -39,6 +39,8 @@
     ;; same buffer.
     (setq find-file-visit-truename t))
 
+;;;; Shells
+
 (defun w32-shell-name ()
   "Return the name of the shell being used."
   (or (bound-and-true-p shell-file-name)
@@ -120,6 +122,8 @@ You should set this to t when using a non-system shell.\n\n"))))
 
 (add-hook 'after-init-hook 'w32-check-shell-configuration)
 
+;;;; Coding-systems, locales, etc.
+
 ;; Override setting chosen at startup.
 (defun w32-set-default-process-coding-system ()
   ;; Most programs on Windows will accept Unix line endings on input
@@ -187,31 +191,6 @@ You should set this to t when using a non-system shell.\n\n"))))
 ;;          (setq source-directory (file-name-as-directory
 ;;                                   (expand-file-name ".." exec-directory)))))
 
-(defun w32-convert-standard-filename (filename)
-  "Convert a standard file's name to something suitable for MS-Windows.
-This means to guarantee valid names and perhaps to canonicalize
-certain patterns.
-
-This function is called by `convert-standard-filename'.
-
-Replace invalid characters and turn Cygwin names into native
-names."
-  (save-match-data
-    (let ((name
-           (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
-               (replace-match "\\1:/" t nil filename)
-             (copy-sequence filename)))
-          (start 0))
-      ;; leave ':' if part of drive specifier
-      (if (and (> (length name) 1)
-               (eq (aref name 1) ?:))
-          (setq start 2))
-      ;; destructively replace invalid filename characters with !
-      (while (string-match "[?*:<>|\"\000-\037]" name start)
-        (aset name (match-beginning 0) ?!)
-        (setq start (match-end 0)))
-      name)))
-
 (defun w32-set-system-coding-system (coding-system)
   "Set the coding system used by the Windows system to CODING-SYSTEM.
 This is used for things like passing font names with non-ASCII
@@ -297,6 +276,76 @@ bit output with no translation."
   (w32-add-charset-info "tis620-0" 'w32-charset-thai 874)
   (w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252))
 
+;;;; Standard filenames
+
+(defun w32-convert-standard-filename (filename)
+  "Convert a standard file's name to something suitable for MS-Windows.
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+This function is called by `convert-standard-filename'.
+
+Replace invalid characters and turn Cygwin names into native
+names."
+  (save-match-data
+    (let ((name
+           (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
+               (replace-match "\\1:/" t nil filename)
+             (copy-sequence filename)))
+          (start 0))
+      ;; leave ':' if part of drive specifier
+      (if (and (> (length name) 1)
+               (eq (aref name 1) ?:))
+          (setq start 2))
+      ;; destructively replace invalid filename characters with !
+      (while (string-match "[?*:<>|\"\000-\037]" name start)
+        (aset name (match-beginning 0) ?!)
+        (setq start (match-end 0)))
+      name)))
+
+;;;; System name and version for emacsbug.el
+
+(defun w32--os-description ()
+  "Return a string describing the underlying OS and its version."
+  (let* ((w32ver (car (w32-version)))
+         (w9x-p (< w32ver 5))
+         (key (if w9x-p
+                  "SOFTWARE/Microsoft/Windows/CurrentVersion"
+                "SOFTWARE/Microsoft/Windows NT/CurrentVersion"))
+         (os-name (w32-read-registry 'HKLM key "ProductName"))
+         (os-version (if w9x-p
+                         (w32-read-registry 'HKLM key "VersionNumber")
+                       (let ((vmajor
+                              (w32-read-registry 'HKLM key
+                                                 "CurrentMajorVersionNumber"))
+                             (vminor
+                              (w32-read-registry 'HKLM key
+                                                 "CurrentMinorVersionNumber")))
+                         (if (and vmajor vmajor)
+                             (format "%d.%d" vmajor vminor)
+                           (w32-read-registry 'HKLM key "CurrentVersion")))))
+         (os-csd (w32-read-registry 'HKLM key "CSDVersion"))
+         (os-rel (or (w32-read-registry 'HKLM key "ReleaseID")
+                     (w32-read-registry 'HKLM key "CSDBuildNumber")
+                 "0"))  ; No Release ID before Windows Vista
+         (os-build (w32-read-registry 'HKLM key "CurrentBuildNumber"))
+         (os-rev (w32-read-registry 'HKLM key "UBR"))
+         (os-rev (if os-rev (format "%d" os-rev))))
+    (if w9x-p
+        (concat
+         (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ")
+         os-name
+         " (v" os-version ")")
+      (concat
+       (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ")
+       os-name      ; Windows 7 Enterprise
+       " "
+       os-csd       ; Service Pack 1
+       (if (and os-csd (> (length os-csd) 0)) " " "")
+       "(v"
+       os-version "." os-rel "." os-build (if os-rev (concat "." os-rev))
+       ")"))))
+
 
 ;;;; Support for build process