Allow scrolling the NSM window

* lisp/net/nsm.el (nsm-query-user): Allow moving
backwards/forwards in the NSM buffer if the window is too small to
show all the details (bug#28069).

diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index 11535a5a5a1d4cd0a2adf9a2fcab997f9d267197..b8c84d5fdea84763c16dccb2c76f4e6ae5ce56bd 100644 (file)
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -815,84 +815,110 @@ protocol."
 (defun nsm-query-user (message status)
   (let ((buffer (get-buffer-create "*Network Security Manager*"))
         (cert-buffer (get-buffer-create "*Certificate Details*"))
-        (certs (plist-get status :certificates)))
+        (certs (plist-get status :certificates))
+        (accept-choices
+         '((?a "always" "Accept this certificate this session and for all future sessions.")
+           (?s "session only" "Accept this certificate this session only.")
+           (?n "no" "Refuse to use this certificate, and close the connection.")
+           (?d "details" "See certificate details")))
+        (details-choices
+         '((?b "backward page" "See previous page")
+           (?f "forward page" "See next page")
+           (?n "next" "Next certificate")
+           (?p "previous" "Previous certificate")
+           (?q "quit" "Quit details view")))
+        (done nil))
     (save-window-excursion
       ;; First format the certificate and warnings.
-      (with-current-buffer-window
-       buffer nil nil
-       (when status (insert (nsm-format-certificate status)))
-       (insert message)
-       (goto-char (point-min))
-       ;; Fill the first line of the message, which usually
-       ;; contains lots of explanatory text.
-       (fill-region (point) (line-end-position)))
+      (pop-to-buffer buffer)
+      (erase-buffer)
+      (let ((inhibit-read-only t))
+        (when status
+          (insert (nsm-format-certificate status)))
+        (insert message)
+        (goto-char (point-min))
+        ;; Fill the first line of the message, which usually
+        ;; contains lots of explanatory text.
+        (fill-region (point) (line-end-position))
+        ;; If the window is too small, add navigation options.
+        (when (> (line-number-at-pos (point-max)) (window-height))
+          (setq accept-choices
+                (append accept-choices
+                        '((?b "backward page" "See previous page")
+                          (?f "forward page" "See next page"))))))
       ;; Then ask the user what to do about it.
       (unwind-protect
-          (let* ((accept-choices '((?a "always" "Accept this certificate this session and for all future sessions.")
-                                   (?s "session only" "Accept this certificate this session only.")
-                                   (?n "no" "Refuse to use this certificate, and close the connection.")
-                                   (?d "details" "See certificate details")))
-                 (details-choices '((?b "backward page" "See previous page")
-                                    (?f "forward page" "See next page")
-                                    (?n "next" "Next certificate")
-                                    (?p "previous" "Previous certificate")
-                                    (?q "quit" "Quit details view")))
-                 (answer (read-multiple-choice "Continue connecting?"
-                                               accept-choices))
-                 (show-details (char-equal (car answer) ?d))
-                 (pems (cl-loop for cert in certs
+          (let* ((pems (cl-loop for cert in certs
                                 collect (gnutls-format-certificate
                                          (plist-get cert :pem))))
-                 (cert-index 0))
-            (while show-details
-              (unless (get-buffer-window cert-buffer)
-                (set-window-buffer (get-buffer-window buffer) cert-buffer)
-                (with-current-buffer cert-buffer
-                  (read-only-mode -1)
-                  (insert (nth cert-index pems))
-                  (goto-char (point-min))
-                  (read-only-mode)))
-
-              (setq answer (read-multiple-choice "Viewing certificate:" details-choices))
-
-              (cond
-               ((char-equal (car answer) ?q)
-                (setq show-details (not show-details))
-                (set-window-buffer (get-buffer-window cert-buffer) buffer)
-                (setq show-details (char-equal
-                                    (car (setq answer
-                                               (read-multiple-choice
-                                                "Continue connecting?"
-                                                accept-choices)))
-                                    ?d)))
-
-               ((char-equal (car answer) ?b)
-                (with-selected-window (get-buffer-window cert-buffer)
-                  (with-current-buffer cert-buffer
-                    (ignore-errors (scroll-down)))))
-
-               ((char-equal (car answer) ?f)
-                (with-selected-window (get-buffer-window cert-buffer)
-                  (with-current-buffer cert-buffer
-                    (ignore-errors (scroll-up)))))
-
-               ((char-equal (car answer) ?n)
-                (with-current-buffer cert-buffer
-                  (read-only-mode -1)
-                  (erase-buffer)
-                  (setq cert-index (mod (1+ cert-index) (length pems)))
-                  (insert (nth cert-index pems))
-                  (goto-char (point-min))
-                  (read-only-mode)))
-
-               ((char-equal (car answer) ?p)
-                (with-current-buffer cert-buffer
-                  (read-only-mode -1)
-                  (erase-buffer)
-                  (setq cert-index (mod (1- cert-index) (length pems)))
-                  (insert (nth cert-index pems))
-                  (goto-char (point-min))
-                  (read-only-mode)))))
+                 (cert-index 0)
+                 show-details answer buf)
+            (while (not done)
+              (setq answer (if show-details
+                               (read-multiple-choice "Viewing certificate:"
+                                                     details-choices)
+                             (read-multiple-choice "Continue connecting?"
+                                                   accept-choices)))
+              (setq buf (if show-details cert-buffer buffer))
+
+              (cl-case (car answer)
+                (?q
+                 ;; Exit the details window.
+                 (set-window-buffer (get-buffer-window cert-buffer) buffer)
+                 (setq show-details nil))
+
+                (?d
+                 ;; Enter the details window.
+                 (set-window-buffer (get-buffer-window buffer) cert-buffer)
+                 (with-current-buffer cert-buffer
+                   (read-only-mode -1)
+                   (insert (nth cert-index pems))
+                   (goto-char (point-min))
+                   (read-only-mode))
+                 (setq show-details t))
+
+                (?b
+                 ;; Scroll down.
+                 (with-selected-window (get-buffer-window buf)
+                   (with-current-buffer buf
+                     (ignore-errors (scroll-down)))))
+
+                (?f
+                 ;; Scroll up.
+                 (with-selected-window (get-buffer-window buf)
+                   (with-current-buffer buf
+                     (ignore-errors (scroll-up)))))
+
+                (?n
+                 ;; "No" or "next certificate".
+                 (if show-details
+                     (with-current-buffer cert-buffer
+                       (read-only-mode -1)
+                       (erase-buffer)
+                       (setq cert-index (mod (1+ cert-index) (length pems)))
+                       (insert (nth cert-index pems))
+                       (goto-char (point-min))
+                       (read-only-mode))
+                   (setq done t)))
+
+                (?a
+                 ;; "Always"
+                 (setq done t))
+
+                (?s
+                 ;; "Session only"
+                 (setq done t))
+
+                (?p
+                 ;; Previous certificate.
+                 (with-current-buffer cert-buffer
+                   (read-only-mode -1)
+                   (erase-buffer)
+                   (setq cert-index (mod (1- cert-index) (length pems)))
+                   (insert (nth cert-index pems))
+                   (goto-char (point-min))
+                   (read-only-mode)))))
+            ;; Return the answer.
             (cadr answer))
         (kill-buffer cert-buffer)
         (kill-buffer buffer)))))