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