Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-compat.el --- Compatibility code for Org-mode |
2 | ||
dfd98937 | 3 | ;; Copyright (C) 2004-2012 Free Software Foundation, Inc. |
20908596 CD |
4 | |
5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
6 | ;; Keywords: outlines, hypermedia, calendar, wp | |
7 | ;; Homepage: http://orgmode.org | |
20908596 CD |
8 | ;; |
9 | ;; This file is part of GNU Emacs. | |
10 | ;; | |
b1fc2b50 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
20908596 | 12 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
20908596 CD |
15 | |
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
20908596 CD |
23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
24 | ;; | |
25 | ;;; Commentary: | |
26 | ||
27 | ;; This file contains code needed for compatibility with XEmacs and older | |
28 | ;; versions of GNU Emacs. | |
29 | ||
30 | ;;; Code: | |
31 | ||
c8d0cf5c CD |
32 | (eval-when-compile |
33 | (require 'cl)) | |
34 | ||
621f83e4 CD |
35 | (require 'org-macs) |
36 | ||
8d642074 | 37 | (declare-function find-library-name "find-func" (library)) |
9d459fc5 | 38 | (declare-function w32-focus-frame "term/w32-win" (frame)) |
c8d0cf5c | 39 | |
86fbb8ca CD |
40 | ;; The following constant is for backward compatibility. We do not use |
41 | ;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs) | |
42 | ;; at compilation time and can therefore optimize code better. | |
43 | (defconst org-xemacs-p (featurep 'xemacs)) | |
20908596 CD |
44 | (defconst org-format-transports-properties-p |
45 | (let ((x "a")) | |
46 | (add-text-properties 0 1 '(test t) x) | |
47 | (get-text-property 0 'test (format "%s" x))) | |
48 | "Does format transport text properties?") | |
49 | ||
50 | (defun org-compatible-face (inherits specs) | |
51 | "Make a compatible face specification. | |
52 | If INHERITS is an existing face and if the Emacs version supports it, | |
c8d0cf5c CD |
53 | just inherit the face. If INHERITS is set and the Emacs version does |
54 | not support it, copy the face specification from the inheritance face. | |
55 | If INHERITS is not given and SPECS is, use SPECS to define the face. | |
20908596 CD |
56 | XEmacs and Emacs 21 do not know about the `min-colors' attribute. |
57 | For them we convert a (min-colors 8) entry to a `tty' entry and move it | |
58 | to the top of the list. The `min-colors' attribute will be removed from | |
59 | any other entries, and any resulting duplicates will be removed entirely." | |
c8d0cf5c CD |
60 | (when (and inherits (facep inherits) (not specs)) |
61 | (setq specs (or specs | |
62 | (get inherits 'saved-face) | |
63 | (get inherits 'face-defface-spec)))) | |
20908596 CD |
64 | (cond |
65 | ((and inherits (facep inherits) | |
c8d0cf5c CD |
66 | (not (featurep 'xemacs)) |
67 | (>= emacs-major-version 22) | |
68 | ;; do not inherit outline faces before Emacs 23 | |
69 | (or (>= emacs-major-version 23) | |
70 | (not (string-match "\\`outline-[0-9]+" | |
71 | (symbol-name inherits))))) | |
20908596 CD |
72 | (list (list t :inherit inherits))) |
73 | ((or (featurep 'xemacs) (< emacs-major-version 22)) | |
74 | ;; These do not understand the `min-colors' attribute. | |
75 | (let (r e a) | |
76 | (while (setq e (pop specs)) | |
77 | (cond | |
78 | ((memq (car e) '(t default)) (push e r)) | |
79 | ((setq a (member '(min-colors 8) (car e))) | |
80 | (nconc r (list (cons (cons '(type tty) (delq (car a) (car e))) | |
81 | (cdr e))))) | |
82 | ((setq a (assq 'min-colors (car e))) | |
83 | (setq e (cons (delq a (car e)) (cdr e))) | |
84 | (or (assoc (car e) r) (push e r))) | |
85 | (t (or (assoc (car e) r) (push e r))))) | |
86 | (nreverse r))) | |
87 | (t specs))) | |
88 | (put 'org-compatible-face 'lisp-indent-function 1) | |
89 | ||
86fbb8ca CD |
90 | (defun org-version-check (version feature level) |
91 | (let* ((v1 (mapcar 'string-to-number (split-string version "[.]"))) | |
92 | (v2 (mapcar 'string-to-number (split-string emacs-version "[.]"))) | |
93 | (rmaj (or (nth 0 v1) 99)) | |
94 | (rmin (or (nth 1 v1) 99)) | |
95 | (rbld (or (nth 2 v1) 99)) | |
96 | (maj (or (nth 0 v2) 0)) | |
97 | (min (or (nth 1 v2) 0)) | |
98 | (bld (or (nth 2 v2) 0))) | |
99 | (if (or (< maj rmaj) | |
100 | (and (= maj rmaj) | |
101 | (< min rmin)) | |
102 | (and (= maj rmaj) | |
103 | (= min rmin) | |
104 | (< bld rbld))) | |
105 | (if (eq level :predicate) | |
106 | ;; just return if we have the version | |
107 | nil | |
108 | (let ((msg (format "Emacs %s or greater is recommended for %s" | |
109 | version feature))) | |
110 | (display-warning 'org msg level) | |
111 | t)) | |
112 | t))) | |
113 | ||
20908596 CD |
114 | ;;;; Emacs/XEmacs compatibility |
115 | ||
86fbb8ca CD |
116 | ;; Keys |
117 | (defconst org-xemacs-key-equivalents | |
118 | '(([mouse-1] . [button1]) | |
119 | ([mouse-2] . [button2]) | |
120 | ([mouse-3] . [button3]) | |
121 | ([C-mouse-4] . [(control mouse-4)]) | |
122 | ([C-mouse-5] . [(control mouse-5)])) | |
123 | "Translation alist for a couple of keys.") | |
124 | ||
20908596 | 125 | ;; Overlay compatibility functions |
20908596 CD |
126 | (defun org-detach-overlay (ovl) |
127 | (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) | |
20908596 CD |
128 | (defun org-overlay-display (ovl text &optional face evap) |
129 | "Make overlay OVL display TEXT with face FACE." | |
130 | (if (featurep 'xemacs) | |
131 | (let ((gl (make-glyph text))) | |
132 | (and face (set-glyph-face gl face)) | |
133 | (set-extent-property ovl 'invisible t) | |
134 | (set-extent-property ovl 'end-glyph gl)) | |
135 | (overlay-put ovl 'display text) | |
136 | (if face (overlay-put ovl 'face face)) | |
137 | (if evap (overlay-put ovl 'evaporate t)))) | |
138 | (defun org-overlay-before-string (ovl text &optional face evap) | |
139 | "Make overlay OVL display TEXT with face FACE." | |
140 | (if (featurep 'xemacs) | |
141 | (let ((gl (make-glyph text))) | |
142 | (and face (set-glyph-face gl face)) | |
143 | (set-extent-property ovl 'begin-glyph gl)) | |
144 | (if face (org-add-props text nil 'face face)) | |
145 | (overlay-put ovl 'before-string text) | |
146 | (if evap (overlay-put ovl 'evaporate t)))) | |
20908596 CD |
147 | (defun org-find-overlays (prop &optional pos delete) |
148 | "Find all overlays specifying PROP at POS or point. | |
149 | If DELETE is non-nil, delete all those overlays." | |
86fbb8ca | 150 | (let ((overlays (overlays-at (or pos (point)))) |
20908596 CD |
151 | ov found) |
152 | (while (setq ov (pop overlays)) | |
86fbb8ca CD |
153 | (if (overlay-get ov prop) |
154 | (if delete (delete-overlay ov) (push ov found)))) | |
20908596 CD |
155 | found)) |
156 | ||
86fbb8ca CD |
157 | (defun org-get-x-clipboard (value) |
158 | "Get the value of the x clipboard, compatible with XEmacs, and GNU Emacs 21." | |
159 | (if (eq window-system 'x) | |
160 | (let ((x (org-get-x-clipboard-compat value))) | |
161 | (if x (org-no-properties x))))) | |
162 | ||
afe98dfa CD |
163 | (defsubst org-decompose-region (beg end) |
164 | "Decompose from BEG to END." | |
165 | (if (featurep 'xemacs) | |
166 | (let ((modified-p (buffer-modified-p)) | |
167 | (buffer-read-only nil)) | |
168 | (remove-text-properties beg end '(composition nil)) | |
169 | (set-buffer-modified-p modified-p)) | |
170 | (decompose-region beg end))) | |
171 | ||
86fbb8ca CD |
172 | ;; Miscellaneous functions |
173 | ||
20908596 CD |
174 | (defun org-add-hook (hook function &optional append local) |
175 | "Add-hook, compatible with both Emacsen." | |
176 | (if (and local (featurep 'xemacs)) | |
177 | (add-local-hook hook function append) | |
178 | (add-hook hook function append local))) | |
179 | ||
180 | (defun org-add-props (string plist &rest props) | |
181 | "Add text properties to entire string, from beginning to end. | |
182 | PLIST may be a list of properties, PROPS are individual properties and values | |
183 | that will be added to PLIST. Returns the string that was modified." | |
184 | (add-text-properties | |
185 | 0 (length string) (if props (append plist props) plist) string) | |
186 | string) | |
187 | (put 'org-add-props 'lisp-indent-function 2) | |
188 | ||
93b62de8 CD |
189 | (defun org-fit-window-to-buffer (&optional window max-height min-height |
190 | shrink-only) | |
191 | "Fit WINDOW to the buffer, but only if it is not a side-by-side window. | |
192 | WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are | |
193 | passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call | |
86fbb8ca | 194 | `shrink-window-if-larger-than-buffer' instead, the height limit is |
93b62de8 | 195 | ignored in this case." |
0bd48b37 CD |
196 | (cond ((if (fboundp 'window-full-width-p) |
197 | (not (window-full-width-p window)) | |
198 | (> (frame-width) (window-width window))) | |
93b62de8 CD |
199 | ;; do nothing if another window would suffer |
200 | ) | |
201 | ((and (fboundp 'fit-window-to-buffer) (not shrink-only)) | |
202 | (fit-window-to-buffer window max-height min-height)) | |
203 | ((fboundp 'shrink-window-if-larger-than-buffer) | |
204 | (shrink-window-if-larger-than-buffer window))) | |
205 | (or window (selected-window))) | |
206 | ||
afe98dfa CD |
207 | (defun org-number-sequence (from &optional to inc) |
208 | "Call `number-sequence or emulate it." | |
209 | (if (fboundp 'number-sequence) | |
210 | (number-sequence from to inc) | |
211 | (if (or (not to) (= from to)) | |
212 | (list from) | |
213 | (or inc (setq inc 1)) | |
214 | (when (zerop inc) (error "The increment can not be zero")) | |
215 | (let (seq (n 0) (next from)) | |
216 | (if (> inc 0) | |
217 | (while (<= next to) | |
218 | (setq seq (cons next seq) | |
219 | n (1+ n) | |
220 | next (+ from (* n inc)))) | |
221 | (while (>= next to) | |
222 | (setq seq (cons next seq) | |
223 | n (1+ n) | |
224 | next (+ from (* n inc))))) | |
225 | (nreverse seq))))) | |
226 | ||
20908596 CD |
227 | ;; Region compatibility |
228 | ||
229 | (defvar org-ignore-region nil | |
230 | "To temporarily disable the active region.") | |
231 | ||
232 | (defun org-region-active-p () | |
233 | "Is `transient-mark-mode' on and the region active? | |
234 | Works on both Emacs and XEmacs." | |
235 | (if org-ignore-region | |
236 | nil | |
237 | (if (featurep 'xemacs) | |
238 | (and zmacs-regions (region-active-p)) | |
239 | (if (fboundp 'use-region-p) | |
240 | (use-region-p) | |
241 | (and transient-mark-mode mark-active))))) ; Emacs 22 and before | |
242 | ||
c8d0cf5c CD |
243 | (defun org-cursor-to-region-beginning () |
244 | (when (and (org-region-active-p) | |
245 | (> (point) (region-beginning))) | |
246 | (exchange-point-and-mark))) | |
247 | ||
3ab2c837 BG |
248 | ;; Emacs 22 misses `activate-mark' |
249 | (if (fboundp 'activate-mark) | |
250 | (defalias 'org-activate-mark 'activate-mark) | |
251 | (defun org-activate-mark () | |
252 | (when (mark t) | |
253 | (setq mark-active t) | |
e66ba1df BG |
254 | (when (and (boundp 'transient-mark-mode) |
255 | (not transient-mark-mode)) | |
256 | (setq transient-mark-mode 'lambda)) | |
257 | (when (boundp 'zmacs-regions) | |
258 | (setq zmacs-regions t))))) | |
259 | ||
3ab2c837 | 260 | |
20908596 CD |
261 | ;; Invisibility compatibility |
262 | ||
20908596 CD |
263 | (defun org-remove-from-invisibility-spec (arg) |
264 | "Remove elements from `buffer-invisibility-spec'." | |
265 | (if (fboundp 'remove-from-invisibility-spec) | |
266 | (remove-from-invisibility-spec arg) | |
267 | (if (consp buffer-invisibility-spec) | |
268 | (setq buffer-invisibility-spec | |
269 | (delete arg buffer-invisibility-spec))))) | |
270 | ||
271 | (defun org-in-invisibility-spec-p (arg) | |
272 | "Is ARG a member of `buffer-invisibility-spec'?" | |
273 | (if (consp buffer-invisibility-spec) | |
274 | (member arg buffer-invisibility-spec) | |
275 | nil)) | |
276 | ||
86fbb8ca | 277 | (defmacro org-xemacs-without-invisibility (&rest body) |
27e428e7 | 278 | "Turn off extents with invisibility while executing BODY." |
86fbb8ca CD |
279 | `(let ((ext-inv (extent-list nil (point-at-bol) (point-at-eol) |
280 | 'all-extents-closed-open 'invisible)) | |
281 | ext-inv-specs) | |
282 | (dolist (ext ext-inv) | |
283 | (when (extent-property ext 'invisible) | |
284 | (add-to-list 'ext-inv-specs (list ext (extent-property | |
285 | ext 'invisible))) | |
286 | (set-extent-property ext 'invisible nil))) | |
287 | ,@body | |
288 | (dolist (ext-inv-spec ext-inv-specs) | |
289 | (set-extent-property (car ext-inv-spec) 'invisible | |
290 | (cadr ext-inv-spec))))) | |
e66ba1df | 291 | (def-edebug-spec org-xemacs-without-invisibility (body)) |
86fbb8ca | 292 | |
20908596 CD |
293 | (defun org-indent-to-column (column &optional minimum buffer) |
294 | "Work around a bug with extents with invisibility in XEmacs." | |
71d35b24 | 295 | (if (featurep 'xemacs) |
86fbb8ca | 296 | (org-xemacs-without-invisibility (indent-to-column column minimum buffer)) |
71d35b24 | 297 | (indent-to-column column minimum))) |
20908596 CD |
298 | |
299 | (defun org-indent-line-to (column) | |
300 | "Work around a bug with extents with invisibility in XEmacs." | |
71d35b24 | 301 | (if (featurep 'xemacs) |
86fbb8ca | 302 | (org-xemacs-without-invisibility (indent-line-to column)) |
71d35b24 | 303 | (indent-line-to column))) |
20908596 CD |
304 | |
305 | (defun org-move-to-column (column &optional force buffer) | |
71d35b24 | 306 | (if (featurep 'xemacs) |
86fbb8ca | 307 | (org-xemacs-without-invisibility (move-to-column column force buffer)) |
71d35b24 | 308 | (move-to-column column force))) |
621f83e4 CD |
309 | |
310 | (defun org-get-x-clipboard-compat (value) | |
86fbb8ca CD |
311 | "Get the clipboard value on XEmacs or Emacs 21." |
312 | (cond ((featurep 'xemacs) | |
313 | (org-no-warnings (get-selection-no-error value))) | |
621f83e4 CD |
314 | ((fboundp 'x-get-selection) |
315 | (condition-case nil | |
316 | (or (x-get-selection value 'UTF8_STRING) | |
317 | (x-get-selection value 'COMPOUND_TEXT) | |
318 | (x-get-selection value 'STRING) | |
319 | (x-get-selection value 'TEXT)) | |
320 | (error nil))))) | |
321 | ||
322 | (defun org-propertize (string &rest properties) | |
323 | (if (featurep 'xemacs) | |
ce4fdcb9 CD |
324 | (progn |
325 | (add-text-properties 0 (length string) properties string) | |
326 | string) | |
621f83e4 | 327 | (apply 'propertize string properties))) |
71d35b24 | 328 | |
ce4fdcb9 CD |
329 | (defun org-substring-no-properties (string &optional from to) |
330 | (if (featurep 'xemacs) | |
db55f368 | 331 | (org-no-properties (substring string (or from 0) to)) |
ce4fdcb9 CD |
332 | (substring-no-properties string from to))) |
333 | ||
c8d0cf5c CD |
334 | (defun org-find-library-name (library) |
335 | (if (fboundp 'find-library-name) | |
336 | (file-name-directory (find-library-name library)) | |
337 | ; XEmacs does not have `find-library-name' | |
338 | (flet ((find-library-name-helper (filename ignored-codesys) | |
339 | filename) | |
340 | (find-library-name (library) | |
341 | (find-library library nil 'find-library-name-helper))) | |
342 | (file-name-directory (find-library-name library))))) | |
343 | ||
0bd48b37 CD |
344 | (defun org-count-lines (s) |
345 | "How many lines in string S?" | |
346 | (let ((start 0) (n 1)) | |
347 | (while (string-match "\n" s start) | |
348 | (setq start (match-end 0) n (1+ n))) | |
349 | (if (and (> (length s) 0) (= (aref s (1- (length s))) ?\n)) | |
350 | (setq n (1- n))) | |
351 | n)) | |
352 | ||
c8d0cf5c CD |
353 | (defun org-kill-new (string &rest args) |
354 | (remove-text-properties 0 (length string) '(line-prefix t wrap-prefix t) | |
355 | string) | |
356 | (apply 'kill-new string args)) | |
357 | ||
54a0dee5 CD |
358 | (defun org-select-frame-set-input-focus (frame) |
359 | "Select FRAME, raise it, and set input focus, if possible." | |
360 | (cond ((featurep 'xemacs) | |
361 | (if (fboundp 'select-frame-set-input-focus) | |
362 | (select-frame-set-input-focus frame) | |
363 | (raise-frame frame) | |
364 | (select-frame frame) | |
365 | (focus-frame frame))) | |
366 | ;; `select-frame-set-input-focus' defined in Emacs 21 will not | |
367 | ;; set the input focus. | |
368 | ((>= emacs-major-version 22) | |
369 | (select-frame-set-input-focus frame)) | |
370 | (t | |
371 | (raise-frame frame) | |
372 | (select-frame frame) | |
373 | (cond ((memq window-system '(x ns mac)) | |
374 | (x-focus-frame frame)) | |
375 | ((eq window-system 'w32) | |
376 | (w32-focus-frame frame))) | |
377 | (when focus-follows-mouse | |
378 | (set-mouse-position frame (1- (frame-width frame)) 0))))) | |
379 | ||
380 | (defun org-float-time (&optional time) | |
381 | "Convert time value TIME to a floating point number. | |
382 | TIME defaults to the current time." | |
383 | (if (featurep 'xemacs) | |
384 | (time-to-seconds (or time (current-time))) | |
385 | (float-time time))) | |
386 | ||
acedf35c CD |
387 | (if (fboundp 'string-match-p) |
388 | (defalias 'org-string-match-p 'string-match-p) | |
389 | (defun org-string-match-p (regexp string &optional start) | |
86fbb8ca | 390 | (save-match-data |
acedf35c | 391 | (funcall 'string-match regexp string start)))) |
86fbb8ca | 392 | |
acedf35c CD |
393 | (if (fboundp 'looking-at-p) |
394 | (defalias 'org-looking-at-p 'looking-at-p) | |
395 | (defun org-looking-at-p (&rest args) | |
86fbb8ca | 396 | (save-match-data |
afe98dfa | 397 | (apply 'looking-at args)))) |
86fbb8ca | 398 | |
ed21c5c8 CD |
399 | ; XEmacs does not have `looking-back'. |
400 | (if (fboundp 'looking-back) | |
401 | (defalias 'org-looking-back 'looking-back) | |
402 | (defun org-looking-back (regexp &optional limit greedy) | |
403 | "Return non-nil if text before point matches regular expression REGEXP. | |
404 | Like `looking-at' except matches before point, and is slower. | |
405 | LIMIT if non-nil speeds up the search by specifying a minimum | |
406 | starting position, to avoid checking matches that would start | |
407 | before LIMIT. | |
408 | ||
409 | If GREEDY is non-nil, extend the match backwards as far as | |
410 | possible, stopping when a single additional previous character | |
411 | cannot be part of a match for REGEXP. When the match is | |
412 | extended, its starting position is allowed to occur before | |
413 | LIMIT." | |
414 | (let ((start (point)) | |
415 | (pos | |
416 | (save-excursion | |
417 | (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t) | |
418 | (point))))) | |
419 | (if (and greedy pos) | |
420 | (save-restriction | |
421 | (narrow-to-region (point-min) start) | |
422 | (while (and (> pos (point-min)) | |
423 | (save-excursion | |
424 | (goto-char pos) | |
425 | (backward-char 1) | |
426 | (looking-at (concat "\\(?:" regexp "\\)\\'")))) | |
427 | (setq pos (1- pos))) | |
428 | (save-excursion | |
429 | (goto-char pos) | |
430 | (looking-at (concat "\\(?:" regexp "\\)\\'"))))) | |
431 | (not (null pos))))) | |
432 | ||
acedf35c CD |
433 | (defun org-floor* (x &optional y) |
434 | "Return a list of the floor of X and the fractional part of X. | |
435 | With two arguments, return floor and remainder of their quotient." | |
436 | (let ((q (floor x y))) | |
437 | (list q (- x (if y (* y q) q))))) | |
438 | ||
e66ba1df BG |
439 | ;; `pop-to-buffer-same-window' has been introduced with Emacs 24.1. |
440 | (defun org-pop-to-buffer-same-window | |
441 | (&optional buffer-or-name norecord label) | |
442 | "Pop to buffer specified by BUFFER-OR-NAME in the selected window." | |
443 | (if (fboundp 'pop-to-buffer-same-window) | |
444 | (funcall | |
445 | 'pop-to-buffer-same-window buffer-or-name norecord) | |
446 | (funcall 'switch-to-buffer buffer-or-name norecord))) | |
5b409b39 | 447 | |
e66ba1df | 448 | (provide 'org-compat) |
b349f79f | 449 | |
20908596 | 450 | ;;; org-compat.el ends here |