Mercurial > hg > xemacs-beta

comparison lisp/utils/map-ynp.el @ 155:43dd3413c7c7 r20-3b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b4
author cvs
date Mon, 13 Aug 2007 09:39:39 +0200
parents c7528f8e288d
children
comparison
equal deleted inserted replaced
154:94141801dd7e 155:43dd3413c7c7
1 ;;; map-ynp.el --- General-purpose boolean question-asker 1 ;;; map-ynp.el --- General-purpose boolean question-asker.
2 2
3 ;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. 3 ;; Copyright (C) 1991-1995, 1997 Free Software Foundation, Inc.
4 4
5 ;; Author: Roland McGrath <roland@gnu.ai.mit.edu> 5 ;; Author: Roland McGrath <roland@gnu.ai.mit.edu>
6 ;; Keywords: lisp, extensions 6 ;; Keywords: lisp, extensions
7 7
8 ;; This file is part of XEmacs. 8 ;; This file is part of XEmacs.
20 ;; You should have received a copy of the GNU General Public License 20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA. 23 ;; 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.30. 25 ;;; Synched up with: Emacs/Mule zeta.
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;;; map-y-or-n-p is a general-purpose question-asking function. 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 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. 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 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 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 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. 35 ;; y once and then n for the remainder; and you can get help with C-h.
36 36
37 ;;; Code: 37 ;;; Code:
38
39 ;; Note: the old code used help-form. That might be a good
40 ;; idea in general, but the code for execute-help-form needs
41 ;; to be moved into Lisp so that it can do things like put
42 ;; the buffer into `help-mode'.
43 38
44 (defun map-y-or-n-p (prompter actor list &optional help action-alist 39 (defun map-y-or-n-p (prompter actor list &optional help action-alist
45 no-cursor-in-echo-area) 40 no-cursor-in-echo-area)
46 "Ask a series of boolean questions. 41 "Ask a series of boolean questions.
47 Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. 42 Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST.
56 on the object without asking the user. 51 on the object without asking the user.
57 52
58 ACTOR is a function of one arg (an object from LIST), 53 ACTOR is a function of one arg (an object from LIST),
59 which gets called with each object that the user answers `yes' for. 54 which gets called with each object that the user answers `yes' for.
60 55
61 If HELP is given, it is a list 56 If HELP is given, it is a list (OBJECT OBJECTS ACTION),
62 (OBJECT OBJECTS ACTION),
63 where OBJECT is a string giving the singular noun for an elt of LIST; 57 where OBJECT is a string giving the singular noun for an elt of LIST;
64 OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive 58 OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive
65 verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\). 59 verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\).
66 60
67 At the prompts, the user may enter y, Y, or SPC to act on that object; 61 At the prompts, the user may enter y, Y, or SPC to act on that object;
82 This function uses `query-replace-map' to define the standard responses, 76 This function uses `query-replace-map' to define the standard responses,
83 but not all of the responses which `query-replace' understands 77 but not all of the responses which `query-replace' understands
84 are meaningful here. 78 are meaningful here.
85 79
86 Returns the number of actions taken." 80 Returns the number of actions taken."
87 (let* (;(old-help-form help-form) 81 (let* ((actions 0)
88 ;(help-form (cons 'map-y-or-n-p-help
89 ; (or help '("object" "objects" "act on"))))
90 (actions 0)
91 user-keys mouse-event map prompt char elt def 82 user-keys mouse-event map prompt char elt def
92 ;delayed-switch-frame 83 ;; Non-nil means we should use mouse menus to ask.
84 ;; use-menus
85 ;;delayed-switch-frame
93 (next (if (or (and list (symbolp list)) 86 (next (if (or (and list (symbolp list))
94 (subrp list) 87 (subrp list)
95 (compiled-function-p list) 88 (compiled-function-p list)
96 (and (consp list) 89 (and (consp list)
97 (eq (car list) 'lambda))) 90 (eq (car list) 'lambda)))
104 list (cdr list)) 97 list (cdr list))
105 t) 98 t)
106 nil)))))) 99 nil))))))
107 (if (should-use-dialog-box-p) 100 (if (should-use-dialog-box-p)
108 ;; Make a list describing a dialog box. 101 ;; Make a list describing a dialog box.
109 (let ((object (capitalize (or (nth 0 help) "object"))) 102 (let (;; (object (capitalize (or (nth 0 help) "object")))
110 (objects (capitalize (or (nth 1 help) "objects"))) 103 ;; (objects (capitalize (or (nth 1 help) "objects")))
111 (action (capitalize (or (nth 2 help) "act on")))) 104 ;; (action (capitalize (or (nth 2 help) "act on")))
105 )
112 (setq map `(("Yes" . act) ("No" . skip) 106 (setq map `(("Yes" . act) ("No" . skip)
113 ; bogus crap. --ben 107 ; bogus crap. --ben
114 ; ((, (if help 108 ; ((, (if help
115 ; (capitalize 109 ; (capitalize
116 ; (or (nth 3 help) 110 ; (or (nth 3 help)
135 (setq user-keys (if action-alist 129 (setq user-keys (if action-alist
136 (concat (mapconcat (function 130 (concat (mapconcat (function
137 (lambda (elt) 131 (lambda (elt)
138 (key-description 132 (key-description
139 (if (characterp (car elt)) 133 (if (characterp (car elt))
134 ;; XEmacs
140 (char-to-string (car elt)) 135 (char-to-string (car elt))
141 (car elt))))) 136 (car elt)))))
142 action-alist ", ") 137 action-alist ", ")
143 " ") 138 " ")
144 "") 139 "")
145 ;; Make a map that defines each user key as a vector containing 140 ;; Make a map that defines each user key as a vector containing
146 ;; its definition. 141 ;; its definition.
142 ;; XEmacs
147 map (let ((foomap (make-sparse-keymap))) 143 map (let ((foomap (make-sparse-keymap)))
148 (mapcar #'(lambda (elt) 144 (mapcar #'(lambda (elt)
149 (define-key 145 (define-key
150 foomap 146 foomap
151 (if (characterp (car elt)) 147 (if (characterp (car elt))
163 (while (funcall next) 159 (while (funcall next)
164 (setq prompt (funcall prompter elt)) 160 (setq prompt (funcall prompter elt))
165 (cond ((stringp prompt) 161 (cond ((stringp prompt)
166 ;; Prompt the user about this object. 162 ;; Prompt the user about this object.
167 (setq quit-flag nil) 163 (setq quit-flag nil)
168 (if mouse-event 164 (if mouse-event ; XEmacs
169 (setq def (or (get-dialog-box-response 165 (setq def (or (get-dialog-box-response
170 mouse-event 166 mouse-event
171 (cons prompt map)) 167 (cons prompt map))
172 'quit)) 168 'quit))
173 ;; Prompt in the echo area. 169 ;; Prompt in the echo area.
189 (setq def (lookup-key map (vector char)))) 185 (setq def (lookup-key map (vector char))))
190 (cond ((eq def 'exit) 186 (cond ((eq def 'exit)
191 (setq next (function (lambda () nil)))) 187 (setq next (function (lambda () nil))))
192 ((eq def 'act) 188 ((eq def 'act)
193 ;; Act on the object. 189 ;; Act on the object.
194 ;(let ((help-form old-help-form))
195 (funcall actor elt) 190 (funcall actor elt)
196 (setq actions (1+ actions))) 191 (setq actions (1+ actions)))
197 ((eq def 'skip) 192 ((eq def 'skip)
198 ;; Skip the object. 193 ;; Skip the object.
199 ) 194 )
205 ((or (eq def 'quit) (eq def 'exit-prefix)) 200 ((or (eq def 'quit) (eq def 'exit-prefix))
206 (setq quit-flag t) 201 (setq quit-flag t)
207 (setq next (` (lambda () 202 (setq next (` (lambda ()
208 (setq next '(, next)) 203 (setq next '(, next))
209 '(, elt))))) 204 '(, elt)))))
210
211 ((eq def 'automatic) 205 ((eq def 'automatic)
212 ;; Act on this and all following objects. 206 ;; Act on this and all following objects.
207 ;; (if (funcall prompter elt) ; Emacs
213 (if (eval (funcall prompter elt)) 208 (if (eval (funcall prompter elt))
214 (progn 209 (progn
215 (funcall actor elt) 210 (funcall actor elt)
216 (setq actions (1+ actions)))) 211 (setq actions (1+ actions))))
217 (while (funcall next) 212 (while (funcall next)
213 ;; (funcall prompter elt) ; Emacs
218 (if (eval (funcall prompter elt)) 214 (if (eval (funcall prompter elt))
219 (progn 215 (progn
220 (funcall actor elt) 216 (funcall actor elt)
221 (setq actions (1+ actions)))))) 217 (setq actions (1+ actions))))))
222 ((eq def 'help) 218 ((eq def 'help)
256 (setq actions (1+ actions)) 252 (setq actions (1+ actions))
257 ;; Regurgitated; try again. 253 ;; Regurgitated; try again.
258 (setq next (` (lambda () 254 (setq next (` (lambda ()
259 (setq next '(, next)) 255 (setq next '(, next))
260 '(, elt)))))) 256 '(, elt))))))
261 ;((and (consp char) 257 ;((and (consp char) ; Emacs
262 ; (eq (car char) 'switch-frame)) 258 ; (eq (car char) 'switch-frame))
263 ; ;; switch-frame event. Put it off until we're done. 259 ; ;; switch-frame event. Put it off until we're done.
264 ; (setq delayed-switch-frame char) 260 ; (setq delayed-switch-frame char)
265 ; (setq next (` (lambda () 261 ; (setq next (` (lambda ()
266 ; (setq next '(, next)) 262 ; (setq next '(, next))
276 '(, elt))))))) 272 '(, elt)))))))
277 ((eval prompt) 273 ((eval prompt)
278 (progn 274 (progn
279 (funcall actor elt) 275 (funcall actor elt)
280 (setq actions (1+ actions))))))) 276 (setq actions (1+ actions)))))))
281 ;(if delayed-switch-frame 277 ;;(if delayed-switch-frame
282 ; (setq unread-command-events 278 ;; (setq unread-command-events
283 ; (cons delayed-switch-frame unread-command-events))) 279 ;; (cons delayed-switch-frame unread-command-events))))
280 ;; ((eval prompt)
281 ;; (progn
282 ;; (funcall actor elt)
283 ;; (setq actions (1+ actions)))))
284 ) 284 )
285 ;; Clear the last prompt from the minibuffer. 285 ;; Clear the last prompt from the minibuffer.
286 (clear-message 'prompt) 286 (clear-message 'prompt)
287 ;; Return the number of actions that were taken. 287 ;; Return the number of actions that were taken.
288 actions)) 288 actions))
289 289
290 ;;; map-ynp.el ends here 290 ;;; map-ynp.el ends here