Skip to content

Commit

Permalink
Move read-multiple-choice to subr-x.el
Browse files Browse the repository at this point in the history 
* lisp/faces.el (read-multiple-choice-face): Fix doc string.

* lisp/emacs-lisp/subr-x.el (read-multiple-choice): Move here
from subr.el.

* lisp/gnus/message.el (subr-x): Ditto.

* lisp/net/nsm.el: Require subr-x for read-multiple-choice.

read-multiple-choice doesn't need to be in the dumped Emacs, so move
it to a less central file.
  • Loading branch information
@larsmagne
larsmagne committed Jul 22, 2016
1 parent 431641a commit ad90397
Show file tree
Hide file tree
Showing 5 changed files with 168 additions and 166 deletions.
165 changes: 165 additions & 0 deletions lisp/emacs-lisp/subr-x.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -198,6 +198,171 @@ to bind a single value, BINDINGS can just be a plain tuple."
(substring string 0 (- (length string) (length suffix)))
string))

(defun read-multiple-choice (prompt choices)
"Ask user a multiple choice question.
PROMPT should be a string that will be displayed as the prompt.
CHOICES is an alist where the first element in each entry is a
character to be entered, the second element is a short name for
the entry to be displayed while prompting (if there's room, it
might be shortened), and the third, optional entry is a longer
explanation that will be displayed in a help buffer if the user
requests more help.
This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
that variable for more information. In this case, the useful
bindings are `recenter', `scroll-up', and `scroll-down'. If the
user enters `recenter', `scroll-up', or `scroll-down' responses,
perform the requested window recentering or scrolling and ask
again.
The return value is the matching entry from the CHOICES list.
Usage example:
\(read-multiple-choice \"Continue connecting?\"
'((?a \"always\")
(?s \"session only\")
(?n \"no\")))"
(let* ((altered-names nil)
(full-prompt
(format
"%s (%s): "
prompt
(mapconcat
(lambda (elem)
(let* ((name (cadr elem))
(pos (seq-position name (car elem)))
(altered-name
(cond
;; Not in the name string.
((not pos)
(format "[%c] %s" (car elem) name))
;; The prompt character is in the name, so highlight
;; it on graphical terminals...
((display-supports-face-attributes-p
'(:underline t) (window-frame))
(setq name (copy-sequence name))
(put-text-property pos (1+ pos)
'face 'read-multiple-choice-face
name)
name)
;; And put it in [bracket] on non-graphical terminals.
(t
(concat
(substring name 0 pos)
"["
(upcase (substring name pos (1+ pos)))
"]"
(substring name (1+ pos)))))))
(push (cons (car elem) altered-name)
altered-names)
altered-name))
(append choices '((?? "?")))
", ")))
tchar buf wrong-char answer)
(save-window-excursion
(save-excursion
(while (not tchar)
(message "%s%s"
(if wrong-char
"Invalid choice. "
"")
full-prompt)
(setq tchar
(if (and (display-popup-menus-p)
last-input-event ; not during startup
(listp last-nonmenu-event)
use-dialog-box)
(x-popup-dialog
t
(cons prompt
(mapcar
(lambda (elem)
(cons (capitalize (cadr elem))
(car elem)))
choices)))
(condition-case nil
(let ((cursor-in-echo-area t))
(read-char))
(error nil))))
(setq answer (lookup-key query-replace-map (vector tchar) t))
(setq tchar
(cond
((eq answer 'recenter)
(recenter) t)
((eq answer 'scroll-up)
(ignore-errors (scroll-up-command)) t)
((eq answer 'scroll-down)
(ignore-errors (scroll-down-command)) t)
((eq answer 'scroll-other-window)
(ignore-errors (scroll-other-window)) t)
((eq answer 'scroll-other-window-down)
(ignore-errors (scroll-other-window-down)) t)
(t tchar)))
(when (eq tchar t)
(setq wrong-char nil
tchar nil))
;; The user has entered an invalid choice, so display the
;; help messages.
(when (and (not (eq tchar nil))
(not (assq tchar choices)))
(setq wrong-char (not (memq tchar '(?? ?\C-h)))
tchar nil)
(when wrong-char
(ding))
(with-help-window (setq buf (get-buffer-create
"*Multiple Choice Help*"))
(with-current-buffer buf
(erase-buffer)
(pop-to-buffer buf)
(insert prompt "\n\n")
(let* ((columns (/ (window-width) 25))
(fill-column 21)
(times 0)
(start (point)))
(dolist (elem choices)
(goto-char start)
(unless (zerop times)
(if (zerop (mod times columns))
;; Go to the next "line".
(goto-char (setq start (point-max)))
;; Add padding.
(while (not (eobp))
(end-of-line)
(insert (make-string (max (- (* (mod times columns)
(+ fill-column 4))
(current-column))
0)
?\s))
(forward-line 1))))
(setq times (1+ times))
(let ((text
(with-temp-buffer
(insert (format
"%c: %s\n"
(car elem)
(cdr (assq (car elem) altered-names))))
(fill-region (point-min) (point-max))
(when (nth 2 elem)
(let ((start (point)))
(insert (nth 2 elem))
(unless (bolp)
(insert "\n"))
(fill-region start (point-max))))
(buffer-string))))
(goto-char start)
(dolist (line (split-string text "\n"))
(end-of-line)
(if (bolp)
(insert line "\n")
(insert line))
(forward-line 1)))))))))))
(when (buffer-live-p buf)
(kill-buffer buf))
(assq tchar choices)))

(provide 'subr-x)

;;; subr-x.el ends here
2 changes: 1 addition & 1 deletion lisp/faces.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2749,7 +2749,7 @@ It is used for characters of no fonts too."
(defface read-multiple-choice-face
'((t (:inherit underline
:weight bold)))
"Face for the symbol name in Apropos output."
"Face for the symbol name in `read-multiple-choice' output."
:group 'basic-faces
:version "25.2")

Expand Down
1 change: 1 addition & 0 deletions lisp/gnus/message.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,7 @@
(require 'mm-util)
(require 'rfc2047)
(require 'puny)
(require 'subr-x)

(autoload 'mailclient-send-it "mailclient")

Expand Down
1 change: 1 addition & 0 deletions lisp/net/nsm.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@
;;; Code:

(require 'cl-lib)
(require 'subr-x)

(defvar nsm-permanent-host-settings nil)
(defvar nsm-temporary-host-settings nil)
Expand Down
165 changes: 0 additions & 165 deletions lisp/subr.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2286,171 +2286,6 @@ keyboard-quit events while waiting for a valid input."
(message "%s%s" prompt (char-to-string char))
char))

(defun read-multiple-choice (prompt choices)
"Ask user a multiple choice question.
PROMPT should be a string that will be displayed as the prompt.

CHOICES is an alist where the first element in each entry is a
character to be entered, the second element is a short name for
the entry to be displayed while prompting (if there's room, it
might be shortened), and the third, optional entry is a longer
explanation that will be displayed in a help buffer if the user
requests more help.

This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
that variable for more information. In this case, the useful
bindings are `recenter', `scroll-up', and `scroll-down'. If the
user enters `recenter', `scroll-up', or `scroll-down' responses,
perform the requested window recentering or scrolling and ask
again.

The return value is the matching entry from the CHOICES list.

Usage example:

\(read-multiple-choice \"Continue connecting?\"
'((?a \"always\")
(?s \"session only\")
(?n \"no\")))"
(let* ((altered-names nil)
(full-prompt
(format
"%s (%s): "
prompt
(mapconcat
(lambda (elem)
(let* ((name (cadr elem))
(pos (seq-position name (car elem)))
(altered-name
(cond
;; Not in the name string.
((not pos)
(format "[%c] %s" (car elem) name))
;; The prompt character is in the name, so highlight
;; it on graphical terminals...
((display-supports-face-attributes-p
'(:underline t) (window-frame))
(setq name (copy-sequence name))
(put-text-property pos (1+ pos)
'face 'read-multiple-choice-face
name)
name)
;; And put it in [bracket] on non-graphical terminals.
(t
(concat
(substring name 0 pos)
"["
(upcase (substring name pos (1+ pos)))
"]"
(substring name (1+ pos)))))))
(push (cons (car elem) altered-name)
altered-names)
altered-name))
(append choices '((?? "?")))
", ")))
tchar buf wrong-char answer)
(save-window-excursion
(save-excursion
(while (not tchar)
(message "%s%s"
(if wrong-char
"Invalid choice. "
"")
full-prompt)
(setq tchar
(if (and (display-popup-menus-p)
last-input-event ; not during startup
(listp last-nonmenu-event)
use-dialog-box)
(x-popup-dialog
t
(cons prompt
(mapcar
(lambda (elem)
(cons (capitalize (cadr elem))
(car elem)))
choices)))
(condition-case nil
(let ((cursor-in-echo-area t))
(read-char))
(error nil))))
(setq answer (lookup-key query-replace-map (vector tchar) t))
(setq tchar
(cond
((eq answer 'recenter)
(recenter) t)
((eq answer 'scroll-up)
(ignore-errors (scroll-up-command)) t)
((eq answer 'scroll-down)
(ignore-errors (scroll-down-command)) t)
((eq answer 'scroll-other-window)
(ignore-errors (scroll-other-window)) t)
((eq answer 'scroll-other-window-down)
(ignore-errors (scroll-other-window-down)) t)
(t tchar)))
(when (eq tchar t)
(setq wrong-char nil
tchar nil))
;; The user has entered an invalid choice, so display the
;; help messages.
(when (and (not (eq tchar nil))
(not (assq tchar choices)))
(setq wrong-char (not (memq tchar '(?? ?\C-h)))
tchar nil)
(when wrong-char
(ding))
(with-help-window (setq buf (get-buffer-create
"*Multiple Choice Help*"))
(with-current-buffer buf
(erase-buffer)
(pop-to-buffer buf)
(insert prompt "\n\n")
(let* ((columns (/ (window-width) 25))
(fill-column 21)
(times 0)
(start (point)))
(dolist (elem choices)
(goto-char start)
(unless (zerop times)
(if (zerop (mod times columns))
;; Go to the next "line".
(goto-char (setq start (point-max)))
;; Add padding.
(while (not (eobp))
(end-of-line)
(insert (make-string (max (- (* (mod times columns)
(+ fill-column 4))
(current-column))
0)
?\s))
(forward-line 1))))
(setq times (1+ times))
(let ((text
(with-temp-buffer
(insert (format
"%c: %s\n"
(car elem)
(cdr (assq (car elem) altered-names))))
(fill-region (point-min) (point-max))
(when (nth 2 elem)
(let ((start (point)))
(insert (nth 2 elem))
(unless (bolp)
(insert "\n"))
(fill-region start (point-max))))
(buffer-string))))
(goto-char start)
(dolist (line (split-string text "\n"))
(end-of-line)
(if (bolp)
(insert line "\n")
(insert line))
(forward-line 1)))))))))))
(when (buffer-live-p buf)
(kill-buffer buf))
(assq tchar choices)))

(defun sit-for (seconds &optional nodisp obsolete)
"Redisplay, then wait for SECONDS seconds. Stop when input is available.
SECONDS may be a floating-point value.
Expand Down

0 comments on commit ad90397

Please sign in to comment.