1 ;;; dialog-gtk.el --- Dialog-box support for XEmacs w/GTK primitives
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
6 ;; Keywords: extensions, internal, dumped
8 ;; This file is part of SXEmacs.
10 ;; SXEmacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; SXEmacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Synched up with: Not in FSF.
27 ;; This file is dumped with SXEmacs (when dialog boxes are compiled in).
30 (require 'gtk-password-dialog)
31 (require 'gtk-file-dialog)
33 (globally-declare-fboundp
35 gtk-main-quit gtk-window-set-transient-for
36 gtk-widget-show-all gtk-main gtk-color-selection-dialog-new
37 gtk-color-selection-dialog-ok-button gtk-widget-hide-all
38 gtk-color-selection-get-color
39 gtk-color-selection-dialog-colorsel
40 gtk-color-selection-dialog-cancel-button gtk-widget-show-now
41 gtk-widget-grab-focus gtk-widget-destroy gtk-dialog-new
42 gtk-window-set-title gtk-container-set-border-width
43 gtk-box-set-spacing gtk-dialog-vbox gtk-container-add
44 gtk-label-new gtk-button-new-with-label
45 gtk-widget-set-sensitive gtk-widget-show gtk-dialog-action-area
46 gtk-label-parse-uline gtk-widget-add-accelerator gtk-accel-group-new
47 gtk-misc-set-alignment gtk-button-new gtk-window-add-accel-group))
49 (defun gtk-popup-convert-underscores (str)
50 ;; Convert the XEmacs button accelerator representation to Gtk mnemonic
51 ;; form. If no accelerator has been provided, put one at the start of the
52 ;; string (this mirrors the behaviour under X). This algorithm is also found
53 ;; in menubar-gtk.c:convert_underscores().
54 (let ((new-str (string))
57 (while (< i (length str))
58 (let ((c (aref str i)))
61 (if (and (not (eq (aref str i) ?_)) (not (eq (aref str i) ?%)))
66 (setq new-str (concat new-str "_")))
68 (setq new-str (concat new-str (string (aref str i))))
71 (if found-accel new-str (concat "_" new-str))
74 (defun popup-builtin-open-dialog (keys)
75 ;; Allowed keywords are:
77 ;; :initial-filename fname
78 ;; :initial-directory dir
79 ;; :filter-list (filter-desc filter ...)
82 ;; :allow-multi-select t/nil
83 ;; :create-prompt-on-nonexistent t/nil
84 ;; :overwrite-prompt t/nil
85 ;; :file-must-exist t/nil
86 ;; :no-network-button t/nil
87 ;; :no-read-only-return t/nil
88 (let ((initial-filename (plist-get keys :initial-filename))
92 (setq widget (gtk-file-dialog-new
93 :directory (plist-get keys :directory)
94 :callback `(lambda (f)
97 :initial-directory (or (plist-get keys :initial-directory nil)
99 (file-name-directory initial-filename)
101 :filter-list (plist-to-alist
102 (plist-get keys :filter-list nil))
103 :file-must-exist (plist-get keys :file-must-exist nil)))
105 (gtk-signal-connect widget 'destroy (lambda (obj data) (gtk-main-quit)))
107 (gtk-window-set-transient-for widget (frame-property nil 'shell-widget))
108 (gtk-widget-show-all widget)
114 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
116 (defun popup-builtin-color-dialog (keys)
118 ;; :initial-color COLOR
119 (let (;(initial-color (or (plist-get keys :initial-color) "white"))
120 (title (or (plist-get keys :title "Select color...")))
124 (setq dialog (gtk-color-selection-dialog-new title))
126 (gtk-color-selection-dialog-ok-button dialog) 'clicked
127 (lambda (button colorsel)
128 (gtk-widget-hide-all dialog)
129 (setq color (gtk-color-selection-get-color colorsel)
132 (gtk-color-selection-dialog-colorsel dialog))
135 (gtk-color-selection-dialog-cancel-button dialog) 'clicked
136 (lambda (&rest ignored)
139 (put dialog 'modal t)
140 (put dialog 'type 'dialog)
141 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
145 (gtk-widget-show-now dialog)
147 '(gtk-widget-destroy dialog))
150 ;; Need to convert from (R G B A) to #rrggbb
151 (format "#%02x%02x%02x"
152 (* 256 (nth 0 color))
153 (* 256 (nth 1 color))
154 (* 256 (nth 2 color)))))
156 (defun popup-builtin-password-dialog (keys)
157 ;; Format is (default callback :keyword value)
158 ;; Allowed keywords are:
164 ;; :verify-prompt string
165 (let* ((default (plist-get keys :default))
170 (generic-cb (lambda (x)
174 ;; Convert the descriptor to keywords and create the dialog
175 (setq info (copy-list keys)
176 info (plist-put info :callback generic-cb)
177 info (plist-put info :default default)
178 dialog (apply 'gtk-password-dialog-new info))
180 ;; Clicking any button or closing the box exits the main loop.
181 (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
183 (lambda (&rest ignored)
186 (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
188 (lambda (&rest ignored)
191 (gtk-signal-connect dialog
193 (lambda (&rest ignored)
196 (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
199 (put dialog 'modal t)
200 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
202 ;; Realize the damn thing & wait for some action...
203 (gtk-widget-show-all dialog)
209 (gtk-widget-destroy dialog)
212 (defun popup-builtin-question-dialog (keys)
215 ;; :buttons BUTTONDESC
216 (let ((title (or (plist-get keys :title) "Question"))
217 (buttons-descr (plist-get keys :buttons))
218 (question (or (plist-get keys :question) "Question goes here..."))
219 (dialog nil) ; GtkDialog
220 (buttons nil) ; List of GtkButton objects
227 (accel-group (gtk-accel-group-new))
230 (if (not buttons-descr)
232 "Dialog descriptor must supply at least one button"))
234 ;; Do the basics - create the dialog, set the window title, and
235 ;; add the label asking the question.
238 (setq dialog (gtk-dialog-new))
239 (gtk-window-set-title dialog title)
240 (gtk-container-set-border-width dialog 3)
241 (gtk-box-set-spacing (gtk-dialog-vbox dialog) 5)
242 (gtk-container-add (gtk-dialog-vbox dialog) (gtk-label-new question))
244 ;; Create the buttons.
245 (mapc (lambda (button)
246 ;; Handle flushright buttons
250 ;; More sanity checking first of all.
251 (if (not (vectorp button))
252 (error "Button descriptor is not a vector: %S" button))
254 (setq length (length button))
257 ((= length 1) ; [ "name" ]
260 ((= length 2) ; [ "name" callback ]
261 (setq callback (aref button 1)
263 ((and (or (= length 3) (= length 4))
264 (not (keywordp (aref button 2))))
265 ;; [ "name" callback active-p ] or
266 ;; [ "name" callback active-p suffix ]
267 ;; We ignore the 'suffix' entry, because that is
268 ;; what the X code does.
269 (setq callback (aref button 1)
270 activep (aref button 2)))
271 (t ; 100% keyword specification
272 (let ((plist (cdr (mapcar 'identity button))))
273 (setq activep (plist-get plist :active)
274 callback (plist-get plist :callback)))))
276 ;; Create the label and determine what the mnemonic key is.
277 (setq label (gtk-label-new ""))
278 (setq accel-key (gtk-label-parse-uline label
279 (gtk-popup-convert-underscores (aref button 0))))
280 ;; Place the label in the button.
281 (gtk-misc-set-alignment label 0.5 0.5)
282 (setq gui-button (gtk-button-new))
283 (gtk-container-add gui-button label)
284 ;; Add ALT-mnemonic to the dialog's accelerator group.
285 (gtk-widget-add-accelerator gui-button "clicked" accel-group
291 (push gui-button buttons)
292 (gtk-widget-set-sensitive (car buttons) (eval activep))
294 ;; Apply the callback
296 (car buttons) 'clicked
297 (lambda (button data)
298 (push (make-event 'misc-user
299 (list 'object (car data)
301 (if (symbolp (car data))
304 unread-command-events)
307 (cons callback dialog))
309 (gtk-widget-show (car buttons))
310 (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start)
311 (gtk-dialog-action-area dialog) (car buttons)
315 ;; Make sure they can't close it with the window manager
316 (gtk-signal-connect dialog 'delete-event (lambda (&rest ignored) t))
317 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
318 (put dialog 'type 'dialog)
319 (put dialog 'modal t)
320 ;; Make the dialog listen for global mnemonic keys.
321 (gtk-window-add-accel-group dialog accel-group)
323 (gtk-widget-show-all dialog)
325 (gtk-widget-destroy dialog)
328 ;; Nothing, we successfully showed the dialog
330 ;; We need to destroy all the widgets, just in case.
331 (mapc 'gtk-widget-destroy buttons)
332 (gtk-widget-destroy dialog)))))
334 (defun gtk-make-dialog-box-internal (type keys)
337 (popup-builtin-open-dialog keys))
339 (popup-builtin-password-dialog keys))
341 (popup-builtin-question-dialog keys))
343 (popup-builtin-color-dialog keys))
357 (error "Unknown type of dialog: %S" type))))
359 (provide 'dialog-gtk)