Mercurial > hg > xemacs-beta
comparison lisp/w3/w3-sysdp.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; sysdep.el --- consolidate Emacs-version dependencies in one file. | |
| 2 | |
| 3 ;; Copyright (C) 1995 Ben Wing. | |
| 4 | |
| 5 ;; Author: Ben Wing <wing@666.com> | |
| 6 ;; Keywords: lisp, tools | |
| 7 ;; Version: 0.001 | |
| 8 | |
| 9 ;; The purpose of this file is to eliminate the cruftiness that | |
| 10 ;; would otherwise be required of packages that want to run on multiple | |
| 11 ;; versions of Emacs. The idea is that we make it look like we're running | |
| 12 ;; the latest version of XEmacs (currently 19.12) by emulating all the | |
| 13 ;; missing functions. | |
| 14 | |
| 15 ;; #### This file does not currently do any advising but should. | |
| 16 ;; Unfortunately, advice.el is a hugely big package. Is any such | |
| 17 ;; thing as `advice-lite' possible? | |
| 18 | |
| 19 ;; #### - This package is great, but its role needs to be thought out a bit | |
| 20 ;; more. Sysdep will not permit programs written for the old XEmacs API to | |
| 21 ;; run on new versions of XEmacs. Sysdep is a backward-compatibility | |
| 22 ;; package for the latest and greatest XEmacs API. It permits programmers | |
| 23 ;; to use the latest XEmacs functionality and still have their programs run | |
| 24 ;; on older versions of XEmacs...perhaps even on FSF Emacs. It should NEVER | |
| 25 ;; ever need to be loaded in the newest XEmacs. It doesn't even make sense | |
| 26 ;; to put it in the lisp/utils part of the XEmacs distribution because it's | |
| 27 ;; real purpose is to be distributed with packages like w3 which take | |
| 28 ;; advantage of the latest and greatest features of XEmacs but still need to | |
| 29 ;; be run on older versions. --Stig | |
| 30 | |
| 31 ;; Any packages that wish to use this file should load it using | |
| 32 ;; `load-library'. It will not load itself if a version of sysdep.el | |
| 33 ;; that is at least as recent has already been loaded, but will | |
| 34 ;; load over an older version of sysdep.el. It will attempt to | |
| 35 ;; not redefine functions that have already been custom-redefined, | |
| 36 ;; but will redefine a function if the supplied definition came from | |
| 37 ;; an older version of sysdep.el. | |
| 38 | |
| 39 ;; Packages such as w3 that wish to include this file with the package | |
| 40 ;; should rename it to something unique, such as `w3-sysdep.el', and | |
| 41 ;; load it with `load-library'. That will ensure that no conflicts | |
| 42 ;; arise if more than one package in the load path provides a version | |
| 43 ;; of sysdep.el. If multiple packages load sysdep.el, the most recent | |
| 44 ;; version will end up loaded; as long as I'm careful not to | |
| 45 ;; introduce bugs in previously working definitions, this should work | |
| 46 ;; fine. | |
| 47 | |
| 48 ;; You may well discover deficiencies in this file as you use it. | |
| 49 ;; The preferable way of dealing with this is to send me a patch | |
| 50 ;; to sysdep.el; that way, the collective body of knowledge gets | |
| 51 ;; increased. | |
| 52 | |
| 53 ;; DO NOT load this file with `require'. | |
| 54 ;; DO NOT put a `provide' statement in this file. | |
| 55 | |
| 56 ;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001) | |
| 57 ;; so that string comparisons to other versions work properly. | |
| 58 | |
| 59 (defconst sysdep-potential-version "0.002") | |
| 60 | |
| 61 (if (and (boundp 'sysdep-version) | |
| 62 (not (string-lessp sysdep-version sysdep-potential-version))) | |
| 63 ;; if a more recent version of sysdep was already loaded, | |
| 64 ;; or if the same package is loaded again, don't load. | |
| 65 nil | |
| 66 | |
| 67 (defconst sysdep-version sysdep-potential-version) | |
| 68 | |
| 69 ;; this macro means: define the function, but only if either it | |
| 70 ;; wasn't bound before, or the supplied binding comes from an older | |
| 71 ;; version of sysdep.el. That way, user-supplied bindings don't | |
| 72 ;; get overridden. | |
| 73 | |
| 74 ;; note: sysdep-defalias is often more useful than this function, | |
| 75 ;; esp. since you can do load-time conditionalizing and can | |
| 76 ;; optionally leave the function undefined. (e.g. frame functions | |
| 77 ;; in v18.) | |
| 78 | |
| 79 (defmacro sysdep-defun (function &rest everything-else) | |
| 80 (` (cond ((or (not (fboundp (quote (, function)))) | |
| 81 (get (quote (, function)) 'sysdep-defined-this)) | |
| 82 (put (quote (, function)) 'sysdep-defined-this t) | |
| 83 (defun (, function) (,@ everything-else)))))) | |
| 84 | |
| 85 (defmacro sysdep-defvar (function &rest everything-else) | |
| 86 (` (cond ((or (not (boundp (quote (, function)))) | |
| 87 (get (quote (, function)) 'sysdep-defined-this)) | |
| 88 (put (quote (, function)) 'sysdep-defined-this t) | |
| 89 (defvar (, function) (,@ everything-else)))))) | |
| 90 | |
| 91 (defmacro sysdep-defconst (function &rest everything-else) | |
| 92 (` (cond ((or (not (boundp (quote (, function)))) | |
| 93 (get (quote (, function)) 'sysdep-defined-this)) | |
| 94 (put (quote (, function)) 'sysdep-defined-this t) | |
| 95 (defconst (, function) (,@ everything-else)))))) | |
| 96 | |
| 97 ;; similar for fset and defalias. No need to quote as the argument | |
| 98 ;; is already quoted. | |
| 99 | |
| 100 (defmacro sysdep-fset (function def) | |
| 101 (` (cond ((and (or (not (fboundp (, function))) | |
| 102 (get (, function) 'sysdep-defined-this)) | |
| 103 (, def)) | |
| 104 (put (, function) 'sysdep-defined-this t) | |
| 105 (fset (, function) (, def)))))) | |
| 106 | |
| 107 (defmacro sysdep-defalias (function def) | |
| 108 (` (cond ((and (or (not (fboundp (, function))) | |
| 109 (get (, function) 'sysdep-defined-this)) | |
| 110 (, def) | |
| 111 (or (listp (, def)) | |
| 112 (and (symbolp (, def)) | |
| 113 (fboundp (, def))))) | |
| 114 (put (, function) 'sysdep-defined-this t) | |
| 115 (defalias (, function) (, def)))))) | |
| 116 | |
| 117 ;; bootstrapping: defalias and define-function don't exist | |
| 118 ;; in older versions of lemacs | |
| 119 | |
| 120 (sysdep-fset 'defalias 'fset) | |
| 121 (sysdep-defalias 'define-function 'defalias) | |
| 122 | |
| 123 ;; useful ways of determining what version is running | |
| 124 ;; emacs-major-version and emacs-minor-version are | |
| 125 ;; already defined in recent versions of FSF Emacs and XEmacs | |
| 126 | |
| 127 (sysdep-defconst emacs-major-version | |
| 128 ;; will string-match ever fail? If so, assume 19.0. | |
| 129 ;; (should we assume 18.something?) | |
| 130 (if (string-match "^[0-9]+" emacs-version) | |
| 131 (string-to-int | |
| 132 (substring emacs-version | |
| 133 (match-beginning 0) (match-end 0))) | |
| 134 19)) | |
| 135 | |
| 136 (sysdep-defconst emacs-minor-version | |
| 137 (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) | |
| 138 (string-to-int | |
| 139 (substring emacs-version | |
| 140 (match-beginning 1) (match-end 1))) | |
| 141 0)) | |
| 142 | |
| 143 (sysdep-defconst sysdep-running-xemacs | |
| 144 (or (string-match "Lucid" emacs-version) | |
| 145 (string-match "XEmacs" emacs-version))) | |
| 146 | |
| 147 (sysdep-defconst window-system nil) | |
| 148 (sysdep-defconst window-system-version 0) | |
| 149 | |
| 150 (sysdep-defvar list-buffers-directory nil) | |
| 151 (sysdep-defvar x-library-search-path '("/usr/X11R6/lib/X11/" | |
| 152 "/usr/X11R5/lib/X11/" | |
| 153 "/usr/lib/X11R6/X11/" | |
| 154 "/usr/lib/X11R5/X11/" | |
| 155 "/usr/local/X11R6/lib/X11/" | |
| 156 "/usr/local/X11R5/lib/X11/" | |
| 157 "/usr/local/lib/X11R6/X11/" | |
| 158 "/usr/local/lib/X11R5/X11/" | |
| 159 "/usr/X11/lib/X11/" | |
| 160 "/usr/lib/X11/" | |
| 161 "/usr/local/lib/X11/" | |
| 162 "/usr/X386/lib/X11/" | |
| 163 "/usr/x386/lib/X11/" | |
| 164 "/usr/XFree86/lib/X11/" | |
| 165 "/usr/unsupported/lib/X11/" | |
| 166 "/usr/athena/lib/X11/" | |
| 167 "/usr/local/x11r5/lib/X11/" | |
| 168 "/usr/lpp/Xamples/lib/X11/" | |
| 169 "/usr/openwin/lib/X11/" | |
| 170 "/usr/openwin/share/lib/X11/") | |
| 171 "Search path used for X11 libraries.") | |
| 172 | |
| 173 ;; frame-related stuff. | |
| 174 | |
| 175 (sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen) | |
| 176 (sysdep-defalias 'deiconify-frame | |
| 177 (cond ((fboundp 'deiconify-screen) 'deiconify-screen) | |
| 178 ;; make-frame-visible will be defined as necessary | |
| 179 (t 'make-frame-visible))) | |
| 180 (sysdep-defalias 'delete-frame 'delete-screen) | |
| 181 (sysdep-defalias 'event-frame 'event-screen) | |
| 182 (sysdep-defalias 'event-glyph-extent 'event-glyph) | |
| 183 (sysdep-defalias 'find-file-other-frame 'find-file-other-screen) | |
| 184 (sysdep-defalias 'find-file-read-only-other-frame | |
| 185 'find-file-read-only-other-screen) | |
| 186 (sysdep-defalias 'frame-height 'screen-height) | |
| 187 (sysdep-defalias 'frame-iconified-p 'screen-iconified-p) | |
| 188 (sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width) | |
| 189 (sysdep-defalias 'frame-list 'screen-list) | |
| 190 (sysdep-defalias 'frame-live-p | |
| 191 (cond ((fboundp 'screen-live-p) 'screen-live-p) | |
| 192 ((fboundp 'live-screen-p) 'live-screen-p) | |
| 193 ;; #### not sure if this is correct (this is for Epoch) | |
| 194 ;; but gnuserv.el uses it this way | |
| 195 ((fboundp 'screenp) 'screenp))) | |
| 196 (sysdep-defalias 'frame-name 'screen-name) | |
| 197 (sysdep-defalias 'frame-parameters 'screen-parameters) | |
| 198 (sysdep-defalias 'frame-pixel-height 'screen-pixel-height) | |
| 199 (sysdep-defalias 'frame-pixel-width 'screen-pixel-width) | |
| 200 (sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width) | |
| 201 (sysdep-defalias 'frame-root-window 'screen-root-window) | |
| 202 (sysdep-defalias 'frame-selected-window 'screen-selected-window) | |
| 203 (sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p) | |
| 204 (sysdep-defalias 'frame-visible-p 'screen-visible-p) | |
| 205 (sysdep-defalias 'frame-width 'screen-width) | |
| 206 (sysdep-defalias 'framep 'screenp) | |
| 207 (sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer) | |
| 208 (sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect) | |
| 209 (sysdep-defalias 'get-other-frame 'get-other-screen) | |
| 210 (sysdep-defalias 'iconify-frame 'iconify-screen) | |
| 211 (sysdep-defalias 'lower-frame 'lower-screen) | |
| 212 (sysdep-defalias 'mail-other-frame 'mail-other-screen) | |
| 213 | |
| 214 (sysdep-defalias 'make-frame | |
| 215 (cond ((fboundp 'make-screen) | |
| 216 (function (lambda (&optional parameters device) | |
| 217 (make-screen parameters)))) | |
| 218 ((fboundp 'x-create-screen) | |
| 219 (function (lambda (&optional parameters device) | |
| 220 (x-create-screen parameters)))))) | |
| 221 | |
| 222 (sysdep-defalias 'make-frame-invisible 'make-screen-invisible) | |
| 223 (sysdep-defalias 'make-frame-visible | |
| 224 (cond ((fboundp 'make-screen-visible) 'make-screen-visible) | |
| 225 ((fboundp 'mapraised-screen) 'mapraised-screen) | |
| 226 ((fboundp 'x-remap-window) | |
| 227 (lambda (&optional x) | |
| 228 (x-remap-window) | |
| 229 (accept-process-output))))) | |
| 230 (sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters) | |
| 231 (sysdep-defalias 'new-frame 'new-screen) | |
| 232 (sysdep-defalias 'next-frame 'next-screen) | |
| 233 (sysdep-defalias 'next-multiframe-window 'next-multiscreen-window) | |
| 234 (sysdep-defalias 'other-frame 'other-screen) | |
| 235 (sysdep-defalias 'previous-frame 'previous-screen) | |
| 236 (sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window) | |
| 237 (sysdep-defalias 'raise-frame | |
| 238 (cond ((fboundp 'raise-screen) 'raise-screen) | |
| 239 ((fboundp 'mapraise-screen) 'mapraise-screen))) | |
| 240 (sysdep-defalias 'redraw-frame 'redraw-screen) | |
| 241 (sysdep-defalias 'select-frame 'select-screen) | |
| 242 (sysdep-defalias 'selected-frame 'selected-screen) | |
| 243 (sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen) | |
| 244 (sysdep-defalias 'set-frame-height 'set-screen-height) | |
| 245 (sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width) | |
| 246 (sysdep-defalias 'set-frame-position 'set-screen-position) | |
| 247 (sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width) | |
| 248 (sysdep-defalias 'set-frame-size 'set-screen-size) | |
| 249 (sysdep-defalias 'set-frame-width 'set-screen-width) | |
| 250 (sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen) | |
| 251 (sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen) | |
| 252 (sysdep-defalias 'visible-frame-list 'visible-screen-list) | |
| 253 (sysdep-defalias 'window-frame 'window-screen) | |
| 254 (sysdep-defalias 'x-create-frame 'x-create-screen) | |
| 255 (sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap) | |
| 256 (sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer) | |
| 257 (sysdep-defalias 'x-display-color-p 'x-color-display-p) | |
| 258 (sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p) | |
| 259 (sysdep-defalias 'menu-event-p 'misc-user-event-p) | |
| 260 | |
| 261 (sysdep-defun add-submenu (menu-path submenu &optional before) | |
| 262 "Add a menu to the menubar or one of its submenus. | |
| 263 If the named menu exists already, it is changed. | |
| 264 MENU-PATH identifies the menu under which the new menu should be inserted. | |
| 265 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
| 266 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
| 267 If MENU-PATH is nil, then the menu will be added to the menubar itself. | |
| 268 SUBMENU is the new menu to add. | |
| 269 See the documentation of `current-menubar' for the syntax. | |
| 270 BEFORE, if provided, is the name of a menu before which this menu should | |
| 271 be added, if this menu is not on its parent already. If the menu is already | |
| 272 present, it will not be moved." | |
| 273 (add-menu menu-path (car submenu) (cdr submenu) before)) | |
| 274 | |
| 275 (sysdep-defun add-menu-button (menu-path menu-leaf &optional before) | |
| 276 "Add a menu item to some menu, creating the menu first if necessary. | |
| 277 If the named item exists already, it is changed. | |
| 278 MENU-PATH identifies the menu under which the new menu item should be inserted. | |
| 279 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
| 280 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
| 281 MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. | |
| 282 BEFORE, if provided, is the name of a menu item before which this item should | |
| 283 be added, if this item is not on the menu already. If the item is already | |
| 284 present, it will not be moved." | |
| 285 (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1) | |
| 286 (aref menu-leaf 2) before)) | |
| 287 | |
| 288 (sysdep-defun make-glyph (&optional spec-list) | |
| 289 (if (and spec-list (cdr-safe (assq 'x spec-list))) | |
| 290 (make-pixmap (cdr-safe (assq 'x spec-list))))) | |
| 291 | |
| 292 (sysdep-defalias 'face-list 'list-faces) | |
| 293 | |
| 294 (sysdep-defun set-face-property (face property value &optional locale | |
| 295 tag-set how-to-add) | |
| 296 "Change a property of FACE." | |
| 297 (and (symbolp face) | |
| 298 (put face property value))) | |
| 299 | |
| 300 (sysdep-defun face-property (face property &optional locale tag-set exact-p) | |
| 301 "Return FACE's value of the given PROPERTY." | |
| 302 (and (symbolp face) (get face property))) | |
| 303 | |
| 304 ;; Device functions | |
| 305 ;; By wmperry@spry.com | |
| 306 ;; This is a complete implementation of all the device-* functions found in | |
| 307 ;; XEmacs 19.14. A 'device' for Emacs 19 is just a frame, from which we can | |
| 308 ;; determine the connection to an X display, etc. | |
| 309 | |
| 310 (sysdep-defalias 'selected-device 'ignore) | |
| 311 (sysdep-defalias 'device-or-frame-p 'framep) | |
| 312 (sysdep-defalias 'device-console 'ignore) | |
| 313 (sysdep-defalias 'device-sound-enabled-p 'ignore) | |
| 314 (sysdep-defalias 'device-live-p 'frame-live-p) | |
| 315 (sysdep-defalias 'devicep 'framep) | |
| 316 (sysdep-defalias 'frame-device 'identity) | |
| 317 (sysdep-defalias 'redisplay-device 'redraw-frame) | |
| 318 (sysdep-defalias 'redraw-device 'redraw-frame) | |
| 319 (sysdep-defalias 'select-device 'select-frame) | |
| 320 (sysdep-defalias 'set-device-class 'ignore) | |
| 321 | |
| 322 (sysdep-defun make-device (type connection &optional props) | |
| 323 "Create a new device of type TYPE, attached to connection CONNECTION. | |
| 324 | |
| 325 The valid values for CONNECTION are device-specific; however, | |
| 326 CONNECTION is generally a string. (Specifically, for X devices, | |
| 327 CONNECTION should be a display specification such as \"foo:0\", and | |
| 328 for TTY devices, CONNECTION should be the filename of a TTY device | |
| 329 file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard | |
| 330 input/output.) | |
| 331 | |
| 332 PROPS, if specified, should be a plist of properties controlling | |
| 333 device creation. | |
| 334 | |
| 335 If CONNECTION specifies an already-existing device connection, that | |
| 336 device is simply returned; no new device is created, and PROPS | |
| 337 have no effect." | |
| 338 (cond | |
| 339 ((and (eq type 'x) connection) | |
| 340 (make-frame-on-display display props)) | |
| 341 ((eq type 'x) | |
| 342 (make-frame props)) | |
| 343 ((eq type 'tty) | |
| 344 nil) | |
| 345 (t | |
| 346 (error "Unsupported device-type: %s" type)))) | |
| 347 | |
| 348 (sysdep-defun make-frame-on-device (type connection &optional props) | |
| 349 "Create a frame of type TYPE on CONNECTION. | |
| 350 TYPE should be a symbol naming the device type, i.e. one of | |
| 351 | |
| 352 x An X display. CONNECTION should be a standard display string | |
| 353 such as \"unix:0\", or nil for the display specified on the | |
| 354 command line or in the DISPLAY environment variable. Only if | |
| 355 support for X was compiled into XEmacs. | |
| 356 tty A standard TTY connection or terminal. CONNECTION should be | |
| 357 a TTY device name such as \"/dev/ttyp2\" (as determined by | |
| 358 the Unix command `tty') or nil for XEmacs' standard input | |
| 359 and output (usually the TTY in which XEmacs started). Only | |
| 360 if support for TTY's was compiled into XEmacs. | |
| 361 ns A connection to a machine running the NeXTstep windowing | |
| 362 system. Not currently implemented. | |
| 363 win32 A connection to a machine running Microsoft Windows NT or | |
| 364 Windows 95. Not currently implemented. | |
| 365 pc A direct-write MS-DOS frame. Not currently implemented. | |
| 366 | |
| 367 PROPS should be an plist of properties, as in the call to `make-frame'. | |
| 368 | |
| 369 If a connection to CONNECTION already exists, it is reused; otherwise, | |
| 370 a new connection is opened." | |
| 371 (make-device type connection props)) | |
| 372 | |
| 373 (sysdep-defun make-tty-device (&optional tty terminal-type) | |
| 374 "Create a new device on TTY. | |
| 375 TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under | |
| 376 SunOS et al.), as returned by the `tty' command. A value of nil means | |
| 377 use the stdin and stdout as passed to XEmacs from the shell. | |
| 378 If TERMINAL-TYPE is non-nil, it should be a string specifying the | |
| 379 type of the terminal attached to the specified tty. If it is nil, | |
| 380 the terminal type will be inferred from the TERM environment variable." | |
| 381 (make-device 'tty tty (list 'terminal-type terminal-type))) | |
| 382 | |
| 383 (sysdep-defun make-x-device (&optional display) | |
| 384 (make-device 'x display)) | |
| 385 | |
| 386 (sysdep-defun set-device-selected-frame (device frame) | |
| 387 "Set the selected frame of device object DEVICE to FRAME. | |
| 388 If DEVICE is nil, the selected device is used. | |
| 389 If DEVICE is the selected device, this makes FRAME the selected frame." | |
| 390 (select-frame frame)) | |
| 391 | |
| 392 (sysdep-defun set-device-baud-rate (device rate) | |
| 393 "Set the output baud rate of DEVICE to RATE. | |
| 394 On most systems, changing this value will affect the amount of padding | |
| 395 and other strategic decisions made during redisplay." | |
| 396 (setq baud-rate rate)) | |
| 397 | |
| 398 (sysdep-defun dfw-device (obj) | |
| 399 "Given a device, frame, or window, return the associated device. | |
| 400 Return nil otherwise." | |
| 401 (cond | |
| 402 ((windowp obj) | |
| 403 (window-frame obj)) | |
| 404 ((framep obj) | |
| 405 obj) | |
| 406 (t | |
| 407 nil))) | |
| 408 | |
| 409 (sysdep-defun event-device (event) | |
| 410 "Return the device that EVENT occurred on. | |
| 411 This will be nil for some types of events (e.g. keyboard and eval events)." | |
| 412 (dfw-device (posn-window (event-start event)))) | |
| 413 | |
| 414 (sysdep-defun find-device (connection &optional type) | |
| 415 "Look for an existing device attached to connection CONNECTION. | |
| 416 Return the device if found; otherwise, return nil. | |
| 417 | |
| 418 If TYPE is specified, only return devices of that type; otherwise, | |
| 419 return devices of any type. (It is possible, although unlikely, | |
| 420 that two devices of different types could have the same connection | |
| 421 name; in such a case, the first device found is returned.)" | |
| 422 (let ((devices (device-list)) | |
| 423 (retval nil)) | |
| 424 (while (and devices (not nil)) | |
| 425 (if (equal connection (device-connection (car devices))) | |
| 426 (setq retval (car devices))) | |
| 427 (setq devices (cdr devices))) | |
| 428 retval)) | |
| 429 | |
| 430 (sysdep-defalias 'get-device 'find-device) | |
| 431 | |
| 432 (sysdep-defun device-baud-rate (&optional device) | |
| 433 "Return the output baud rate of DEVICE." | |
| 434 baud-rate) | |
| 435 | |
| 436 (sysdep-defun device-on-window-system-p (&optional device) | |
| 437 "Return non-nil if DEVICE is on a window system. | |
| 438 This generally means that there is support for the mouse, the menubar, | |
| 439 the toolbar, glyphs, etc." | |
| 440 (and (cdr-safe (assq 'display (frame-parameters device))) t)) | |
| 441 | |
| 442 (sysdep-defun device-name (&optional device) | |
| 443 "Return the name of the specified device." | |
| 444 ;; doesn't handle the 19.29 multiple X display stuff yet | |
| 445 ;; doesn't handle NeXTStep either | |
| 446 (cond | |
| 447 ((null window-system) "stdio") | |
| 448 ((getenv "DISPLAY") | |
| 449 (let ((str (getenv "DISPLAY")) | |
| 450 (x (1- (length (getenv "DISPLAY")))) | |
| 451 (y 0)) | |
| 452 (while (/= y x) | |
| 453 (if (or (= (aref str y) ?:) | |
| 454 (= (aref str y) ?.)) | |
| 455 (aset str y ?-)) | |
| 456 (setq y (1+ y))) | |
| 457 str)) | |
| 458 (t "stdio"))) | |
| 459 | |
| 460 | |
| 461 (sysdep-defun device-connection (&optional device) | |
| 462 "Return the connection of the specified device. | |
| 463 DEVICE defaults to the selected device if omitted" | |
| 464 (or (cdr-safe (assq 'display (frame-parameters device))) "stdio")) | |
| 465 | |
| 466 (sysdep-defun device-frame-list (&optional device) | |
| 467 "Return a list of all frames on DEVICE. | |
| 468 If DEVICE is nil, the selected device will be used." | |
| 469 (let ((desired (device-connection device))) | |
| 470 (filtered-frame-list (function (lambda (x) (equal (device-connection x) | |
| 471 desired)))))) | |
| 472 (sysdep-defun device-list () | |
| 473 "Return a list of all devices" | |
| 474 (let ((seen nil) | |
| 475 (cur nil) | |
| 476 (conn nil) | |
| 477 (retval nil) | |
| 478 (not-heard (frame-list))) | |
| 479 (while not-heard | |
| 480 (setq cur (car not-heard) | |
| 481 conn (device-connection cur) | |
| 482 not-heard (cdr not-heard)) | |
| 483 (if (member conn seen) | |
| 484 nil ; Already got it | |
| 485 (setq seen (cons conn seen) ; Whoo hoo, a new one! | |
| 486 retval (cons cur retval)))) | |
| 487 retval)) | |
| 488 | |
| 489 (sysdep-defvar delete-device-hook nil | |
| 490 "Function or functions to call when a device is deleted. | |
| 491 One argument, the to-be-deleted device.") | |
| 492 | |
| 493 (sysdep-defun delete-device (device &optional force) | |
| 494 "Delete DEVICE, permanently eliminating it from use. | |
| 495 Normally, you cannot delete the last non-minibuffer-only frame (you must | |
| 496 use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional | |
| 497 second argument FORCE is non-nil, you can delete the last frame. (This | |
| 498 will automatically call `save-buffers-kill-emacs'.)" | |
| 499 (let ((frames (device-frame-list device))) | |
| 500 (run-hook-with-args 'delete-device-hook device) | |
| 501 (while frames | |
| 502 (delete-frame (car frames) force) | |
| 503 (setq frames (cdr frames))))) | |
| 504 | |
| 505 (sysdep-defalias 'device-color-cells | |
| 506 (cond | |
| 507 ((null window-system) 'ignore) | |
| 508 ((fboundp 'display-color-cells) 'display-color-cells) | |
| 509 ((fboundp 'x-display-color-cells) 'x-display-color-cells) | |
| 510 ((fboundp 'ns-display-color-cells) 'ns-display-color-celles) | |
| 511 (t 'ignore))) | |
| 512 | |
| 513 (sysdep-defun try-font-name (fontname &rest args) | |
| 514 (car-safe (x-list-fonts fontname))) | |
| 515 | |
| 516 (sysdep-defalias 'device-pixel-width | |
| 517 (cond | |
| 518 ((and (eq window-system 'x) (fboundp 'x-display-pixel-width)) | |
| 519 'x-display-pixel-width) | |
| 520 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-width)) | |
| 521 'ns-display-pixel-width) | |
| 522 (t 'ignore))) | |
| 523 | |
| 524 (sysdep-defalias 'device-pixel-height | |
| 525 (cond | |
| 526 ((and (eq window-system 'x) (fboundp 'x-display-pixel-height)) | |
| 527 'x-display-pixel-height) | |
| 528 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-height)) | |
| 529 'ns-display-pixel-height) | |
| 530 (t 'ignore))) | |
| 531 | |
| 532 (sysdep-defalias 'device-mm-width | |
| 533 (cond | |
| 534 ((and (eq window-system 'x) (fboundp 'x-display-mm-width)) | |
| 535 'x-display-mm-width) | |
| 536 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-width)) | |
| 537 'ns-display-mm-width) | |
| 538 (t 'ignore))) | |
| 539 | |
| 540 (sysdep-defalias 'device-mm-height | |
| 541 (cond | |
| 542 ((and (eq window-system 'x) (fboundp 'x-display-mm-height)) | |
| 543 'x-display-mm-height) | |
| 544 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-height)) | |
| 545 'ns-display-mm-height) | |
| 546 (t 'ignore))) | |
| 547 | |
| 548 (sysdep-defalias 'device-bitplanes | |
| 549 (cond | |
| 550 ((and (eq window-system 'x) (fboundp 'x-display-planes)) | |
| 551 'x-display-planes) | |
| 552 ((and (eq window-system 'ns) (fboundp 'ns-display-planes)) | |
| 553 'ns-display-planes) | |
| 554 (t 'ignore))) | |
| 555 | |
| 556 (sysdep-defalias 'device-class | |
| 557 (cond | |
| 558 ((and (eq window-system 'x) (fboundp 'x-display-visual-class)) | |
| 559 (function | |
| 560 (lambda (&optional device) | |
| 561 (let ((val (symbol-name (x-display-visual-class device)))) | |
| 562 (cond | |
| 563 ((string-match "color" val) 'color) | |
| 564 ((string-match "gray-scale" val) 'grayscale) | |
| 565 (t 'mono)))))) | |
| 566 ((fboundp 'number-of-colors) | |
| 567 (function | |
| 568 (lambda (&optional device) | |
| 569 (if (= 2 (number-of-colors)) | |
| 570 'mono | |
| 571 'color)))) | |
| 572 ((and (eq window-system 'x) (fboundp 'x-color-p)) | |
| 573 (function | |
| 574 (lambda (&optional device) | |
| 575 (if (x-color-p) | |
| 576 'color | |
| 577 'mono)))) | |
| 578 ((and (eq window-system 'ns) (fboundp 'ns-display-visual-class)) | |
| 579 (function | |
| 580 (lambda (&optional device) | |
| 581 (let ((val (symbol-name (ns-display-visual-class)))) | |
| 582 (cond | |
| 583 ((string-match "color" val) 'color) | |
| 584 ((string-match "gray-scale" val) 'grayscale) | |
| 585 (t 'mono)))))) | |
| 586 (t (function (lambda (&optional device) 'mono))))) | |
| 587 | |
| 588 (sysdep-defun device-class-list () | |
| 589 "Returns a list of valid device classes." | |
| 590 (list 'color 'grayscale 'mono)) | |
| 591 | |
| 592 (sysdep-defun valid-device-class-p (class) | |
| 593 "Given a CLASS, return t if it is valid. | |
| 594 Valid classes are 'color, 'grayscale, and 'mono." | |
| 595 (memq class (device-class-list))) | |
| 596 | |
| 597 (sysdep-defun device-or-frame-type (device-or-frame) | |
| 598 "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. | |
| 599 DEVICE-OR-FRAME should be a device or a frame object. See `device-type' | |
| 600 for a description of the possible types." | |
| 601 (if (cdr-safe (assq 'display (frame-parameters device-or-frame))) | |
| 602 window-system | |
| 603 'tty)) | |
| 604 | |
| 605 (sysdep-defun device-type (&optional device) | |
| 606 "Return the type of the specified device (e.g. `x' or `tty'). | |
| 607 Value is `tty' for a tty device (a character-only terminal), | |
| 608 `x' for a device which is a connection to an X server, | |
| 609 'ns' for a device which is a connection to a NeXTStep dps server, | |
| 610 'win32' for a Windows-NT window, | |
| 611 'pm' for an OS/2 Presentation Manager window, | |
| 612 'intuition' for an Amiga screen" | |
| 613 (device-or-frame-type device)) | |
| 614 | |
| 615 (sysdep-defun device-type-list () | |
| 616 "Return a list of valid console types." | |
| 617 (if window-system | |
| 618 (list window-system 'tty) | |
| 619 (list 'tty))) | |
| 620 | |
| 621 (sysdep-defun valid-device-type-p (type) | |
| 622 "Given a TYPE, return t if it is valid." | |
| 623 (memq type (device-type-list))) | |
| 624 | |
| 625 | |
| 626 ;; Extent stuff | |
| 627 (sysdep-fset 'delete-extent 'delete-overlay) | |
| 628 (sysdep-fset 'extent-end-position 'overlay-end) | |
| 629 (sysdep-fset 'extent-start-position 'overlay-start) | |
| 630 (sysdep-fset 'set-extent-endpoints 'move-overlay) | |
| 631 | |
| 632 (sysdep-defun extent-property (extent property &optional default) | |
| 633 (or (overlay-get extent property) default)) | |
| 634 | |
| 635 (sysdep-defun extent-at (pos &optional object property before at-flag) | |
| 636 (let ((tmp (overlays-at (point))) | |
| 637 ovls) | |
| 638 (if property | |
| 639 (while tmp | |
| 640 (if (extent-property (car tmp) property) | |
| 641 (setq ovls (cons (car tmp) ovls))) | |
| 642 (setq tmp (cdr tmp))) | |
| 643 (setq ovls tmp | |
| 644 tmp nil)) | |
| 645 (car-safe | |
| 646 (sort ovls | |
| 647 (function | |
| 648 (lambda (a b) | |
| 649 (< (- (extent-end-position a) (extent-start-position a)) | |
| 650 (- (extent-end-position b) (extent-start-position b))))))))) | |
| 651 | |
| 652 | |
| 653 (sysdep-defun overlays-in (beg end) | |
| 654 "Return a list of the overlays that overlap the region BEG ... END. | |
| 655 Overlap means that at least one character is contained within the overlay | |
| 656 and also contained within the specified region. | |
| 657 Empty overlays are included in the result if they are located at BEG | |
| 658 or between BEG and END." | |
| 659 (let ((ovls (overlay-lists)) | |
| 660 tmp retval) | |
| 661 (if (< end beg) | |
| 662 (setq tmp end | |
| 663 end beg | |
| 664 beg tmp)) | |
| 665 (setq ovls (nconc (car ovls) (cdr ovls))) | |
| 666 (while ovls | |
| 667 (setq tmp (car ovls) | |
| 668 ovls (cdr ovls)) | |
| 669 (if (or (and (<= (overlay-start tmp) end) | |
| 670 (>= (overlay-start tmp) beg)) | |
| 671 (and (<= (overlay-end tmp) end) | |
| 672 (>= (overlay-end tmp) beg))) | |
| 673 (setq retval (cons tmp retval)))) | |
| 674 retval)) | |
| 675 | |
| 676 (sysdep-defun map-extents (function &optional object from to | |
| 677 maparg flags property value) | |
| 678 (let ((tmp (overlays-in (or from (point-min)) | |
| 679 (or to (point-max)))) | |
| 680 ovls) | |
| 681 (if property | |
| 682 (while tmp | |
| 683 (if (extent-property (car tmp) property) | |
| 684 (setq ovls (cons (car tmp) ovls))) | |
| 685 (setq tmp (cdr tmp))) | |
| 686 (setq ovls tmp | |
| 687 tmp nil)) | |
| 688 (catch 'done | |
| 689 (while ovls | |
| 690 (setq tmp (funcall function (car ovls) maparg) | |
| 691 ovls (cdr ovls)) | |
| 692 (if tmp | |
| 693 (throw 'done tmp)))))) | |
| 694 | |
| 695 ;; misc | |
| 696 (sysdep-defun symbol-value-in-buffer (symbol buffer &optional unbound-value) | |
| 697 "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound." | |
| 698 (save-excursion | |
| 699 (set-buffer buffer) | |
| 700 (if (not (boundp symbol)) | |
| 701 unbound-value | |
| 702 (symbol-value symbol)))) | |
| 703 | |
| 704 (sysdep-defun insert-file-contents-literally | |
| 705 (file &optional visit beg end replace) | |
| 706 "Like `insert-file-contents', q.v., but only reads in the file. | |
| 707 A buffer may be modified in several ways after reading into the buffer due | |
| 708 to advanced Emacs features, such as file-name-handlers, format decoding, | |
| 709 find-file-hooks, etc. | |
| 710 This function ensures that none of these modifications will take place." | |
| 711 (let ((file-name-handler-alist nil) | |
| 712 (find-file-hooks nil)) | |
| 713 (insert-file-contents file visit beg end replace))) | |
| 714 | |
| 715 (sysdep-defun alist-to-plist (alist) | |
| 716 "Convert association list ALIST into the equivalent property-list form. | |
| 717 The plist is returned. This converts from | |
| 718 | |
| 719 \((a . 1) (b . 2) (c . 3)) | |
| 720 | |
| 721 into | |
| 722 | |
| 723 \(a 1 b 2 c 3) | |
| 724 | |
| 725 The original alist is not modified. See also `destructive-alist-to-plist'." | |
| 726 (let (plist) | |
| 727 (while alist | |
| 728 (let ((el (car alist))) | |
| 729 (setq plist (cons (cdr el) (cons (car el) plist)))) | |
| 730 (setq alist (cdr alist))) | |
| 731 (nreverse plist))) | |
| 732 | |
| 733 (sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun) | |
| 734 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. | |
| 735 TOGGLE is a symbol which is used as the variable which toggle the minor mode, | |
| 736 NAME is the name that should appear in the modeline (it should be a string | |
| 737 beginning with a space), KEYMAP is a keymap to make active when the minor | |
| 738 mode is active, and AFTER is the toggling symbol used for another minor | |
| 739 mode. If AFTER is non-nil, then it is used to position the new mode in the | |
| 740 minor-mode alists. TOGGLE-FUN specifies an interactive function that | |
| 741 is called to toggle the mode on and off; this affects what appens when | |
| 742 button2 is pressed on the mode, and when button3 is pressed somewhere | |
| 743 in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an | |
| 744 interactive function, TOGGLE is used as the toggle function. | |
| 745 | |
| 746 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" | |
| 747 (if (not (assq toggle minor-mode-alist)) | |
| 748 (setq minor-mode-alist (cons (list toggle name) minor-mode-alist))) | |
| 749 (if (and keymap (not (assq toggle minor-mode-map-alist))) | |
| 750 (setq minor-mode-map-alist (cons (cons toggle keymap) | |
| 751 minor-mode-map-alist)))) | |
| 752 | |
| 753 (sysdep-defvar x-font-regexp-foundry-and-family | |
| 754 (let ((- "[-?]") | |
| 755 (foundry "[^-]+") | |
| 756 (family "[^-]+") | |
| 757 ) | |
| 758 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) | |
| 759 | |
| 760 (sysdep-defun match-string (num &optional string) | |
| 761 "Return string of text matched by last search. | |
| 762 NUM specifies which parenthesized expression in the last regexp. | |
| 763 Value is nil if NUMth pair didn't match, or there were less than NUM pairs. | |
| 764 Zero means the entire text matched by the whole regexp or whole string. | |
| 765 STRING should be given if the last search was by `string-match' on STRING." | |
| 766 (if (match-beginning num) | |
| 767 (if string | |
| 768 (substring string (match-beginning num) (match-end num)) | |
| 769 (buffer-substring (match-beginning num) (match-end num))))) | |
| 770 | |
| 771 (sysdep-defun add-hook (hook-var function &optional at-end) | |
| 772 "Add a function to a hook. | |
| 773 First argument HOOK-VAR (a symbol) is the name of a hook, second | |
| 774 argument FUNCTION is the function to add. | |
| 775 Third (optional) argument AT-END means to add the function at the end | |
| 776 of the hook list instead of the beginning. If the function is already | |
| 777 present, this has no effect. | |
| 778 Returns nil if FUNCTION was already present in HOOK-VAR, else new | |
| 779 value of HOOK-VAR." | |
| 780 (if (not (boundp hook-var)) (set hook-var nil)) | |
| 781 (let ((old (symbol-value hook-var))) | |
| 782 (if (or (not (listp old)) (eq (car old) 'lambda)) | |
| 783 (setq old (list old))) | |
| 784 (if (member function old) | |
| 785 nil | |
| 786 (set hook-var | |
| 787 (if at-end | |
| 788 (append old (list function)) ; don't nconc | |
| 789 (cons function old)))))) | |
| 790 | |
| 791 (sysdep-defalias 'valid-color-name-p | |
| 792 (cond | |
| 793 ((fboundp 'x-valid-color-name-p) ; XEmacs/Lucid | |
| 794 'x-valid-color-name-p) | |
| 795 ((and window-system | |
| 796 (fboundp 'color-defined-p)) ; NS/Emacs 19 | |
| 797 'color-defined-p) | |
| 798 ((and window-system | |
| 799 (fboundp 'x-color-defined-p)) ; Emacs 19 | |
| 800 'x-color-defined-p) | |
| 801 ((fboundp 'get-color) ; Epoch | |
| 802 (function (lambda (color) | |
| 803 (let ((x (get-color color))) | |
| 804 (if x | |
| 805 (setq x (progn | |
| 806 (free-color x) | |
| 807 t))) | |
| 808 x)))) | |
| 809 (t 'identity))) ; All others | |
| 810 | |
| 811 ;; Misc. | |
| 812 (sysdep-defun split-string (string pattern) | |
| 813 "Return a list of substrings of STRING which are separated by PATTERN." | |
| 814 (let (parts (start 0)) | |
| 815 (while (string-match pattern string start) | |
| 816 (setq parts (cons (substring string start (match-beginning 0)) parts) | |
| 817 start (match-end 0))) | |
| 818 (nreverse (cons (substring string start) parts)) | |
| 819 )) | |
| 820 | |
| 821 (sysdep-defun member (elt list) | |
| 822 (while (and list (not (equal elt (car list)))) | |
| 823 (setq list (cdr list))) | |
| 824 list) | |
| 825 | |
| 826 (sysdep-defun rassoc (key list) | |
| 827 (let ((found nil)) | |
| 828 (while (and list (not found)) | |
| 829 (if (equal (cdr (car list)) key) (setq found (car list))) | |
| 830 (setq list (cdr list))) | |
| 831 found)) | |
| 832 | |
| 833 (sysdep-defun display-error (error-object stream) | |
| 834 "Display `error-object' on `stream' in a user-friendly way." | |
| 835 (funcall (or (let ((type (car-safe error-object))) | |
| 836 (catch 'error | |
| 837 (and (consp error-object) | |
| 838 (symbolp type) | |
| 839 ;;(stringp (get type 'error-message)) | |
| 840 (consp (get type 'error-conditions)) | |
| 841 (let ((tail (cdr error-object))) | |
| 842 (while (not (null tail)) | |
| 843 (if (consp tail) | |
| 844 (setq tail (cdr tail)) | |
| 845 (throw 'error nil))) | |
| 846 t) | |
| 847 ;; (check-type condition condition) | |
| 848 (get type 'error-conditions) | |
| 849 ;; Search class hierarchy | |
| 850 (let ((tail (get type 'error-conditions))) | |
| 851 (while (not (null tail)) | |
| 852 (cond ((not (and (consp tail) | |
| 853 (symbolp (car tail)))) | |
| 854 (throw 'error nil)) | |
| 855 ((get (car tail) 'display-error) | |
| 856 (throw 'error (get (car tail) | |
| 857 'display-error))) | |
| 858 (t | |
| 859 (setq tail (cdr tail))))) | |
| 860 ;; Default method | |
| 861 (function | |
| 862 (lambda (error-object stream) | |
| 863 (let ((type (car error-object)) | |
| 864 (tail (cdr error-object)) | |
| 865 (first t)) | |
| 866 (if (eq type 'error) | |
| 867 (progn (princ (car tail) stream) | |
| 868 (setq tail (cdr tail))) | |
| 869 (princ (or (get type 'error-message) type) | |
| 870 stream)) | |
| 871 (while tail | |
| 872 (princ (if first ": " ", ") stream) | |
| 873 (prin1 (car tail) stream) | |
| 874 (setq tail (cdr tail) | |
| 875 first nil))))))))) | |
| 876 (function | |
| 877 (lambda (error-object stream) | |
| 878 (princ "Peculiar error " stream) | |
| 879 (prin1 error-object stream)))) | |
| 880 error-object stream)) | |
| 881 | |
| 882 (sysdep-defun find-face (face) | |
| 883 (car-safe (memq face (face-list)))) | |
| 884 | |
| 885 ;; window functions | |
| 886 | |
| 887 ;; not defined in v18 | |
| 888 (sysdep-defun eval-buffer (bufname &optional printflag) | |
| 889 (save-excursion | |
| 890 (set-buffer bufname) | |
| 891 (eval-current-buffer))) | |
| 892 | |
| 893 (sysdep-defun window-minibuffer-p (window) | |
| 894 "Returns non-nil if WINDOW is a minibuffer window." | |
| 895 (eq window (minibuffer-window))) | |
| 896 | |
| 897 ;; not defined in v18 | |
| 898 (sysdep-defun window-live-p (window) | |
| 899 "Returns t if OBJ is a window which is currently visible." | |
| 900 (and (windowp window) | |
| 901 (window-point window))) | |
| 902 | |
| 903 ;; this parenthesis closes the if statement at the top of the file. | |
| 904 | |
| 905 ) | |
| 906 | |
| 907 ;; DO NOT put a provide statement here. This file should never be | |
| 908 ;; loaded with `require'. Use `load-library' instead. | |
| 909 | |
| 910 ;;; sysdep.el ends here | |
| 911 | |
| 912 ;;;(sysdep.el) Local Variables: | |
| 913 ;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun) | |
| 914 ;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun) | |
| 915 ;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun) | |
| 916 ;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun) | |
| 917 ;;;(sysdep.el) End: |