Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-compat.el --- Compatibility code for Org-mode |
2 | ||
3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
6 | ;; Keywords: outlines, hypermedia, calendar, wp | |
7 | ;; Homepage: http://orgmode.org | |
8 | ;; Version: 6.02b | |
9 | ;; | |
10 | ;; This file is part of GNU Emacs. | |
11 | ;; | |
12 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
14 | ;; the Free Software Foundation; either version 3, or (at your option) | |
15 | ;; any later version. | |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
25 | ;; Boston, MA 02110-1301, USA. | |
26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
27 | ;; | |
28 | ;;; Commentary: | |
29 | ||
30 | ;; This file contains code needed for compatibility with XEmacs and older | |
31 | ;; versions of GNU Emacs. | |
32 | ||
33 | ;;; Code: | |
34 | ||
35 | (defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself | |
36 | (defconst org-format-transports-properties-p | |
37 | (let ((x "a")) | |
38 | (add-text-properties 0 1 '(test t) x) | |
39 | (get-text-property 0 'test (format "%s" x))) | |
40 | "Does format transport text properties?") | |
41 | ||
42 | (defun org-compatible-face (inherits specs) | |
43 | "Make a compatible face specification. | |
44 | If INHERITS is an existing face and if the Emacs version supports it, | |
45 | just inherit the face. If not, use SPECS to define the face. | |
46 | XEmacs and Emacs 21 do not know about the `min-colors' attribute. | |
47 | For them we convert a (min-colors 8) entry to a `tty' entry and move it | |
48 | to the top of the list. The `min-colors' attribute will be removed from | |
49 | any other entries, and any resulting duplicates will be removed entirely." | |
50 | (cond | |
51 | ((and inherits (facep inherits) | |
52 | (not (featurep 'xemacs)) (> emacs-major-version 22)) | |
53 | ;; In Emacs 23, we use inheritance where possible. | |
54 | ;; We only do this in Emacs 23, because only there the outline | |
55 | ;; faces have been changed to the original org-mode-level-faces. | |
56 | (list (list t :inherit inherits))) | |
57 | ((or (featurep 'xemacs) (< emacs-major-version 22)) | |
58 | ;; These do not understand the `min-colors' attribute. | |
59 | (let (r e a) | |
60 | (while (setq e (pop specs)) | |
61 | (cond | |
62 | ((memq (car e) '(t default)) (push e r)) | |
63 | ((setq a (member '(min-colors 8) (car e))) | |
64 | (nconc r (list (cons (cons '(type tty) (delq (car a) (car e))) | |
65 | (cdr e))))) | |
66 | ((setq a (assq 'min-colors (car e))) | |
67 | (setq e (cons (delq a (car e)) (cdr e))) | |
68 | (or (assoc (car e) r) (push e r))) | |
69 | (t (or (assoc (car e) r) (push e r))))) | |
70 | (nreverse r))) | |
71 | (t specs))) | |
72 | (put 'org-compatible-face 'lisp-indent-function 1) | |
73 | ||
74 | ;;;; Emacs/XEmacs compatibility | |
75 | ||
76 | ;; Overlay compatibility functions | |
77 | (defun org-make-overlay (beg end &optional buffer) | |
78 | (if (featurep 'xemacs) | |
79 | (make-extent beg end buffer) | |
80 | (make-overlay beg end buffer))) | |
81 | (defun org-delete-overlay (ovl) | |
82 | (if (featurep 'xemacs) (progn (delete-extent ovl) nil) (delete-overlay ovl))) | |
83 | (defun org-detach-overlay (ovl) | |
84 | (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) | |
85 | (defun org-move-overlay (ovl beg end &optional buffer) | |
86 | (if (featurep 'xemacs) | |
87 | (set-extent-endpoints ovl beg end (or buffer (current-buffer))) | |
88 | (move-overlay ovl beg end buffer))) | |
89 | (defun org-overlay-put (ovl prop value) | |
90 | (if (featurep 'xemacs) | |
91 | (set-extent-property ovl prop value) | |
92 | (overlay-put ovl prop value))) | |
93 | (defun org-overlay-display (ovl text &optional face evap) | |
94 | "Make overlay OVL display TEXT with face FACE." | |
95 | (if (featurep 'xemacs) | |
96 | (let ((gl (make-glyph text))) | |
97 | (and face (set-glyph-face gl face)) | |
98 | (set-extent-property ovl 'invisible t) | |
99 | (set-extent-property ovl 'end-glyph gl)) | |
100 | (overlay-put ovl 'display text) | |
101 | (if face (overlay-put ovl 'face face)) | |
102 | (if evap (overlay-put ovl 'evaporate t)))) | |
103 | (defun org-overlay-before-string (ovl text &optional face evap) | |
104 | "Make overlay OVL display TEXT with face FACE." | |
105 | (if (featurep 'xemacs) | |
106 | (let ((gl (make-glyph text))) | |
107 | (and face (set-glyph-face gl face)) | |
108 | (set-extent-property ovl 'begin-glyph gl)) | |
109 | (if face (org-add-props text nil 'face face)) | |
110 | (overlay-put ovl 'before-string text) | |
111 | (if evap (overlay-put ovl 'evaporate t)))) | |
112 | (defun org-overlay-get (ovl prop) | |
113 | (if (featurep 'xemacs) | |
114 | (extent-property ovl prop) | |
115 | (overlay-get ovl prop))) | |
116 | (defun org-overlays-at (pos) | |
117 | (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) | |
118 | (defun org-overlays-in (&optional start end) | |
119 | (if (featurep 'xemacs) | |
120 | (extent-list nil start end) | |
121 | (overlays-in start end))) | |
122 | (defun org-overlay-start (o) | |
123 | (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) | |
124 | (defun org-overlay-end (o) | |
125 | (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) | |
126 | (defun org-overlay-buffer (o) | |
127 | (if (featurep 'xemacs) (extent-buffer o) (overlay-buffer o))) | |
128 | (defun org-find-overlays (prop &optional pos delete) | |
129 | "Find all overlays specifying PROP at POS or point. | |
130 | If DELETE is non-nil, delete all those overlays." | |
131 | (let ((overlays (org-overlays-at (or pos (point)))) | |
132 | ov found) | |
133 | (while (setq ov (pop overlays)) | |
134 | (if (org-overlay-get ov prop) | |
135 | (if delete (org-delete-overlay ov) (push ov found)))) | |
136 | found)) | |
137 | ||
138 | (defun org-add-hook (hook function &optional append local) | |
139 | "Add-hook, compatible with both Emacsen." | |
140 | (if (and local (featurep 'xemacs)) | |
141 | (add-local-hook hook function append) | |
142 | (add-hook hook function append local))) | |
143 | ||
144 | (defun org-add-props (string plist &rest props) | |
145 | "Add text properties to entire string, from beginning to end. | |
146 | PLIST may be a list of properties, PROPS are individual properties and values | |
147 | that will be added to PLIST. Returns the string that was modified." | |
148 | (add-text-properties | |
149 | 0 (length string) (if props (append plist props) plist) string) | |
150 | string) | |
151 | (put 'org-add-props 'lisp-indent-function 2) | |
152 | ||
153 | ;; Region compatibility | |
154 | ||
155 | (defvar org-ignore-region nil | |
156 | "To temporarily disable the active region.") | |
157 | ||
158 | (defun org-region-active-p () | |
159 | "Is `transient-mark-mode' on and the region active? | |
160 | Works on both Emacs and XEmacs." | |
161 | (if org-ignore-region | |
162 | nil | |
163 | (if (featurep 'xemacs) | |
164 | (and zmacs-regions (region-active-p)) | |
165 | (if (fboundp 'use-region-p) | |
166 | (use-region-p) | |
167 | (and transient-mark-mode mark-active))))) ; Emacs 22 and before | |
168 | ||
169 | ;; Invisibility compatibility | |
170 | ||
171 | (defun org-add-to-invisibility-spec (arg) | |
172 | "Add elements to `buffer-invisibility-spec'. | |
173 | See documentation for `buffer-invisibility-spec' for the kind of elements | |
174 | that can be added." | |
175 | (cond | |
176 | ((fboundp 'add-to-invisibility-spec) | |
177 | (add-to-invisibility-spec arg)) | |
178 | ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) | |
179 | (setq buffer-invisibility-spec (list arg))) | |
180 | (t | |
181 | (setq buffer-invisibility-spec | |
182 | (cons arg buffer-invisibility-spec))))) | |
183 | ||
184 | (defun org-remove-from-invisibility-spec (arg) | |
185 | "Remove elements from `buffer-invisibility-spec'." | |
186 | (if (fboundp 'remove-from-invisibility-spec) | |
187 | (remove-from-invisibility-spec arg) | |
188 | (if (consp buffer-invisibility-spec) | |
189 | (setq buffer-invisibility-spec | |
190 | (delete arg buffer-invisibility-spec))))) | |
191 | ||
192 | (defun org-in-invisibility-spec-p (arg) | |
193 | "Is ARG a member of `buffer-invisibility-spec'?" | |
194 | (if (consp buffer-invisibility-spec) | |
195 | (member arg buffer-invisibility-spec) | |
196 | nil)) | |
197 | ||
198 | (defun org-indent-to-column (column &optional minimum buffer) | |
199 | "Work around a bug with extents with invisibility in XEmacs." | |
200 | (if (featurep 'xemacs) | |
201 | (let ((ext-inv (extent-list | |
202 | nil (point-at-bol) (point-at-eol) | |
203 | 'all-extents-closed-open 'invisible)) | |
204 | ext-inv-specs) | |
205 | (dolist (ext ext-inv) | |
206 | (when (extent-property ext 'invisible) | |
207 | (add-to-list 'ext-inv-specs (list ext (extent-property | |
208 | ext 'invisible))) | |
209 | (set-extent-property ext 'invisible nil))) | |
210 | (indent-to-column column minimum buffer) | |
211 | (dolist (ext-inv-spec ext-inv-specs) | |
212 | (set-extent-property (car ext-inv-spec) 'invisible | |
213 | (cadr ext-inv-spec)))) | |
214 | (indent-to-column column minimum))) | |
215 | ||
216 | (defun org-indent-line-to (column) | |
217 | "Work around a bug with extents with invisibility in XEmacs." | |
218 | (if (featurep 'xemacs) | |
219 | (let ((ext-inv (extent-list | |
220 | nil (point-at-bol) (point-at-eol) | |
221 | 'all-extents-closed-open 'invisible)) | |
222 | ext-inv-specs) | |
223 | (dolist (ext ext-inv) | |
224 | (when (extent-property ext 'invisible) | |
225 | (add-to-list 'ext-inv-specs (list ext (extent-property | |
226 | ext 'invisible))) | |
227 | (set-extent-property ext 'invisible nil))) | |
228 | (indent-line-to column) | |
229 | (dolist (ext-inv-spec ext-inv-specs) | |
230 | (set-extent-property (car ext-inv-spec) 'invisible | |
231 | (cadr ext-inv-spec)))) | |
232 | (indent-line-to column))) | |
233 | ||
234 | (defun org-move-to-column (column &optional force buffer) | |
235 | (if (featurep 'xemacs) | |
236 | (let ((ext-inv (extent-list | |
237 | nil (point-at-bol) (point-at-eol) | |
238 | 'all-extents-closed-open 'invisible)) | |
239 | ext-inv-specs) | |
240 | (dolist (ext ext-inv) | |
241 | (when (extent-property ext 'invisible) | |
242 | (add-to-list 'ext-inv-specs (list ext (extent-property ext | |
243 | 'invisible))) | |
244 | (set-extent-property ext 'invisible nil))) | |
245 | (move-to-column column force buffer) | |
246 | (dolist (ext-inv-spec ext-inv-specs) | |
247 | (set-extent-property (car ext-inv-spec) 'invisible | |
248 | (cadr ext-inv-spec)))) | |
249 | (move-to-column column force))) | |
250 | ||
251 | ||
252 | (provide 'org-compat) | |
253 | ||
254 | ;;; org-compat.el ends here |