Mercurial > hg > xemacs-beta

comparison lisp/dialog.el @ 209:41ff10fd062f r20-4b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b3
author cvs
date Mon, 13 Aug 2007 10:04:58 +0200
parents
children 7347b34c275b abe6d1db359e
comparison
equal deleted inserted replaced
208:f427b8ec4379 209:41ff10fd062f
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
31 ;;; Code:
32 (defun yes-or-no-p-dialog-box (prompt)
33 "Ask user a \"y or n\" question with a popup dialog box.
34 Returns t if answer is \"yes\".
35 Takes one argument, which is the string to display to ask the question."
36 (let ((echo-keystrokes 0)
37 event)
38 (popup-dialog-box
39 ;; "Non-violent language please!" says Robin.
40 (cons prompt '(["Yes" yes t] ["No" no t] nil ["Cancel" abort t])))
41 ; (cons prompt '(["Yes" yes t] ["No" no t] nil ["Abort" abort t])))
42 (catch 'ynp-done
43 (while t
44 (setq event (next-command-event event))
45 (cond ((and (misc-user-event-p event) (eq (event-object event) 'yes))
46 (throw 'ynp-done t))
47 ((and (misc-user-event-p event) (eq (event-object event) 'no))
48 (throw 'ynp-done nil))
49 ((and (misc-user-event-p event)
50 (or (eq (event-object event) 'abort)
51 (eq (event-object event) 'menu-no-selection-hook)))
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")))))))
58
59 (defun yes-or-no-p-maybe-dialog-box (prompt)
60 "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.
62 Takes one argument, which is the string to display to ask the question.
63 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
64 The user must confirm the answer with RET,
65 and can edit it until it as been confirmed."
66 (if (should-use-dialog-box-p)
67 (yes-or-no-p-dialog-box prompt)
68 (yes-or-no-p-minibuf prompt)))
69
70 (defun y-or-n-p-maybe-dialog-box (prompt)
71 "Ask user a \"y or n\" question. Return t if answer is \"y\".
72 Takes one argument, which is the string to display to ask the question.
73 The question is asked with a dialog box or the minibuffer, as appropriate.
74 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
75 No confirmation of the answer is requested; a single character is enough.
76 Also accepts Space to mean yes, or Delete to mean no."
77 (if (should-use-dialog-box-p)
78 (yes-or-no-p-dialog-box prompt)
79 (y-or-n-p-minibuf prompt)))
80
81 (if (fboundp 'popup-dialog-box)
82 (progn
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)))
85
86 ;; this is call-compatible with the horribly-named FSF Emacs function
87 ;; `x-popup-dialog'. I refuse to use that name.
88 (defun get-dialog-box-response (position contents)
89 ;; by Stig@hackvan.com
90 ;; modified by pez@atlantic2.sbi.com
91 "Pop up a dialog box and return user's selection.
92 POSITION specifies which frame to use.
93 This is normally an event or a window or frame.
94 If POSITION is t or nil, it means to use the frame the mouse is on.
95 The dialog box appears in the middle of the specified frame.
96
97 CONTENTS specifies the alternatives to display in the dialog box.
98 It is a list of the form (TITLE ITEM1 ITEM2...).
99 Each ITEM is a cons cell (STRING . VALUE).
100 The return value is VALUE from the chosen item.
101
102 An ITEM may also be just a string--that makes a nonselectable item.
103 An ITEM may also be nil--that means to put all preceding items
104 on the left of the dialog box and all following items on the right."
105 (cond
106 ((eventp position)
107 (select-frame (event-frame position)))
108 ((framep position)
109 (select-frame position))
110 ((windowp position)
111 (select-window position)))
112 (let ((dbox (cons (car contents)
113 (mapcar #'(lambda (x)
114 (cond
115 ((null x)
116 nil)
117 ((stringp x)
118 `[,x 'ignore nil]) ;this will never get
119 ;selected
120 (t
121 `[,(car x) (throw 'result ',(cdr x)) t])))
122 (cdr contents))
123 )))
124 (catch 'result
125 (popup-dialog-box dbox)
126 (dispatch-event (next-command-event)))))
127
128 (defun message-box (fmt &rest args)
129 "Display a message, in a dialog box if possible.
130 If the selected device has no dialog-box support, use the echo area.
131 The arguments are the same as to `format'.
132
133 If the only argument is nil, clear any existing message; let the
134 minibuffer contents show."
135 (if (and (null fmt) (null args))
136 (progn
137 (clear-message nil)
138 nil)
139 (let ((str (apply 'format fmt args)))
140 (if (device-on-window-system-p)
141 (get-dialog-box-response nil (list str (cons "OK" t)))
142 (display-message 'message str))
143 str)))
144
145 (defun message-or-box (fmt &rest args)
146 "Display a message in a dialog box or in the echo area.\n\
147 If this command was invoked with the mouse, use a dialog box.\n\
148 Otherwise, use the echo area.
149 The arguments are the same as to `format'.
150
151 If the only argument is nil, clear any existing message; let the
152 minibuffer contents show."
153 (if (should-use-dialog-box-p)
154 (apply 'message-box fmt args)
155 (apply 'message fmt args)))
156
157 ;;; dialog.el ends here