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