Mercurial > hg > xemacs-beta
annotate lisp/device.el @ 5324:d0bb90d90736
Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy.
lisp/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 30 Dec 2010 13:46:50 +0000 |
| parents | 0d43872986b6 |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;;; device.el --- miscellaneous device functions not written in C |
| 2 | |
| 3 ;; Copyright (C) 1994-5, 1997 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995, 1996 Ben Wing | |
| 5 | |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: internal, dumped | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 23 ;; Free Software Foundation, 59 Temple Place - Suite 330, | |
| 24 ;; Boston, MA 02111-1307, USA. | |
| 25 | |
| 26 ;;; Synched up with: Not in FSF. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; This file is dumped with XEmacs. | |
| 31 | |
| 32 ;;; Code: | |
| 33 | |
| 440 | 34 ;;; Initialization |
| 35 | |
| 36 ; Specifier tag 'printer which matches printers | |
| 37 (define-specifier-tag 'printer (function device-printer-p)) | |
| 38 | |
| 39 ; Specifier tag 'display which matches displays | |
| 40 (define-specifier-tag 'display (function | |
| 41 (lambda (device) | |
| 42 (not (device-printer-p device))))) | |
| 43 | |
| 44 ;;; Functions | |
| 45 | |
| 428 | 46 (defun device-list () |
| 47 "Return a list of all devices." | |
|
5264
0d43872986b6
Change (apply 'nconc (mapcar ...)) to (mapcan ...); warn about first form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4759
diff
changeset
|
48 (mapcan 'console-device-list (console-list))) |
| 428 | 49 |
| 50 (defun device-type (&optional device) | |
| 51 "Return the type of the specified device (e.g. `x' or `tty'). | |
| 52 This is equivalent to the type of the device's console. | |
| 53 Value is `tty' for a tty device (a character-only terminal), | |
| 54 `x' for a device that is a screen on an X display, | |
| 462 | 55 `gtk' for a device that is a GTK connection. |
| 440 | 56 `mswindows' for a device that is a MS Windows workstation, |
| 57 `msprinter' for a device that is a MS Windows printer connection, | |
| 428 | 58 `stream' for a stream device (which acts like a stdio stream), and |
| 59 `dead' for a deleted device." | |
| 60 (or device (setq device (selected-device))) | |
| 61 (if (not (device-live-p device)) 'dead | |
| 62 (console-type (device-console device)))) | |
| 63 | |
| 64 (defun make-tty-device (&optional tty terminal-type controlling-process) | |
| 65 "Create a new device on TTY. | |
| 66 TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under | |
| 67 SunOS et al.), as returned by the `tty' command. A value of nil means | |
| 68 use the stdin and stdout as passed to XEmacs from the shell. | |
| 69 If TERMINAL-TYPE is non-nil, it should be a string specifying the | |
| 70 type of the terminal attached to the specified tty. If it is nil, | |
| 71 the terminal type will be inferred from the TERM environment variable. | |
| 72 If CONTROLLING-PROCESS is non-nil, it should be an integer | |
| 73 specifying the process id of the process in control of the specified tty. If | |
| 74 it is nil, it is assumes to be the value returned by emacs-pid." | |
| 75 (make-device 'tty tty (list 'terminal-type terminal-type | |
| 76 'controlling-process controlling-process))) | |
| 77 | |
| 78 (defun device-pixel-width (&optional device) | |
| 79 "Return the width in pixels of DEVICE, or nil if unknown." | |
| 80 (let ((ds (device-system-metric device 'size-device))) | |
| 81 (and ds (car ds)))) | |
| 82 | |
| 83 (defun device-pixel-height (&optional device) | |
| 84 "Return the height in pixels of DEVICE, or nil if unknown." | |
| 85 (let ((ds (device-system-metric device 'size-device))) | |
| 86 (and ds (cdr ds)))) | |
| 87 | |
| 88 (defun device-mm-width (&optional device) | |
| 89 "Return the width in millimeters of DEVICE, or nil if unknown." | |
| 90 (let ((ds (device-system-metric device 'size-device-mm))) | |
| 91 (and ds (car ds)))) | |
| 92 | |
| 93 (defun device-mm-height (&optional device) | |
| 94 "Return the height in millimeters of DEVICE, or nil if unknown." | |
| 95 (let ((ds (device-system-metric device 'size-device-mm))) | |
| 96 (and ds (cdr ds)))) | |
| 97 | |
| 98 (defun device-bitplanes (&optional device) | |
| 99 "Return the number of bitplanes of DEVICE, or nil if unknown." | |
| 100 (device-system-metric device 'num-bit-planes)) | |
| 101 | |
| 102 (defun device-color-cells (&optional device) | |
| 103 "Return the number of color cells of DEVICE, or nil if unknown." | |
| 104 (device-system-metric device 'num-color-cells)) | |
| 105 | |
| 1942 | 106 (defun device-num-screens (&optional device) |
| 107 "Return the number of display screens available on DEVICE, or 1 if unknown." | |
| 108 (device-system-metric device 'num-screens 1)) | |
| 109 | |
| 110 (defun device-backing-store (&optional device) | |
| 111 "Return the backing store capability of DEVICE. | |
| 112 The value may be `always', `when-mapped', `not-useful', or nil if | |
| 113 the question is inapplicable to a certain kind of display." | |
| 114 (device-system-metric device 'backing-store)) | |
| 115 | |
| 116 (defun device-save-under (&optional device) | |
| 117 "Return non-nil if DEVICE supports the SaveUnder feature." | |
| 118 (device-system-metric device 'save-under)) | |
| 119 | |
| 462 | 120 (defun make-gtk-device () |
| 121 "Create a new GTK device." | |
| 122 (make-device 'gtk nil)) | |
| 123 | |
| 428 | 124 (defun make-x-device (&optional display) |
| 125 "Create a new device connected to DISPLAY." | |
| 126 (make-device 'x display)) | |
| 127 | |
| 128 (defun make-mswindows-device () | |
| 129 "Create a new mswindows device." | |
| 130 (make-device 'mswindows nil)) | |
| 131 | |
| 132 (defun device-on-window-system-p (&optional device) | |
| 133 "Return non-nil if DEVICE is on a window system. | |
| 134 This generally means that there is support for the mouse, the menubar, | |
| 135 the toolbar, glyphs, etc." | |
| 136 (or device (setq device (selected-device))) | |
| 137 (console-on-window-system-p (device-console device))) | |
| 138 | |
| 139 (defun call-device-method (name device &rest args) | |
| 140 "Call a DEVICE-specific function with the generic name NAME. | |
| 440 | 141 If DEVICE is not provided then the selected device is used." |
| 428 | 142 (or device (setq device (selected-device))) |
| 143 (or (symbolp name) (error "function name must be a symbol")) | |
| 144 (let ((devmeth (intern (concat (symbol-name | |
| 145 (device-type device)) "-" (symbol-name name))))) | |
| 146 (if (functionp devmeth) | |
| 147 (if args | |
| 148 (apply devmeth args) | |
| 149 (funcall devmeth)) | |
| 150 nil))) | |
| 151 | |
| 152 (defmacro define-device-method (name &optional docstring) | |
| 153 "Define NAME to be a device method." | |
| 154 `(defun ,name (&rest arglist) ,docstring | |
| 155 (apply 'call-device-method (quote ,name) nil arglist))) | |
| 156 | |
| 157 (defmacro define-device-method* (name &optional docstring) | |
| 158 "Define NAME to be a device method." | |
| 159 `(defun* ,name (&rest arglist) ,docstring | |
| 160 (apply 'call-device-method (quote ,name) nil arglist))) | |
| 161 | |
| 162 (defalias 'valid-device-type-p 'valid-console-type-p) | |
| 163 (defalias 'device-type-list 'console-type-list) | |
| 164 (defalias 'device-pixel-depth 'device-bitplanes) | |
| 165 | |
| 166 ;;; device.el ends here |