177
|
1 ;;; $Id: adapt.el,v 1.5 1997/07/26 22:09:44 steve Exp $
|
0
|
2 ;;;
|
116
|
3 ;;; Copyright (C) 1993 - 1997 Heiko Muenkel
|
0
|
4 ;;; email: muenkel@tnt.uni-hannover.de
|
|
5 ;;;
|
|
6 ;;; This program is free software; you can redistribute it and/or modify
|
|
7 ;;; it under the terms of the GNU General Public License as published by
|
|
8 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
9 ;;; any later version.
|
|
10 ;;;
|
|
11 ;;; This program is distributed in the hope that it will be useful,
|
|
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
14 ;;; GNU General Public License for more details.
|
|
15 ;;;
|
|
16 ;;; You should have received a copy of the GNU General Public License
|
|
17 ;;; along with this program; if not, write to the Free Software
|
|
18 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
19 ;;;
|
|
20 ;;;
|
|
21 ;;; Description:
|
|
22 ;;;
|
116
|
23 ;;; General functions to port XEmacs functions to GNU Emacs 19.
|
0
|
24 ;;;
|
|
25 ;;; Installation:
|
|
26 ;;;
|
|
27 ;;; Put this file in one of your lisp load directories.
|
|
28 ;;;
|
|
29
|
|
30
|
|
31 (defun adapt-xemacsp ()
|
|
32 "Returns non nil if the editor is the XEmacs."
|
|
33 (or (string-match "Lucid" emacs-version)
|
|
34 (string-match "XEmacs" emacs-version)))
|
|
35
|
|
36
|
|
37 (defun adapt-lemacsp ()
|
|
38 "Returns non nil if the editor is the XEmacs.
|
|
39 Old version, use `adapt-xemacsp' instead of this."
|
|
40 (or (string-match "Lucid" emacs-version)
|
|
41 (string-match "XEmacs" emacs-version)))
|
|
42
|
|
43
|
|
44 (defun adapt-emacs19p ()
|
|
45 "Returns non nil if the editor is the GNU Emacs 19."
|
|
46 (and
|
|
47 (not (adapt-xemacsp))
|
|
48 (string= (substring emacs-version 0 2) "19")))
|
|
49
|
116
|
50 ;;; Functions, which don't exist in both emacs versions
|
0
|
51
|
|
52 (defun adapt-region-active-p ()
|
|
53 "Returns t, if a region is active."
|
|
54 (if (adapt-xemacsp)
|
|
55 (mark)
|
|
56 mark-active))
|
|
57
|
116
|
58 (if (not (fboundp 'file-remote-p))
|
|
59 (defun file-remote-p (file)
|
|
60 "Test wether file resides on the local system.
|
|
61 The special value 'unknown is returned if no remote file acess package
|
|
62 has been loaded."
|
|
63 (if (not (featurep 'ange-ftp))
|
|
64 (require 'ange-ftp))
|
|
65 (if (not (fboundp 'ange-ftp-ftp-p))
|
|
66 nil ; better than nothing, if no ange-ftp-ftp-p exists
|
|
67 (ange-ftp-ftp-path file))))
|
0
|
68
|
116
|
69
|
|
70 ;;; Functions, which don't exist in the Emacs 19
|
0
|
71 (if (adapt-emacs19p)
|
|
72 (progn
|
|
73 (load-library "lucid")
|
|
74
|
|
75 (load-library "lmenu")
|
|
76
|
|
77 (if window-system
|
|
78 (require 'font-lock)
|
|
79 )
|
|
80
|
|
81 (make-face 'font-lock-comment-face)
|
|
82
|
|
83 (defun read-number (prompt &optional integers-only)
|
|
84 "Reads a number from the minibuffer."
|
|
85 (interactive)
|
|
86 (let ((error t)
|
|
87 (number nil))
|
|
88 (if integers-only
|
|
89 (while error
|
|
90 (let ((input-string (read-string prompt)))
|
|
91 (setq number (if (string= "" input-string)
|
|
92 nil
|
|
93 (read input-string)))
|
|
94 (if (integerp number)
|
|
95 (setq error nil))))
|
|
96 (while error
|
|
97 (let ((input-string (read-string prompt)))
|
|
98 (setq number (if (string= "" input-string)
|
|
99 nil
|
|
100 (read input-string)))
|
|
101 (if (numberp number)
|
|
102 (setq error nil)))))
|
|
103 number))
|
|
104
|
|
105 (defvar original-read-string-function nil
|
|
106 "Points to the original Emacs 19 function read-string.")
|
|
107
|
|
108 (if (not original-read-string-function)
|
|
109 (fset 'original-read-string-function
|
|
110 (symbol-function 'read-string)))
|
|
111
|
|
112 (defun read-string (prompt &optional initial-contents history)
|
|
113 "Return a string from the minibuffer, prompting with string PROMPT.
|
|
114 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
|
|
115 in the minibuffer before reading.
|
|
116 Third arg HISTORY, if non-nil, specifies a history list."
|
|
117 (read-from-minibuffer prompt initial-contents nil nil history))
|
|
118
|
|
119 (defun make-extent (beg end &optional buffer)
|
|
120 (make-overlay beg end buffer))
|
|
121
|
|
122 (defun set-extent-property (extent prop value)
|
|
123 (if (eq prop 'duplicable)
|
|
124 (cond ((and value (not (overlay-get extent prop)))
|
|
125 ;; If becoming duplicable,
|
|
126 ;; copy all overlay props to text props.
|
|
127 (add-text-properties (overlay-start extent)
|
|
128 (overlay-end extent)
|
|
129 (overlay-properties extent)
|
|
130 (overlay-buffer extent)))
|
|
131 ;; If becoming no longer duplicable, remove these text props.
|
|
132 ((and (not value) (overlay-get extent prop))
|
|
133 (remove-text-properties (overlay-start extent)
|
|
134 (overlay-end extent)
|
|
135 (overlay-properties extent)
|
|
136 (overlay-buffer extent))))
|
|
137 ;; If extent is already duplicable, put this property
|
|
138 ;; on the text as well as on the overlay.
|
|
139 (if (overlay-get extent 'duplicable)
|
|
140 (put-text-property (overlay-start extent)
|
|
141 (overlay-end extent)
|
|
142 prop value (overlay-buffer extent))))
|
|
143 (overlay-put extent prop value))
|
|
144
|
|
145 (defun set-extent-face (extent face)
|
|
146 (set-extent-property extent 'face face))
|
|
147
|
|
148 (defun delete-extent (extent)
|
|
149 (set-extent-property extent 'duplicable nil)
|
|
150 (delete-overlay extent))
|
|
151
|
|
152 ; (defun make-extent (from to &optional buffer)
|
|
153 ; "Make extent for range [FROM, TO) in BUFFER -- BUFFER defaults to
|
|
154 ;current buffer. Insertions at point TO will be outside of the extent;
|
|
155 ;insertions at FROM will be inside the extent (and the extent will grow.).
|
|
156 ;This is only a simple emulation of the Lucid Emacs extents !"
|
|
157 ; (list 'extent from to buffer))
|
|
158 ;
|
|
159 ; (defun set-extent-face (extent face)
|
|
160 ; "Make the given EXTENT have the graphic attributes specified by FACE.
|
|
161 ;This is only a simple emulation of the Lucid Emacs extents !"
|
|
162 ; (put-text-property (car (cdr extent))
|
|
163 ; (car (cdr (cdr extent)))
|
|
164 ; 'face
|
|
165 ; face
|
|
166 ; (car (cdr (cdr (cdr extent))))))
|
|
167 ;
|
|
168 ; (defun delete-extent (extent_obj)
|
|
169 ; "Remove EXTENT from its buffer; this does not modify the buffer's text,
|
|
170 ;only its display properties.
|
|
171 ;This is only a simple emulation of the Lucid Emacs extents !"
|
|
172 ; (remove-text-properties (car (cdr extent_obj))
|
|
173 ; (car (cdr (cdr extent_obj)))
|
|
174 ; (list 'face nil)
|
|
175 ; (car (cdr (cdr (cdr extent_obj))))))
|
|
176 ;
|
|
177
|
|
178 (if (not (fboundp 'emacs-pid))
|
|
179 (defun emacs-pid ()
|
|
180 "Return the process ID of Emacs, as an integer.
|
|
181 This is a dummy function for old versions of the Emacs 19.
|
|
182 You should install a new version, which has `emacs-pid' implemented."
|
|
183 0)
|
|
184 )
|
|
185
|
|
186 (if (not (fboundp 'facep))
|
|
187 (defun facep (object)
|
|
188 "Whether OBJECT is a FACE.
|
|
189 It's only a dummy function in the Emacs 19, which returns always nil."
|
|
190 nil))
|
|
191
|
|
192 ; (if (not (fboundp 'set-extent-property))
|
|
193 ; (defun set-extent-property (extent property value)
|
|
194 ; "Change a property of an extent.
|
|
195 ;Only a dummy version in Emacs 19."))
|
|
196
|
2
|
197 (if (not (fboundp 'region-active-p))
|
|
198 (defun region-active-p ()
|
|
199 "Non-nil iff the region is active.
|
|
200 If `zmacs-regions' is true, this is equivalent to `region-exists-p'.
|
|
201 Otherwise, this function always returns false."
|
|
202 (adapt-region-active-p)))
|
|
203
|
|
204 (if (not (fboundp 'next-command-event))
|
|
205 (defun next-command-event (&optional event prompt)
|
|
206 "Unlike the XEmacs version it reads the next event, if
|
|
207 it is a command event or not.
|
|
208
|
|
209 Return the next available \"user\" event.
|
|
210 Pass this object to `dispatch-event' to handle it.
|
|
211
|
|
212 If EVENT is non-nil, it should be an event object and will be filled in
|
|
213 and returned; otherwise a new event object will be created and returned.
|
|
214 If PROMPT is non-nil, it should be a string and will be displayed in the
|
|
215 echo area while this function is waiting for an event.
|
|
216
|
|
217 The event returned will be a keyboard, mouse press, or mouse release event.
|
|
218 If there are non-command events available (mouse motion, sub-process output,
|
|
219 etc) then these will be executed (with `dispatch-event') and discarded. This
|
|
220 function is provided as a convenience; it is equivalent to the lisp code
|
|
221
|
|
222 (while (progn
|
|
223 (next-event event prompt)
|
|
224 (not (or (key-press-event-p event)
|
|
225 (button-press-event-p event)
|
|
226 (button-release-event-p event)
|
|
227 (misc-user-event-p event))))
|
|
228 (dispatch-event event))"
|
|
229 (message prompt)
|
|
230 (or event
|
|
231 (read-event))))
|
|
232
|
|
233 (if (not (fboundp 'button-event-p))
|
|
234 (defun button-event-p (obj)
|
|
235 "True if OBJ is a button-press or button-release event object."
|
|
236 (and (eventp obj)
|
|
237 (or (eq 'mouse-1 (event-basic-type obj))
|
|
238 (eq 'mouse-2 (event-basic-type obj))
|
153
|
239 (eq 'mouse-3 (event-basic-type obj))
|
|
240 (eq 'down-mouse-1 (event-basic-type obj))
|
|
241 (eq 'down-mouse-2 (event-basic-type obj))
|
|
242 (eq 'down-mouse-3 (event-basic-type obj))
|
|
243 (eq 'up-mouse-1 (event-basic-type obj))
|
|
244 (eq 'up-mouse-2 (event-basic-type obj))
|
|
245 (eq 'up-mouse-3 (event-basic-type obj))
|
|
246 (eq 'drag-mouse-1 (event-basic-type obj))
|
|
247 (eq 'drag-mouse-2 (event-basic-type obj))
|
|
248 (eq 'drag-mouse-3 (event-basic-type obj))
|
|
249 ))))
|
|
250
|
|
251 (if (not (fboundp 'button-drag-event-p))
|
|
252 (defun button-drag-event-p (obj)
|
|
253 "True if OBJ is a mouse-button-drag event object."
|
|
254 (and (button-event-p obj)
|
|
255 (member 'drag (event-modifiers obj)))))
|
2
|
256
|
|
257 (if (not (fboundp 'button-press-event-p))
|
|
258 (defun button-press-event-p (obj)
|
|
259 "True if OBJ is a mouse-button-press event object."
|
|
260 (and (button-event-p obj)
|
|
261 (member 'down (event-modifiers obj)))))
|
|
262
|
|
263 (if (not (fboundp 'button-release-event-p))
|
|
264 (defun button-release-event-p (obj)
|
|
265 "True if OBJ is a mouse-button-release event object."
|
|
266 (and (button-event-p obj)
|
|
267 (not (button-press-event-p obj)))))
|
|
268
|
116
|
269 (if (not (fboundp 'button-click-event-p))
|
|
270 (defun button-click-event-p (obj)
|
|
271 "True if OBJ is a click event obkect."
|
|
272 ;; only for the Emacs 19
|
|
273 ;; doesn't exist and can't (?) exist in the XEmacs
|
|
274 (and (button-event-p obj)
|
|
275 (member 'click (event-modifiers obj)))))
|
|
276
|
|
277 (if (not (fboundp 'mouse-event-p))
|
|
278 (defun mouse-event-p (obj)
|
|
279 "True if OBJ is a button-press, button-release, or mouse-motion event object."
|
|
280 (or (button-event-p obj)
|
|
281 (member 'drag (event-modifiers obj)))))
|
|
282
|
2
|
283 (if (not (fboundp 'event-window))
|
|
284 (defun event-window (event)
|
153
|
285 "Return the window of the given mouse EVENT.
|
|
286 This may be nil if the event occurred in the border or over a toolbar.
|
|
287 The modeline is considered to be in the window it represents.
|
|
288
|
|
289 If the EVENT is a mouse drag event, then the end event window is returned."
|
|
290 (if (button-drag-event-p event)
|
|
291 (and (listp event)
|
|
292 (third event)
|
|
293 (listp (third event))
|
|
294 (windowp (car (third event)))
|
|
295 (car (third event)))
|
|
296 (and (eventp event)
|
|
297 (listp event)
|
|
298 (second event)
|
|
299 (listp (second event))
|
|
300 (windowp (car (second event)))
|
|
301 (car (second event))))))
|
|
302
|
|
303 ; (listp (cdr event))
|
|
304 ; (listp (car (cdr event)))
|
|
305 ; (windowp (car (car (cdr event))))
|
|
306 ; (car (car (cdr event))))))
|
2
|
307
|
|
308 (if (not (fboundp 'event-buffer))
|
|
309 (defun event-buffer (event)
|
153
|
310 "Given a mouse-motion, button-press, or button-release event,
|
|
311 return the buffer on which that event occurred. This will be nil for
|
|
312 non-mouse events. If event-over-text-area-p is nil, this will also be nil."
|
2
|
313 (if (button-event-p event)
|
|
314 (window-buffer (event-window event)))))
|
|
315
|
|
316
|
|
317 (if (not (fboundp 'event-closest-point))
|
|
318 (defun event-closest-point (event)
|
153
|
319 "Return the character position of the given mouse EVENT.
|
|
320 If the EVENT did not occur over a window or over text, return the
|
|
321 closest point to the location of the EVENT. If the Y pixel position
|
2
|
322 overlaps a window and the X pixel position is to the left of that
|
|
323 window, the closest point is the beginning of the line containing the
|
|
324 Y position. If the Y pixel position overlaps a window and the X pixel
|
|
325 position is to the right of that window, the closest point is the end
|
|
326 of the line containing the Y position. If the Y pixel position is
|
|
327 above a window, return 0. If it is below a window, return the value
|
153
|
328 of (window-end).
|
|
329
|
|
330 If the EVENT is a drag event, the event-end will be used."
|
|
331 (if (button-drag-event-p event)
|
|
332 (posn-point (event-end event))
|
|
333 (posn-point (event-start event)))))
|
2
|
334
|
|
335 (if (not (fboundp 'add-minor-mode))
|
|
336 (defun add-minor-mode (toggle
|
|
337 name
|
|
338 &optional
|
|
339 keymap
|
|
340 after
|
|
341 toggle-fun)
|
|
342 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
|
|
343 TOGGLE is a symbol whose value as a variable specifies whether the
|
|
344 minor mode is active. NAME is the name that should appear in the
|
|
345 modeline (it should be a string beginning with a space). KEYMAP is a
|
|
346 keymap to make active when the minor mode is active. AFTER is the
|
|
347 toggling symbol used for another minor mode. If AFTER is non-nil,
|
|
348 then it is used to position the new mode in the minor-mode alists.
|
|
349
|
|
350 TOGGLE-FUN is only a dummy variable in the Emacs 19. In the XEmacs
|
|
351 it has the following description:
|
|
352 TOGGLE-FUN specifies an interactive function that is called to toggle
|
|
353 the mode on and off; this affects what happens when button2 is pressed
|
|
354 on the mode, and when button3 is pressed somewhere in the list of
|
|
355 modes. If TOGGLE-FUN is nil and TOGGLE names an interactive function,
|
|
356 TOGGLE is used as the toggle function.
|
|
357
|
|
358 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)
|
|
359
|
|
360 WARNING: THIS FUNCTION ISN'T READ YET."
|
|
361 (if after
|
|
362 (add-minor-mode-1 toggle name keymap after)
|
|
363 (if (not (assq toggle minor-mode-alist))
|
|
364 (progn
|
|
365 (setq minor-mode-alist
|
|
366 (cons (list toggle name)
|
|
367 minor-mode-alist))))
|
|
368 (if (not (assq toggle minor-mode-map-alist))
|
|
369 (progn
|
|
370 (setq minor-mode-map-alist
|
|
371 (cons (cons toggle keymap)
|
|
372 minor-mode-map-alist))))
|
|
373 ))
|
|
374 )
|
98
|
375
|
|
376 (if (not (fboundp 'redraw-modeline))
|
|
377 (defalias 'redraw-modeline 'force-mode-line-update))
|
|
378
|
116
|
379 (if (not (fboundp 'mouse-track))
|
|
380 (defalias 'mouse-track 'mouse-drag-region))
|
|
381
|
153
|
382 (if (not (fboundp 'windows-of-buffer))
|
|
383 (defun windows-of-buffer (&optional buffer)
|
|
384 "Returns a list of windows that have BUFFER in them.
|
|
385 If BUFFER is not specified, the current buffer will be used."
|
|
386 (get-buffer-window-list buffer)))
|
|
387
|
|
388 (if (not (boundp 'help-selects-help-window))
|
|
389 (defvar help-selects-help-window t
|
|
390 "*If nil, use the \"old Emacs\" behavior for Help buffers.
|
|
391 This just displays the buffer in another window, rather than selecting
|
|
392 the window."))
|
|
393
|
|
394 (if (not (fboundp 'with-displaying-help-buffer))
|
|
395 (defun with-displaying-help-buffer (thunk)
|
|
396 (let ((winconfig (current-window-configuration))
|
|
397 (was-one-window (one-window-p))
|
|
398 (help-not-visible
|
|
399 (not (and (windows-of-buffer "*Help*") ;shortcut
|
|
400 (member (selected-frame)
|
|
401 (mapcar 'window-frame
|
|
402 (windows-of-buffer "*Help*")))))))
|
|
403 (prog1 (with-output-to-temp-buffer "*Help*"
|
|
404 (prog1 (funcall thunk)
|
|
405 (save-excursion
|
|
406 (set-buffer standard-output)
|
|
407 (help-mode))))
|
|
408 (let ((helpwin (get-buffer-window "*Help*")))
|
|
409 (if helpwin
|
|
410 (progn
|
|
411 (save-excursion
|
|
412 (set-buffer (window-buffer helpwin))
|
|
413 ;;If the *Help* buffer is already displayed on this
|
|
414 ;; frame, don't override the previous configuration
|
|
415 ; (if help-not-visible
|
|
416 ; (set-frame-property
|
|
417 ; (selected-frame)
|
|
418 ; 'help-window-config winconfig)))
|
|
419 )
|
|
420 (if help-selects-help-window
|
|
421 (select-window helpwin))
|
|
422 (cond ((eq helpwin (selected-window))
|
|
423 (message
|
|
424 (substitute-command-keys
|
|
425 "\\[scroll-up] to scroll the help."
|
|
426 )))
|
|
427 (was-one-window
|
|
428 (message
|
|
429 (substitute-command-keys
|
|
430 "\\[scroll-other-window] to scroll the help."
|
|
431 )))
|
|
432 (t
|
|
433 (message
|
|
434 (substitute-command-keys
|
|
435 "\\[scroll-other-window] to scroll the help."
|
|
436 )))))))))))
|
|
437
|
|
438 (if (not (fboundp 'set-extent-mouse-face))
|
|
439 (defun set-extent-mouse-face (extent face)
|
|
440 "Set the face used to highlight EXTENT when the mouse passes over it.
|
|
441 FACE can also be a list of faces, and all faces listed will apply,
|
|
442 with faces earlier in the list taking priority over those later in the
|
|
443 list.
|
|
444
|
|
445 In the Emacs 19, the argument FACE could not be a list of faces."
|
|
446 (put-text-property (overlay-start extent)
|
|
447 (overlay-end extent)
|
|
448 'mouse-face face)
|
|
449 ))
|
|
450
|
|
451
|
|
452 (if (not (fboundp 'read-directory-name))
|
|
453 (defalias 'read-directory-name 'read-file-name))
|
|
454
|
177
|
455 (if (not (fboundp 'define-obsolete-function-alias))
|
|
456 (defsubst define-obsolete-function-alias (oldfun newfun)
|
|
457 "Define OLDFUN as an obsolete alias for function NEWFUN.
|
|
458 This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN
|
|
459 as obsolete."
|
|
460 (define-function oldfun newfun)
|
|
461 (make-obsolete oldfun newfun)))
|
|
462
|
|
463 (if (not (fboundp 'define-obsolete-variable-alias))
|
|
464 (defsubst define-obsolete-variable-alias (oldvar newvar)
|
|
465 "Define OLDVAR as an obsolete alias for varction NEWVAR.
|
|
466 This makes referencing or setting OLDVAR equivalent to referencing or
|
|
467 setting NEWVAR and marks OLDVAR as obsolete.
|
|
468
|
|
469 It is not full implemented in the Emacs 19, because of the lack of
|
|
470 the function defvaralias.y"
|
|
471 ;;(defvaralias oldvar newvar) <- doesn't exist in the Emacs 19.34
|
|
472 (make-obsolete-variable oldvar newvar)))
|
|
473
|
|
474 (if (not (fboundp 'defgroup))
|
|
475 (defmacro defgroup (symbol members doc &rest args)
|
|
476 "Dummy definition. Used, if the custom package isn't installed.
|
|
477 The dummy definition makes nothing, it returns only nil."
|
|
478 nil))
|
|
479
|
|
480 (if (not (fboundp 'defcustom))
|
|
481 (defmacro defcustom (symbol value doc &rest args)
|
|
482 "Simulates the defcustom definition from the custom package.
|
|
483 It calles a `defvar' with the arguments SYMBOL, VALUE and DOC."
|
|
484 `(defvar ,symbol ,value ,doc)))
|
|
485
|
153
|
486
|
0
|
487 ))
|
2
|
488
|
0
|
489
|
|
490 (provide 'adapt)
|