Mercurial > hg > xemacs-beta

comparison lisp/dialog.el @ 406:b8cc9ab3f761 r21-2-33

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-33
author cvs
date Mon, 13 Aug 2007 11:17:09 +0200
parents 2f8bb876ab1d
children 697ef44129c6
comparison
equal deleted inserted replaced
405:0e08f63c74d2 406:b8cc9ab3f761
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;; This file is dumped with XEmacs (when dialog boxes are compiled in). 29 ;; This file is dumped with XEmacs (when dialog boxes are compiled in).
30 30
31 ;; Dialog boxes are non-modal at the C level, but made modal at the
32 ;; Lisp level via hacks in functions such as yes-or-no-p-dialog-box
33 ;; below. Perhaps there should be truly modal dialog boxes
34 ;; implemented at the C level for safety. All code using dialog boxes
35 ;; should be careful to assume that the environment, for example the
36 ;; current buffer, might be completely different after returning from
37 ;; yes-or-no-p-dialog-box, but such code is difficult to write and test.
38
31 ;;; Code: 39 ;;; Code:
32 (defun yes-or-no-p-dialog-box (prompt) 40 (defun yes-or-no-p-dialog-box (prompt)
33 "Ask user a \"y or n\" question with a popup dialog box. 41 "Ask user a yes-or-no question with a popup dialog box.
34 Returns t if answer is \"yes\". 42 Return t if the answer is \"yes\".
35 Takes one argument, which is the string to display to ask the question." 43 Takes one argument, which is the string to display to ask the question."
36 (let ((echo-keystrokes 0) 44 (save-selected-frame
37 event)
38 (popup-dialog-box 45 (popup-dialog-box
39 ;; "Non-violent language please!" says Robin. 46 (list prompt ["Yes" yes t] ["No" no t] nil ["Cancel" cancel t]))
40 (cons prompt '(["%_Yes" yes t] ["%_No" no t] nil ["%_Cancel" abort t]))) 47 (let (event)
41 ; (cons prompt '(["%_Yes" yes t] ["%_No" no t] nil ["A%_bort" abort t]))) 48 (catch 'ynp-done
42 (catch 'ynp-done 49 (while t
43 (while t 50 (setq event (next-command-event event))
44 (setq event (next-command-event event)) 51 (when (misc-user-event-p event)
45 (cond ((and (misc-user-event-p event) (eq (event-object event) 'yes)) 52 (message "%s" (event-object event))
46 (throw 'ynp-done t)) 53 (case (event-object event)
47 ((and (misc-user-event-p event) (eq (event-object event) 'no)) 54 ((yes) (throw 'ynp-done t))
48 (throw 'ynp-done nil)) 55 ((no) (throw 'ynp-done nil))
49 ((and (misc-user-event-p event) 56 ((cancel menu-no-selection-hook) (signal 'quit nil))))
50 (or (eq (event-object event) 'abort) 57 (unless (button-release-event-p event) ; don't beep twice
51 (eq (event-object event) 'menu-no-selection-hook))) 58 (beep)
52 (signal 'quit nil)) 59 (message "please answer the dialog box")))))))
53 ((button-release-event-p event) ;; don't beep twice
54 nil)
55 (t
56 (beep)
57 (message "please answer the dialog box")))))))
58 60
59 (defun yes-or-no-p-maybe-dialog-box (prompt) 61 (defun yes-or-no-p-maybe-dialog-box (prompt)
60 "Ask user a yes-or-no question. Return t if answer is yes. 62 "Ask user a yes-or-no question. Return t if answer is yes.
61 The question is asked with a dialog box or the minibuffer, as appropriate. 63 The question is asked with a dialog box or the minibuffer, as appropriate.
62 Takes one argument, which is the string to display to ask the question. 64 Takes one argument, which is the string to display to ask the question.
76 Also accepts Space to mean yes, or Delete to mean no." 78 Also accepts Space to mean yes, or Delete to mean no."
77 (if (should-use-dialog-box-p) 79 (if (should-use-dialog-box-p)
78 (yes-or-no-p-dialog-box prompt) 80 (yes-or-no-p-dialog-box prompt)
79 (y-or-n-p-minibuf prompt))) 81 (y-or-n-p-minibuf prompt)))
80 82
81 (if (fboundp 'popup-dialog-box) 83 (when (fboundp 'popup-dialog-box)
82 (progn 84 (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box)
83 (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box) 85 (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box))
84 (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box)))
85 86
86 ;; this is call-compatible with the horribly-named FSF Emacs function 87 ;; this is call-compatible with the horribly-named FSF Emacs function
87 ;; `x-popup-dialog'. I refuse to use that name. 88 ;; `x-popup-dialog'. I refuse to use that name.
88 (defun get-dialog-box-response (position contents) 89 (defun get-dialog-box-response (position contents)
89 ;; by Stig@hackvan.com 90 ;; by Stig@hackvan.com
152 minibuffer contents show." 153 minibuffer contents show."
153 (if (should-use-dialog-box-p) 154 (if (should-use-dialog-box-p)
154 (apply 'message-box fmt args) 155 (apply 'message-box fmt args)
155 (apply 'message fmt args))) 156 (apply 'message fmt args)))
156 157
158 (defun make-dialog-box (&optional spec props parent)
159 "Create a frame suitable for use as a general dialog box.
160 The frame is made a child of PARENT (defaults to the selected frame),
161 and has additional properties PROPS, as well as `dialog-frame-plist'.
162 SPEC is a string or glyph to be placed in the gutter. If INVISIBLE is
163 non-nil then the frame is initially unmapped.
164 Normally the created frame has no modelines, menubars, scrollbars,
165 minibuffer or toolbars and is entirely covered by its gutter."
166 (or parent (setq parent (selected-frame)))
167 (let* ((ftop (frame-property parent 'top))
168 (fleft (frame-property parent 'left))
169 (fwidth (frame-pixel-width parent))
170 (fheight (frame-pixel-height parent))
171 (fonth (font-height (face-font 'default)))
172 (fontw (font-width (face-font 'default)))
173 (props (append props dialog-frame-plist))
174 (dfheight (plist-get props 'height))
175 (dfwidth (plist-get props 'width))
176 (unmapped (plist-get props 'initially-unmapped))
177 (gutter-spec spec)
178 (name (or (plist-get props 'name) "XEmacs"))
179 (frame nil))
180 (plist-remprop props 'initially-unmapped)
181 ;; allow the user to just provide a glyph
182 (when (glyphp spec)
183 (setq gutter-spec (copy-sequence "\n"))
184 (set-extent-begin-glyph (make-extent 0 1 gutter-spec) spec))
185 ;; under FVWM at least, if I don't specify the initial position,
186 ;; it ends up always at (0, 0). xwininfo doesn't tell me
187 ;; that there are any program-specified position hints, so
188 ;; it must be an FVWM bug. So just be smashing and position
189 ;; in the center of the selected frame.
190 (setq frame (make-frame
191 (append props
192 `(popup ,parent initially-unmapped t
193 menubar-visible-p nil
194 has-modeline-p nil
195 default-toolbar-visible-p nil
196 top-gutter-visible-p t
197 top-gutter-height ,(* dfheight fonth)
198 top-gutter ,gutter-spec
199 minibuffer none
200 name ,name
201 modeline-shadow-thickness 0
202 vertical-scrollbar-visible-p nil
203 horizontal-scrollbar-visible-p nil
204 unsplittable t
205 left ,(+ fleft (- (/ fwidth 2)
206 (/ (* dfwidth fontw)
207 2)))
208 top ,(+ ftop (- (/ fheight 2)
209 (/ (* dfheight fonth)
210 2)))))))
211 (set-face-foreground 'modeline [default foreground] frame)
212 (set-face-background 'modeline [default background] frame)
213 (unless unmapped (make-frame-visible frame))
214 frame))
215
216
157 ;;; dialog.el ends here 217 ;;; dialog.el ends here