git.chise.org Git - chise/xemacs-chise.git-/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         (callback nil)
 184         (flushrightp nil)
 185         (length nil)
 186         (errp t))
 187     (if (not buttons-descr)
 188         (error 'syntax-error
 189                "Dialog descriptor must supply at least one button"))
 190
 191     ;; Do the basics - create the dialog, set the window title, and
 192     ;; add the label asking the question.
 193     (unwind-protect
 194         (progn
 195           (setq dialog (gtk-dialog-new))
 196           (gtk-window-set-title dialog title)
 197           (gtk-container-set-border-width dialog 3)
 198           (gtk-box-set-spacing (gtk-dialog-vbox dialog) 5)
 199           (gtk-container-add (gtk-dialog-vbox dialog) (gtk-label-new question))
 200
 201           ;; Create the buttons.
 202           (mapc (lambda (button)
 203                   ;; Handle flushright buttons
 204                   (if (null button)
 205                       (setq flushrightp t)
 206
 207                     ;; More sanity checking first of all.
 208                     (if (not (vectorp button))
 209                         (error "Button descriptor is not a vector: %S" button))
 210
 211                     (setq length (length button))
 212
 213                     (cond
 214                      ((= length 1)      ; [ "name" ]
 215                       (setq callback nil
 216                             activep nil))
 217                      ((= length 2)      ; [ "name" callback ]
 218                       (setq callback (aref button 1)
 219                             activep t))
 220                      ((and (or (= length 3) (= length 4))
 221                            (not (keywordp (aref button 2))))
 222                       ;; [ "name" callback active-p ] or
 223                       ;; [ "name" callback active-p suffix ]
 224                       ;; We ignore the 'suffix' entry, because that is
 225                       ;; what the X code does.
 226                       (setq callback (aref button 1)
 227                             activep (aref button 2)))
 228                      (t                 ; 100% keyword specification
 229                       (let ((plist (cdr (mapcar 'identity button))))
 230                         (setq activep (plist-get plist :active)
 231                               callback (plist-get plist :callback)))))
 232
 233                     (push (gtk-button-new-with-label (aref button 0)) buttons)
 234                     (gtk-widget-set-sensitive (car buttons) (eval activep))
 235
 236                     ;; Apply the callback
 237                     (gtk-signal-connect
 238                      (car buttons) 'clicked
 239                      (lambda (button data)
 240                        (push (make-event 'misc-user
 241                                          (list 'object (car data)
 242                                                'function
 243                                                (if (symbolp (car data))
 244                                                    'call-interactively
 245                                                  'eval)))
 246                              unread-command-events)
 247                        (gtk-main-quit)
 248                        t)
 249                      (cons callback dialog))
 250
 251                     (gtk-widget-show (car buttons))
 252                     (funcall (if flushrightp 'gtk-box-pack-end 'gtk-box-pack-start)
 253                              (gtk-dialog-action-area dialog) (car buttons)
 254                              nil t 2)))
 255                 buttons-descr)
 256
 257           ;; Make sure they can't close it with the window manager
 258           (gtk-signal-connect dialog 'delete-event (lambda (&rest ignored) t))
 259           (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
 260           (put dialog 'type 'dialog)
 261           (put dialog 'modal t)
 262           (gtk-widget-show-all dialog)
 263           (gtk-main)
 264           (gtk-widget-destroy dialog)
 265           (setq errp nil))
 266       (if (not errp)
 267           ;; Nothing, we successfully showed the dialog
 268           nil
 269         ;; We need to destroy all the widgets, just in case.
 270         (mapc 'gtk-widget-destroy buttons)
 271         (gtk-widget-destroy dialog)))))
 272
 273 (defun gtk-make-dialog-box-internal (type keys)
 274   (case type
 275     (file
 276      (popup-builtin-open-dialog keys))
 277     (password
 278      (popup-builtin-password-dialog keys))
 279     (question
 280      (popup-builtin-question-dialog keys))
 281     (color
 282      (popup-builtin-color-dialog keys))
 283     (find
 284      )
 285     (font
 286      )
 287     (replace
 288      )
 289     (mswindows-message
 290      ;; This should really be renamed!
 291      )
 292     (print
 293      )
 294     (page-setup
 295      )
 296     (print-setup
 297      )
 298     (default
 299       (error "Unknown type of dialog: %S" type))))
 300
 301 (provide 'dialog-gtk)