git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/dialog-gtk.el

   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       filename)))
  74
  75 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
  76
  77 (defun popup-builtin-color-dialog (keys)
  78   ;; Allowed 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...")))
  82         (dialog nil)
  83         (clicked-ok nil)
  84         (color nil))
  85     (setq dialog (gtk-color-selection-dialog-new title))
  86     (gtk-signal-connect
  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)
  91              clicked-ok t)
  92        (gtk-main-quit))
  93      (gtk-color-selection-dialog-colorsel dialog))
  94
  95     (gtk-signal-connect
  96      (gtk-color-selection-dialog-cancel-button dialog) 'clicked
  97      (lambda (&rest ignored)
  98        (gtk-main-quit)))
  99
 100     (put dialog 'modal t)
 101     (put dialog 'type 'dialog)
 102     (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
 103
 104     (unwind-protect
 105         (progn
 106           (gtk-widget-show-now dialog)
 107           (gtk-main))
 108       '(gtk-widget-destroy dialog))
 109     (if (not clicked-ok)
 110         (signal 'quit nil))
 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)))))
 116
 117 (defun popup-builtin-password-dialog (keys)
 118   ;; Format is (default callback :keyword value)
 119   ;; Allowed keywords are:
 120   ;;
 121   ;;  :title string
 122   :;  :prompt string
 123   ;;  :default string
 124   ;;  :verify boolean
 125   ;;  :verify-prompt string
 126   (let* ((default (plist-get keys :default))
 127          (dialog nil)
 128          (clicked-ok nil)
 129          (passwd nil)
 130          (info nil)
 131          (generic-cb (lambda (x)
 132                        (setq clicked-ok t
 133                              passwd x))))
 134
 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))
 140
 141     ;; Clicking any button or closing the box exits the main loop.
 142     (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
 143                         'clicked
 144                         (lambda (&rest ignored)
 145                           (gtk-main-quit)))
 146
 147     (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
 148                         'clicked
 149                         (lambda (&rest ignored)
 150                           (gtk-main-quit)))
 151
 152     (gtk-signal-connect dialog
 153                         'delete-event
 154                         (lambda (&rest ignored)
 155                           (gtk-main-quit)))
 156
 157     (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
 158
 159     ;; Make us modal...
 160     (put dialog 'modal t)
 161     (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
 162
 163     ;; Realize the damn thing & wait for some action...
 164     (gtk-widget-show-all dialog)
 165     (gtk-main)
 166
 167     (if (not clicked-ok)
 168         (signal 'quit nil))
 169
 170     (gtk-widget-destroy dialog)
 171     passwd))
 172
 173 (defun popup-builtin-question-dialog (keys)
 174   ;; Allowed keywords:
 175   ;;   :question STRING
 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
 182         (activep t)
 183         (flushrightp nil)
 184         (errp t))
 185     (if (not buttons-descr)
 186         (error 'syntax-error
 187                "Dialog descriptor must supply at least one button"))
 188
 189     ;; Do the basics - create the dialog, set the window title, and
 190     ;; add the label asking the question.
 191     (unwind-protect
 192         (progn
 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))
 198
 199           ;; Create the buttons.
 200           (mapc (lambda (button)
 201                   ;; Handle flushright buttons
 202                   (if (null button)
 203                       (setq flushrightp t)
 204
 205                     ;; More sanity checking first of all.
 206                     (if (not (vectorp button))
 207                         (error "Button descriptor is not a vector: %S" button))
 208
 209                     (if (< (length button) 3)
 210                         (error "Button descriptor is too small: %S" button))
 211
 212                     (push (gtk-button-new-with-label (aref button 0)) buttons)
 213
 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
 218                         ;; the X code does.
 219                         (setq activep (aref button 2))
 220                       (let ((ctr 2)
 221                             (len (length button)))
 222                         (if (logand len 1)
 223                             (error
 224                              "Button descriptor has an odd number of keywords and values: %S"
 225                              button))
 226                         (while (< ctr len)
 227                           (if (eq (aref button ctr) :active)
 228                               (setq activep (aref button (1+ ctr))
 229                                     ctr len))
 230                           (setq ctr (+ ctr 2)))))
 231                     (gtk-widget-set-sensitive (car buttons) (eval activep))
 232
 233                     ;; Apply the callback
 234                     (gtk-signal-connect
 235                      (car buttons) 'clicked
 236                      (lambda (button data)
 237                        (push (make-event 'misc-user
 238                                          (list 'object (car data)
 239                                                'function
 240                                                (if (symbolp (car data))
 241                                                    'call-interactively
 242                                                  'eval)))
 243                              unread-command-events)
 244                        (gtk-main-quit)
 245                        t)
 246                      (cons (aref button 1) dialog))
 247
 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)
 251                              nil t 2)))
 252                 buttons-descr)
 253
 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)
 260           (gtk-main)
 261           (gtk-widget-destroy dialog)
 262           (setq errp nil))
 263       (if (not errp)
 264           ;; Nothing, we successfully showed the dialog
 265           nil
 266         ;; We need to destroy all the widgets, just in case.
 267         (mapc 'gtk-widget-destroy buttons)
 268         (gtk-widget-destroy dialog)))))
 269
 270 (defun gtk-make-dialog-box-internal (type keys)
 271   (case type
 272     (file
 273      (popup-builtin-open-dialog keys))
 274     (password
 275      (popup-builtin-password-dialog keys))
 276     (question
 277      (popup-builtin-question-dialog keys))
 278     (color
 279      (popup-builtin-color-dialog keys))
 280     (find
 281      )
 282     (font
 283      )
 284     (replace
 285      )
 286     (mswindows-message
 287      ;; This should really be renamed!
 288      )
 289     (print
 290      )
 291     (page-setup
 292      )
 293     (print-setup
 294      )
 295     (default
 296       (error "Unknown type of dialog: %S" type))))
 297
 298 (provide 'dialog-gtk)