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 gtk-popup-convert-underscores (str)
36 ;; Convert the XEmacs button accelerator representation to Gtk mnemonic
37 ;; form. If no accelerator has been provided, put one at the start of the
38 ;; string (this mirrors the behaviour under X). This algorithm is also found
39 ;; in menubar-gtk.c:convert_underscores().
40 (let ((new-str (string))
43 (while (< i (length str))
44 (let ((c (aref str i)))
47 (if (and (not (eq (aref str i) ?_)) (not (eq (aref str i) ?%)))
52 (setq new-str (concat new-str "_")))
54 (setq new-str (concat new-str (string (aref str i))))
57 (if found-accel new-str (concat "_" new-str))
60 (defun popup-builtin-open-dialog (keys)
61 ;; Allowed keywords are:
63 ;; :initial-filename fname
64 ;; :initial-directory dir
65 ;; :filter-list (filter-desc filter ...)
68 ;; :allow-multi-select t/nil
69 ;; :create-prompt-on-nonexistent t/nil
70 ;; :overwrite-prompt t/nil
71 ;; :file-must-exist t/nil
72 ;; :no-network-button t/nil
73 ;; :no-read-only-return t/nil
74 (let ((initial-filename (plist-get keys :initial-filename))
78 (setq widget (gtk-file-dialog-new
79 :directory (plist-get keys :directory)
80 :callback `(lambda (f)
83 :initial-directory (or (plist-get keys :initial-directory nil)
85 (file-name-directory initial-filename)
87 :filter-list (plist-to-alist
88 (plist-get keys :filter-list nil))
89 :file-must-exist (plist-get keys :file-must-exist nil)))
91 (gtk-signal-connect widget 'destroy (lambda (obj data) (gtk-main-quit)))
93 (gtk-window-set-transient-for widget (frame-property nil 'shell-widget))
94 (gtk-widget-show-all widget)
100 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
102 (defun popup-builtin-color-dialog (keys)
104 ;; :initial-color COLOR
105 (let ((initial-color (or (plist-get keys :initial-color) "white"))
106 (title (or (plist-get keys :title "Select color...")))
110 (setq dialog (gtk-color-selection-dialog-new title))
112 (gtk-color-selection-dialog-ok-button dialog) 'clicked
113 (lambda (button colorsel)
114 (gtk-widget-hide-all dialog)
115 (setq color (gtk-color-selection-get-color colorsel)
118 (gtk-color-selection-dialog-colorsel dialog))
121 (gtk-color-selection-dialog-cancel-button dialog) 'clicked
122 (lambda (&rest ignored)
125 (put dialog 'modal t)
126 (put dialog 'type 'dialog)
127 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
131 (gtk-widget-show-now dialog)
133 '(gtk-widget-destroy dialog))
136 ;; Need to convert from (R G B A) to #rrggbb
137 (format "#%02x%02x%02x"
138 (* 256 (nth 0 color))
139 (* 256 (nth 1 color))
140 (* 256 (nth 2 color)))))
142 (defun popup-builtin-password-dialog (keys)
143 ;; Format is (default callback :keyword value)
144 ;; Allowed keywords are:
150 ;; :verify-prompt string
151 (let* ((default (plist-get keys :default))
156 (generic-cb (lambda (x)
160 ;; Convert the descriptor to keywords and create the dialog
161 (setq info (copy-list keys)
162 info (plist-put info :callback generic-cb)
163 info (plist-put info :default default)
164 dialog (apply 'gtk-password-dialog-new info))
166 ;; Clicking any button or closing the box exits the main loop.
167 (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
169 (lambda (&rest ignored)
172 (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
174 (lambda (&rest ignored)
177 (gtk-signal-connect dialog
179 (lambda (&rest ignored)
182 (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
185 (put dialog 'modal t)
186 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
188 ;; Realize the damn thing & wait for some action...
189 (gtk-widget-show-all dialog)
195 (gtk-widget-destroy dialog)
198 (defun popup-builtin-question-dialog (keys)
201 ;; :buttons BUTTONDESC
202 (let ((title (or (plist-get keys :title) "Question"))
203 (buttons-descr (plist-get keys :buttons))
204 (question (or (plist-get keys :question) "Question goes here..."))
205 (dialog nil) ; GtkDialog
206 (buttons nil) ; List of GtkButton objects
213 (accel-group (gtk-accel-group-new))
216 (if (not buttons-descr)
218 "Dialog descriptor must supply at least one button"))
220 ;; Do the basics - create the dialog, set the window title, and
221 ;; add the label asking the question.
224 (setq dialog (gtk-dialog-new))
225 (gtk-window-set-title dialog title)
226 (gtk-container-set-border-width dialog 3)
227 (gtk-box-set-spacing (gtk-dialog-vbox dialog) 5)
228 (gtk-container-add (gtk-dialog-vbox dialog) (gtk-label-new question))
230 ;; Create the buttons.
231 (mapc (lambda (button)
232 ;; Handle flushright buttons
236 ;; More sanity checking first of all.
237 (if (not (vectorp button))
238 (error "Button descriptor is not a vector: %S" button))
240 (setq length (length button))
243 ((= length 1) ; [ "name" ]
246 ((= length 2) ; [ "name" callback ]
247 (setq callback (aref button 1)
249 ((and (or (= length 3) (= length 4))
250 (not (keywordp (aref button 2))))
251 ;; [ "name" callback active-p ] or
252 ;; [ "name" callback active-p suffix ]
253 ;; We ignore the 'suffix' entry, because that is
254 ;; what the X code does.
255 (setq callback (aref button 1)
256 activep (aref button 2)))
257 (t ; 100% keyword specification
258 (let ((plist (cdr (mapcar 'identity button))))
259 (setq activep (plist-get plist :active)
260 callback (plist-get plist :callback)))))
262 ;; Create the label and determine what the mnemonic key is.
263 (setq label (gtk-label-new ""))
264 (setq accel-key (gtk-label-parse-uline label
265 (gtk-popup-convert-underscores (aref button 0))))
266 ;; Place the label in the button.
267 (gtk-misc-set-alignment label 0.5 0.5)
268 (setq gui-button (gtk-button-new))
269 (gtk-container-add gui-button label)
270 ;; Add ALT-mnemonic to the dialog's accelerator group.
271 (gtk-widget-add-accelerator gui-button "clicked" accel-group
277 (push gui-button buttons)
278 (gtk-widget-set-sensitive (car buttons) (eval activep))
280 ;; Apply the callback
282 (car buttons) 'clicked
283 (lambda (button data)
284 (push (make-event 'misc-user
285 (list 'object (car data)
287 (if (symbolp (car data))
290 unread-command-events)
293 (cons callback dialog))
295 (gtk-widget-show (car buttons))
296 (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start)
297 (gtk-dialog-action-area dialog) (car buttons)
301 ;; Make sure they can't close it with the window manager
302 (gtk-signal-connect dialog 'delete-event (lambda (&rest ignored) t))
303 (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
304 (put dialog 'type 'dialog)
305 (put dialog 'modal t)
306 ;; Make the dialog listen for global mnemonic keys.
307 (gtk-window-add-accel-group dialog accel-group)
309 (gtk-widget-show-all dialog)
311 (gtk-widget-destroy dialog)
314 ;; Nothing, we successfully showed the dialog
316 ;; We need to destroy all the widgets, just in case.
317 (mapc 'gtk-widget-destroy buttons)
318 (gtk-widget-destroy dialog)))))
320 (defun gtk-make-dialog-box-internal (type keys)
323 (popup-builtin-open-dialog keys))
325 (popup-builtin-password-dialog keys))
327 (popup-builtin-question-dialog keys))
329 (popup-builtin-color-dialog keys))
337 ;; This should really be renamed!
346 (error "Unknown type of dialog: %S" type))))
348 (provide 'dialog-gtk)