cgit.sxemacs.org Git - sxemacs/blob - lisp/dialog.el

   1 ;;; dialog.el --- Dialog-box support for XEmacs
   2
   3 ;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 2000 Ben Wing.
   5
   6 ;; Maintainer: SXEmacs Development Team
   7 ;; Keywords: extensions, internal, dumped
   8
   9 ;; This file is part of SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not in FSF.
  25
  26 ;;; Commentary:
  27
  28 ;; This file is dumped with SXEmacs (when dialog boxes are compiled in).
  29
  30 ;; Dialog boxes are non-modal at the C level, but made modal at the
  31 ;; Lisp level via hacks in functions such as yes-or-no-p-dialog-box
  32 ;; below.  Perhaps there should be truly modal dialog boxes
  33 ;; implemented at the C level for safety.  All code using dialog boxes
  34 ;; should be careful to assume that the environment, for example the
  35 ;; current buffer, might be completely different after returning from
  36 ;; yes-or-no-p-dialog-box, but such code is difficult to write and test.
  37
  38 ;;; Code:
  39 (defun yes-or-no-p-dialog-box (prompt)
  40   "Ask user a yes-or-no question with a popup dialog box.
  41 Return t if the answer is \"yes\", nil if \"no\".  Takes one argument,
  42 the question string to display."
  43   (save-selected-frame
  44     (make-dialog-box 'question
  45                      :question prompt
  46                      :modal t
  47                      :buttons '(["Yes" (dialog-box-finish t)]
  48                                 ["No" (dialog-box-finish nil)]
  49                                 nil
  50                                 ["Cancel" (dialog-box-cancel)]))))
  51
  52 ;; FSF has a similar function `x-popup-dialog'.
  53 (defun get-dialog-box-response (position contents)
  54   "Pop up a dialog box and return user's selection.
  55 POSITION specifies which frame to use.
  56 This is normally an event or a window or frame.
  57 If POSITION is t or nil, it means to use the frame the mouse is on.
  58 The dialog box appears in the middle of the specified frame.
  59
  60 CONTENTS specifies the alternatives to display in the dialog box.
  61 It is a list of the form (TITLE ITEM1 ITEM2...).
  62 Each ITEM is a cons cell (STRING . VALUE).
  63 The return value is VALUE from the chosen item.
  64
  65 An ITEM may also be just a string--that makes a nonselectable item.
  66 An ITEM may also be nil--that means to put all preceding items
  67 on the left of the dialog box and all following items on the right."
  68   (cond
  69    ((eventp position)
  70     (select-frame (event-frame position)))
  71    ((framep position)
  72     (select-frame position))
  73    ((windowp position)
  74     (select-window position)))
  75   (make-dialog-box 'question
  76                    :question (car contents)
  77                    :modal t
  78                    :buttons
  79                    (mapcar #'(lambda (x)
  80                                (cond
  81                                 ((null x)
  82                                  nil)
  83                                 ((stringp x)
  84                                  ;;this will never get selected
  85                                  `[,x 'ignore nil])
  86                                 (t
  87                                  `[,(car x) (dialog-box-finish ',(cdr x)) t])))
  88                            (cdr contents))))
  89
  90 (defun message-box (fmt &rest args)
  91   "Display a message, in a dialog box if possible.
  92 If the selected device has no dialog-box support, use the echo area.
  93 The arguments are the same as to `format'.
  94
  95 If the only argument is nil, clear any existing message; let the
  96 minibuffer contents show."
  97   (if (and (null fmt) (null args))
  98       (progn
  99         (clear-message nil)
 100         nil)
 101     (let ((str (apply 'format fmt args)))
 102       (if (device-on-window-system-p)
 103           (get-dialog-box-response nil (list str (cons "%_OK" t)))
 104         (display-message 'message str))
 105       str)))
 106
 107 (defun message-or-box (fmt &rest args)
 108   "Display a message in a dialog box or in the echo area.
 109 If this command was invoked with the mouse, use a dialog box.
 110 Otherwise, use the echo area.
 111 The arguments are the same as to `format'.
 112
 113 If the only argument is nil, clear any existing message; let the
 114 minibuffer contents show."
 115   (if (should-use-dialog-box-p)
 116       (apply 'message-box fmt args)
 117     (apply 'message fmt args)))
 118
 119 (defun make-dialog-box (type &rest cl-keys)
 120   "Pop up a dialog box.
 121 TYPE is a symbol, the type of dialog box.  Remaining arguments are
 122 keyword-value pairs, specifying the particular characteristics of the
 123 dialog box.  The allowed keywords are particular to each type, but
 124 some standard keywords are common to many types:
 125
 126 :title
 127   The title of the dialog box's window.
 128
 129 :modal
 130   If true, indicates that XEmacs will wait until the user is \"done\"
 131   with the dialog box (usually, this means that a response has been
 132   given).  Typically, the response is returned.  NOTE: Some dialog
 133   boxes are always modal.  If the dialog box is modal, `make-dialog-box'
 134   returns immediately.  The return value will be either nil or a
 135   dialog box handle of some sort, e.g. a frame for type `general'.
 136
 137 ---------------------------------------------------------------------------
 138
 139 Recognized types are
 140
 141 general
 142   A dialog box consisting of an XEmacs glyph, typically a `layout'
 143   widget specifying a dialog box arrangement.  This is the most
 144   general and powerful dialog box type, but requires more work than
 145   the other types below.
 146
 147 question
 148   A simple dialog box that displays a question and contains one or
 149   more user-defined buttons to specify possible responses. (This is
 150   compatible with the old built-in dialog boxes formerly specified
 151   using `popup-dialog-box'.)
 152
 153 file
 154   A file dialog box, of the type typically used in the window system
 155   XEmacs is running on.
 156
 157 color
 158   A color picker.
 159
 160 find
 161   A find dialog box.
 162
 163 font
 164   A font chooser.
 165
 166 print
 167   A dialog box used when printing (e.g. number of pages, printer).
 168
 169 page-setup
 170   A dialog box for setting page options (e.g. margins) for printing.
 171
 172 replace
 173   A find/replace dialog box.
 174
 175 ---------------------------------------------------------------------------
 176
 177 For type `general':
 178
 179 This type creates a frame and puts the specified widget layout in it.
 180 \(Currently this is done by eliminating all areas but the gutter and placing
 181 the layout there; but this is an implementation detail and may change.)
 182
 183 The keywords allowed for `general' are
 184
 185 :spec
 186   The widget spec -- anything that can be passed to `make-glyph'.
 187 :title
 188   The title of the frame.
 189 :parent
 190   The frame is made a child of this frame (defaults to the selected frame).
 191 :properties
 192   Additional properties of the frame, as well as `dialog-frame-plist'.
 193 :autosize
 194   If t the frame is sized to exactly fit the widgets given by :spec.
 195
 196 ---------------------------------------------------------------------------
 197
 198 For type `question':
 199
 200 The keywords allowed are
 201
 202 :modal
 203   t or nil.  When t, the dialog box callback should exit the dialog box
 204   using the functions `dialog-box-finish' or `dialog-box-cancel'.
 205 :title
 206   The title of the frame.
 207 :question
 208   A string, the question.
 209 :buttons
 210   A list, describing the buttons below the question.  Each of these is a
 211   vector, the syntax of which is essentially the same as that of popup menu
 212   items.  They may have any of the following forms:
 213
 214    [ \"name\" callback <active-p> ]
 215    [ \"name\" callback <active-p> \"suffix\" ]
 216    [ \"name\" callback :<keyword> <value>  :<keyword> <value> ... ]
 217
 218   The name is the string to display on the button; it is filtered through the
 219   resource database, so it is possible for resources to override what string
 220   is actually displayed.
 221
 222   Accelerators can be indicated in the string by putting the sequence
 223   \"%_\" before the character corresponding to the key that will invoke
 224   the button.  Uppercase and lowercase accelerators are equivalent.  The
 225   sequence \"%%\" is also special, and is translated into a single %.
 226
 227   If the `callback' of a button is a symbol, then it must name a command.
 228   It will be invoked with `call-interactively'.  If it is a list, then it is
 229   evaluated with `eval'.
 230
 231   One (and only one) of the buttons may be `nil'.  This marker means that all
 232   following buttons should be flushright instead of flushleft.
 233
 234   Though the keyword/value syntax is supported for dialog boxes just as in
 235   popup menus, the only keyword which is both meaningful and fully implemented
 236   for dialog box buttons is `:active'.
 237
 238 ---------------------------------------------------------------------------
 239
 240 For type `file':
 241
 242 The keywords allowed are
 243
 244 :initial-filename
 245   The initial filename to be placed in the dialog box (defaults to nothing).
 246 :initial-directory
 247   The initial directory to be selected in the dialog box (defaults to the
 248   current buffer's `default-directory).
 249 :filter-list
 250   A list of                     (filter-desc filter ...)
 251 :title
 252   The title of the dialog box (defaults to \"Open\").
 253 :allow-multi-select             t or nil
 254 :create-prompt-on-nonexistent   t or nil
 255 :overwrite-prompt               t or nil
 256 :file-must-exist                t or nil
 257 :no-network-button              t or nil
 258 :no-read-only-return            t or nil
 259
 260 ---------------------------------------------------------------------------
 261
 262 For type `directory':
 263
 264 The keywords allowed are
 265
 266 :initial-directory
 267   The initial directory to be selected in the dialog box (defaults to the
 268   current buffer's `default-directory).
 269 :title
 270   The title of the dialog box (defaults to \"Open\").
 271
 272 ---------------------------------------------------------------------------
 273
 274 For type `print':
 275
 276 This invokes the Windows standard Print dialog.
 277 This dialog is usually invoked when the user selects the Print command.
 278 After the user presses OK, the program should start actual printout.
 279
 280 The keywords allowed are
 281
 282 :device
 283   An 'msprinter device.
 284 :print-settings
 285   A printer settings object.
 286 :allow-selection
 287   t or nil -- whether the \"Selection\" button is enabled (defaults to nil).
 288 :allow-pages
 289   t or nil -- whether the \"Pages\" button and associated edit controls
 290   are enabled (defaults to t).
 291 :selected-page-button
 292   `all', `selection', or `pages' -- which page button is initially
 293   selected.
 294
 295 Exactly one of :device and :print-settings must be given.
 296
 297 The function brings up the Print dialog, where the user can
 298 select a different printer and/or change printer options.  Connection
 299 name can change as a result of selecting a different printer device.  If
 300 a device is specified, then changes are stored into the settings object
 301 currently selected into that printer.  If a settings object is supplied,
 302 then changes are recorded into it, and, it is selected into a
 303 printer, then changes are propagated to that printer
 304 too.
 305
 306 Return value is nil if the user has canceled the dialog.  Otherwise, it
 307 is a new plist, with the following properties:
 308   name                   Printer device name, even if unchanged by the user.
 309   from-page              First page to print, 1-based.  Returned if
 310                          `selected-page-button' is `pages'.
 311                          user, then this value is not included in the plist.
 312   to-page                Last page to print, inclusive, 1-based.  Returned if
 313                          `selected-page-button' is `pages'.
 314   copies                 Number of copies to print.  Always returned.
 315   selected-page-button   Which page button was selected (`all', `selection',
 316                          or `pages').
 317
 318 The DEVICE is destroyed and an error is signaled in case of
 319 initialization problem with the new printer.
 320
 321 See also the `page-setup' dialog box type.
 322
 323 ---------------------------------------------------------------------------
 324
 325 For type `page-setup':
 326
 327 This invokes the Windows standard Page Setup dialog.
 328 This dialog is usually invoked in response to the Page Setup command,
 329 and used to choose such parameters as page orientation, print margins
 330 etc.  Note that this dialog contains the \"Printer\" button, which
 331 invokes the Printer Setup dialog so that the user can update the
 332 printer options or even select a different printer as well.
 333
 334 The keywords allowed are
 335
 336 :device
 337   An 'msprinter device.
 338 :print-settings
 339   A printer settings object.
 340 :properties
 341   A plist of job properties.
 342
 343 Exactly one of these keywords must be given.
 344
 345 The function brings up the Page Setup dialog, where the user
 346 can select a different printer and/or change printer options.
 347 Connection name can change as a result of selecting a different printer
 348 device.  If a device is specified, then changes are stored into the
 349 settings object currently selected into that printer.  If a settings
 350 object is supplied, then changes are recorded into it, and, it is
 351 selected into a printer, then changes are propagated to that printer
 352 too.
 353
 354 :properties specifies a plist of job properties;
 355 see `default-msprinter-frame-plist' for the complete list.  The plist
 356 is used to initialize the dialog.
 357
 358 Return value is nil if the user has canceled the dialog.  Otherwise,
 359 it is a new plist, containing the new list of properties.
 360
 361 NOTE: The margin properties (returned by this function) are *NOT* stored
 362 into the print-settings or device object.
 363
 364 The DEVICE is destroyed and an error is signaled in case of
 365 initialization problem with the new printer.
 366
 367 See also the `print' dialog box type."
 368   (flet ((dialog-box-modal-loop (thunk)
 369            (let* ((frames (frame-list))
 370                   (result
 371                    ;; ok, this is extremely tricky.  normally a modal
 372                    ;; dialog will pop itself down using (dialog-box-finish)
 373                    ;; or (dialog-box-cancel), which throws back to this
 374                    ;; catch.  but question dialog boxes pop down themselves
 375                    ;; regardless, so a badly written question dialog box
 376                    ;; that does not use (dialog-box-finish) could seriously
 377                    ;; wedge us.  furthermore, we disable all other frames
 378                    ;; in order to implement modality; we need to restore
 379                    ;; them before the dialog box is destroyed, because
 380                    ;; otherwise windows at least will notice that no top-
 381                    ;; level window can have the focus and will shift the
 382                    ;; focus to a different app, raising it and obscuring us.
 383                    ;; so we create `delete-dialog-box-hook', which is
 384                    ;; called right *before* the dialog box gets destroyed.
 385                    ;; here, we put a hook on it, and when it's our dialog
 386                    ;; box and not someone else's that's being destroyed,
 387                    ;; we reenable all the frames and remove the hook.
 388                    ;; BUT ...  we still have to deal with exiting the
 389                    ;; modal loop in case it doesn't happen before us.
 390                    ;; we can't do this until after the callbacks for this
 391                    ;; dialog box get executed, and that doesn't happen until
 392                    ;; after the dialog box is destroyed.  so to keep things
 393                    ;; synchronous, we enqueue an eval event, which goes into
 394                    ;; the same queue as the misc-user events encapsulating
 395                    ;; the dialog callbacks and will go after it (because
 396                    ;; destroying the dialog box happens after processing
 397                    ;; its selection).  if the dialog boxes are written
 398                    ;; properly, we don't see this eval event, because we've
 399                    ;; already exited our modal loop. (Thus, we make sure the
 400                    ;; function given in this eval event is actually defined
 401                    ;; and does nothing.) If we do see it, though, we know
 402                    ;; that we encountered a badly written dialog box and
 403                    ;; need to exit now.  Currently we just return nil, but
 404                    ;; maybe we should signal an error or issue a warning.
 405                    (catch 'internal-dialog-box-finish
 406                      (let ((id (eval thunk))
 407                            (sym (gensym)))
 408                        (fset sym
 409                              `(lambda (did)
 410                                 (when (eq ',id did)
 411                                   (mapc 'enable-frame ',frames)
 412                                   (enqueue-eval-event
 413                                    'internal-make-dialog-box-exit did)
 414                                   (remove-hook 'delete-dialog-box-hook
 415                                                ',sym))))
 416                        (if (framep id)
 417                            (add-hook 'delete-frame-hook sym)
 418                          (add-hook 'delete-dialog-box-hook sym))
 419                        (mapc 'disable-frame frames)
 420                        (block nil
 421                          (while t
 422                            (let ((event (next-event)))
 423                              (if (and (eval-event-p event)
 424                                       (eq (event-function event)
 425                                           'internal-make-dialog-box-exit)
 426                                       (eq (event-object event) id))
 427                                  (return '(nil))
 428                                (dispatch-event event)))))))))
 429              (if (listp result)
 430                  (car result)
 431                (signal 'quit nil)))))
 432     (case type
 433       (general
 434         (cl-parsing-keywords
 435             ((:title "XEmacs")
 436              (:parent (selected-frame))
 437              :modal
 438              :properties
 439              :autosize
 440              :spec)
 441             ()
 442           (flet ((create-dialog-box-frame ()
 443                    (let* ((ftop (frame-property cl-parent 'top))
 444                           (fleft (frame-property cl-parent 'left))
 445                           (fwidth (frame-pixel-width cl-parent))
 446                           (fheight (frame-pixel-height cl-parent))
 447                           (fonth (font-height (face-font 'default)))
 448                           (fontw (font-width (face-font 'default)))
 449                           (cl-properties (append cl-properties
 450                                                  dialog-frame-plist))
 451                           (dfheight (plist-get cl-properties 'height))
 452                           (dfwidth (plist-get cl-properties 'width))
 453                           (unmapped (plist-get cl-properties
 454                                                'initially-unmapped))
 455                           (gutter-spec cl-spec)
 456                           (name (or (plist-get cl-properties 'name) "XEmacs"))
 457                           (frame nil))
 458                      (plist-remprop cl-properties 'initially-unmapped)
 459                      ;; allow the user to just provide a glyph
 460                      (or (glyphp cl-spec) (setq cl-spec (make-glyph cl-spec)))
 461                      (setq gutter-spec (copy-sequence "\n"))
 462                      (set-extent-begin-glyph (make-extent 0 1 gutter-spec)
 463                                              cl-spec)
 464                      ;; under FVWM at least, if I don't specify the
 465                      ;; initial position, it ends up always at (0, 0).
 466                      ;; xwininfo doesn't tell me that there are any
 467                      ;; program-specified position hints, so it must be
 468                      ;; an FVWM bug.  So just be smashing and position in
 469                      ;; the center of the selected frame.
 470                      (setq frame
 471                            (make-frame
 472                             (append cl-properties
 473                                     `(popup ,cl-parent initially-unmapped t
 474                                             menubar-visible-p nil
 475                                             has-modeline-p nil
 476                                             default-toolbar-visible-p nil
 477                                             top-gutter-visible-p t
 478                                             top-gutter-height ,
 479                                             (* dfheight fonth)
 480                                             top-gutter ,gutter-spec
 481                                             minibuffer none
 482                                             name ,name
 483                                             modeline-shadow-thickness 0
 484                                             vertical-scrollbar-visible-p nil
 485                                             horizontal-scrollbar-visible-p nil
 486                                             unsplittable t
 487                                             internal-border-width 8
 488                                             left ,(+ fleft (- (/ fwidth 2)
 489                                                               (/ (* dfwidth
 490                                                                     fontw)
 491                                                                  2)))
 492                                             top ,(+ ftop (- (/ fheight 2)
 493                                                             (/ (* dfheight
 494                                                                   fonth)
 495                                                                2)))))))
 496                      (set-face-foreground 'modeline [default foreground] frame)
 497                      (set-face-background 'modeline [default background] frame)
 498                      ;; resize before mapping
 499                      (when cl-autosize
 500                        (set-frame-pixel-size
 501                         frame
 502                         (image-instance-width
 503                          (glyph-image-instance cl-spec
 504                                                (frame-selected-window frame)))
 505                         (image-instance-height
 506                          (glyph-image-instance cl-spec
 507                                                (frame-selected-window frame)))))
 508                      ;; somehow, even though the resizing is supposed
 509                      ;; to be while the frame is not visible, a
 510                      ;; visible resize is perceptible
 511                      (unless unmapped (make-frame-visible frame))
 512                      (let ((newbuf (generate-new-buffer " *dialog box*")))
 513                        (set-buffer-dedicated-frame newbuf frame)
 514                        (set-frame-property frame 'dialog-box-buffer newbuf)
 515                        (set-window-buffer (frame-root-window frame) newbuf)
 516                        (with-current-buffer newbuf
 517                          (set (make-local-variable 'frame-title-format)
 518                               cl-title)
 519                          (add-local-hook 'delete-frame-hook
 520                                          #'(lambda (frame)
 521                                              (kill-buffer
 522                                               (frame-property
 523                                                frame
 524                                                'dialog-box-buffer))))))
 525                      frame)))
 526             (if cl-modal
 527                 (dialog-box-modal-loop '(create-dialog-box-frame))
 528               (create-dialog-box-frame)))))
 529       (question
 530         (cl-parsing-keywords
 531             ((:modal nil))
 532             t
 533           (remf cl-keys :modal)
 534           (if cl-modal
 535               (dialog-box-modal-loop `(make-dialog-box-internal ',type
 536                                                                 ',cl-keys))
 537             (make-dialog-box-internal type cl-keys))))
 538       (t
 539         (make-dialog-box-internal type cl-keys)))))
 540
 541 (defun dialog-box-finish (result)
 542   "Exit a modal dialog box, returning RESULT.
 543 This is meant to be executed from a dialog box callback function."
 544   (throw 'internal-dialog-box-finish (list result)))
 545
 546 (defun dialog-box-cancel ()
 547   "Cancel a modal dialog box.
 548 This is meant to be executed from a dialog box callback function."
 549   (throw 'internal-dialog-box-finish 'cancel))
 550
 551 ;; an eval event, used as a trigger inside of the dialog modal loop.
 552 (defun internal-make-dialog-box-exit (did)
 553   nil)
 554
 555 (make-obsolete 'popup-dialog-box 'make-dialog-box)
 556 (defun popup-dialog-box (desc)
 557   "Obsolete equivalent of (make-dialog-box 'question ...).
 558
 559 \(popup-dialog-box (QUESTION BUTTONS ...)
 560
 561 is equivalent to
 562
 563 \(make-dialog-box 'question :question QUESTION :buttons BUTTONS)"
 564   (check-argument-type 'stringp (car desc))
 565   (or (consp (cdr desc))
 566       (error 'syntax-error
 567              "Dialog descriptor must supply at least one button"
 568              desc))
 569   (make-dialog-box 'question :question (car desc) :buttons (cdr desc)))
 570
 571 ;;; dialog.el ends here