Mercurial > hg > xemacs-beta

comparison lisp/dialog-gtk.el @ 462:0784d089fdc9 r21-2-46

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-46
author cvs
date Mon, 13 Aug 2007 11:44:37 +0200
parents
children 7039e6323819
comparison
equal deleted inserted replaced
461:120ed4009e51 462:0784d089fdc9
1 ;;; dialog-gtk.el --- Dialog-box support for XEmacs w/GTK primitives
2
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
4
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
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 (require 'cl)
32 (require 'gtk-password-dialog)
33 (require 'gtk-file-dialog)
34
35 (defun popup-builtin-open-dialog (keys)
36 ;; Allowed keywords are:
37 ;;
38 ;; :initial-filename fname
39 ;; :initial-directory dir
40 ;; :filter-list (filter-desc filter ...)
41 ;; :directory t/nil
42 ;; :title string
43 ;; :allow-multi-select t/nil
44 ;; :create-prompt-on-nonexistent t/nil
45 ;; :overwrite-prompt t/nil
46 ;; :file-must-exist t/nil
47 ;; :no-network-button t/nil
48 ;; :no-read-only-return t/nil
49 (let ((initial-filename (plist-get keys :initial-filename))
50 (clicked-ok nil)
51 (filename nil)
52 (widget nil))
53 (setq widget (gtk-file-dialog-new
54 :directory (plist-get keys :directory)
55 :callback `(lambda (f)
56 (setq clicked-ok t
57 filename f))
58 :initial-directory (or (plist-get keys :initial-directory nil)
59 (if initial-filename
60 (file-name-directory initial-filename)
61 default-directory))
62 :filter-list (plist-to-alist
63 (plist-get keys :filter-list nil))
64 :file-must-exist (plist-get keys :file-must-exist nil)))
65
66 (gtk-signal-connect widget 'destroy (lambda (obj data) (gtk-main-quit)))
67
68 (gtk-window-set-transient-for widget (frame-property nil 'shell-widget))
69 (gtk-widget-show-all widget)
70 (gtk-main)
71 (if (not clicked-ok)
72 (signal 'quit nil))))
73
74 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
75
76 (defun popup-builtin-color-dialog (keys)
77 ;; Allowed keys:
78 ;; :initial-color COLOR
79 (let ((initial-color (or (plist-get keys :initial-color) "white"))
80 (title (or (plist-get keys :title "Select color...")))
81 (dialog nil)
82 (clicked-ok nil)
83 (color nil))
84 (setq dialog (gtk-color-selection-dialog-new title))
85 (gtk-signal-connect
86 (gtk-color-selection-dialog-ok-button dialog) 'clicked
87 (lambda (button colorsel)
88 (gtk-widget-hide-all dialog)
89 (setq color (gtk-color-selection-get-color colorsel)
90 clicked-ok t)
91 (gtk-main-quit))
92 (gtk-color-selection-dialog-colorsel dialog))
93
94 (gtk-signal-connect
95 (gtk-color-selection-dialog-cancel-button dialog) 'clicked
96 (lambda (&rest ignored)
97 (gtk-main-quit)))
98
99 (put dialog 'modal t)
100 (put dialog 'type 'dialog)
101 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
102
103 (unwind-protect
104 (progn
105 (gtk-widget-show-now dialog)
106 (gtk-main))
107 '(gtk-widget-destroy dialog))
108 (if (not clicked-ok)
109 (signal 'quit nil))
110 ;; Need to convert from (R G B A) to #rrggbb
111 (format "#%02x%02x%02x"
112 (* 256 (nth 0 color))
113 (* 256 (nth 1 color))
114 (* 256 (nth 2 color)))))
115
116 (defun popup-builtin-password-dialog (keys)
117 ;; Format is (default callback :keyword value)
118 ;; Allowed keywords are:
119 ;;
120 ;; :title string
121 :; :prompt string
122 ;; :default string
123 ;; :verify boolean
124 ;; :verify-prompt string
125 (let* ((default (plist-get keys :default))
126 (dialog nil)
127 (clicked-ok nil)
128 (passwd nil)
129 (info nil)
130 (generic-cb (lambda (x)
131 (setq clicked-ok t
132 passwd x))))
133
134 ;; Convert the descriptor to keywords and create the dialog
135 (setq info (copy-list keys)
136 info (plist-put info :callback generic-cb)
137 info (plist-put info :default default)
138 dialog (apply 'gtk-password-dialog-new info))
139
140 ;; Clicking any button or closing the box exits the main loop.
141 (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
142 'clicked
143 (lambda (&rest ignored)
144 (gtk-main-quit)))
145
146 (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
147 'clicked
148 (lambda (&rest ignored)
149 (gtk-main-quit)))
150
151 (gtk-signal-connect dialog
152 'delete-event
153 (lambda (&rest ignored)
154 (gtk-main-quit)))
155
156 (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
157
158 ;; Make us modal...
159 (put dialog 'modal t)
160 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
161
162 ;; Realize the damn thing & wait for some action...
163 (gtk-widget-show-all dialog)
164 (gtk-main)
165
166 (if (not clicked-ok)
167 (signal 'quit nil))
168
169 (gtk-widget-destroy dialog)
170 passwd))
171
172 (defun popup-builtin-question-dialog (keys)
173 ;; Allowed keywords:
174 ;; :question STRING
175 ;; :buttons BUTTONDESC
176 (let ((title (or (plist-get keys :title) "Question"))
177 (buttons-descr (plist-get keys :buttons))
178 (question (or (plist-get keys :question) "Question goes here..."))
179 (dialog nil) ; GtkDialog
180 (buttons nil) ; List of GtkButton objects
181 (activep t)
182 (flushrightp nil)
183 (errp t))
184 (if (not buttons-descr)
185 (error 'syntax-error
186 "Dialog descriptor must supply at least one button"))
187
188 ;; Do the basics - create the dialog, set the window title, and
189 ;; add the label asking the question.
190 (unwind-protect
191 (progn
192 (setq dialog (gtk-dialog-new))
193 (gtk-window-set-title dialog title)
194 (gtk-container-set-border-width dialog 3)
195 (gtk-box-set-spacing (gtk-dialog-vbox dialog) 5)
196 (gtk-container-add (gtk-dialog-vbox dialog) (gtk-label-new question))
197
198 ;; Create the buttons.
199 (mapc (lambda (button)
200 ;; Handle flushright buttons
201 (if (null button)
202 (setq flushrightp t)
203
204 ;; More sanity checking first of all.
205 (if (not (vectorp button))
206 (error "Button descriptor is not a vector: %S" button))
207
208 (if (< (length button) 3)
209 (error "Button descriptor is too small: %S" button))
210
211 (push (gtk-button-new-with-label (aref button 0)) buttons)
212
213 ;; Need to detect what flavor of descriptor it is.
214 (if (not (keywordp (aref button 2)))
215 ;; Simple style... just [ name callback activep ]
216 ;; We ignore the 'suffix' entry, because that is what
217 ;; the X code does.
218 (setq activep (aref button 2))
219 (let ((ctr 2)
220 (len (length button)))
221 (if (logand len 1)
222 (error
223 "Button descriptor has an odd number of keywords and values: %S"
224 button))
225 (while (< ctr len)
226 (if (eq (aref button ctr) :active)
227 (setq activep (aref button (1+ ctr))
228 ctr len))
229 (setq ctr (+ ctr 2)))))
230 (gtk-widget-set-sensitive (car buttons) (eval activep))
231
232 ;; Apply the callback
233 (gtk-signal-connect
234 (car buttons) 'clicked
235 (lambda (button data)
236 (push (make-event 'misc-user
237 (list 'object (car data)
238 'function
239 (if (symbolp (car data))
240 'call-interactively
241 'eval)))
242 unread-command-events)
243 (gtk-main-quit)
244 t)
245 (cons (aref button 1) dialog))
246
247 (gtk-widget-show (car buttons))
248 (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start)
249 (gtk-dialog-action-area dialog) (car buttons)
250 nil t 2)))
251 buttons-descr)
252
253 ;; Make sure they can't close it with the window manager
254 (gtk-signal-connect dialog 'delete-event (lambda (&rest ignored) t))
255 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
256 (put dialog 'type 'dialog)
257 (put dialog 'modal t)
258 (gtk-widget-show-all dialog)
259 (gtk-main)
260 (gtk-widget-destroy dialog)
261 (setq errp nil))
262 (if (not errp)
263 ;; Nothing, we successfully showed the dialog
264 nil
265 ;; We need to destroy all the widgets, just in case.
266 (mapc 'gtk-widget-destroy buttons)
267 (gtk-widget-destroy dialog)))))
268
269 (defun gtk-make-dialog-box-internal (type keys)
270 (case type
271 (file
272 (popup-builtin-open-dialog keys))
273 (password
274 (popup-builtin-password-dialog keys))
275 (question
276 (popup-builtin-question-dialog keys))
277 (color
278 (popup-builtin-color-dialog keys))
279 (find
280 )
281 (font
282 )
283 (replace
284 )
285 (mswindows-message
286 ;; This should really be renamed!
287 )
288 (print
289 )
290 (page-setup
291 )
292 (print-setup
293 )
294 (default
295 (error "Unknown type of dialog: %S" type))))
296
297 (provide 'dialog-gtk)