Mercurial > hg > xemacs-beta

comparison lisp/dialog.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents b8cc9ab3f761
children
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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
39 ;;; Code: 31 ;;; Code:
40 (defun yes-or-no-p-dialog-box (prompt) 32 (defun yes-or-no-p-dialog-box (prompt)
41 "Ask user a yes-or-no question with a popup dialog box. 33 "Ask user a \"y or n\" question with a popup dialog box.
42 Return t if the answer is \"yes\". 34 Returns t if answer is \"yes\".
43 Takes one argument, which is the string to display to ask the question." 35 Takes one argument, which is the string to display to ask the question."
44 (save-selected-frame 36 (let ((echo-keystrokes 0)
37 event)
45 (popup-dialog-box 38 (popup-dialog-box
46 (list prompt ["Yes" yes t] ["No" no t] nil ["Cancel" cancel t])) 39 ;; "Non-violent language please!" says Robin.
47 (let (event) 40 (cons prompt '(["Yes" yes t] ["No" no t] nil ["Cancel" abort t])))
48 (catch 'ynp-done 41 ; (cons prompt '(["Yes" yes t] ["No" no t] nil ["Abort" abort t])))
49 (while t 42 (catch 'ynp-done
50 (setq event (next-command-event event)) 43 (while t
51 (when (misc-user-event-p event) 44 (setq event (next-command-event event))
52 (message "%s" (event-object event)) 45 (cond ((and (misc-user-event-p event) (eq (event-object event) 'yes))
53 (case (event-object event) 46 (throw 'ynp-done t))
54 ((yes) (throw 'ynp-done t)) 47 ((and (misc-user-event-p event) (eq (event-object event) 'no))
55 ((no) (throw 'ynp-done nil)) 48 (throw 'ynp-done nil))
56 ((cancel menu-no-selection-hook) (signal 'quit nil)))) 49 ((and (misc-user-event-p event)
57 (unless (button-release-event-p event) ; don't beep twice 50 (or (eq (event-object event) 'abort)
58 (beep) 51 (eq (event-object event) 'menu-no-selection-hook)))
59 (message "please answer the dialog box"))))))) 52 (signal 'quit nil))
53 ((button-release-event-p event) ;; don't beep twice
54 nil)
55 (t
56 (beep)
57 (message "please answer the dialog box")))))))
60 58
61 (defun yes-or-no-p-maybe-dialog-box (prompt) 59 (defun yes-or-no-p-maybe-dialog-box (prompt)
62 "Ask user a yes-or-no question. Return t if answer is yes. 60 "Ask user a yes-or-no question. Return t if answer is yes.
63 The question is asked with a dialog box or the minibuffer, as appropriate. 61 The question is asked with a dialog box or the minibuffer, as appropriate.
64 Takes one argument, which is the string to display to ask the question. 62 Takes one argument, which is the string to display to ask the question.
78 Also accepts Space to mean yes, or Delete to mean no." 76 Also accepts Space to mean yes, or Delete to mean no."
79 (if (should-use-dialog-box-p) 77 (if (should-use-dialog-box-p)
80 (yes-or-no-p-dialog-box prompt) 78 (yes-or-no-p-dialog-box prompt)
81 (y-or-n-p-minibuf prompt))) 79 (y-or-n-p-minibuf prompt)))
82 80
83 (when (fboundp 'popup-dialog-box) 81 (if (fboundp 'popup-dialog-box)
84 (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box) 82 (progn
85 (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box)) 83 (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box)
84 (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box)))
86 85
87 ;; this is call-compatible with the horribly-named FSF Emacs function 86 ;; this is call-compatible with the horribly-named FSF Emacs function
88 ;; `x-popup-dialog'. I refuse to use that name. 87 ;; `x-popup-dialog'. I refuse to use that name.
89 (defun get-dialog-box-response (position contents) 88 (defun get-dialog-box-response (position contents)
90 ;; by Stig@hackvan.com 89 ;; by Stig@hackvan.com
137 (progn 136 (progn
138 (clear-message nil) 137 (clear-message nil)
139 nil) 138 nil)
140 (let ((str (apply 'format fmt args))) 139 (let ((str (apply 'format fmt args)))
141 (if (device-on-window-system-p) 140 (if (device-on-window-system-p)
142 (get-dialog-box-response nil (list str (cons "%_OK" t))) 141 (get-dialog-box-response nil (list str (cons "OK" t)))
143 (display-message 'message str)) 142 (display-message 'message str))
144 str))) 143 str)))
145 144
146 (defun message-or-box (fmt &rest args) 145 (defun message-or-box (fmt &rest args)
147 "Display a message in a dialog box or in the echo area.\n\ 146 "Display a message in a dialog box or in the echo area.\n\
153 minibuffer contents show." 152 minibuffer contents show."
154 (if (should-use-dialog-box-p) 153 (if (should-use-dialog-box-p)
155 (apply 'message-box fmt args) 154 (apply 'message-box fmt args)
156 (apply 'message fmt args))) 155 (apply 'message fmt args)))
157 156
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
217 ;;; dialog.el ends here 157 ;;; dialog.el ends here