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