1 ;;; dialog.el --- Dialog-box support for XEmacs
3 ;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 2000 Ben Wing.
6 ;; Maintainer: SXEmacs Development Team
7 ;; Keywords: extensions, internal, dumped
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: Not in FSF.
28 ;; This file is dumped with SXEmacs (when dialog boxes are compiled in).
30 ;; Dialog boxes are non-modal at the C level, but made modal at the
31 ;; Lisp level via hacks in functions such as yes-or-no-p-dialog-box
32 ;; below. Perhaps there should be truly modal dialog boxes
33 ;; implemented at the C level for safety. All code using dialog boxes
34 ;; should be careful to assume that the environment, for example the
35 ;; current buffer, might be completely different after returning from
36 ;; yes-or-no-p-dialog-box, but such code is difficult to write and test.
39 (defun yes-or-no-p-dialog-box (prompt)
40 "Ask user a yes-or-no question with a popup dialog box.
41 Return t if the answer is \"yes\", nil if \"no\". Takes one argument,
42 the question string to display."
44 (make-dialog-box 'question
47 :buttons '(["Yes" (dialog-box-finish t)]
48 ["No" (dialog-box-finish nil)]
50 ["Cancel" (dialog-box-cancel)]))))
52 ;; FSF has a similar function `x-popup-dialog'.
53 (defun get-dialog-box-response (position contents)
54 "Pop up a dialog box and return user's selection.
55 POSITION specifies which frame to use.
56 This is normally an event or a window or frame.
57 If POSITION is t or nil, it means to use the frame the mouse is on.
58 The dialog box appears in the middle of the specified frame.
60 CONTENTS specifies the alternatives to display in the dialog box.
61 It is a list of the form (TITLE ITEM1 ITEM2...).
62 Each ITEM is a cons cell (STRING . VALUE).
63 The return value is VALUE from the chosen item.
65 An ITEM may also be just a string--that makes a nonselectable item.
66 An ITEM may also be nil--that means to put all preceding items
67 on the left of the dialog box and all following items on the right."
70 (select-frame (event-frame position)))
72 (select-frame position))
74 (select-window position)))
75 (make-dialog-box 'question
76 :question (car contents)
84 ;;this will never get selected
87 `[,(car x) (dialog-box-finish ',(cdr x)) t])))
90 (defun message-box (fmt &rest args)
91 "Display a message, in a dialog box if possible.
92 If the selected device has no dialog-box support, use the echo area.
93 The arguments are the same as to `format'.
95 If the only argument is nil, clear any existing message; let the
96 minibuffer contents show."
97 (if (and (null fmt) (null args))
101 (let ((str (apply 'format fmt args)))
102 (if (device-on-window-system-p)
103 (get-dialog-box-response nil (list str (cons "%_OK" t)))
104 (display-message 'message str))
107 (defun message-or-box (fmt &rest args)
108 "Display a message in a dialog box or in the echo area.
109 If this command was invoked with the mouse, use a dialog box.
110 Otherwise, use the echo area.
111 The arguments are the same as to `format'.
113 If the only argument is nil, clear any existing message; let the
114 minibuffer contents show."
115 (if (should-use-dialog-box-p)
116 (apply 'message-box fmt args)
117 (apply 'message fmt args)))
119 (defun make-dialog-box (type &rest cl-keys)
120 "Pop up a dialog box.
121 TYPE is a symbol, the type of dialog box. Remaining arguments are
122 keyword-value pairs, specifying the particular characteristics of the
123 dialog box. The allowed keywords are particular to each type, but
124 some standard keywords are common to many types:
127 The title of the dialog box's window.
130 If true, indicates that XEmacs will wait until the user is \"done\"
131 with the dialog box (usually, this means that a response has been
132 given). Typically, the response is returned. NOTE: Some dialog
133 boxes are always modal. If the dialog box is modal, `make-dialog-box'
134 returns immediately. The return value will be either nil or a
135 dialog box handle of some sort, e.g. a frame for type `general'.
137 ---------------------------------------------------------------------------
142 A dialog box consisting of an XEmacs glyph, typically a `layout'
143 widget specifying a dialog box arrangement. This is the most
144 general and powerful dialog box type, but requires more work than
145 the other types below.
148 A simple dialog box that displays a question and contains one or
149 more user-defined buttons to specify possible responses. (This is
150 compatible with the old built-in dialog boxes formerly specified
151 using `popup-dialog-box'.)
154 A file dialog box, of the type typically used in the window system
155 XEmacs is running on.
167 A dialog box used when printing (e.g. number of pages, printer).
170 A dialog box for setting page options (e.g. margins) for printing.
173 A find/replace dialog box.
175 ---------------------------------------------------------------------------
179 This type creates a frame and puts the specified widget layout in it.
180 \(Currently this is done by eliminating all areas but the gutter and placing
181 the layout there; but this is an implementation detail and may change.)
183 The keywords allowed for `general' are
186 The widget spec -- anything that can be passed to `make-glyph'.
188 The title of the frame.
190 The frame is made a child of this frame (defaults to the selected frame).
192 Additional properties of the frame, as well as `dialog-frame-plist'.
194 If t the frame is sized to exactly fit the widgets given by :spec.
196 ---------------------------------------------------------------------------
200 The keywords allowed are
203 t or nil. When t, the dialog box callback should exit the dialog box
204 using the functions `dialog-box-finish' or `dialog-box-cancel'.
206 The title of the frame.
208 A string, the question.
210 A list, describing the buttons below the question. Each of these is a
211 vector, the syntax of which is essentially the same as that of popup menu
212 items. They may have any of the following forms:
214 [ \"name\" callback <active-p> ]
215 [ \"name\" callback <active-p> \"suffix\" ]
216 [ \"name\" callback :<keyword> <value> :<keyword> <value> ... ]
218 The name is the string to display on the button; it is filtered through the
219 resource database, so it is possible for resources to override what string
220 is actually displayed.
222 Accelerators can be indicated in the string by putting the sequence
223 \"%_\" before the character corresponding to the key that will invoke
224 the button. Uppercase and lowercase accelerators are equivalent. The
225 sequence \"%%\" is also special, and is translated into a single %.
227 If the `callback' of a button is a symbol, then it must name a command.
228 It will be invoked with `call-interactively'. If it is a list, then it is
229 evaluated with `eval'.
231 One (and only one) of the buttons may be `nil'. This marker means that all
232 following buttons should be flushright instead of flushleft.
234 Though the keyword/value syntax is supported for dialog boxes just as in
235 popup menus, the only keyword which is both meaningful and fully implemented
236 for dialog box buttons is `:active'.
238 ---------------------------------------------------------------------------
242 The keywords allowed are
245 The initial filename to be placed in the dialog box (defaults to nothing).
247 The initial directory to be selected in the dialog box (defaults to the
248 current buffer's `default-directory).
250 A list of (filter-desc filter ...)
252 The title of the dialog box (defaults to \"Open\").
253 :allow-multi-select t or nil
254 :create-prompt-on-nonexistent t or nil
255 :overwrite-prompt t or nil
256 :file-must-exist t or nil
257 :no-network-button t or nil
258 :no-read-only-return t or nil
260 ---------------------------------------------------------------------------
262 For type `directory':
264 The keywords allowed are
267 The initial directory to be selected in the dialog box (defaults to the
268 current buffer's `default-directory).
270 The title of the dialog box (defaults to \"Open\").
272 ---------------------------------------------------------------------------
276 This invokes the Windows standard Print dialog.
277 This dialog is usually invoked when the user selects the Print command.
278 After the user presses OK, the program should start actual printout.
280 The keywords allowed are
283 An 'msprinter device.
285 A printer settings object.
287 t or nil -- whether the \"Selection\" button is enabled (defaults to nil).
289 t or nil -- whether the \"Pages\" button and associated edit controls
290 are enabled (defaults to t).
291 :selected-page-button
292 `all', `selection', or `pages' -- which page button is initially
295 Exactly one of :device and :print-settings must be given.
297 The function brings up the Print dialog, where the user can
298 select a different printer and/or change printer options. Connection
299 name can change as a result of selecting a different printer device. If
300 a device is specified, then changes are stored into the settings object
301 currently selected into that printer. If a settings object is supplied,
302 then changes are recorded into it, and, it is selected into a
303 printer, then changes are propagated to that printer
306 Return value is nil if the user has canceled the dialog. Otherwise, it
307 is a new plist, with the following properties:
308 name Printer device name, even if unchanged by the user.
309 from-page First page to print, 1-based. Returned if
310 `selected-page-button' is `pages'.
311 user, then this value is not included in the plist.
312 to-page Last page to print, inclusive, 1-based. Returned if
313 `selected-page-button' is `pages'.
314 copies Number of copies to print. Always returned.
315 selected-page-button Which page button was selected (`all', `selection',
318 The DEVICE is destroyed and an error is signaled in case of
319 initialization problem with the new printer.
321 See also the `page-setup' dialog box type.
323 ---------------------------------------------------------------------------
325 For type `page-setup':
327 This invokes the Windows standard Page Setup dialog.
328 This dialog is usually invoked in response to the Page Setup command,
329 and used to choose such parameters as page orientation, print margins
330 etc. Note that this dialog contains the \"Printer\" button, which
331 invokes the Printer Setup dialog so that the user can update the
332 printer options or even select a different printer as well.
334 The keywords allowed are
337 An 'msprinter device.
339 A printer settings object.
341 A plist of job properties.
343 Exactly one of these keywords must be given.
345 The function brings up the Page Setup dialog, where the user
346 can select a different printer and/or change printer options.
347 Connection name can change as a result of selecting a different printer
348 device. If a device is specified, then changes are stored into the
349 settings object currently selected into that printer. If a settings
350 object is supplied, then changes are recorded into it, and, it is
351 selected into a printer, then changes are propagated to that printer
354 :properties specifies a plist of job properties;
355 see `default-msprinter-frame-plist' for the complete list. The plist
356 is used to initialize the dialog.
358 Return value is nil if the user has canceled the dialog. Otherwise,
359 it is a new plist, containing the new list of properties.
361 NOTE: The margin properties (returned by this function) are *NOT* stored
362 into the print-settings or device object.
364 The DEVICE is destroyed and an error is signaled in case of
365 initialization problem with the new printer.
367 See also the `print' dialog box type."
368 (flet ((dialog-box-modal-loop (thunk)
369 (let* ((frames (frame-list))
371 ;; ok, this is extremely tricky. normally a modal
372 ;; dialog will pop itself down using (dialog-box-finish)
373 ;; or (dialog-box-cancel), which throws back to this
374 ;; catch. but question dialog boxes pop down themselves
375 ;; regardless, so a badly written question dialog box
376 ;; that does not use (dialog-box-finish) could seriously
377 ;; wedge us. furthermore, we disable all other frames
378 ;; in order to implement modality; we need to restore
379 ;; them before the dialog box is destroyed, because
380 ;; otherwise windows at least will notice that no top-
381 ;; level window can have the focus and will shift the
382 ;; focus to a different app, raising it and obscuring us.
383 ;; so we create `delete-dialog-box-hook', which is
384 ;; called right *before* the dialog box gets destroyed.
385 ;; here, we put a hook on it, and when it's our dialog
386 ;; box and not someone else's that's being destroyed,
387 ;; we reenable all the frames and remove the hook.
388 ;; BUT ... we still have to deal with exiting the
389 ;; modal loop in case it doesn't happen before us.
390 ;; we can't do this until after the callbacks for this
391 ;; dialog box get executed, and that doesn't happen until
392 ;; after the dialog box is destroyed. so to keep things
393 ;; synchronous, we enqueue an eval event, which goes into
394 ;; the same queue as the misc-user events encapsulating
395 ;; the dialog callbacks and will go after it (because
396 ;; destroying the dialog box happens after processing
397 ;; its selection). if the dialog boxes are written
398 ;; properly, we don't see this eval event, because we've
399 ;; already exited our modal loop. (Thus, we make sure the
400 ;; function given in this eval event is actually defined
401 ;; and does nothing.) If we do see it, though, we know
402 ;; that we encountered a badly written dialog box and
403 ;; need to exit now. Currently we just return nil, but
404 ;; maybe we should signal an error or issue a warning.
405 (catch 'internal-dialog-box-finish
406 (let ((id (eval thunk))
411 (mapc 'enable-frame ',frames)
413 'internal-make-dialog-box-exit did)
414 (remove-hook 'delete-dialog-box-hook
417 (add-hook 'delete-frame-hook sym)
418 (add-hook 'delete-dialog-box-hook sym))
419 (mapc 'disable-frame frames)
422 (let ((event (next-event)))
423 (if (and (eval-event-p event)
424 (eq (event-function event)
425 'internal-make-dialog-box-exit)
426 (eq (event-object event) id))
428 (dispatch-event event)))))))))
431 (signal 'quit nil)))))
436 (:parent (selected-frame))
442 (flet ((create-dialog-box-frame ()
443 (let* ((ftop (frame-property cl-parent 'top))
444 (fleft (frame-property cl-parent 'left))
445 (fwidth (frame-pixel-width cl-parent))
446 (fheight (frame-pixel-height cl-parent))
447 (fonth (font-height (face-font 'default)))
448 (fontw (font-width (face-font 'default)))
449 (cl-properties (append cl-properties
451 (dfheight (plist-get cl-properties 'height))
452 (dfwidth (plist-get cl-properties 'width))
453 (unmapped (plist-get cl-properties
454 'initially-unmapped))
455 (gutter-spec cl-spec)
456 (name (or (plist-get cl-properties 'name) "XEmacs"))
458 (plist-remprop cl-properties 'initially-unmapped)
459 ;; allow the user to just provide a glyph
460 (or (glyphp cl-spec) (setq cl-spec (make-glyph cl-spec)))
461 (setq gutter-spec (copy-sequence "\n"))
462 (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
464 ;; under FVWM at least, if I don't specify the
465 ;; initial position, it ends up always at (0, 0).
466 ;; xwininfo doesn't tell me that there are any
467 ;; program-specified position hints, so it must be
468 ;; an FVWM bug. So just be smashing and position in
469 ;; the center of the selected frame.
472 (append cl-properties
473 `(popup ,cl-parent initially-unmapped t
474 menubar-visible-p nil
476 default-toolbar-visible-p nil
477 top-gutter-visible-p t
480 top-gutter ,gutter-spec
483 modeline-shadow-thickness 0
484 vertical-scrollbar-visible-p nil
485 horizontal-scrollbar-visible-p nil
487 internal-border-width 8
488 left ,(+ fleft (- (/ fwidth 2)
492 top ,(+ ftop (- (/ fheight 2)
496 (set-face-foreground 'modeline [default foreground] frame)
497 (set-face-background 'modeline [default background] frame)
498 ;; resize before mapping
500 (set-frame-pixel-size
502 (image-instance-width
503 (glyph-image-instance cl-spec
504 (frame-selected-window frame)))
505 (image-instance-height
506 (glyph-image-instance cl-spec
507 (frame-selected-window frame)))))
508 ;; somehow, even though the resizing is supposed
509 ;; to be while the frame is not visible, a
510 ;; visible resize is perceptible
511 (unless unmapped (make-frame-visible frame))
512 (let ((newbuf (generate-new-buffer " *dialog box*")))
513 (set-buffer-dedicated-frame newbuf frame)
514 (set-frame-property frame 'dialog-box-buffer newbuf)
515 (set-window-buffer (frame-root-window frame) newbuf)
516 (with-current-buffer newbuf
517 (set (make-local-variable 'frame-title-format)
519 (add-local-hook 'delete-frame-hook
524 'dialog-box-buffer))))))
527 (dialog-box-modal-loop '(create-dialog-box-frame))
528 (create-dialog-box-frame)))))
533 (remf cl-keys :modal)
535 (dialog-box-modal-loop `(make-dialog-box-internal ',type
537 (make-dialog-box-internal type cl-keys))))
539 (make-dialog-box-internal type cl-keys)))))
541 (defun dialog-box-finish (result)
542 "Exit a modal dialog box, returning RESULT.
543 This is meant to be executed from a dialog box callback function."
544 (throw 'internal-dialog-box-finish (list result)))
546 (defun dialog-box-cancel ()
547 "Cancel a modal dialog box.
548 This is meant to be executed from a dialog box callback function."
549 (throw 'internal-dialog-box-finish 'cancel))
551 ;; an eval event, used as a trigger inside of the dialog modal loop.
552 (defun internal-make-dialog-box-exit (did)
555 (make-obsolete 'popup-dialog-box 'make-dialog-box)
556 (defun popup-dialog-box (desc)
557 "Obsolete equivalent of (make-dialog-box 'question ...).
559 \(popup-dialog-box (QUESTION BUTTONS ...)
563 \(make-dialog-box 'question :question QUESTION :buttons BUTTONS)"
564 (check-argument-type 'stringp (car desc))
565 (or (consp (cdr desc))
567 "Dialog descriptor must supply at least one button"
569 (make-dialog-box 'question :question (car desc) :buttons (cdr desc)))
571 ;;; dialog.el ends here