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