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

   1 ;;; dialog.el --- Dialog-box support for XEmacs
   2
   3 ;; Copyright (C) 1991-4, 1997 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: XEmacs Development Team
   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 ;; Dialog boxes are non-modal at the C level, but made modal at the
  32 ;; Lisp level via hacks in functions such as yes-or-no-p-dialog-box
  33 ;; below.  Perhaps there should be truly modal dialog boxes
  34 ;; implemented at the C level for safety.  All code using dialog boxes
  35 ;; should be careful to assume that the environment, for example the
  36 ;; current buffer, might be completely different after returning from
  37 ;; yes-or-no-p-dialog-box, but such code is difficult to write and test.
  38
  39 ;;; Code:
  40 (defun yes-or-no-p-dialog-box (prompt)
  41   "Ask user a yes-or-no question with a popup dialog box.
  42 Return t if the answer is \"yes\".
  43 Takes one argument, which is the string to display to ask the question."
  44   (save-selected-frame
  45     (popup-dialog-box
  46      (list prompt ["Yes" yes t] ["No" no t] nil ["Cancel" cancel t]))
  47     (let (event)
  48       (catch 'ynp-done
  49         (while t
  50           (setq event (next-command-event event))
  51           (when (misc-user-event-p event)
  52             (message "%s" (event-object event))
  53             (case (event-object event)
  54               ((yes) (throw 'ynp-done t))
  55               ((no)  (throw 'ynp-done nil))
  56               ((cancel menu-no-selection-hook) (signal 'quit nil))))
  57           (unless (button-release-event-p event) ; don't beep twice
  58             (beep)
  59             (message "please answer the dialog box")))))))
  60
  61 (defun yes-or-no-p-maybe-dialog-box (prompt)
  62   "Ask user a yes-or-no question.  Return t if answer is yes.
  63 The question is asked with a dialog box or the minibuffer, as appropriate.
  64 Takes one argument, which is the string to display to ask the question.
  65 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
  66 The user must confirm the answer with RET,
  67 and can edit it until it as been confirmed."
  68   (if (should-use-dialog-box-p)
  69       (yes-or-no-p-dialog-box prompt)
  70     (yes-or-no-p-minibuf prompt)))
  71
  72 (defun y-or-n-p-maybe-dialog-box (prompt)
  73   "Ask user a \"y or n\" question.  Return t if answer is \"y\".
  74 Takes one argument, which is the string to display to ask the question.
  75 The question is asked with a dialog box or the minibuffer, as appropriate.
  76 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
  77 No confirmation of the answer is requested; a single character is enough.
  78 Also accepts Space to mean yes, or Delete to mean no."
  79   (if (should-use-dialog-box-p)
  80       (yes-or-no-p-dialog-box prompt)
  81     (y-or-n-p-minibuf prompt)))
  82
  83 (when (fboundp 'popup-dialog-box)
  84   (fset 'yes-or-no-p 'yes-or-no-p-maybe-dialog-box)
  85   (fset 'y-or-n-p 'y-or-n-p-maybe-dialog-box))
  86
  87 ;; this is call-compatible with the horribly-named FSF Emacs function
  88 ;; `x-popup-dialog'.  I refuse to use that name.
  89 (defun get-dialog-box-response (position contents)
  90   ;; by Stig@hackvan.com
  91   ;; modified by pez@atlantic2.sbi.com
  92   "Pop up a dialog box and return user's selection.
  93 POSITION specifies which frame to use.
  94 This is normally an event or a window or frame.
  95 If POSITION is t or nil, it means to use the frame the mouse is on.
  96 The dialog box appears in the middle of the specified frame.
  97
  98 CONTENTS specifies the alternatives to display in the dialog box.
  99 It is a list of the form (TITLE ITEM1 ITEM2...).
 100 Each ITEM is a cons cell (STRING . VALUE).
 101 The return value is VALUE from the chosen item.
 102
 103 An ITEM may also be just a string--that makes a nonselectable item.
 104 An ITEM may also be nil--that means to put all preceding items
 105 on the left of the dialog box and all following items on the right."
 106   (cond
 107    ((eventp position)
 108     (select-frame (event-frame position)))
 109    ((framep position)
 110     (select-frame position))
 111    ((windowp position)
 112     (select-window position)))
 113   (let ((dbox (cons (car contents)
 114                     (mapcar #'(lambda (x)
 115                                 (cond
 116                                  ((null x)
 117                                   nil)
 118                                  ((stringp x)
 119                                   `[,x 'ignore nil]) ;this will never get
 120                                                      ;selected
 121                                  (t
 122                                   `[,(car x) (throw 'result ',(cdr x)) t])))
 123                             (cdr contents))
 124                     )))
 125     (catch 'result
 126       (popup-dialog-box dbox)
 127       (dispatch-event (next-command-event)))))
 128
 129 (defun message-box (fmt &rest args)
 130   "Display a message, in a dialog box if possible.
 131 If the selected device has no dialog-box support, use the echo area.
 132 The arguments are the same as to `format'.
 133
 134 If the only argument is nil, clear any existing message; let the
 135 minibuffer contents show."
 136   (if (and (null fmt) (null args))
 137       (progn
 138         (clear-message nil)
 139         nil)
 140     (let ((str (apply 'format fmt args)))
 141       (if (device-on-window-system-p)
 142           (get-dialog-box-response nil (list str (cons "%_OK" t)))
 143         (display-message 'message str))
 144       str)))
 145
 146 (defun message-or-box (fmt &rest args)
 147   "Display a message in a dialog box or in the echo area.\n\
 148 If this command was invoked with the mouse, use a dialog box.\n\
 149 Otherwise, use the echo area.
 150 The arguments are the same as to `format'.
 151
 152 If the only argument is nil, clear any existing message; let the
 153 minibuffer contents show."
 154   (if (should-use-dialog-box-p)
 155       (apply 'message-box fmt args)
 156     (apply 'message fmt args)))
 157
 158 (defun make-dialog-box (&optional spec props parent)
 159   "Create a frame suitable for use as a general dialog box.
 160 The frame is made a child of PARENT (defaults to the selected frame),
 161 and has additional properties PROPS, as well as `dialog-frame-plist'.
 162 SPEC is a string or glyph to be placed in the gutter. If INVISIBLE is
 163 non-nil then the frame is initially unmapped.
 164 Normally the created frame has no modelines, menubars, scrollbars,
 165 minibuffer or toolbars and is entirely covered by its gutter."
 166   (or parent (setq parent (selected-frame)))
 167   (let* ((ftop (frame-property parent 'top))
 168          (fleft (frame-property parent 'left))
 169          (fwidth (frame-pixel-width parent))
 170          (fheight (frame-pixel-height parent))
 171          (fonth (font-height (face-font 'default)))
 172          (fontw (font-width (face-font 'default)))
 173          (props (append props dialog-frame-plist))
 174          (dfheight (plist-get props 'height))
 175          (dfwidth (plist-get props 'width))
 176          (unmapped (plist-get props 'initially-unmapped))
 177          (gutter-spec spec)
 178          (name (or (plist-get props 'name) "XEmacs"))
 179          (frame nil))
 180     (plist-remprop props 'initially-unmapped)
 181     ;; allow the user to just provide a glyph
 182     (when (glyphp spec)
 183       (setq gutter-spec (copy-sequence "\n"))
 184       (set-extent-begin-glyph (make-extent 0 1 gutter-spec) spec))
 185     ;; under FVWM at least, if I don't specify the initial position,
 186     ;; it ends up always at (0, 0).  xwininfo doesn't tell me
 187     ;; that there are any program-specified position hints, so
 188     ;; it must be an FVWM bug.  So just be smashing and position
 189     ;; in the center of the selected frame.
 190     (setq frame (make-frame
 191                  (append props
 192                          `(popup ,parent initially-unmapped t
 193                                  menubar-visible-p nil
 194                                  has-modeline-p nil
 195                                  default-toolbar-visible-p nil
 196                                  top-gutter-visible-p t
 197                                  top-gutter-height ,(* dfheight fonth)
 198                                  top-gutter ,gutter-spec
 199                                  minibuffer none
 200                                  name ,name
 201                                  modeline-shadow-thickness 0
 202                                  vertical-scrollbar-visible-p nil
 203                                  horizontal-scrollbar-visible-p nil
 204                                  unsplittable t
 205                                  left ,(+ fleft (- (/ fwidth 2)
 206                                                    (/ (* dfwidth fontw)
 207                                                       2)))
 208                                  top ,(+ ftop (- (/ fheight 2)
 209                                                  (/ (* dfheight fonth)
 210                                                     2)))))))
 211     (set-face-foreground 'modeline [default foreground] frame)
 212     (set-face-background 'modeline [default background] frame)
 213     (unless unmapped (make-frame-visible frame))
 214     frame))
 215
 216
 217 ;;; dialog.el ends here