Mercurial > hg > xemacs-beta

comparison lisp/w3/devices.el @ 136:b980b6286996 r20-2b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b2
author cvs
date Mon, 13 Aug 2007 09:31:12 +0200
parents
children 6608ceec7cf8
comparison
equal deleted inserted replaced
135:4636a6841cd6 136:b980b6286996
1 ;;; devices.el -- XEmacs device API emulation
2 ;; Author: wmperry
3 ;; Created: 1997/04/21 15:57:56
4 ;; Version: 1.2
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
117 (defsubst set-device-selected-frame (device frame)
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
123 (defsubst set-device-baud-rate (device rate)
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
140 (defsubst event-device (event)
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
145 (defsubst device-connection (&optional device)
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
172 (defsubst device-on-window-system-p (&optional device)
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
178 (defsubst device-name (&optional device)
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
221 (defsubst device-color-cells (&optional device)
222 (case window-system
223 ((x win32 pm) (x-display-color-cells device))
224 (ns (ns-display-color-cells device))
225 (otherwise 1)))
226
227 (defsubst device-pixel-width (&optional device)
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
233 (defsubst device-pixel-height (&optional device)
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
239 (defsubst device-mm-width (&optional device)
240 (case window-system
241 ((x win32 pm) (x-display-mm-width device))
242 (ns (ns-display-mm-width device))
243 (otherwise nil)))
244
245 (defsubst device-mm-height (&optional device)
246 (case window-system
247 ((x win32 pm) (x-display-mm-height device))
248 (ns (ns-display-mm-height device))
249 (otherwise nil)))
250
251 (defsubst device-bitplanes (&optional device)
252 (case window-system
253 ((x win32 pm) (x-display-planes device))
254 (ns (ns-display-planes device))
255 (otherwise 2)))
256
257 (defsubst device-class (&optional device)
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
300 (defsubst device-class-list ()
301 "Returns a list of valid device classes."
302 (list 'color 'grayscale 'mono))
303
304 (defsubst valid-device-class-p (class)
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
309 (defsubst device-or-frame-type (device-or-frame)
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
315 (defsubst device-type (&optional device)
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
325 (defsubst device-type-list ()
326 "Return a list of valid console types."
327 (if window-system
328 (list window-system 'tty)
329 (list 'tty)))
330
331 (defsubst valid-device-type-p (type)
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)))