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

   1 ;;; gui.el --- Basic GUI functions for SXEmacs.
   2
   3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1996 Ben Wing
   5
   6 ;; Maintainer: SXEmacs Development Team
   7 ;; Keywords: 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 window system support is compiled in).
  29
  30 ;;; Code:
  31
  32 (defcustom dialog-frame-plist '(width 60 height 20)
  33   "Plist of frame properties for initially creating a dialog frame.
  34 Properties specified here supersede the values given in
  35 `default-frame-plist'."
  36   :type 'plist
  37   :group 'frames)
  38
  39 (defun make-dialog-frame (&optional props parent)
  40   "Create a frame suitable for use as a dialog box.
  41 The frame is made a child of PARENT (defaults to the selected frame),
  42 and has additional properties PROPS, as well as `dialog-frame-plist'.
  43 Normally it also has no modelines, menubars, or toolbars."
  44   (or parent (setq parent (selected-frame)))
  45   (let* ((ftop (frame-property parent 'top))
  46          (fleft (frame-property parent 'left))
  47          (fwidth (frame-pixel-width parent))
  48          (fheight (frame-pixel-height parent))
  49          (fonth (font-height (face-font 'default)))
  50          (fontw (font-width (face-font 'default)))
  51          (props (append props dialog-frame-plist))
  52          (dfheight (plist-get props 'height))
  53          (dfwidth (plist-get props 'width))
  54          ;; under FVWM at least, if I don't specify the initial position,
  55          ;; it ends up always at (0, 0).  xwininfo doesn't tell me
  56          ;; that there are any program-specified position hints, so
  57          ;; it must be an FVWM bug.  So just be smashing and position
  58          ;; in the center of the selected frame.
  59          (frame (make-frame
  60                  (append props
  61                          `(popup ,parent initially-unmapped t
  62                                  menubar-visible-p nil
  63                                  has-modeline-p nil
  64                                  default-toolbar-visible-p nil
  65                                  default-gutter-visible-p nil
  66                                  modeline-shadow-thickness 0
  67                                  left ,(+ fleft (- (/ fwidth 2)
  68                                                    (/ (* dfwidth fontw)
  69                                                       2)))
  70                                  top ,(+ ftop (- (/ fheight 2)
  71                                                  (/ (* dfheight fonth)
  72                                                     2))))))))
  73     (set-face-foreground 'modeline [default foreground] frame)
  74     (set-face-background 'modeline [default background] frame)
  75     (make-frame-visible frame)
  76     frame))
  77
  78 (defvar gui-button-shadow-thickness 2)
  79
  80 (defun gui-button-p (object)
  81   "True if OBJECT is a GUI button."
  82   (and (vectorp object)
  83        (> (length object) 0)
  84        (eq 'button (aref object 0))))
  85
  86 (make-face 'gui-button-face "Face used for gui buttons")
  87 (if (not (face-differs-from-default-p 'gui-button-face))
  88     (progn
  89       (set-face-reverse-p 'gui-button-face t)
  90       (set-face-background 'gui-button-face '(((x color) . "grey75")))
  91       (set-face-foreground 'gui-button-face '(((x color) . "black")))))
  92
  93
  94 (defun gui-button-action (instance action user-data)
  95   (let ((domain (image-instance-domain instance)))
  96     (with-current-buffer (if (windowp domain)
  97                              (window-buffer domain) nil)
  98       (funcall action user-data))))
  99
 100 (defun make-gui-button (string &optional action user-data)
 101   "Make a GUI button whose label is STRING and whose action is ACTION.
 102 If the button is inserted in a buffer and then clicked on, and ACTION
 103 is non-nil, ACTION will be called with one argument, USER-DATA.
 104 When ACTION is called, the buffer containing the button is made current."
 105   (vector 'button
 106           :descriptor string
 107           :face 'gui-button-face
 108           :callback-ex `(lambda (image-instance event)
 109                           (gui-button-action image-instance
 110                                              (quote ,action)
 111                                              (quote ,user-data)))))
 112
 113 (defun insert-gui-button (button &optional pos buffer)
 114   "Insert GUI button BUTTON at POS in BUFFER."
 115   (check-argument-type 'gui-button-p button)
 116   (declare-fboundp (make-annotation (make-glyph button)
 117                                     pos 'text buffer nil)))
 118
 119 ;;; gui.el ends here