(let* ((altered-names nil)
(full-prompt
(format
- "%s (%s, ?): "
+ "%s (%s): "
prompt
(mapconcat
(lambda (elem)
(format "[%c] %s" (car elem) name))
;; The prompt character is in the name, so highlight
;; it on graphical terminals...
- ((display-graphic-p)
+ ((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
(push (cons (car elem) altered-name)
altered-names)
altered-name))
- choices ", ")))
- tchar buf)
+ (append choices '((?? "?")))
+ ", ")))
+ tchar buf wrong-char)
(save-window-excursion
(save-excursion
(while (not tchar)
- (message "%s" full-prompt)
- (setq tchar (condition-case nil
- (read-char)
- (error nil)))
+ (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))))
;; The user has entered an invalid choice, so display the
;; help messages.
(when (not (assq tchar choices))
- (setq tchar nil)
+ (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
;; Add padding.
(while (not (eobp))
(end-of-line)
- (insert (make-string (- (* (mod times columns)
- (+ fill-column 4))
- (current-column))
+ (insert (make-string (max (- (* (mod times columns)
+ (+ fill-column 4))
+ (current-column))
+ 0)
?\s))
(forward-line 1))))
(setq times (1+ times))
(cdr (assq (car elem) altered-names))))
(fill-region (point-min) (point-max))
(when (nth 2 elem)
- (insert (nth 2 elem))
- (unless (bolp)
- (insert "\n"))
- (fill-region start (point-max)))
+ (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"))