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