|
209
|
1 ;;; dialog.el --- Dialog-box support for XEmacs
|
|
|
2
|
|
|
3 ;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; Maintainer: XEmacs Development Team
|
|
|
6 ;; Keywords: extensions, internal, dumped
|
|
|
7
|
|
|
8 ;; This file is part of XEmacs.
|
|
|
9
|
|
|
10 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 ;; under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
18 ;; General Public License for more details.
|
|
|
19
|
|
|
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
|
|
|
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Synched up with: Not in FSF.
|
|
|
26
|
|
|
27 ;;; Commentary:
|
|
|
28
|
|
|
29 ;; This file is dumped with XEmacs (when dialog boxes are compiled in).
|
|
|
30
|
|
406
|
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
|
|
209
|
39 ;;; Code:
|
|
|
40 (defun yes-or-no-p-dialog-box (prompt)
|
|
406
|
41 "Ask user a yes-or-no question with a popup dialog box.
|
|
|
42 Return t if the answer is \"yes\".
|
|
209
|
43 Takes one argument, which is the string to display to ask the question."
|
|
406
|
44 (save-selected-frame
|
|
371
|
45 (popup-dialog-box
|
|
406
|
46 (list prompt ["Yes" yes t] ["No" no t] nil ["Cancel" cancel t]))
|
|
|
47 (let (event)
|
|
|
48 (catch 'ynp-done
|
|
|
49 (while t
|
|
|
50 (setq event (next-command-event event))
|
|
|
51 (when (misc-user-event-p event)
|
|
|
52 (message "%s" (event-object event))
|
|
|
53 (case (event-object event)
|
|
|
54 ((yes) (throw 'ynp-done t))
|
|
|
55 ((no) (throw 'ynp-done nil))
|
|
|
56 ((cancel menu-no-selection-hook) (signal 'quit nil))))
|
|
|
57 (unless (button-release-event-p event) ; don't beep twice
|
|
|
58 (beep)
|
|
|
59 (message "please answer the dialog box")))))))
|
|
209
|
60
|
|
|
61 (defun yes-or-no-p-maybe-dialog-box (prompt)
|
|
|
62 "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.
|
|
|
64 Takes one argument, which is the string to display to ask the question.
|
|
|
65 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
|
|
|
66 The user must confirm the answer with RET,
|
|
|
67 and can edit it until it as been confirmed."
|
|
|
68 (if (should-use-dialog-box-p)
|
|
|
69 (yes-or-no-p-dialog-box prompt)
|
|
|
70 (yes-or-no-p-minibuf prompt)))
|
|
|
71
|
|
|
72 (defun y-or-n-p-maybe-dialog-box (prompt)
|
|
|
73 "Ask user a \"y or n\" question. Return t if answer is \"y\".
|
|
|
74 Takes one argument, which is the string to display to ask the question.
|
|
|
75 The question is asked with a dialog box or the minibuffer, as appropriate.
|
|
|
76 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
|
|
|
77 No confirmation of the answer is requested; a single character is enough.
|
|
|
78 Also accepts Space to mean yes, or Delete to mean no."
|
|
|
79 (if (should-use-dialog-box-p)
|
|
|
80 (yes-or-no-p-dialog-box prompt)
|
|
|
81 (y-or-n-p-minibuf prompt)))
|
|
|
82
|
|
406
|
83 (when (fboundp 'popup-dialog-box)
|
|
|
84 (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))
|
|
209
|
86
|
|
|
87 ;; this is call-compatible with the horribly-named FSF Emacs function
|
|
|
88 ;; `x-popup-dialog'. I refuse to use that name.
|
|
|
89 (defun get-dialog-box-response (position contents)
|
|
|
90 ;; by Stig@hackvan.com
|
|
|
91 ;; modified by pez@atlantic2.sbi.com
|
|
|
92 "Pop up a dialog box and return user's selection.
|
|
|
93 POSITION specifies which frame to use.
|
|
|
94 This is normally an event or a window or frame.
|
|
|
95 If POSITION is t or nil, it means to use the frame the mouse is on.
|
|
|
96 The dialog box appears in the middle of the specified frame.
|
|
|
97
|
|
|
98 CONTENTS specifies the alternatives to display in the dialog box.
|
|
|
99 It is a list of the form (TITLE ITEM1 ITEM2...).
|
|
|
100 Each ITEM is a cons cell (STRING . VALUE).
|
|
|
101 The return value is VALUE from the chosen item.
|
|
|
102
|
|
|
103 An ITEM may also be just a string--that makes a nonselectable item.
|
|
|
104 An ITEM may also be nil--that means to put all preceding items
|
|
|
105 on the left of the dialog box and all following items on the right."
|
|
|
106 (cond
|
|
|
107 ((eventp position)
|
|
|
108 (select-frame (event-frame position)))
|
|
|
109 ((framep position)
|
|
|
110 (select-frame position))
|
|
|
111 ((windowp position)
|
|
|
112 (select-window position)))
|
|
|
113 (let ((dbox (cons (car contents)
|
|
|
114 (mapcar #'(lambda (x)
|
|
|
115 (cond
|
|
|
116 ((null x)
|
|
|
117 nil)
|
|
|
118 ((stringp x)
|
|
|
119 `[,x 'ignore nil]) ;this will never get
|
|
|
120 ;selected
|
|
|
121 (t
|
|
|
122 `[,(car x) (throw 'result ',(cdr x)) t])))
|
|
|
123 (cdr contents))
|
|
|
124 )))
|
|
|
125 (catch 'result
|
|
|
126 (popup-dialog-box dbox)
|
|
|
127 (dispatch-event (next-command-event)))))
|
|
|
128
|
|
|
129 (defun message-box (fmt &rest args)
|
|
|
130 "Display a message, in a dialog box if possible.
|
|
|
131 If the selected device has no dialog-box support, use the echo area.
|
|
|
132 The arguments are the same as to `format'.
|
|
|
133
|
|
|
134 If the only argument is nil, clear any existing message; let the
|
|
|
135 minibuffer contents show."
|
|
|
136 (if (and (null fmt) (null args))
|
|
|
137 (progn
|
|
|
138 (clear-message nil)
|
|
|
139 nil)
|
|
|
140 (let ((str (apply 'format fmt args)))
|
|
|
141 (if (device-on-window-system-p)
|
|
404
|
142 (get-dialog-box-response nil (list str (cons "%_OK" t)))
|
|
209
|
143 (display-message 'message str))
|
|
|
144 str)))
|
|
|
145
|
|
|
146 (defun message-or-box (fmt &rest args)
|
|
|
147 "Display a message in a dialog box or in the echo area.\n\
|
|
|
148 If this command was invoked with the mouse, use a dialog box.\n\
|
|
|
149 Otherwise, use the echo area.
|
|
|
150 The arguments are the same as to `format'.
|
|
|
151
|
|
|
152 If the only argument is nil, clear any existing message; let the
|
|
|
153 minibuffer contents show."
|
|
|
154 (if (should-use-dialog-box-p)
|
|
|
155 (apply 'message-box fmt args)
|
|
|
156 (apply 'message fmt args)))
|
|
|
157
|
|
406
|
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
|
|
209
|
217 ;;; dialog.el ends here
|
