cgit.sxemacs.org Git - sxemacs/blob - lisp/map-ynp.el

   1 ;;; map-ynp.el --- General-purpose boolean question-asker.
   2
   3 ;; Copyright (C) 1991-1995, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Roland McGrath <roland@gnu.ai.mit.edu>
   6 ;; Keywords: lisp, extensions, dumped
   7
   8 ;; This file is part of SXEmacs.
   9
  10 ;; SXEmacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; SXEmacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Emacs/Mule zeta.
  24
  25 ;;; Commentary:
  26
  27 ;; This file is dumped with SXEmacs.
  28
  29 ;; map-y-or-n-p is a general-purpose question-asking function.
  30 ;; It asks a series of y/n questions (a la y-or-n-p), and decides to
  31 ;; applies an action to each element of a list based on the answer.
  32 ;; The nice thing is that you also get some other possible answers
  33 ;; to use, reminiscent of query-replace: ! to answer y to all remaining
  34 ;; questions; ESC or q to answer n to all remaining questions; . to answer
  35 ;; y once and then n for the remainder; and you can get help with C-h.
  36
  37 ;;; Code:
  38
  39 (defun map-y-or-n-p (prompter actor list &optional help action-alist
  40                               no-cursor-in-echo-area)
  41   "Ask a series of boolean questions.
  42 Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST.
  43
  44 LIST is a list of objects, or a function of no arguments to return the next
  45 object or nil.
  46
  47 If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\).  If not
  48 a string, PROMPTER is a function of one arg (an object from LIST), which
  49 returns a string to be used as the prompt for that object.  If the return
  50 value is not a string, it may be nil to ignore the object or non-nil to act
  51 on the object without asking the user.
  52
  53 ACTOR is a function of one arg (an object from LIST),
  54 which gets called with each object that the user answers `yes' for.
  55
  56 If HELP is given, it is a list (OBJECT OBJECTS ACTION),
  57 where OBJECT is a string giving the singular noun for an elt of LIST;
  58 OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive
  59 verb describing ACTOR.  The default is \(\"object\" \"objects\" \"act on\"\).
  60
  61 At the prompts, the user may enter y, Y, or SPC to act on that object;
  62 n, N, or DEL to skip that object; ! to act on all following objects;
  63 ESC or q to exit (skip all following objects); . (period) to act on the
  64 current object and then exit; or \\[help-command] to get help.
  65
  66 If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys
  67 that will be accepted.  KEY is a character; FUNCTION is a function of one
  68 arg (an object from LIST); HELP is a string.  When the user hits KEY,
  69 FUNCTION is called.  If it returns non-nil, the object is considered
  70 \"acted upon\", and the next object from LIST is processed.  If it returns
  71 nil, the prompt is repeated for the same object.
  72
  73 Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set
  74 `cursor-in-echo-area' while prompting.
  75
  76 This function uses `query-replace-map' to define the standard responses,
  77 but not all of the responses which `query-replace' understands
  78 are meaningful here.
  79
  80 Returns the number of actions taken."
  81   (let* ((actions 0)
  82          user-keys mouse-event map prompt char elt def
  83          ;; Non-nil means we should use mouse menus to ask.
  84          ;; use-menus
  85          ;;delayed-switch-frame
  86          (next (if (or (and list (symbolp list))
  87                        (subrp list)
  88                        (compiled-function-p list)
  89                        (and (consp list)
  90                             (eq (car list) 'lambda)))
  91                    #'(lambda () (setq elt (funcall list)))
  92                  #'(lambda ()
  93                      (if list
  94                          (progn
  95                            (setq elt (car list)
  96                                  list (cdr list))
  97                            t)
  98                        nil)))))
  99     (if (should-use-dialog-box-p)
 100         ;; Make a list describing a dialog box.
 101         (let (;; (object (capitalize (or (nth 0 help) "object")))
 102               ;; (objects (capitalize (or (nth 1 help) "objects")))
 103               ;; (action (capitalize (or (nth 2 help) "act on")))
 104               )
 105           (setq map `(("%_Yes" . act) ("%_No" . skip)
 106 ; bogus crap.  --ben
 107 ;                       ((, (if help
 108 ;                               (capitalize
 109 ;                                (or (nth 3 help)
 110 ;                                    (concat action " All " objects)))
 111 ;                             "Do All")) . automatic)
 112 ;                       ((, (if help
 113 ;                               (capitalize
 114 ;                                (or (nth 4 help)
 115 ;                                    (concat action " " object " And Quit")))
 116 ;                             "Do it and Quit")) . act-and-exit)
 117 ;                       ((, (capitalize
 118 ;                            (or (and help (nth 5 help)) "Quit")))
 119 ;                        . exit)
 120                         ("Yes %_All" . automatic)
 121                         ("No A%_ll" . exit)
 122                         ("%_Cancel" . quit)
 123                         ,@(mapcar #'(lambda (elt)
 124                                       (cons (capitalize (nth 2 elt))
 125                                             (vector (nth 1 elt))))
 126                                   action-alist))
 127                 mouse-event last-command-event))
 128       (setq user-keys (if action-alist
 129                           (concat (mapconcat #'(lambda (elt)
 130                                                  (key-description
 131                                                   (if (characterp (car elt))
 132                                                       ;; XEmacs
 133                                                       (char-to-string (car elt))
 134                                                     (car elt))))
 135                                              action-alist ", ")
 136                                   " ")
 137                         "")
 138             ;; Make a map that defines each user key as a vector containing
 139             ;; its definition.
 140             ;; XEmacs
 141             map (let ((foomap (make-sparse-keymap)))
 142                   (mapcar #'(lambda (elt)
 143                               (define-key
 144                                 foomap
 145                                 (if (characterp (car elt))
 146                                     (char-to-string (car elt))
 147                                   (car elt))
 148                                 (vector (nth 1 elt))))
 149                           action-alist)
 150                   (set-keymap-parents foomap (list query-replace-map))
 151                   foomap)))
 152     (unwind-protect
 153         (progn
 154           (if (stringp prompter)
 155               (setq prompter `(lambda (object)
 156                                 (format ,prompter object))))
 157           (while (funcall next)
 158             (setq prompt (funcall prompter elt))
 159             (cond ((stringp prompt)
 160                    ;; Prompt the user about this object.
 161                    (setq quit-flag nil)
 162                    (if mouse-event ; XEmacs
 163                        (setq def (or (get-dialog-box-response
 164                                       mouse-event
 165                                       (cons prompt map))
 166                                      'quit))
 167                      ;; Prompt in the echo area.
 168                      (let ((cursor-in-echo-area (not no-cursor-in-echo-area)))
 169                        (display-message
 170                         'prompt
 171                         (format "%s(y, n, !, ., q, %sor %s) "
 172                                 prompt user-keys
 173                                 (key-description (vector help-char))))
 174                        (setq char (next-command-event))
 175                        ;; Show the answer to the question.
 176                        (display-message
 177                         'prompt
 178                         (format
 179                          "%s(y, n, !, ., q, %sor %s) %s"
 180                          prompt user-keys
 181                          (key-description (vector help-char))
 182                          (single-key-description char))))
 183                      (setq def (lookup-key map (vector char))))
 184                    (cond ((eq def 'exit)
 185                           (setq next #'(lambda () nil)))
 186                          ((eq def 'act)
 187                           ;; Act on the object.
 188                           (funcall actor elt)
 189                           (setq actions (1+ actions)))
 190                          ((eq def 'skip)
 191                           ;; Skip the object.
 192                           )
 193                          ((eq def 'act-and-exit)
 194                           ;; Act on the object and then exit.
 195                           (funcall actor elt)
 196                           (setq actions (1+ actions)
 197                                 next (function (lambda () nil))))
 198                          ((or (eq def 'quit) (eq def 'exit-prefix))
 199                           (setq quit-flag t)
 200                           (setq next `(lambda ()
 201                                         (setq next ',next)
 202                                           ',elt)))
 203                          ((eq def 'automatic)
 204                           ;; Act on this and all following objects.
 205                           ;; (if (funcall prompter elt) ; Emacs
 206                           (if (eval (funcall prompter elt))
 207                               (progn
 208                                 (funcall actor elt)
 209                                 (setq actions (1+ actions))))
 210                           (while (funcall next)
 211                             ;; (funcall prompter elt) ; Emacs
 212                             (if (eval (funcall prompter elt))
 213                                 (progn
 214                                   (funcall actor elt)
 215                                   (setq actions (1+ actions))))))
 216                          ((eq def 'help)
 217                           (with-output-to-temp-buffer "*Help*"
 218                             (princ
 219                              (let ((object (if help (nth 0 help) "object"))
 220                                    (objects (if help (nth 1 help) "objects"))
 221                                    (action (if help (nth 2 help) "act on")))
 222                                (concat
 223                                 (format "Type SPC or `y' to %s the current %s;
 224 DEL or `n' to skip the current %s;
 225 ! to %s all remaining %s;
 226 ESC or `q' to exit;\n"
 227                                         action object object action objects)
 228                                 (mapconcat (function
 229                                             (lambda (elt)
 230                                               (format "%c to %s"
 231                                                       (nth 0 elt)
 232                                                       (normalize-menu-item-name
 233                                                        (nth 2 elt)))))
 234                                            action-alist
 235                                            ";\n")
 236                                 (if action-alist ";\n")
 237                                 (format "or . (period) to %s \
 238 the current %s and exit."
 239                                         action object))))
 240                             (save-excursion
 241                               (set-buffer standard-output)
 242                               (help-mode)))
 243
 244                           (setq next `(lambda ()
 245                                         (setq next ',next)
 246                                         ',elt)))
 247                          ((vectorp def)
 248                           ;; A user-defined key.
 249                           (if (funcall (aref def 0) elt) ;Call its function.
 250                               ;; The function has eaten this object.
 251                               (setq actions (1+ actions))
 252                             ;; Regurgitated; try again.
 253                             (setq next `(lambda ()
 254                                           (setq next ',next)
 255                                           ',elt))))
 256                          ;((and (consp char) ; Emacs
 257                          ;      (eq (car char) 'switch-frame))
 258                          ; ;; switch-frame event.  Put it off until we're done.
 259                          ; (setq delayed-switch-frame char)
 260                          ; (setq next `(lambda ()
 261                          ;               (setq next ',next)
 262                          ;               ',elt)))
 263                          (t
 264                           ;; Random char.
 265                           (message "Type %s for help."
 266                                    (key-description (vector help-char)))
 267                           (beep)
 268                           (sit-for 1)
 269                           (setq next `(lambda ()
 270                                         (setq next ',next)
 271                                         ',elt)))))
 272                   ((eval prompt)
 273                    (progn
 274                      (funcall actor elt)
 275                      (setq actions (1+ actions)))))))
 276       ;;(if delayed-switch-frame
 277       ;;           (setq unread-command-events
 278       ;;                 (cons delayed-switch-frame unread-command-events))))
 279       ;;                   ((eval prompt)
 280       ;;                    (progn
 281       ;;                      (funcall actor elt)
 282       ;;                      (setq actions (1+ actions)))))
 283       )
 284     ;; Clear the last prompt from the minibuffer.
 285     (clear-message 'prompt)
 286     ;; Return the number of actions that were taken.
 287     actions))
 288
 289 ;;; map-ynp.el ends here