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)
74 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
76 (defun popup-builtin-color-dialog (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...")))
84 (setq dialog (gtk-color-selection-dialog-new title))
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)
92 (gtk-color-selection-dialog-colorsel dialog))
95 (gtk-color-selection-dialog-cancel-button dialog) 'clicked
96 (lambda (&rest ignored)
100 (put dialog 'type 'dialog)
101 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
105 (gtk-widget-show-now dialog)
107 '(gtk-widget-destroy dialog))
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)))))
116 (defun popup-builtin-password-dialog (keys)
117 ;; Format is (default callback :keyword value)
118 ;; Allowed keywords are:
124 ;; :verify-prompt string
125 (let* ((default (plist-get keys :default))
130 (generic-cb (lambda (x)
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))
140 ;; Clicking any button or closing the box exits the main loop.
141 (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
143 (lambda (&rest ignored)
146 (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
148 (lambda (&rest ignored)
151 (gtk-signal-connect dialog
153 (lambda (&rest ignored)
156 (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
159 (put dialog 'modal t)
160 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
162 ;; Realize the damn thing & wait for some action...
163 (gtk-widget-show-all dialog)
169 (gtk-widget-destroy dialog)
172 (defun popup-builtin-question-dialog (keys)
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
184 (if (not buttons-descr)
186 "Dialog descriptor must supply at least one button"))
188 ;; Do the basics - create the dialog, set the window title, and
189 ;; add the label asking the question.
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))
198 ;; Create the buttons.
199 (mapc (lambda (button)
200 ;; Handle flushright buttons
204 ;; More sanity checking first of all.
205 (if (not (vectorp button))
206 (error "Button descriptor is not a vector: %S" button))
208 (if (< (length button) 3)
209 (error "Button descriptor is too small: %S" button))
211 (push (gtk-button-new-with-label (aref button 0)) buttons)
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
218 (setq activep (aref button 2))
220 (len (length button)))
223 "Button descriptor has an odd number of keywords and values: %S"
226 (if (eq (aref button ctr) :active)
227 (setq activep (aref button (1+ ctr))
229 (setq ctr (+ ctr 2)))))
230 (gtk-widget-set-sensitive (car buttons) (eval activep))
232 ;; Apply the callback
234 (car buttons) 'clicked
235 (lambda (button data)
236 (push (make-event 'misc-user
237 (list 'object (car data)
239 (if (symbolp (car data))
242 unread-command-events)
245 (cons (aref button 1) dialog))
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)
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)
260 (gtk-widget-destroy dialog)
263 ;; Nothing, we successfully showed the dialog
265 ;; We need to destroy all the widgets, just in case.
266 (mapc 'gtk-widget-destroy buttons)
267 (gtk-widget-destroy dialog)))))
269 (defun gtk-make-dialog-box-internal (type keys)
272 (popup-builtin-open-dialog keys))
274 (popup-builtin-password-dialog keys))
276 (popup-builtin-question-dialog keys))
278 (popup-builtin-color-dialog keys))
286 ;; This should really be renamed!
295 (error "Unknown type of dialog: %S" type))))
297 (provide 'dialog-gtk)