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 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))
  41         (i 0)
  42         (found-accel nil))
  43     (while (< i (length str))
  44       (let ((c (aref str i)))
  45         (cond ((eq c ?%)
  46                (setq i (1+ i))
  47                (if (and (not (eq (aref str i) ?_)) (not (eq (aref str i) ?%)))
  48                    (setq i (1- i)))
  49                (setq found-accel 1)
  50                )
  51               ((eq c ?_)
  52                 (setq new-str (concat new-str "_")))
  53                ))
  54         (setq new-str (concat new-str (string (aref str i))))
  55         (setq i (1+ i))
  56         )
  57     (if found-accel new-str (concat "_" new-str))
  58     ))
  59
  60 (defun popup-builtin-open-dialog (keys)
  61   ;; Allowed keywords are:
  62   ;;
  63   ;;  :initial-filename fname
  64   ;;  :initial-directory dir
  65   ;;  :filter-list (filter-desc filter ...)
  66   ;;  :directory t/nil
  67   ;;  :title string
  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))
  75         (clicked-ok nil)
  76         (filename nil)
  77         (widget nil))
  78     (setq widget (gtk-file-dialog-new
  79                   :directory (plist-get keys :directory)
  80                   :callback `(lambda (f)
  81                                (setq clicked-ok t
  82                                      filename f))
  83                   :initial-directory (or (plist-get keys :initial-directory nil)
  84                                          (if initial-filename
  85                                              (file-name-directory initial-filename)
  86                                            default-directory))
  87                   :filter-list (plist-to-alist
  88                                 (plist-get keys :filter-list nil))
  89                   :file-must-exist (plist-get keys :file-must-exist nil)))
  90
  91     (gtk-signal-connect widget 'destroy (lambda (obj data) (gtk-main-quit)))
  92
  93     (gtk-window-set-transient-for widget (frame-property nil 'shell-widget))
  94     (gtk-widget-show-all widget)
  95     (gtk-main)
  96     (if (not clicked-ok)
  97         (signal 'quit nil)
  98       filename)))
  99
 100 (defalias 'popup-builtin-save-as-dialog 'popup-builtin-open-dialog)
 101
 102 (defun popup-builtin-color-dialog (keys)
 103   ;; Allowed 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...")))
 107         (dialog nil)
 108         (clicked-ok nil)
 109         (color nil))
 110     (setq dialog (gtk-color-selection-dialog-new title))
 111     (gtk-signal-connect
 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)
 116              clicked-ok t)
 117        (gtk-main-quit))
 118      (gtk-color-selection-dialog-colorsel dialog))
 119
 120     (gtk-signal-connect
 121      (gtk-color-selection-dialog-cancel-button dialog) 'clicked
 122      (lambda (&rest ignored)
 123        (gtk-main-quit)))
 124
 125     (put dialog 'modal t)
 126     (put dialog 'type 'dialog)
 127     (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
 128
 129     (unwind-protect
 130         (progn
 131           (gtk-widget-show-now dialog)
 132           (gtk-main))
 133       '(gtk-widget-destroy dialog))
 134     (if (not clicked-ok)
 135         (signal 'quit nil))
 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)))))
 141
 142 (defun popup-builtin-password-dialog (keys)
 143   ;; Format is (default callback :keyword value)
 144   ;; Allowed keywords are:
 145   ;;
 146   ;;  :title string
 147   :;  :prompt string
 148   ;;  :default string
 149   ;;  :verify boolean
 150   ;;  :verify-prompt string
 151   (let* ((default (plist-get keys :default))
 152          (dialog nil)
 153          (clicked-ok nil)
 154          (passwd nil)
 155          (info nil)
 156          (generic-cb (lambda (x)
 157                        (setq clicked-ok t
 158                              passwd x))))
 159
 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))
 165
 166     ;; Clicking any button or closing the box exits the main loop.
 167     (gtk-signal-connect (gtk-password-dialog-ok-button dialog)
 168                         'clicked
 169                         (lambda (&rest ignored)
 170                           (gtk-main-quit)))
 171
 172     (gtk-signal-connect (gtk-password-dialog-cancel-button dialog)
 173                         'clicked
 174                         (lambda (&rest ignored)
 175                           (gtk-main-quit)))
 176
 177     (gtk-signal-connect dialog
 178                         'delete-event
 179                         (lambda (&rest ignored)
 180                           (gtk-main-quit)))
 181
 182     (gtk-widget-grab-focus (gtk-password-dialog-entry-widget dialog))
 183
 184     ;; Make us modal...
 185     (put dialog 'modal t)
 186     (gtk-window-set-transient-for dialog (frame-property nil 'shell-widget))
 187
 188     ;; Realize the damn thing & wait for some action...
 189     (gtk-widget-show-all dialog)
 190     (gtk-main)
 191
 192     (if (not clicked-ok)
 193         (signal 'quit nil))
 194
 195     (gtk-widget-destroy dialog)
 196     passwd))
 197
 198 (defun popup-builtin-question-dialog (keys)
 199   ;; Allowed keywords:
 200   ;;   :question STRING
 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
 207         (activep t)
 208         (callback nil)
 209         (flushrightp nil)
 210         (length nil)
 211         (label nil)
 212         (gui-button nil)
 213         (accel-group (gtk-accel-group-new))
 214         (accel-key nil)
 215         (errp t))
 216     (if (not buttons-descr)
 217         (error 'syntax-error
 218                "Dialog descriptor must supply at least one button"))
 219
 220     ;; Do the basics - create the dialog, set the window title, and
 221     ;; add the label asking the question.
 222     (unwind-protect
 223         (progn
 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))
 229
 230           ;; Create the buttons.
 231           (mapc (lambda (button)
 232                   ;; Handle flushright buttons
 233                   (if (null button)
 234                       (setq flushrightp t)
 235
 236                     ;; More sanity checking first of all.
 237                     (if (not (vectorp button))
 238                         (error "Button descriptor is not a vector: %S" button))
 239
 240                     (setq length (length button))
 241
 242                     (cond
 243                      ((= length 1)      ; [ "name" ]
 244                       (setq callback nil
 245                             activep nil))
 246                      ((= length 2)      ; [ "name" callback ]
 247                       (setq callback (aref button 1)
 248                             activep t))
 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)))))
 261
 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
 272                                                 accel-key
 273                                                 8 ; GDK_MOD1_MASK
 274                                                 4 ; GTK_ACCEL_LOCKED
 275                                                 )
 276
 277                     (push gui-button buttons)
 278                     (gtk-widget-set-sensitive (car buttons) (eval activep))
 279
 280                     ;; Apply the callback
 281                     (gtk-signal-connect
 282                      (car buttons) 'clicked
 283                      (lambda (button data)
 284                        (push (make-event 'misc-user
 285                                          (list 'object (car data)
 286                                                'function
 287                                                (if (symbolp (car data))
 288                                                    'call-interactively
 289                                                  'eval)))
 290                              unread-command-events)
 291                        (gtk-main-quit)
 292                        t)
 293                      (cons callback dialog))
 294
 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)
 298                              nil t 2)))
 299                 buttons-descr)
 300
 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)
 308
 309           (gtk-widget-show-all dialog)
 310           (gtk-main)
 311           (gtk-widget-destroy dialog)
 312           (setq errp nil))
 313       (if (not errp)
 314           ;; Nothing, we successfully showed the dialog
 315           nil
 316         ;; We need to destroy all the widgets, just in case.
 317         (mapc 'gtk-widget-destroy buttons)
 318         (gtk-widget-destroy dialog)))))
 319
 320 (defun gtk-make-dialog-box-internal (type keys)
 321   (case type
 322     (file
 323      (popup-builtin-open-dialog keys))
 324     (password
 325      (popup-builtin-password-dialog keys))
 326     (question
 327      (popup-builtin-question-dialog keys))
 328     (color
 329      (popup-builtin-color-dialog keys))
 330     (find
 331      )
 332     (font
 333      )
 334     (replace
 335      )
 336     (mswindows-message
 337      ;; This should really be renamed!
 338      )
 339     (print
 340      )
 341     (page-setup
 342      )
 343     (print-setup
 344      )
 345     (default
 346       (error "Unknown type of dialog: %S" type))))
 347
 348 (provide 'dialog-gtk)