cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/devices.el

   1 ;;; devices.el -- XEmacs device API emulation
   2 ;; Author: $Author: wmperry $
   3 ;; Created: $Date: 2002/02/01 17:42:48 $
   4 ;; Version: $Revision: 1.4 $
   5 ;; Keywords:
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29
  30 ;; This is a complete implementation of all the device-* functions found in
  31 ;; XEmacs 19.14.  A 'device' for Emacs 19 is just a frame, from which we can
  32 ;; determine the connection to an X display, etc.
  33
  34 (eval-when-compile
  35   (require 'cl)
  36   (when (featurep 'xemacs)
  37     (set 'byte-optimize nil)))
  38
  39 (when (not (featurep 'xemacs))
  40   (defalias 'selected-device 'ignore)
  41   (defalias 'device-or-frame-p 'framep)
  42   (defalias 'device-console 'ignore)
  43   (defalias 'device-sound-enabled-p 'ignore)
  44   (defalias 'device-live-p 'frame-live-p)
  45   (defalias 'devicep 'framep)
  46   (defalias 'frame-device 'identity)
  47   (defalias 'redisplay-device 'redraw-frame)
  48   (defalias 'redraw-device 'redraw-frame)
  49   (defalias 'select-device 'select-frame)
  50   (defalias 'set-device-class 'ignore)
  51
  52   (defun make-device (type connection &optional props)
  53     "Create a new device of type TYPE, attached to connection CONNECTION.
  54
  55 The valid values for CONNECTION are device-specific; however,
  56 CONNECTION is generally a string. (Specifically, for X devices,
  57 CONNECTION should be a display specification such as \"foo:0\", and
  58 for TTY devices, CONNECTION should be the filename of a TTY device
  59 file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard
  60 input/output.)
  61
  62 PROPS, if specified, should be a plist of properties controlling
  63 device creation.
  64
  65 If CONNECTION specifies an already-existing device connection, that
  66 device is simply returned; no new device is created, and PROPS
  67 have no effect."
  68     (cond
  69      ((and (eq type 'x) connection)
  70       (make-frame-on-display connection props))
  71      ((eq type 'x)
  72       (make-frame props))
  73      ((eq type 'tty)
  74       nil)
  75      (t
  76       (error "Unsupported device-type: %s" type))))
  77
  78   (defun make-frame-on-device (type connection &optional props)
  79     "Create a frame of type TYPE on CONNECTION.
  80 TYPE should be a symbol naming the device type, i.e. one of
  81
  82 x       An X display.  CONNECTION should be a standard display string
  83         such as \"unix:0\", or nil for the display specified on the
  84         command line or in the DISPLAY environment variable.  Only if
  85         support for X was compiled into XEmacs.
  86 tty     A standard TTY connection or terminal.  CONNECTION should be
  87         a TTY device name such as \"/dev/ttyp2\" (as determined by
  88         the Unix command `tty') or nil for XEmacs' standard input
  89         and output (usually the TTY in which XEmacs started).  Only
  90         if support for TTY's was compiled into XEmacs.
  91 ns      A connection to a machine running the NeXTstep windowing
  92         system.  Not currently implemented.
  93 win32   A connection to a machine running Microsoft Windows NT or
  94         Windows 95.  Not currently implemented.
  95 pc      A direct-write MS-DOS frame.  Not currently implemented.
  96
  97 PROPS should be an plist of properties, as in the call to `make-frame'.
  98
  99 If a connection to CONNECTION already exists, it is reused; otherwise,
 100 a new connection is opened."
 101     (make-device type connection props))
 102
 103   (defun make-tty-device (&optional tty terminal-type)
 104     "Create a new device on TTY.
 105   TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under
 106 SunOS et al.), as returned by the `tty' command.  A value of nil means
 107 use the stdin and stdout as passed to XEmacs from the shell.
 108   If TERMINAL-TYPE is non-nil, it should be a string specifying the
 109 type of the terminal attached to the specified tty.  If it is nil,
 110 the terminal type will be inferred from the TERM environment variable."
 111     (make-device 'tty tty (list 'terminal-type terminal-type)))
 112
 113   (defun make-x-device (&optional display)
 114     (make-device 'x display))
 115
 116   (defun set-device-selected-frame (device frame)
 117     "Set the selected frame of device object DEVICE to FRAME.
 118 If DEVICE is nil, the selected device is used.
 119 If DEVICE is the selected device, this makes FRAME the selected frame."
 120     (select-frame frame))
 121
 122   (defun set-device-baud-rate (device rate)
 123     "Set the output baud rate of DEVICE to RATE.
 124 On most systems, changing this value will affect the amount of padding
 125 and other strategic decisions made during redisplay."
 126     (setq baud-rate rate))
 127
 128   (defun dfw-device (obj)
 129     "Given a device, frame, or window, return the associated device.
 130 Return nil otherwise."
 131     (cond
 132      ((windowp obj)
 133       (window-frame obj))
 134      ((framep obj)
 135       obj)
 136      (t
 137       nil)))
 138
 139   (defun event-device (event)
 140     "Return the device that EVENT occurred on.
 141 This will be nil for some types of events (e.g. keyboard and eval events)."
 142     (dfw-device (posn-window (event-start event))))
 143
 144   (defun device-connection (&optional device)
 145     "Return the connection of the specified device.
 146 DEVICE defaults to the selected device if omitted"
 147     (or (cdr-safe (assq 'display (frame-parameters device))) "stdio"))
 148
 149   (defun find-device (connection &optional type)
 150     "Look for an existing device attached to connection CONNECTION.
 151 Return the device if found; otherwise, return nil.
 152
 153 If TYPE is specified, only return devices of that type; otherwise,
 154 return devices of any type. (It is possible, although unlikely,
 155 that two devices of different types could have the same connection
 156 name; in such a case, the first device found is returned.)"
 157     (let ((devices (device-list))
 158           (retval nil))
 159       (while (and devices (not nil))
 160         (if (equal connection (device-connection (car devices)))
 161             (setq retval (car devices)))
 162         (setq devices (cdr devices)))
 163       retval))
 164
 165   (defalias 'get-device 'find-device)
 166
 167   (defmacro device-baud-rate (&optional device)
 168     "Return the output baud rate of DEVICE."
 169     'baud-rate)
 170
 171   (defun device-on-window-system-p (&optional device)
 172     "Return non-nil if DEVICE is on a window system.
 173 This generally means that there is support for the mouse, the menubar,
 174 the toolbar, glyphs, etc."
 175     (and (cdr-safe (assq 'display (frame-parameters device))) t))
 176
 177   (defun device-name (&optional device)
 178     "Return the name of the specified device."
 179     (or (cdr-safe (assq 'display (frame-parameters device))) "stdio"))
 180
 181   (defun device-frame-list (&optional device)
 182     "Return a list of all frames on DEVICE.
 183 If DEVICE is nil, the selected device will be used."
 184     (let ((desired (device-connection device)))
 185       (filtered-frame-list (function (lambda (x) (equal (device-connection x)
 186                                                         desired))))))
 187   (defun device-list ()
 188     "Return a list of all devices"
 189     (let ((seen nil)
 190           (cur nil)
 191           (conn nil)
 192           (retval nil)
 193           (not-heard (frame-list)))
 194       (while not-heard
 195         (setq cur (car not-heard)
 196               conn (device-connection cur)
 197               not-heard (cdr not-heard))
 198         (if (member conn seen)
 199             nil                         ; Already got it
 200           (setq seen (cons conn seen)   ; Whoo hoo, a new one!
 201                 retval (cons cur retval))))
 202       retval))
 203
 204   (defvar delete-device-hook nil
 205     "Function or functions to call when a device is deleted.
 206 One argument, the to-be-deleted device.")
 207
 208   (defun delete-device (device &optional force)
 209     "Delete DEVICE, permanently eliminating it from use.
 210 Normally, you cannot delete the last non-minibuffer-only frame (you must
 211 use `save-buffers-kill-emacs' or `kill-emacs').  However, if optional
 212 second argument FORCE is non-nil, you can delete the last frame. (This
 213 will automatically call `save-buffers-kill-emacs'.)"
 214     (let ((frames (device-frame-list device)))
 215       (run-hook-with-args 'delete-device-hook device)
 216       (while frames
 217         (delete-frame (car frames) force)
 218         (setq frames (cdr frames)))))
 219
 220   (defun device-color-cells (&optional device)
 221     (case window-system
 222       ((x win32 w32 pm) (x-display-color-cells device))
 223       (otherwise 1)))
 224
 225   (defun device-pixel-width (&optional device)
 226     (case window-system
 227       ((x win32 w32 pm) (x-display-pixel-width device))
 228       (otherwise (frame-width device))))
 229
 230   (defun device-pixel-height (&optional device)
 231     (case window-system
 232       ((x win32 w32 pm) (x-display-pixel-height device))
 233       (otherwise (frame-height device))))
 234
 235   (defun device-mm-width (&optional device)
 236     (case window-system
 237       ((x win32 w32 pm) (x-display-mm-width device))
 238       (otherwise nil)))
 239
 240   (defun device-mm-height (&optional device)
 241     (case window-system
 242       ((x win32 w32 pm) (x-display-mm-height device))
 243       (otherwise nil)))
 244
 245   (defun device-bitplanes (&optional device)
 246     (case window-system
 247       ((x win32 w32 pm) (x-display-planes device))
 248       (otherwise 2)))
 249
 250   (defun device-class (&optional device)
 251     (if (fboundp 'display-color-p)
 252         (if (display-color-p device)
 253             'color
 254           (if (display-grayscale-p device)
 255               'grayscale
 256             'mono))
 257       (case window-system
 258         (x                              ; X11
 259          (cond
 260           ((fboundp 'x-display-visual-class)
 261            (let ((val (symbol-name (x-display-visual-class device))))
 262              (cond
 263               ((string-match "color" val) 'color)
 264               ((string-match "gray-scale" val) 'grayscale)
 265               (t 'mono))))
 266           ((fboundp 'x-display-color-p)
 267            (if (x-display-color-p device)
 268                'color
 269              'mono))
 270           (t 'color)))
 271         (pm                             ; OS/2 Presentation Manager
 272          (cond
 273           ((fboundp 'pm-display-visual-class)
 274            (let ((val (symbol-name (pm-display-visual-class device))))
 275              (cond
 276               ((string-match "color" val) 'color)
 277               ((string-match "gray-scale" val) 'grayscale)
 278               (t 'mono))))
 279           ((fboundp 'pm-display-color-p)
 280            (if (pm-display-color-p device)
 281                'color
 282              'mono))
 283           (t 'color)))
 284         (otherwise 'color))))
 285
 286   (defun device-class-list ()
 287     "Returns a list of valid device classes."
 288     (list 'color 'grayscale 'mono))
 289
 290   (defun valid-device-class-p (class)
 291     "Given a CLASS, return t if it is valid.
 292 Valid classes are 'color, 'grayscale, and 'mono."
 293     (memq class (device-class-list)))
 294
 295   (defun device-or-frame-type (device-or-frame)
 296     "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME.
 297 DEVICE-OR-FRAME should be a device or a frame object.  See `device-type'
 298 for a description of the possible types."
 299     (or window-system 'tty))
 300
 301   (defun device-type (&optional device)
 302     "Return the type of the specified device (e.g. `x' or `tty').
 303 Value is `tty' for a tty device (a character-only terminal),
 304 `x' for a device which is a connection to an X server,
 305 'ns' for a device which is a connection to a NeXTStep dps server,
 306 'win32' or 'w32' for a Windows-NT window,
 307 'pm' for an OS/2 Presentation Manager window,
 308 'intuition' for an Amiga screen"
 309     (device-or-frame-type device))
 310
 311   (defun device-type-list ()
 312     "Return a list of valid console types."
 313     (if window-system
 314         (list window-system 'tty)
 315       (list 'tty)))
 316
 317   (defun valid-device-type-p (type)
 318     "Given a TYPE, return t if it is valid."
 319     (memq type (device-type-list)))
 320
 321   )   ; This closes the conditional on whether we are in XEmacs or not
 322
 323 (provide 'devices)
 324
 325 (eval-when-compile
 326   (when (featurep 'xemacs)
 327     (set 'byte-optimize t)))