1;;; devices.el -- XEmacs device API emulation
2;; Author: wmperry
3;; Created: 1998/04/17 19:05:35
4;; Version: 1.7
5;; Keywords:
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1998 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(require 'cl)
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
57The valid values for CONNECTION are device-specific; however,
58CONNECTION is generally a string. (Specifically, for X devices,
59CONNECTION should be a display specification such as \"foo:0\", and
60for TTY devices, CONNECTION should be the filename of a TTY device
61file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard
62input/output.)
63
64PROPS, if specified, should be a plist of properties controlling
65device creation.
66
67If CONNECTION specifies an already-existing device connection, that
68device is simply returned; no new device is created, and PROPS
69have 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.
82TYPE should be a symbol naming the device type, i.e. one of
83
84x	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.
88tty	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.
93ns	A connection to a machine running the NeXTstep windowing
94	system.  Not currently implemented.
95win32	A connection to a machine running Microsoft Windows NT or
96	Windows 95.  Not currently implemented.
97pc	A direct-write MS-DOS frame.  Not currently implemented.
98
99PROPS should be an plist of properties, as in the call to `make-frame'.
100
101If a connection to CONNECTION already exists, it is reused; otherwise,
102a 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
108SunOS et al.), as returned by the `tty' command.  A value of nil means
109use 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
111type of the terminal attached to the specified tty.  If it is nil,
112the 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
118(defun set-device-selected-frame (device frame)
119  "Set the selected frame of device object DEVICE to FRAME.
120If DEVICE is nil, the selected device is used.
121If DEVICE is the selected device, this makes FRAME the selected frame."
122  (select-frame frame))
123
124(defun set-device-baud-rate (device rate)
125  "Set the output baud rate of DEVICE to RATE.
126On most systems, changing this value will affect the amount of padding
127and 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.
132Return nil otherwise."
133  (cond
134   ((windowp obj)
135    (window-frame obj))
136   ((framep obj)
137    obj)
138   (t
139    nil)))
140
141(defun event-device (event)
142  "Return the device that EVENT occurred on.
143This will be nil for some types of events (e.g. keyboard and eval events)."
144  (dfw-device (posn-window (event-start event))))
145
146(defun device-connection (&optional device)
147  "Return the connection of the specified device.
148DEVICE 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.
153Return the device if found; otherwise, return nil.
154
155If TYPE is specified, only return devices of that type; otherwise,
156return devices of any type. (It is possible, although unlikely,
157that two devices of different types could have the same connection
158name; 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
173(defun device-on-window-system-p (&optional device)
174  "Return non-nil if DEVICE is on a window system.
175This generally means that there is support for the mouse, the menubar,
176the toolbar, glyphs, etc."
177  (and (cdr-safe (assq 'display (frame-parameters device))) t))
178
179(defun device-name (&optional device)
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.
185If 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.
208One argument, the to-be-deleted device.")
209
210(defun delete-device (device &optional force)
211  "Delete DEVICE, permanently eliminating it from use.
212Normally, you cannot delete the last non-minibuffer-only frame (you must
213use `save-buffers-kill-emacs' or `kill-emacs').  However, if optional
214second argument FORCE is non-nil, you can delete the last frame. (This
215will 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
222(defun device-color-cells (&optional device)
223  (case window-system
224    ((x win32 w32 pm) (x-display-color-cells device))
225    (ns (ns-display-color-cells device))
226    (otherwise 1)))
227
228(defun device-pixel-width (&optional device)
229  (case window-system
230    ((x win32 w32 pm) (x-display-pixel-width device))
231    (ns (ns-display-pixel-width device))
232    (otherwise (frame-width device))))
233
234(defun device-pixel-height (&optional device)
235  (case window-system
236    ((x win32 w32 pm) (x-display-pixel-height device))
237    (ns (ns-display-pixel-height device))
238    (otherwise (frame-height device))))
239
240(defun device-mm-width (&optional device)
241  (case window-system
242    ((x win32 w32 pm) (x-display-mm-width device))
243    (ns (ns-display-mm-width device))
244    (otherwise nil)))
245
246(defun device-mm-height (&optional device)
247  (case window-system
248    ((x win32 w32 pm) (x-display-mm-height device))
249    (ns (ns-display-mm-height device))
250    (otherwise nil)))
251
252(defun device-bitplanes (&optional device)
253  (case window-system
254    ((x win32 w32 pm) (x-display-planes device))
255    (ns (ns-display-planes device))
256    (otherwise 2)))
257
258(defun device-class (&optional device)
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
301(defun device-class-list ()
302  "Returns a list of valid device classes."
303  (list 'color 'grayscale 'mono))
304
305(defun valid-device-class-p (class)
306  "Given a CLASS, return t if it is valid.
307Valid classes are 'color, 'grayscale, and 'mono."
308  (memq class (device-class-list)))
309
310(defun device-or-frame-type (device-or-frame)
311  "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME.
312DEVICE-OR-FRAME should be a device or a frame object.  See `device-type'
313for a description of the possible types."
314  (or window-system 'tty))
315
316(defun device-type (&optional device)
317  "Return the type of the specified device (e.g. `x' or `tty').
318Value 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' or 'w32' 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
326(defun device-type-list ()
327  "Return a list of valid console types."
328  (if window-system
329      (list window-system 'tty)
330    (list 'tty)))
331
332(defun valid-device-type-p (type)
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)))
343