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