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 XEmacs.
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)
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.
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.
25 ;;; Synched up with: Not in FSF.
29 ;; This file is dumped with XEmacs (when dialog boxes are compiled in).
32 (require 'gtk-password-dialog)
33 (require 'gtk-file-dialog)
35 (defun popup-builtin-open-dialog (keys)
36 ;; Allowed keywords are:
38 ;; :initial-filename fname
39 ;; :initial-directory dir
40 ;; :filter-list (filter-desc filter ...)
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))
53 (setq widget (gtk-file-dialog-new
54 :directory (plist-get keys :directory)
55 :callback `(lambda (f)
58 :initial-directory (or (plist-get keys :initial-directory nil)
60 (file-name-directory initial-filename)
62 :filter-list (plist-to-alist
63 (plist-get keys :filter-list nil))
64 :file-must-exist (plist-get keys :file-must-exist nil)))
66 (gtk-signal-connect widget 'destroy (lambda (obj data) (gtk-main-quit)))
68 (gtk-window-set-transient-for widget (frame-property nil 'shell-widget))
69 (gtk-widget-show-all widget)
75 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
77 (defun popup-builtin-color-dialog (keys)
79 ;; :initial-color COLOR
80 (let ((initial-color (or (plist-get keys :initial-color) "white"))
81 (title (or (plist-get keys :title "Select color...")))
85 (setq dialog (gtk-color-selection-dialog-new title))
87 (gtk-color-selection-dialog-ok-button dialog) 'clicked
88 (lambda (button colorsel)
89 (gtk-widget-hide-all dialog)
90 (setq color (gtk-color-selection-get-color colorsel)
93 (gtk-color-selection-dialog-colorsel dialog))
96 (gtk-color-selection-dialog-cancel-button dialog) 'clicked
97 (lambda (&rest ignored)
100 (put dialog 'modal t)
101 (put dialog 'type 'dialog)
102 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
106 (gtk-widget-show-now dialog)
108 '(gtk-widget-destroy dialog))
111 ;; Need to convert from (R G B A) to #rrggbb
112 (format "#%02x%02x%02x"
113 (* 256 (nth 0 color))
114 (* 256 (nth 1 color))
115 (* 256 (nth 2 color)))))
117 (defun popup-builtin-password-dialog (keys)
118 ;; Format is (default callback :keyword value)
119 ;; Allowed keywords are:
125 ;; :verify-prompt string
126 (let* ((default (plist-get keys :default))
131 (generic-cb (lambda (x)
135 ;; Convert the descriptor to keywords and create the dialog
136 (setq info (copy-list keys)
137 info (plist-put info :callback generic-cb)
138 info (plist-put info :default default)
139 dialog (apply 'gtk-password-dialog-new info))
141 ;; Clicking any button or closing the box exits the main loop.
142 (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
144 (lambda (&rest ignored)
147 (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
149 (lambda (&rest ignored)
152 (gtk-signal-connect dialog
154 (lambda (&rest ignored)
157 (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
160 (put dialog 'modal t)
161 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
163 ;; Realize the damn thing & wait for some action...
164 (gtk-widget-show-all dialog)
170 (gtk-widget-destroy dialog)
173 (defun popup-builtin-question-dialog (keys)
176 ;; :buttons BUTTONDESC
177 (let ((title (or (plist-get keys :title) "Question"))
178 (buttons-descr (plist-get keys :buttons))
179 (question (or (plist-get keys :question) "Question goes here..."))
180 (dialog nil) ; GtkDialog
181 (buttons nil) ; List of GtkButton objects
185 (if (not buttons-descr)
187 "Dialog descriptor must supply at least one button"))
189 ;; Do the basics - create the dialog, set the window title, and
190 ;; add the label asking the question.
193 (setq dialog (gtk-dialog-new))
194 (gtk-window-set-title dialog title)
195 (gtk-container-set-border-width dialog 3)
196 (gtk-box-set-spacing (gtk-dialog-vbox dialog) 5)
197 (gtk-container-add (gtk-dialog-vbox dialog) (gtk-label-new question))
199 ;; Create the buttons.
200 (mapc (lambda (button)
201 ;; Handle flushright buttons
205 ;; More sanity checking first of all.
206 (if (not (vectorp button))
207 (error "Button descriptor is not a vector: %S" button))
209 (if (< (length button) 3)
210 (error "Button descriptor is too small: %S" button))
212 (push (gtk-button-new-with-label (aref button 0)) buttons)
214 ;; Need to detect what flavor of descriptor it is.
215 (if (not (keywordp (aref button 2)))
216 ;; Simple style... just [ name callback activep ]
217 ;; We ignore the 'suffix' entry, because that is what
219 (setq activep (aref button 2))
221 (len (length button)))
224 "Button descriptor has an odd number of keywords and values: %S"
227 (if (eq (aref button ctr) :active)
228 (setq activep (aref button (1+ ctr))
230 (setq ctr (+ ctr 2)))))
231 (gtk-widget-set-sensitive (car buttons) (eval activep))
233 ;; Apply the callback
235 (car buttons) 'clicked
236 (lambda (button data)
237 (push (make-event 'misc-user
238 (list 'object (car data)
240 (if (symbolp (car data))
243 unread-command-events)
246 (cons (aref button 1) dialog))
248 (gtk-widget-show (car buttons))
249 (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start)
250 (gtk-dialog-action-area dialog) (car buttons)
254 ;; Make sure they can't close it with the window manager
255 (gtk-signal-connect dialog 'delete-event (lambda (&rest ignored) t))
256 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
257 (put dialog 'type 'dialog)
258 (put dialog 'modal t)
259 (gtk-widget-show-all dialog)
261 (gtk-widget-destroy dialog)
264 ;; Nothing, we successfully showed the dialog
266 ;; We need to destroy all the widgets, just in case.
267 (mapc 'gtk-widget-destroy buttons)
268 (gtk-widget-destroy dialog)))))
270 (defun gtk-make-dialog-box-internal (type keys)
273 (popup-builtin-open-dialog keys))
275 (popup-builtin-password-dialog keys))
277 (popup-builtin-question-dialog keys))
279 (popup-builtin-color-dialog keys))
287 ;; This should really be renamed!
296 (error "Unknown type of dialog: %S" type))))
298 (provide 'dialog-gtk)