|
0
|
1 ;;; sysdep.el --- consolidate Emacs-version dependencies in one file.
|
|
|
2
|
|
82
|
3 ;; Copyright (c) 1995 - 1997 Ben Wing.
|
|
0
|
4
|
|
82
|
5 ;; Author: Ben Wing <wing@666.com>, William Perry <wmperry@cs.indiana.edu>
|
|
0
|
6 ;; Keywords: lisp, tools
|
|
80
|
7 ;; Version: 0.003
|
|
0
|
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 ;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001)
|
|
|
54 ;; so that string comparisons to other versions work properly.
|
|
|
55
|
|
80
|
56 (defconst sysdep-potential-version "0.003")
|
|
0
|
57
|
|
|
58 ;; this macro means: define the function, but only if either it
|
|
|
59 ;; wasn't bound before, or the supplied binding comes from an older
|
|
|
60 ;; version of sysdep.el. That way, user-supplied bindings don't
|
|
|
61 ;; get overridden.
|
|
|
62
|
|
|
63 ;; note: sysdep-defalias is often more useful than this function,
|
|
|
64 ;; esp. since you can do load-time conditionalizing and can
|
|
|
65 ;; optionally leave the function undefined. (e.g. frame functions
|
|
|
66 ;; in v18.)
|
|
|
67
|
|
|
68 (defmacro sysdep-defun (function &rest everything-else)
|
|
80
|
69 (` (cond ((and (not (fboundp (quote (, function))))
|
|
|
70 (or
|
|
|
71 (not
|
|
|
72 (stringp (get (quote (, function)) 'sysdep-defined-this)))
|
|
|
73 (and (get (quote (, function)) 'sysdep-defined-this)
|
|
|
74 (string-lessp
|
|
|
75 (get (quote (, function)) 'sysdep-defined-this)
|
|
|
76 sysdep-potential-version))))
|
|
|
77 (put (quote (, function)) 'sysdep-defined-this
|
|
|
78 sysdep-potential-version)
|
|
0
|
79 (defun (, function) (,@ everything-else))))))
|
|
|
80
|
|
|
81 (defmacro sysdep-defvar (function &rest everything-else)
|
|
80
|
82 (` (cond ((and (not (boundp (quote (, function))))
|
|
|
83 (or
|
|
|
84 (not
|
|
|
85 (stringp (get (quote (, function)) 'sysdep-defined-this)))
|
|
|
86 (and (get (quote (, function)) 'sysdep-defined-this)
|
|
|
87 (string-lessp
|
|
|
88 (get (quote (, function)) 'sysdep-defined-this)
|
|
|
89 sysdep-potential-version))))
|
|
0
|
90 (put (quote (, function)) 'sysdep-defined-this t)
|
|
|
91 (defvar (, function) (,@ everything-else))))))
|
|
|
92
|
|
|
93 (defmacro sysdep-defconst (function &rest everything-else)
|
|
80
|
94 (` (cond ((and (not (boundp (quote (, function))))
|
|
|
95 (or
|
|
|
96 (not
|
|
|
97 (stringp (get (quote (, function)) 'sysdep-defined-this)))
|
|
|
98 (and (get (quote (, function)) 'sysdep-defined-this)
|
|
|
99 (string-lessp
|
|
|
100 (get (quote (, function)) 'sysdep-defined-this)
|
|
|
101 sysdep-potential-version))))
|
|
0
|
102 (put (quote (, function)) 'sysdep-defined-this t)
|
|
|
103 (defconst (, function) (,@ everything-else))))))
|
|
|
104
|
|
|
105 ;; similar for fset and defalias. No need to quote as the argument
|
|
|
106 ;; is already quoted.
|
|
|
107
|
|
|
108 (defmacro sysdep-fset (function def)
|
|
80
|
109 (` (cond ((and (not (fboundp (, function)))
|
|
|
110 (or (not (stringp
|
|
|
111 (get (, function) 'sysdep-defined-this)))
|
|
|
112 (and (get (, function) 'sysdep-defined-this)
|
|
|
113 (string-lessp
|
|
|
114 (get (, function) 'sysdep-defined-this)
|
|
|
115 sysdep-potential-version)))
|
|
0
|
116 (, def))
|
|
|
117 (put (, function) 'sysdep-defined-this t)
|
|
|
118 (fset (, function) (, def))))))
|
|
|
119
|
|
|
120 (defmacro sysdep-defalias (function def)
|
|
80
|
121 (` (cond ((and (not (fboundp (, function)))
|
|
|
122 (or (not (stringp
|
|
|
123 (get (, function) 'sysdep-defined-this)))
|
|
|
124 (and (get (, function) 'sysdep-defined-this)
|
|
|
125 (string-lessp
|
|
|
126 (get (, function) 'sysdep-defined-this)
|
|
|
127 sysdep-potential-version)))
|
|
0
|
128 (, def)
|
|
|
129 (or (listp (, def))
|
|
|
130 (and (symbolp (, def))
|
|
|
131 (fboundp (, def)))))
|
|
|
132 (put (, function) 'sysdep-defined-this t)
|
|
|
133 (defalias (, function) (, def))))))
|
|
|
134
|
|
|
135 ;; bootstrapping: defalias and define-function don't exist
|
|
|
136 ;; in older versions of lemacs
|
|
|
137
|
|
|
138 (sysdep-fset 'defalias 'fset)
|
|
|
139 (sysdep-defalias 'define-function 'defalias)
|
|
|
140
|
|
|
141 ;; useful ways of determining what version is running
|
|
|
142 ;; emacs-major-version and emacs-minor-version are
|
|
|
143 ;; already defined in recent versions of FSF Emacs and XEmacs
|
|
|
144
|
|
|
145 (sysdep-defconst emacs-major-version
|
|
|
146 ;; will string-match ever fail? If so, assume 19.0.
|
|
|
147 ;; (should we assume 18.something?)
|
|
|
148 (if (string-match "^[0-9]+" emacs-version)
|
|
|
149 (string-to-int
|
|
|
150 (substring emacs-version
|
|
|
151 (match-beginning 0) (match-end 0)))
|
|
|
152 19))
|
|
|
153
|
|
|
154 (sysdep-defconst emacs-minor-version
|
|
|
155 (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
|
|
|
156 (string-to-int
|
|
|
157 (substring emacs-version
|
|
|
158 (match-beginning 1) (match-end 1)))
|
|
|
159 0))
|
|
|
160
|
|
|
161 (sysdep-defconst sysdep-running-xemacs
|
|
|
162 (or (string-match "Lucid" emacs-version)
|
|
|
163 (string-match "XEmacs" emacs-version)))
|
|
|
164
|
|
|
165 (sysdep-defconst window-system nil)
|
|
|
166 (sysdep-defconst window-system-version 0)
|
|
|
167
|
|
|
168 (sysdep-defvar list-buffers-directory nil)
|
|
2
|
169 (sysdep-defvar x-library-search-path (`
|
|
|
170 ("/usr/X11R6/lib/X11/"
|
|
0
|
171 "/usr/X11R5/lib/X11/"
|
|
|
172 "/usr/lib/X11R6/X11/"
|
|
|
173 "/usr/lib/X11R5/X11/"
|
|
|
174 "/usr/local/X11R6/lib/X11/"
|
|
|
175 "/usr/local/X11R5/lib/X11/"
|
|
|
176 "/usr/local/lib/X11R6/X11/"
|
|
|
177 "/usr/local/lib/X11R5/X11/"
|
|
|
178 "/usr/X11/lib/X11/"
|
|
|
179 "/usr/lib/X11/"
|
|
|
180 "/usr/local/lib/X11/"
|
|
|
181 "/usr/X386/lib/X11/"
|
|
|
182 "/usr/x386/lib/X11/"
|
|
|
183 "/usr/XFree86/lib/X11/"
|
|
|
184 "/usr/unsupported/lib/X11/"
|
|
|
185 "/usr/athena/lib/X11/"
|
|
|
186 "/usr/local/x11r5/lib/X11/"
|
|
|
187 "/usr/lpp/Xamples/lib/X11/"
|
|
|
188 "/usr/openwin/lib/X11/"
|
|
2
|
189 "/usr/openwin/share/lib/X11/"
|
|
|
190 (, data-directory)
|
|
|
191 )
|
|
|
192 )
|
|
0
|
193 "Search path used for X11 libraries.")
|
|
|
194
|
|
|
195 ;; frame-related stuff.
|
|
|
196
|
|
|
197 (sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen)
|
|
|
198 (sysdep-defalias 'deiconify-frame
|
|
|
199 (cond ((fboundp 'deiconify-screen) 'deiconify-screen)
|
|
|
200 ;; make-frame-visible will be defined as necessary
|
|
|
201 (t 'make-frame-visible)))
|
|
|
202 (sysdep-defalias 'delete-frame 'delete-screen)
|
|
|
203 (sysdep-defalias 'event-frame 'event-screen)
|
|
|
204 (sysdep-defalias 'event-glyph-extent 'event-glyph)
|
|
|
205 (sysdep-defalias 'find-file-other-frame 'find-file-other-screen)
|
|
|
206 (sysdep-defalias 'find-file-read-only-other-frame
|
|
|
207 'find-file-read-only-other-screen)
|
|
|
208 (sysdep-defalias 'frame-height 'screen-height)
|
|
|
209 (sysdep-defalias 'frame-iconified-p 'screen-iconified-p)
|
|
|
210 (sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width)
|
|
|
211 (sysdep-defalias 'frame-list 'screen-list)
|
|
|
212 (sysdep-defalias 'frame-live-p
|
|
|
213 (cond ((fboundp 'screen-live-p) 'screen-live-p)
|
|
|
214 ((fboundp 'live-screen-p) 'live-screen-p)
|
|
|
215 ;; #### not sure if this is correct (this is for Epoch)
|
|
|
216 ;; but gnuserv.el uses it this way
|
|
|
217 ((fboundp 'screenp) 'screenp)))
|
|
|
218 (sysdep-defalias 'frame-name 'screen-name)
|
|
|
219 (sysdep-defalias 'frame-parameters 'screen-parameters)
|
|
|
220 (sysdep-defalias 'frame-pixel-height 'screen-pixel-height)
|
|
|
221 (sysdep-defalias 'frame-pixel-width 'screen-pixel-width)
|
|
|
222 (sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width)
|
|
|
223 (sysdep-defalias 'frame-root-window 'screen-root-window)
|
|
|
224 (sysdep-defalias 'frame-selected-window 'screen-selected-window)
|
|
|
225 (sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p)
|
|
|
226 (sysdep-defalias 'frame-visible-p 'screen-visible-p)
|
|
|
227 (sysdep-defalias 'frame-width 'screen-width)
|
|
|
228 (sysdep-defalias 'framep 'screenp)
|
|
|
229 (sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer)
|
|
|
230 (sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect)
|
|
|
231 (sysdep-defalias 'get-other-frame 'get-other-screen)
|
|
|
232 (sysdep-defalias 'iconify-frame 'iconify-screen)
|
|
|
233 (sysdep-defalias 'lower-frame 'lower-screen)
|
|
70
|
234 (sysdep-defalias 'mail-other-frame 'mail-other-screen)
|
|
0
|
235
|
|
|
236 (sysdep-defalias 'make-frame
|
|
|
237 (cond ((fboundp 'make-screen)
|
|
|
238 (function (lambda (&optional parameters device)
|
|
|
239 (make-screen parameters))))
|
|
|
240 ((fboundp 'x-create-screen)
|
|
|
241 (function (lambda (&optional parameters device)
|
|
|
242 (x-create-screen parameters))))))
|
|
|
243
|
|
|
244 (sysdep-defalias 'make-frame-invisible 'make-screen-invisible)
|
|
|
245 (sysdep-defalias 'make-frame-visible
|
|
|
246 (cond ((fboundp 'make-screen-visible) 'make-screen-visible)
|
|
|
247 ((fboundp 'mapraised-screen) 'mapraised-screen)
|
|
|
248 ((fboundp 'x-remap-window)
|
|
|
249 (lambda (&optional x)
|
|
|
250 (x-remap-window)
|
|
|
251 (accept-process-output)))))
|
|
|
252 (sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters)
|
|
|
253 (sysdep-defalias 'new-frame 'new-screen)
|
|
|
254 (sysdep-defalias 'next-frame 'next-screen)
|
|
|
255 (sysdep-defalias 'next-multiframe-window 'next-multiscreen-window)
|
|
|
256 (sysdep-defalias 'other-frame 'other-screen)
|
|
|
257 (sysdep-defalias 'previous-frame 'previous-screen)
|
|
|
258 (sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window)
|
|
|
259 (sysdep-defalias 'raise-frame
|
|
|
260 (cond ((fboundp 'raise-screen) 'raise-screen)
|
|
|
261 ((fboundp 'mapraise-screen) 'mapraise-screen)))
|
|
|
262 (sysdep-defalias 'redraw-frame 'redraw-screen)
|
|
|
263 (sysdep-defalias 'select-frame 'select-screen)
|
|
|
264 (sysdep-defalias 'selected-frame 'selected-screen)
|
|
|
265 (sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen)
|
|
|
266 (sysdep-defalias 'set-frame-height 'set-screen-height)
|
|
|
267 (sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width)
|
|
|
268 (sysdep-defalias 'set-frame-position 'set-screen-position)
|
|
|
269 (sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width)
|
|
|
270 (sysdep-defalias 'set-frame-size 'set-screen-size)
|
|
|
271 (sysdep-defalias 'set-frame-width 'set-screen-width)
|
|
|
272 (sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen)
|
|
|
273 (sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen)
|
|
|
274 (sysdep-defalias 'visible-frame-list 'visible-screen-list)
|
|
|
275 (sysdep-defalias 'window-frame 'window-screen)
|
|
|
276 (sysdep-defalias 'x-create-frame 'x-create-screen)
|
|
|
277 (sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap)
|
|
|
278 (sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer)
|
|
|
279 (sysdep-defalias 'x-display-color-p 'x-color-display-p)
|
|
|
280 (sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p)
|
|
|
281 (sysdep-defalias 'menu-event-p 'misc-user-event-p)
|
|
|
282
|
|
80
|
283 ;; WMP - commention these out so that Emacs 19 doesn't get screwed by them.
|
|
|
284 ;; In particular, this makes the 'custom' package blow up quite well.
|
|
|
285 ;;(sysdep-defun add-submenu (menu-path submenu &optional before)
|
|
|
286 ;; "Add a menu to the menubar or one of its submenus.
|
|
|
287 ;;If the named menu exists already, it is changed.
|
|
|
288 ;;MENU-PATH identifies the menu under which the new menu should be inserted.
|
|
|
289 ;; It is a list of strings; for example, (\"File\") names the top-level \"File\"
|
|
|
290 ;; menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
|
|
|
291 ;; If MENU-PATH is nil, then the menu will be added to the menubar itself.
|
|
|
292 ;;SUBMENU is the new menu to add.
|
|
|
293 ;; See the documentation of `current-menubar' for the syntax.
|
|
|
294 ;;BEFORE, if provided, is the name of a menu before which this menu should
|
|
|
295 ;; be added, if this menu is not on its parent already. If the menu is already
|
|
|
296 ;; present, it will not be moved."
|
|
|
297 ;; (add-menu menu-path (car submenu) (cdr submenu) before))
|
|
0
|
298
|
|
80
|
299 ;;(sysdep-defun add-menu-button (menu-path menu-leaf &optional before)
|
|
|
300 ;; "Add a menu item to some menu, creating the menu first if necessary.
|
|
|
301 ;;If the named item exists already, it is changed.
|
|
|
302 ;;MENU-PATH identifies the menu under which the new menu item should be inserted.
|
|
|
303 ;; It is a list of strings; for example, (\"File\") names the top-level \"File\"
|
|
|
304 ;; menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
|
|
|
305 ;;MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'.
|
|
|
306 ;;BEFORE, if provided, is the name of a menu item before which this item should
|
|
|
307 ;; be added, if this item is not on the menu already. If the item is already
|
|
|
308 ;; present, it will not be moved."
|
|
|
309 ;; (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1)
|
|
|
310 ;; (aref menu-leaf 2) before))
|
|
0
|
311
|
|
|
312 (sysdep-defun make-glyph (&optional spec-list)
|
|
|
313 (if (and spec-list (cdr-safe (assq 'x spec-list)))
|
|
|
314 (make-pixmap (cdr-safe (assq 'x spec-list)))))
|
|
|
315
|
|
|
316 (sysdep-defalias 'face-list 'list-faces)
|
|
|
317
|
|
80
|
318 (sysdep-defun set-keymap-parent (keymap new-parent)
|
|
|
319 (let ((tail keymap))
|
|
|
320 (while (and tail (cdr tail) (not (eq (car (cdr tail)) 'keymap)))
|
|
|
321 (setq tail (cdr tail)))
|
|
|
322 (if tail
|
|
|
323 (setcdr tail new-parent))))
|
|
|
324
|
|
2
|
325 (sysdep-defun facep (face)
|
|
|
326 "Return t if X is a face name or an internal face vector."
|
|
|
327 ;; CAUTION!!! This is Emacs 19.x, for x <= 28, specific
|
|
|
328 ;; I know of no version of Lucid Emacs or XEmacs that did not have
|
|
|
329 ;; facep. Even if they did, they are unsupported, so big deal.
|
|
80
|
330 (if (not window-system)
|
|
|
331 nil ; FIXME if FSF ever does TTY faces
|
|
|
332 (and (or (internal-facep face)
|
|
|
333 (and (symbolp face) (assq face global-face-data)))
|
|
|
334 t)))
|
|
2
|
335
|
|
0
|
336 (sysdep-defun set-face-property (face property value &optional locale
|
|
|
337 tag-set how-to-add)
|
|
|
338 "Change a property of FACE."
|
|
|
339 (and (symbolp face)
|
|
|
340 (put face property value)))
|
|
|
341
|
|
|
342 (sysdep-defun face-property (face property &optional locale tag-set exact-p)
|
|
|
343 "Return FACE's value of the given PROPERTY."
|
|
|
344 (and (symbolp face) (get face property)))
|
|
|
345
|
|
80
|
346 ;;; Additional text property functions.
|
|
|
347
|
|
|
348 ;; The following three text property functions are not generally available (and
|
|
|
349 ;; it's not certain that they should be) so they are inlined for speed.
|
|
|
350 ;; The case for `fillin-text-property' is simple; it may or not be generally
|
|
|
351 ;; useful. (Since it is used here, it is useful in at least one place.;-)
|
|
|
352 ;; However, the case for `append-text-property' and `prepend-text-property' is
|
|
|
353 ;; more complicated. Should they remove duplicate property values or not? If
|
|
|
354 ;; so, should the first or last duplicate item remain? Or the one that was
|
|
|
355 ;; added? In our implementation, the first duplicate remains.
|
|
|
356
|
|
|
357 (sysdep-defun fillin-text-property (start end setprop markprop value &optional object)
|
|
|
358 "Fill in one property of the text from START to END.
|
|
|
359 Arguments PROP and VALUE specify the property and value to put where none are
|
|
|
360 already in place. Therefore existing property values are not overwritten.
|
|
|
361 Optional argument OBJECT is the string or buffer containing the text."
|
|
|
362 (let ((start (text-property-any start end markprop nil object)) next)
|
|
|
363 (while start
|
|
|
364 (setq next (next-single-property-change start markprop object end))
|
|
|
365 (put-text-property start next setprop value object)
|
|
|
366 (put-text-property start next markprop value object)
|
|
|
367 (setq start (text-property-any next end markprop nil object)))))
|
|
|
368
|
|
|
369 ;; This function (from simon's unique.el) is rewritten and inlined for speed.
|
|
|
370 ;(defun unique (list function)
|
|
|
371 ; "Uniquify LIST, deleting elements using FUNCTION.
|
|
|
372 ;Return the list with subsequent duplicate items removed by side effects.
|
|
|
373 ;FUNCTION is called with an element of LIST and a list of elements from LIST,
|
|
|
374 ;and should return the list of elements with occurrences of the element removed,
|
|
|
375 ;i.e., a function such as `delete' or `delq'.
|
|
|
376 ;This function will work even if LIST is unsorted. See also `uniq'."
|
|
|
377 ; (let ((list list))
|
|
|
378 ; (while list
|
|
|
379 ; (setq list (setcdr list (funcall function (car list) (cdr list))))))
|
|
|
380 ; list)
|
|
|
381
|
|
|
382 (sysdep-defun unique (list)
|
|
|
383 "Uniquify LIST, deleting elements using `delq'.
|
|
|
384 Return the list with subsequent duplicate items removed by side effects."
|
|
|
385 (let ((list list))
|
|
|
386 (while list
|
|
|
387 (setq list (setcdr list (delq (car list) (cdr list))))))
|
|
|
388 list)
|
|
|
389
|
|
|
390 ;; A generalisation of `facemenu-add-face' for any property, but without the
|
|
|
391 ;; removal of inactive faces via `facemenu-discard-redundant-faces' and special
|
|
|
392 ;; treatment of `default'. Uses `unique' to remove duplicate property values.
|
|
|
393 (sysdep-defun prepend-text-property (start end prop value &optional object)
|
|
|
394 "Prepend to one property of the text from START to END.
|
|
|
395 Arguments PROP and VALUE specify the property and value to prepend to the value
|
|
|
396 already in place. The resulting property values are always lists, and unique.
|
|
|
397 Optional argument OBJECT is the string or buffer containing the text."
|
|
|
398 (let ((val (if (listp value) value (list value))) next prev)
|
|
|
399 (while (/= start end)
|
|
|
400 (setq next (next-single-property-change start prop object end)
|
|
|
401 prev (get-text-property start prop object))
|
|
|
402 (put-text-property
|
|
|
403 start next prop
|
|
|
404 (unique (append val (if (listp prev) prev (list prev))))
|
|
|
405 object)
|
|
|
406 (setq start next))))
|
|
|
407
|
|
|
408 (sysdep-defun append-text-property (start end prop value &optional object)
|
|
|
409 "Append to one property of the text from START to END.
|
|
|
410 Arguments PROP and VALUE specify the property and value to append to the value
|
|
|
411 already in place. The resulting property values are always lists, and unique.
|
|
|
412 Optional argument OBJECT is the string or buffer containing the text."
|
|
|
413 (let ((val (if (listp value) value (list value))) next prev)
|
|
|
414 (while (/= start end)
|
|
|
415 (setq next (next-single-property-change start prop object end)
|
|
|
416 prev (get-text-property start prop object))
|
|
|
417 (put-text-property
|
|
|
418 start next prop
|
|
|
419 (unique (append (if (listp prev) prev (list prev)) val))
|
|
|
420 object)
|
|
|
421 (setq start next))))
|
|
|
422
|
|
2
|
423 ;; Property list functions
|
|
|
424 ;;
|
|
|
425 (sysdep-defun plist-put (plist prop val)
|
|
|
426 "Change value in PLIST of PROP to VAL.
|
|
|
427 PLIST is a property list, which is a list of the form
|
|
|
428 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
|
|
|
429 If PROP is already a property on the list, its value is set to VAL,
|
|
|
430 otherwise the new PROP VAL pair is added. The new plist is returned;
|
|
|
431 use `(setq x (plist-put x prop val))' to be sure to use the new value.
|
|
|
432 The PLIST is modified by side effects."
|
|
|
433 (let ((node (memq prop plist)))
|
|
|
434 (if node
|
|
|
435 (setcar (cdr node) val)
|
|
|
436 (setq plist (cons prop (cons val plist))))
|
|
|
437 plist))
|
|
|
438
|
|
|
439 (sysdep-defun plist-get (plist prop)
|
|
|
440 "Extract a value from a property list.
|
|
|
441 PLIST is a property list, which is a list of the form
|
|
|
442 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
|
|
|
443 corresponding to the given PROP, or nil if PROP is not
|
|
|
444 one of the properties on the list."
|
|
80
|
445 (while (and plist (not (eq (car plist) prop)))
|
|
|
446 (setq plist (cdr (cdr plist))))
|
|
|
447 (and plist (car (cdr plist))))
|
|
2
|
448
|
|
0
|
449 ;; Device functions
|
|
2
|
450 ;; By wmperry@cs.indiana.edu
|
|
0
|
451 ;; This is a complete implementation of all the device-* functions found in
|
|
|
452 ;; XEmacs 19.14. A 'device' for Emacs 19 is just a frame, from which we can
|
|
|
453 ;; determine the connection to an X display, etc.
|
|
|
454
|
|
|
455 (sysdep-defalias 'selected-device 'ignore)
|
|
|
456 (sysdep-defalias 'device-or-frame-p 'framep)
|
|
|
457 (sysdep-defalias 'device-console 'ignore)
|
|
|
458 (sysdep-defalias 'device-sound-enabled-p 'ignore)
|
|
|
459 (sysdep-defalias 'device-live-p 'frame-live-p)
|
|
|
460 (sysdep-defalias 'devicep 'framep)
|
|
|
461 (sysdep-defalias 'frame-device 'identity)
|
|
|
462 (sysdep-defalias 'redisplay-device 'redraw-frame)
|
|
|
463 (sysdep-defalias 'redraw-device 'redraw-frame)
|
|
|
464 (sysdep-defalias 'select-device 'select-frame)
|
|
|
465 (sysdep-defalias 'set-device-class 'ignore)
|
|
|
466
|
|
|
467 (sysdep-defun make-device (type connection &optional props)
|
|
|
468 "Create a new device of type TYPE, attached to connection CONNECTION.
|
|
|
469
|
|
|
470 The valid values for CONNECTION are device-specific; however,
|
|
|
471 CONNECTION is generally a string. (Specifically, for X devices,
|
|
|
472 CONNECTION should be a display specification such as \"foo:0\", and
|
|
|
473 for TTY devices, CONNECTION should be the filename of a TTY device
|
|
|
474 file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard
|
|
|
475 input/output.)
|
|
|
476
|
|
|
477 PROPS, if specified, should be a plist of properties controlling
|
|
|
478 device creation.
|
|
|
479
|
|
|
480 If CONNECTION specifies an already-existing device connection, that
|
|
|
481 device is simply returned; no new device is created, and PROPS
|
|
|
482 have no effect."
|
|
|
483 (cond
|
|
|
484 ((and (eq type 'x) connection)
|
|
80
|
485 (make-frame-on-display connection props))
|
|
0
|
486 ((eq type 'x)
|
|
|
487 (make-frame props))
|
|
|
488 ((eq type 'tty)
|
|
|
489 nil)
|
|
|
490 (t
|
|
|
491 (error "Unsupported device-type: %s" type))))
|
|
|
492
|
|
|
493 (sysdep-defun make-frame-on-device (type connection &optional props)
|
|
|
494 "Create a frame of type TYPE on CONNECTION.
|
|
|
495 TYPE should be a symbol naming the device type, i.e. one of
|
|
|
496
|
|
|
497 x An X display. CONNECTION should be a standard display string
|
|
|
498 such as \"unix:0\", or nil for the display specified on the
|
|
|
499 command line or in the DISPLAY environment variable. Only if
|
|
|
500 support for X was compiled into XEmacs.
|
|
|
501 tty A standard TTY connection or terminal. CONNECTION should be
|
|
|
502 a TTY device name such as \"/dev/ttyp2\" (as determined by
|
|
|
503 the Unix command `tty') or nil for XEmacs' standard input
|
|
|
504 and output (usually the TTY in which XEmacs started). Only
|
|
|
505 if support for TTY's was compiled into XEmacs.
|
|
|
506 ns A connection to a machine running the NeXTstep windowing
|
|
|
507 system. Not currently implemented.
|
|
|
508 win32 A connection to a machine running Microsoft Windows NT or
|
|
|
509 Windows 95. Not currently implemented.
|
|
|
510 pc A direct-write MS-DOS frame. Not currently implemented.
|
|
|
511
|
|
80
|
512 PROPS should be an plist of properties, as in the call to `make-frame'.
|
|
0
|
513
|
|
|
514 If a connection to CONNECTION already exists, it is reused; otherwise,
|
|
|
515 a new connection is opened."
|
|
|
516 (make-device type connection props))
|
|
|
517
|
|
|
518 (sysdep-defun make-tty-device (&optional tty terminal-type)
|
|
|
519 "Create a new device on TTY.
|
|
|
520 TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under
|
|
|
521 SunOS et al.), as returned by the `tty' command. A value of nil means
|
|
|
522 use the stdin and stdout as passed to XEmacs from the shell.
|
|
|
523 If TERMINAL-TYPE is non-nil, it should be a string specifying the
|
|
|
524 type of the terminal attached to the specified tty. If it is nil,
|
|
|
525 the terminal type will be inferred from the TERM environment variable."
|
|
|
526 (make-device 'tty tty (list 'terminal-type terminal-type)))
|
|
|
527
|
|
|
528 (sysdep-defun make-x-device (&optional display)
|
|
|
529 (make-device 'x display))
|
|
|
530
|
|
|
531 (sysdep-defun set-device-selected-frame (device frame)
|
|
|
532 "Set the selected frame of device object DEVICE to FRAME.
|
|
|
533 If DEVICE is nil, the selected device is used.
|
|
|
534 If DEVICE is the selected device, this makes FRAME the selected frame."
|
|
|
535 (select-frame frame))
|
|
|
536
|
|
|
537 (sysdep-defun set-device-baud-rate (device rate)
|
|
|
538 "Set the output baud rate of DEVICE to RATE.
|
|
|
539 On most systems, changing this value will affect the amount of padding
|
|
|
540 and other strategic decisions made during redisplay."
|
|
|
541 (setq baud-rate rate))
|
|
|
542
|
|
|
543 (sysdep-defun dfw-device (obj)
|
|
|
544 "Given a device, frame, or window, return the associated device.
|
|
|
545 Return nil otherwise."
|
|
|
546 (cond
|
|
|
547 ((windowp obj)
|
|
|
548 (window-frame obj))
|
|
|
549 ((framep obj)
|
|
|
550 obj)
|
|
|
551 (t
|
|
|
552 nil)))
|
|
|
553
|
|
|
554 (sysdep-defun event-device (event)
|
|
|
555 "Return the device that EVENT occurred on.
|
|
|
556 This will be nil for some types of events (e.g. keyboard and eval events)."
|
|
|
557 (dfw-device (posn-window (event-start event))))
|
|
|
558
|
|
|
559 (sysdep-defun find-device (connection &optional type)
|
|
|
560 "Look for an existing device attached to connection CONNECTION.
|
|
|
561 Return the device if found; otherwise, return nil.
|
|
|
562
|
|
|
563 If TYPE is specified, only return devices of that type; otherwise,
|
|
|
564 return devices of any type. (It is possible, although unlikely,
|
|
|
565 that two devices of different types could have the same connection
|
|
|
566 name; in such a case, the first device found is returned.)"
|
|
|
567 (let ((devices (device-list))
|
|
|
568 (retval nil))
|
|
|
569 (while (and devices (not nil))
|
|
|
570 (if (equal connection (device-connection (car devices)))
|
|
|
571 (setq retval (car devices)))
|
|
|
572 (setq devices (cdr devices)))
|
|
|
573 retval))
|
|
|
574
|
|
|
575 (sysdep-defalias 'get-device 'find-device)
|
|
|
576
|
|
|
577 (sysdep-defun device-baud-rate (&optional device)
|
|
|
578 "Return the output baud rate of DEVICE."
|
|
|
579 baud-rate)
|
|
|
580
|
|
|
581 (sysdep-defun device-on-window-system-p (&optional device)
|
|
|
582 "Return non-nil if DEVICE is on a window system.
|
|
|
583 This generally means that there is support for the mouse, the menubar,
|
|
|
584 the toolbar, glyphs, etc."
|
|
|
585 (and (cdr-safe (assq 'display (frame-parameters device))) t))
|
|
|
586
|
|
|
587 (sysdep-defun device-name (&optional device)
|
|
|
588 "Return the name of the specified device."
|
|
|
589 ;; doesn't handle the 19.29 multiple X display stuff yet
|
|
|
590 ;; doesn't handle NeXTStep either
|
|
|
591 (cond
|
|
|
592 ((null window-system) "stdio")
|
|
|
593 ((getenv "DISPLAY")
|
|
|
594 (let ((str (getenv "DISPLAY"))
|
|
|
595 (x (1- (length (getenv "DISPLAY"))))
|
|
|
596 (y 0))
|
|
|
597 (while (/= y x)
|
|
|
598 (if (or (= (aref str y) ?:)
|
|
|
599 (= (aref str y) ?.))
|
|
|
600 (aset str y ?-))
|
|
|
601 (setq y (1+ y)))
|
|
|
602 str))
|
|
|
603 (t "stdio")))
|
|
|
604
|
|
|
605 (sysdep-defun device-connection (&optional device)
|
|
|
606 "Return the connection of the specified device.
|
|
|
607 DEVICE defaults to the selected device if omitted"
|
|
|
608 (or (cdr-safe (assq 'display (frame-parameters device))) "stdio"))
|
|
|
609
|
|
|
610 (sysdep-defun device-frame-list (&optional device)
|
|
|
611 "Return a list of all frames on DEVICE.
|
|
|
612 If DEVICE is nil, the selected device will be used."
|
|
|
613 (let ((desired (device-connection device)))
|
|
|
614 (filtered-frame-list (function (lambda (x) (equal (device-connection x)
|
|
|
615 desired))))))
|
|
|
616 (sysdep-defun device-list ()
|
|
|
617 "Return a list of all devices"
|
|
|
618 (let ((seen nil)
|
|
|
619 (cur nil)
|
|
|
620 (conn nil)
|
|
|
621 (retval nil)
|
|
|
622 (not-heard (frame-list)))
|
|
|
623 (while not-heard
|
|
|
624 (setq cur (car not-heard)
|
|
|
625 conn (device-connection cur)
|
|
|
626 not-heard (cdr not-heard))
|
|
|
627 (if (member conn seen)
|
|
|
628 nil ; Already got it
|
|
|
629 (setq seen (cons conn seen) ; Whoo hoo, a new one!
|
|
|
630 retval (cons cur retval))))
|
|
|
631 retval))
|
|
|
632
|
|
|
633 (sysdep-defvar delete-device-hook nil
|
|
|
634 "Function or functions to call when a device is deleted.
|
|
|
635 One argument, the to-be-deleted device.")
|
|
|
636
|
|
|
637 (sysdep-defun delete-device (device &optional force)
|
|
|
638 "Delete DEVICE, permanently eliminating it from use.
|
|
|
639 Normally, you cannot delete the last non-minibuffer-only frame (you must
|
|
|
640 use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional
|
|
|
641 second argument FORCE is non-nil, you can delete the last frame. (This
|
|
|
642 will automatically call `save-buffers-kill-emacs'.)"
|
|
|
643 (let ((frames (device-frame-list device)))
|
|
|
644 (run-hook-with-args 'delete-device-hook device)
|
|
|
645 (while frames
|
|
|
646 (delete-frame (car frames) force)
|
|
|
647 (setq frames (cdr frames)))))
|
|
|
648
|
|
|
649 (sysdep-defalias 'device-color-cells
|
|
|
650 (cond
|
|
|
651 ((null window-system) 'ignore)
|
|
|
652 ((fboundp 'display-color-cells) 'display-color-cells)
|
|
|
653 ((fboundp 'x-display-color-cells) 'x-display-color-cells)
|
|
|
654 ((fboundp 'ns-display-color-cells) 'ns-display-color-celles)
|
|
|
655 (t 'ignore)))
|
|
|
656
|
|
|
657 (sysdep-defun try-font-name (fontname &rest args)
|
|
80
|
658 (cond
|
|
|
659 ((eq window-system 'x) (car-safe (x-list-fonts fontname)))
|
|
|
660 ((eq window-system 'ns) (car-safe (ns-list-fonts fontname)))
|
|
|
661 (t nil)))
|
|
0
|
662
|
|
|
663 (sysdep-defalias 'device-pixel-width
|
|
|
664 (cond
|
|
70
|
665 ((and (eq window-system 'x) (fboundp 'x-display-pixel-width))
|
|
0
|
666 'x-display-pixel-width)
|
|
|
667 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-width))
|
|
|
668 'ns-display-pixel-width)
|
|
|
669 (t 'ignore)))
|
|
|
670
|
|
|
671 (sysdep-defalias 'device-pixel-height
|
|
|
672 (cond
|
|
70
|
673 ((and (eq window-system 'x) (fboundp 'x-display-pixel-height))
|
|
0
|
674 'x-display-pixel-height)
|
|
|
675 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-height))
|
|
|
676 'ns-display-pixel-height)
|
|
|
677 (t 'ignore)))
|
|
|
678
|
|
|
679 (sysdep-defalias 'device-mm-width
|
|
|
680 (cond
|
|
70
|
681 ((and (eq window-system 'x) (fboundp 'x-display-mm-width))
|
|
0
|
682 'x-display-mm-width)
|
|
|
683 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-width))
|
|
|
684 'ns-display-mm-width)
|
|
|
685 (t 'ignore)))
|
|
|
686
|
|
|
687 (sysdep-defalias 'device-mm-height
|
|
|
688 (cond
|
|
70
|
689 ((and (eq window-system 'x) (fboundp 'x-display-mm-height))
|
|
0
|
690 'x-display-mm-height)
|
|
|
691 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-height))
|
|
|
692 'ns-display-mm-height)
|
|
|
693 (t 'ignore)))
|
|
|
694
|
|
|
695 (sysdep-defalias 'device-bitplanes
|
|
|
696 (cond
|
|
70
|
697 ((and (eq window-system 'x) (fboundp 'x-display-planes))
|
|
0
|
698 'x-display-planes)
|
|
|
699 ((and (eq window-system 'ns) (fboundp 'ns-display-planes))
|
|
|
700 'ns-display-planes)
|
|
|
701 (t 'ignore)))
|
|
|
702
|
|
|
703 (sysdep-defalias 'device-class
|
|
|
704 (cond
|
|
2
|
705 ;; First, Xwindows
|
|
0
|
706 ((and (eq window-system 'x) (fboundp 'x-display-visual-class))
|
|
|
707 (function
|
|
|
708 (lambda (&optional device)
|
|
|
709 (let ((val (symbol-name (x-display-visual-class device))))
|
|
|
710 (cond
|
|
|
711 ((string-match "color" val) 'color)
|
|
|
712 ((string-match "gray-scale" val) 'grayscale)
|
|
|
713 (t 'mono))))))
|
|
2
|
714 ;; Now, Presentation-Manager under OS/2
|
|
|
715 ((and (eq window-system 'pm) (fboundp 'pm-display-visual-class))
|
|
|
716 (function
|
|
|
717 (lambda (&optional device)
|
|
|
718 (let ((val (symbol-name (pm-display-visual-class device))))
|
|
|
719 (cond
|
|
|
720 ((string-match "color" val) 'color)
|
|
|
721 ((string-match "gray-scale" val) 'grayscale)
|
|
|
722 (t 'mono))))))
|
|
|
723 ;; A slightly different way of doing it under OS/2
|
|
|
724 ((and (eq window-system 'pm) (fboundp 'pm-display-color-p))
|
|
|
725 (function
|
|
|
726 (lambda (&optional device)
|
|
|
727 (if (pm-display-color-p)
|
|
|
728 'color
|
|
|
729 'mono))))
|
|
0
|
730 ((fboundp 'number-of-colors)
|
|
|
731 (function
|
|
|
732 (lambda (&optional device)
|
|
|
733 (if (= 2 (number-of-colors))
|
|
|
734 'mono
|
|
|
735 'color))))
|
|
|
736 ((and (eq window-system 'x) (fboundp 'x-color-p))
|
|
|
737 (function
|
|
|
738 (lambda (&optional device)
|
|
|
739 (if (x-color-p)
|
|
|
740 'color
|
|
|
741 'mono))))
|
|
|
742 ((and (eq window-system 'ns) (fboundp 'ns-display-visual-class))
|
|
|
743 (function
|
|
|
744 (lambda (&optional device)
|
|
|
745 (let ((val (symbol-name (ns-display-visual-class))))
|
|
|
746 (cond
|
|
|
747 ((string-match "color" val) 'color)
|
|
|
748 ((string-match "gray-scale" val) 'grayscale)
|
|
|
749 (t 'mono))))))
|
|
70
|
750 (t (function (lambda (&optional device) 'mono)))))
|
|
0
|
751
|
|
|
752 (sysdep-defun device-class-list ()
|
|
|
753 "Returns a list of valid device classes."
|
|
|
754 (list 'color 'grayscale 'mono))
|
|
|
755
|
|
|
756 (sysdep-defun valid-device-class-p (class)
|
|
|
757 "Given a CLASS, return t if it is valid.
|
|
|
758 Valid classes are 'color, 'grayscale, and 'mono."
|
|
|
759 (memq class (device-class-list)))
|
|
|
760
|
|
|
761 (sysdep-defun device-or-frame-type (device-or-frame)
|
|
|
762 "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME.
|
|
|
763 DEVICE-OR-FRAME should be a device or a frame object. See `device-type'
|
|
|
764 for a description of the possible types."
|
|
2
|
765 (if (or (cdr-safe (assq 'display (frame-parameters device-or-frame)))
|
|
|
766 (cdr-safe (assq 'window-id (frame-parameters device-or-frame))))
|
|
0
|
767 window-system
|
|
|
768 'tty))
|
|
|
769
|
|
|
770 (sysdep-defun device-type (&optional device)
|
|
|
771 "Return the type of the specified device (e.g. `x' or `tty').
|
|
|
772 Value is `tty' for a tty device (a character-only terminal),
|
|
|
773 `x' for a device which is a connection to an X server,
|
|
|
774 'ns' for a device which is a connection to a NeXTStep dps server,
|
|
|
775 'win32' for a Windows-NT window,
|
|
|
776 'pm' for an OS/2 Presentation Manager window,
|
|
|
777 'intuition' for an Amiga screen"
|
|
|
778 (device-or-frame-type device))
|
|
|
779
|
|
|
780 (sysdep-defun device-type-list ()
|
|
|
781 "Return a list of valid console types."
|
|
|
782 (if window-system
|
|
|
783 (list window-system 'tty)
|
|
|
784 (list 'tty)))
|
|
|
785
|
|
|
786 (sysdep-defun valid-device-type-p (type)
|
|
|
787 "Given a TYPE, return t if it is valid."
|
|
|
788 (memq type (device-type-list)))
|
|
|
789
|
|
70
|
790
|
|
0
|
791 ;; Extent stuff
|
|
|
792 (sysdep-fset 'delete-extent 'delete-overlay)
|
|
|
793 (sysdep-fset 'extent-end-position 'overlay-end)
|
|
|
794 (sysdep-fset 'extent-start-position 'overlay-start)
|
|
|
795 (sysdep-fset 'set-extent-endpoints 'move-overlay)
|
|
2
|
796 (sysdep-fset 'set-extent-property 'overlay-put)
|
|
|
797 (sysdep-fset 'make-extent 'make-overlay)
|
|
0
|
798
|
|
|
799 (sysdep-defun extent-property (extent property &optional default)
|
|
|
800 (or (overlay-get extent property) default))
|
|
|
801
|
|
|
802 (sysdep-defun extent-at (pos &optional object property before at-flag)
|
|
|
803 (let ((tmp (overlays-at (point)))
|
|
|
804 ovls)
|
|
|
805 (if property
|
|
|
806 (while tmp
|
|
|
807 (if (extent-property (car tmp) property)
|
|
|
808 (setq ovls (cons (car tmp) ovls)))
|
|
|
809 (setq tmp (cdr tmp)))
|
|
|
810 (setq ovls tmp
|
|
|
811 tmp nil))
|
|
|
812 (car-safe
|
|
|
813 (sort ovls
|
|
|
814 (function
|
|
|
815 (lambda (a b)
|
|
|
816 (< (- (extent-end-position a) (extent-start-position a))
|
|
|
817 (- (extent-end-position b) (extent-start-position b)))))))))
|
|
|
818
|
|
|
819 (sysdep-defun overlays-in (beg end)
|
|
|
820 "Return a list of the overlays that overlap the region BEG ... END.
|
|
|
821 Overlap means that at least one character is contained within the overlay
|
|
|
822 and also contained within the specified region.
|
|
|
823 Empty overlays are included in the result if they are located at BEG
|
|
|
824 or between BEG and END."
|
|
|
825 (let ((ovls (overlay-lists))
|
|
|
826 tmp retval)
|
|
|
827 (if (< end beg)
|
|
|
828 (setq tmp end
|
|
|
829 end beg
|
|
|
830 beg tmp))
|
|
|
831 (setq ovls (nconc (car ovls) (cdr ovls)))
|
|
|
832 (while ovls
|
|
|
833 (setq tmp (car ovls)
|
|
|
834 ovls (cdr ovls))
|
|
|
835 (if (or (and (<= (overlay-start tmp) end)
|
|
|
836 (>= (overlay-start tmp) beg))
|
|
|
837 (and (<= (overlay-end tmp) end)
|
|
|
838 (>= (overlay-end tmp) beg)))
|
|
|
839 (setq retval (cons tmp retval))))
|
|
|
840 retval))
|
|
|
841
|
|
|
842 (sysdep-defun map-extents (function &optional object from to
|
|
|
843 maparg flags property value)
|
|
|
844 (let ((tmp (overlays-in (or from (point-min))
|
|
|
845 (or to (point-max))))
|
|
|
846 ovls)
|
|
|
847 (if property
|
|
|
848 (while tmp
|
|
|
849 (if (extent-property (car tmp) property)
|
|
|
850 (setq ovls (cons (car tmp) ovls)))
|
|
|
851 (setq tmp (cdr tmp)))
|
|
|
852 (setq ovls tmp
|
|
|
853 tmp nil))
|
|
|
854 (catch 'done
|
|
|
855 (while ovls
|
|
|
856 (setq tmp (funcall function (car ovls) maparg)
|
|
|
857 ovls (cdr ovls))
|
|
|
858 (if tmp
|
|
|
859 (throw 'done tmp))))))
|
|
|
860
|
|
|
861 ;; misc
|
|
2
|
862 (sysdep-fset 'make-local-hook 'make-local-variable)
|
|
|
863
|
|
|
864 (sysdep-defun buffer-substring-no-properties (beg end)
|
|
|
865 "Return the text from BEG to END, without text properties, as a string."
|
|
|
866 (format "%s" (buffer-substring beg end)))
|
|
|
867
|
|
0
|
868 (sysdep-defun symbol-value-in-buffer (symbol buffer &optional unbound-value)
|
|
|
869 "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
|
|
|
870 (save-excursion
|
|
|
871 (set-buffer buffer)
|
|
|
872 (if (not (boundp symbol))
|
|
|
873 unbound-value
|
|
|
874 (symbol-value symbol))))
|
|
|
875
|
|
|
876 (sysdep-defun insert-file-contents-literally
|
|
|
877 (file &optional visit beg end replace)
|
|
|
878 "Like `insert-file-contents', q.v., but only reads in the file.
|
|
|
879 A buffer may be modified in several ways after reading into the buffer due
|
|
|
880 to advanced Emacs features, such as file-name-handlers, format decoding,
|
|
|
881 find-file-hooks, etc.
|
|
|
882 This function ensures that none of these modifications will take place."
|
|
|
883 (let ((file-name-handler-alist nil)
|
|
|
884 (find-file-hooks nil))
|
|
|
885 (insert-file-contents file visit beg end replace)))
|
|
|
886
|
|
|
887 (sysdep-defun alist-to-plist (alist)
|
|
|
888 "Convert association list ALIST into the equivalent property-list form.
|
|
|
889 The plist is returned. This converts from
|
|
|
890
|
|
|
891 \((a . 1) (b . 2) (c . 3))
|
|
|
892
|
|
|
893 into
|
|
|
894
|
|
|
895 \(a 1 b 2 c 3)
|
|
|
896
|
|
|
897 The original alist is not modified. See also `destructive-alist-to-plist'."
|
|
|
898 (let (plist)
|
|
|
899 (while alist
|
|
|
900 (let ((el (car alist)))
|
|
|
901 (setq plist (cons (cdr el) (cons (car el) plist))))
|
|
|
902 (setq alist (cdr alist)))
|
|
|
903 (nreverse plist)))
|
|
|
904
|
|
|
905 (sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun)
|
|
|
906 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
|
|
|
907 TOGGLE is a symbol which is used as the variable which toggle the minor mode,
|
|
|
908 NAME is the name that should appear in the modeline (it should be a string
|
|
|
909 beginning with a space), KEYMAP is a keymap to make active when the minor
|
|
|
910 mode is active, and AFTER is the toggling symbol used for another minor
|
|
|
911 mode. If AFTER is non-nil, then it is used to position the new mode in the
|
|
|
912 minor-mode alists. TOGGLE-FUN specifies an interactive function that
|
|
|
913 is called to toggle the mode on and off; this affects what appens when
|
|
|
914 button2 is pressed on the mode, and when button3 is pressed somewhere
|
|
|
915 in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an
|
|
|
916 interactive function, TOGGLE is used as the toggle function.
|
|
|
917
|
|
|
918 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
|
|
|
919 (if (not (assq toggle minor-mode-alist))
|
|
|
920 (setq minor-mode-alist (cons (list toggle name) minor-mode-alist)))
|
|
|
921 (if (and keymap (not (assq toggle minor-mode-map-alist)))
|
|
|
922 (setq minor-mode-map-alist (cons (cons toggle keymap)
|
|
|
923 minor-mode-map-alist))))
|
|
|
924
|
|
|
925 (sysdep-defvar x-font-regexp-foundry-and-family
|
|
|
926 (let ((- "[-?]")
|
|
|
927 (foundry "[^-]+")
|
|
|
928 (family "[^-]+")
|
|
|
929 )
|
|
|
930 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
|
|
|
931
|
|
|
932 (sysdep-defun match-string (num &optional string)
|
|
|
933 "Return string of text matched by last search.
|
|
|
934 NUM specifies which parenthesized expression in the last regexp.
|
|
|
935 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
|
|
|
936 Zero means the entire text matched by the whole regexp or whole string.
|
|
|
937 STRING should be given if the last search was by `string-match' on STRING."
|
|
|
938 (if (match-beginning num)
|
|
|
939 (if string
|
|
|
940 (substring string (match-beginning num) (match-end num))
|
|
|
941 (buffer-substring (match-beginning num) (match-end num)))))
|
|
|
942
|
|
|
943 (sysdep-defun add-hook (hook-var function &optional at-end)
|
|
|
944 "Add a function to a hook.
|
|
|
945 First argument HOOK-VAR (a symbol) is the name of a hook, second
|
|
|
946 argument FUNCTION is the function to add.
|
|
|
947 Third (optional) argument AT-END means to add the function at the end
|
|
|
948 of the hook list instead of the beginning. If the function is already
|
|
|
949 present, this has no effect.
|
|
|
950 Returns nil if FUNCTION was already present in HOOK-VAR, else new
|
|
|
951 value of HOOK-VAR."
|
|
|
952 (if (not (boundp hook-var)) (set hook-var nil))
|
|
|
953 (let ((old (symbol-value hook-var)))
|
|
|
954 (if (or (not (listp old)) (eq (car old) 'lambda))
|
|
|
955 (setq old (list old)))
|
|
|
956 (if (member function old)
|
|
|
957 nil
|
|
|
958 (set hook-var
|
|
|
959 (if at-end
|
|
|
960 (append old (list function)) ; don't nconc
|
|
|
961 (cons function old))))))
|
|
|
962
|
|
|
963 (sysdep-defalias 'valid-color-name-p
|
|
|
964 (cond
|
|
|
965 ((fboundp 'x-valid-color-name-p) ; XEmacs/Lucid
|
|
|
966 'x-valid-color-name-p)
|
|
|
967 ((and window-system
|
|
|
968 (fboundp 'color-defined-p)) ; NS/Emacs 19
|
|
|
969 'color-defined-p)
|
|
|
970 ((and window-system
|
|
2
|
971 (fboundp 'pm-color-defined-p))
|
|
|
972 'pm-color-defined-p)
|
|
|
973 ((and window-system
|
|
0
|
974 (fboundp 'x-color-defined-p)) ; Emacs 19
|
|
|
975 'x-color-defined-p)
|
|
|
976 ((fboundp 'get-color) ; Epoch
|
|
|
977 (function (lambda (color)
|
|
|
978 (let ((x (get-color color)))
|
|
|
979 (if x
|
|
|
980 (setq x (progn
|
|
|
981 (free-color x)
|
|
|
982 t)))
|
|
|
983 x))))
|
|
|
984 (t 'identity))) ; All others
|
|
|
985
|
|
|
986 ;; Misc.
|
|
|
987 (sysdep-defun split-string (string pattern)
|
|
|
988 "Return a list of substrings of STRING which are separated by PATTERN."
|
|
|
989 (let (parts (start 0))
|
|
|
990 (while (string-match pattern string start)
|
|
|
991 (setq parts (cons (substring string start (match-beginning 0)) parts)
|
|
|
992 start (match-end 0)))
|
|
|
993 (nreverse (cons (substring string start) parts))
|
|
|
994 ))
|
|
|
995
|
|
|
996 (sysdep-defun member (elt list)
|
|
|
997 (while (and list (not (equal elt (car list))))
|
|
|
998 (setq list (cdr list)))
|
|
|
999 list)
|
|
|
1000
|
|
|
1001 (sysdep-defun rassoc (key list)
|
|
|
1002 (let ((found nil))
|
|
|
1003 (while (and list (not found))
|
|
|
1004 (if (equal (cdr (car list)) key) (setq found (car list)))
|
|
|
1005 (setq list (cdr list)))
|
|
|
1006 found))
|
|
|
1007
|
|
|
1008 (sysdep-defun display-error (error-object stream)
|
|
|
1009 "Display `error-object' on `stream' in a user-friendly way."
|
|
|
1010 (funcall (or (let ((type (car-safe error-object)))
|
|
|
1011 (catch 'error
|
|
|
1012 (and (consp error-object)
|
|
|
1013 (symbolp type)
|
|
|
1014 ;;(stringp (get type 'error-message))
|
|
|
1015 (consp (get type 'error-conditions))
|
|
|
1016 (let ((tail (cdr error-object)))
|
|
|
1017 (while (not (null tail))
|
|
|
1018 (if (consp tail)
|
|
|
1019 (setq tail (cdr tail))
|
|
|
1020 (throw 'error nil)))
|
|
|
1021 t)
|
|
|
1022 ;; (check-type condition condition)
|
|
|
1023 (get type 'error-conditions)
|
|
|
1024 ;; Search class hierarchy
|
|
|
1025 (let ((tail (get type 'error-conditions)))
|
|
|
1026 (while (not (null tail))
|
|
|
1027 (cond ((not (and (consp tail)
|
|
|
1028 (symbolp (car tail))))
|
|
|
1029 (throw 'error nil))
|
|
|
1030 ((get (car tail) 'display-error)
|
|
|
1031 (throw 'error (get (car tail)
|
|
|
1032 'display-error)))
|
|
|
1033 (t
|
|
|
1034 (setq tail (cdr tail)))))
|
|
|
1035 ;; Default method
|
|
|
1036 (function
|
|
|
1037 (lambda (error-object stream)
|
|
|
1038 (let ((type (car error-object))
|
|
|
1039 (tail (cdr error-object))
|
|
|
1040 (first t))
|
|
|
1041 (if (eq type 'error)
|
|
|
1042 (progn (princ (car tail) stream)
|
|
|
1043 (setq tail (cdr tail)))
|
|
|
1044 (princ (or (get type 'error-message) type)
|
|
|
1045 stream))
|
|
|
1046 (while tail
|
|
|
1047 (princ (if first ": " ", ") stream)
|
|
|
1048 (prin1 (car tail) stream)
|
|
|
1049 (setq tail (cdr tail)
|
|
|
1050 first nil)))))))))
|
|
|
1051 (function
|
|
|
1052 (lambda (error-object stream)
|
|
|
1053 (princ "Peculiar error " stream)
|
|
|
1054 (prin1 error-object stream))))
|
|
|
1055 error-object stream))
|
|
|
1056
|
|
80
|
1057 (sysdep-defun decode-time (&optional specified-time)
|
|
|
1058 (let* ((date (current-time-string specified-time))
|
|
|
1059 (dateinfo (and date (timezone-parse-date date)))
|
|
|
1060 (timeinfo (and dateinfo (timezone-parse-time (aref dateinfo 3)))))
|
|
|
1061 (list (aref timeinfo 2) (aref timeinfo 1)
|
|
|
1062 (aref timeinfo 0) (aref dateinfo 2)
|
|
|
1063 (aref dateinfo 1) (aref dateinfo 0)
|
|
|
1064 "unknown" nil 0)))
|
|
|
1065
|
|
0
|
1066 (sysdep-defun find-face (face)
|
|
|
1067 (car-safe (memq face (face-list))))
|
|
|
1068
|
|
2
|
1069 (sysdep-defun set-marker-insertion-type (marker type)
|
|
|
1070 "Set the insertion-type of MARKER to TYPE.
|
|
|
1071 If TYPE is t, it means the marker advances when you insert text at it.
|
|
|
1072 If TYPE is nil, it means the marker stays behind when you insert text at it."
|
|
|
1073 nil)
|
|
|
1074
|
|
0
|
1075 ;; window functions
|
|
|
1076
|
|
|
1077 ;; not defined in v18
|
|
|
1078 (sysdep-defun eval-buffer (bufname &optional printflag)
|
|
80
|
1079 (interactive)
|
|
0
|
1080 (save-excursion
|
|
|
1081 (set-buffer bufname)
|
|
|
1082 (eval-current-buffer)))
|
|
|
1083
|
|
|
1084 (sysdep-defun window-minibuffer-p (window)
|
|
|
1085 "Returns non-nil if WINDOW is a minibuffer window."
|
|
|
1086 (eq window (minibuffer-window)))
|
|
|
1087
|
|
|
1088 (sysdep-defun window-live-p (window)
|
|
|
1089 "Returns t if OBJ is a window which is currently visible."
|
|
|
1090 (and (windowp window)
|
|
|
1091 (window-point window)))
|
|
|
1092
|
|
80
|
1093 (provide 'w3-sysdp)
|
|
0
|
1094 ;;; sysdep.el ends here
|
|
|
1095
|
|
|
1096 ;;;(sysdep.el) Local Variables:
|
|
|
1097 ;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun)
|
|
|
1098 ;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun)
|
|
|
1099 ;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun)
|
|
|
1100 ;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun)
|
|
|
1101 ;;;(sysdep.el) End:
|
