Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-compat.el --- Compatibility code for Org-mode |
2 | ||
1e4f816a CD |
3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 |
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 | |
8bfe682a | 9 | ;; Version: 6.33 |
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 | |
20908596 CD |
42 | (defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself |
43 | (defconst org-format-transports-properties-p | |
44 | (let ((x "a")) | |
45 | (add-text-properties 0 1 '(test t) x) | |
46 | (get-text-property 0 'test (format "%s" x))) | |
47 | "Does format transport text properties?") | |
48 | ||
49 | (defun org-compatible-face (inherits specs) | |
50 | "Make a compatible face specification. | |
51 | If INHERITS is an existing face and if the Emacs version supports it, | |
c8d0cf5c CD |
52 | just inherit the face. If INHERITS is set and the Emacs version does |
53 | not support it, copy the face specification from the inheritance face. | |
54 | If INHERITS is not given and SPECS is, use SPECS to define the face. | |
20908596 CD |
55 | XEmacs and Emacs 21 do not know about the `min-colors' attribute. |
56 | For them we convert a (min-colors 8) entry to a `tty' entry and move it | |
57 | to the top of the list. The `min-colors' attribute will be removed from | |
58 | any other entries, and any resulting duplicates will be removed entirely." | |
c8d0cf5c CD |
59 | (when (and inherits (facep inherits) (not specs)) |
60 | (setq specs (or specs | |
61 | (get inherits 'saved-face) | |
62 | (get inherits 'face-defface-spec)))) | |
20908596 CD |
63 | (cond |
64 | ((and inherits (facep inherits) | |
c8d0cf5c CD |
65 | (not (featurep 'xemacs)) |
66 | (>= emacs-major-version 22) | |
67 | ;; do not inherit outline faces before Emacs 23 | |
68 | (or (>= emacs-major-version 23) | |
69 | (not (string-match "\\`outline-[0-9]+" | |
70 | (symbol-name inherits))))) | |
20908596 CD |
71 | (list (list t :inherit inherits))) |
72 | ((or (featurep 'xemacs) (< emacs-major-version 22)) | |
73 | ;; These do not understand the `min-colors' attribute. | |
74 | (let (r e a) | |
75 | (while (setq e (pop specs)) | |
76 | (cond | |
77 | ((memq (car e) '(t default)) (push e r)) | |
78 | ((setq a (member '(min-colors 8) (car e))) | |
79 | (nconc r (list (cons (cons '(type tty) (delq (car a) (car e))) | |
80 | (cdr e))))) | |
81 | ((setq a (assq 'min-colors (car e))) | |
82 | (setq e (cons (delq a (car e)) (cdr e))) | |
83 | (or (assoc (car e) r) (push e r))) | |
84 | (t (or (assoc (car e) r) (push e r))))) | |
85 | (nreverse r))) | |
86 | (t specs))) | |
87 | (put 'org-compatible-face 'lisp-indent-function 1) | |
88 | ||
89 | ;;;; Emacs/XEmacs compatibility | |
90 | ||
91 | ;; Overlay compatibility functions | |
92 | (defun org-make-overlay (beg end &optional buffer) | |
93 | (if (featurep 'xemacs) | |
94 | (make-extent beg end buffer) | |
95 | (make-overlay beg end buffer))) | |
96 | (defun org-delete-overlay (ovl) | |
97 | (if (featurep 'xemacs) (progn (delete-extent ovl) nil) (delete-overlay ovl))) | |
98 | (defun org-detach-overlay (ovl) | |
99 | (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) | |
100 | (defun org-move-overlay (ovl beg end &optional buffer) | |
101 | (if (featurep 'xemacs) | |
102 | (set-extent-endpoints ovl beg end (or buffer (current-buffer))) | |
103 | (move-overlay ovl beg end buffer))) | |
104 | (defun org-overlay-put (ovl prop value) | |
105 | (if (featurep 'xemacs) | |
106 | (set-extent-property ovl prop value) | |
107 | (overlay-put ovl prop value))) | |
108 | (defun org-overlay-display (ovl text &optional face evap) | |
109 | "Make overlay OVL display TEXT with face FACE." | |
110 | (if (featurep 'xemacs) | |
111 | (let ((gl (make-glyph text))) | |
112 | (and face (set-glyph-face gl face)) | |
113 | (set-extent-property ovl 'invisible t) | |
114 | (set-extent-property ovl 'end-glyph gl)) | |
115 | (overlay-put ovl 'display text) | |
116 | (if face (overlay-put ovl 'face face)) | |
117 | (if evap (overlay-put ovl 'evaporate t)))) | |
118 | (defun org-overlay-before-string (ovl text &optional face evap) | |
119 | "Make overlay OVL display TEXT with face FACE." | |
120 | (if (featurep 'xemacs) | |
121 | (let ((gl (make-glyph text))) | |
122 | (and face (set-glyph-face gl face)) | |
123 | (set-extent-property ovl 'begin-glyph gl)) | |
124 | (if face (org-add-props text nil 'face face)) | |
125 | (overlay-put ovl 'before-string text) | |
126 | (if evap (overlay-put ovl 'evaporate t)))) | |
127 | (defun org-overlay-get (ovl prop) | |
128 | (if (featurep 'xemacs) | |
129 | (extent-property ovl prop) | |
130 | (overlay-get ovl prop))) | |
131 | (defun org-overlays-at (pos) | |
132 | (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) | |
133 | (defun org-overlays-in (&optional start end) | |
134 | (if (featurep 'xemacs) | |
135 | (extent-list nil start end) | |
136 | (overlays-in start end))) | |
137 | (defun org-overlay-start (o) | |
138 | (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) | |
139 | (defun org-overlay-end (o) | |
140 | (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) | |
141 | (defun org-overlay-buffer (o) | |
142 | (if (featurep 'xemacs) (extent-buffer o) (overlay-buffer o))) | |
143 | (defun org-find-overlays (prop &optional pos delete) | |
144 | "Find all overlays specifying PROP at POS or point. | |
145 | If DELETE is non-nil, delete all those overlays." | |
146 | (let ((overlays (org-overlays-at (or pos (point)))) | |
147 | ov found) | |
148 | (while (setq ov (pop overlays)) | |
149 | (if (org-overlay-get ov prop) | |
150 | (if delete (org-delete-overlay ov) (push ov found)))) | |
151 | found)) | |
152 | ||
153 | (defun org-add-hook (hook function &optional append local) | |
154 | "Add-hook, compatible with both Emacsen." | |
155 | (if (and local (featurep 'xemacs)) | |
156 | (add-local-hook hook function append) | |
157 | (add-hook hook function append local))) | |
158 | ||
159 | (defun org-add-props (string plist &rest props) | |
160 | "Add text properties to entire string, from beginning to end. | |
161 | PLIST may be a list of properties, PROPS are individual properties and values | |
162 | that will be added to PLIST. Returns the string that was modified." | |
163 | (add-text-properties | |
164 | 0 (length string) (if props (append plist props) plist) string) | |
165 | string) | |
166 | (put 'org-add-props 'lisp-indent-function 2) | |
167 | ||
93b62de8 CD |
168 | (defun org-fit-window-to-buffer (&optional window max-height min-height |
169 | shrink-only) | |
170 | "Fit WINDOW to the buffer, but only if it is not a side-by-side window. | |
171 | WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are | |
172 | passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call | |
173 | `shrink-window-if-larger-than-buffer' instead, the hight limit are | |
174 | ignored in this case." | |
0bd48b37 CD |
175 | (cond ((if (fboundp 'window-full-width-p) |
176 | (not (window-full-width-p window)) | |
177 | (> (frame-width) (window-width window))) | |
93b62de8 CD |
178 | ;; do nothing if another window would suffer |
179 | ) | |
180 | ((and (fboundp 'fit-window-to-buffer) (not shrink-only)) | |
181 | (fit-window-to-buffer window max-height min-height)) | |
182 | ((fboundp 'shrink-window-if-larger-than-buffer) | |
183 | (shrink-window-if-larger-than-buffer window))) | |
184 | (or window (selected-window))) | |
185 | ||
20908596 CD |
186 | ;; Region compatibility |
187 | ||
188 | (defvar org-ignore-region nil | |
189 | "To temporarily disable the active region.") | |
190 | ||
191 | (defun org-region-active-p () | |
192 | "Is `transient-mark-mode' on and the region active? | |
193 | Works on both Emacs and XEmacs." | |
194 | (if org-ignore-region | |
195 | nil | |
196 | (if (featurep 'xemacs) | |
197 | (and zmacs-regions (region-active-p)) | |
198 | (if (fboundp 'use-region-p) | |
199 | (use-region-p) | |
200 | (and transient-mark-mode mark-active))))) ; Emacs 22 and before | |
201 | ||
c8d0cf5c CD |
202 | (defun org-cursor-to-region-beginning () |
203 | (when (and (org-region-active-p) | |
204 | (> (point) (region-beginning))) | |
205 | (exchange-point-and-mark))) | |
206 | ||
20908596 CD |
207 | ;; Invisibility compatibility |
208 | ||
209 | (defun org-add-to-invisibility-spec (arg) | |
210 | "Add elements to `buffer-invisibility-spec'. | |
211 | See documentation for `buffer-invisibility-spec' for the kind of elements | |
212 | that can be added." | |
213 | (cond | |
214 | ((fboundp 'add-to-invisibility-spec) | |
215 | (add-to-invisibility-spec arg)) | |
216 | ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) | |
71d35b24 | 217 | (setq buffer-invisibility-spec (list arg))) |
20908596 CD |
218 | (t |
219 | (setq buffer-invisibility-spec | |
220 | (cons arg buffer-invisibility-spec))))) | |
221 | ||
222 | (defun org-remove-from-invisibility-spec (arg) | |
223 | "Remove elements from `buffer-invisibility-spec'." | |
224 | (if (fboundp 'remove-from-invisibility-spec) | |
225 | (remove-from-invisibility-spec arg) | |
226 | (if (consp buffer-invisibility-spec) | |
227 | (setq buffer-invisibility-spec | |
228 | (delete arg buffer-invisibility-spec))))) | |
229 | ||
230 | (defun org-in-invisibility-spec-p (arg) | |
231 | "Is ARG a member of `buffer-invisibility-spec'?" | |
232 | (if (consp buffer-invisibility-spec) | |
233 | (member arg buffer-invisibility-spec) | |
234 | nil)) | |
235 | ||
236 | (defun org-indent-to-column (column &optional minimum buffer) | |
237 | "Work around a bug with extents with invisibility in XEmacs." | |
71d35b24 CD |
238 | (if (featurep 'xemacs) |
239 | (let ((ext-inv (extent-list | |
240 | nil (point-at-bol) (point-at-eol) | |
241 | 'all-extents-closed-open 'invisible)) | |
242 | ext-inv-specs) | |
243 | (dolist (ext ext-inv) | |
244 | (when (extent-property ext 'invisible) | |
245 | (add-to-list 'ext-inv-specs (list ext (extent-property | |
246 | ext 'invisible))) | |
247 | (set-extent-property ext 'invisible nil))) | |
248 | (indent-to-column column minimum buffer) | |
249 | (dolist (ext-inv-spec ext-inv-specs) | |
250 | (set-extent-property (car ext-inv-spec) 'invisible | |
251 | (cadr ext-inv-spec)))) | |
252 | (indent-to-column column minimum))) | |
20908596 CD |
253 | |
254 | (defun org-indent-line-to (column) | |
255 | "Work around a bug with extents with invisibility in XEmacs." | |
71d35b24 CD |
256 | (if (featurep 'xemacs) |
257 | (let ((ext-inv (extent-list | |
258 | nil (point-at-bol) (point-at-eol) | |
259 | 'all-extents-closed-open 'invisible)) | |
260 | ext-inv-specs) | |
261 | (dolist (ext ext-inv) | |
262 | (when (extent-property ext 'invisible) | |
263 | (add-to-list 'ext-inv-specs (list ext (extent-property | |
264 | ext 'invisible))) | |
265 | (set-extent-property ext 'invisible nil))) | |
266 | (indent-line-to column) | |
267 | (dolist (ext-inv-spec ext-inv-specs) | |
268 | (set-extent-property (car ext-inv-spec) 'invisible | |
269 | (cadr ext-inv-spec)))) | |
270 | (indent-line-to column))) | |
20908596 CD |
271 | |
272 | (defun org-move-to-column (column &optional force buffer) | |
71d35b24 CD |
273 | (if (featurep 'xemacs) |
274 | (let ((ext-inv (extent-list | |
275 | nil (point-at-bol) (point-at-eol) | |
276 | 'all-extents-closed-open 'invisible)) | |
277 | ext-inv-specs) | |
278 | (dolist (ext ext-inv) | |
279 | (when (extent-property ext 'invisible) | |
280 | (add-to-list 'ext-inv-specs (list ext (extent-property ext | |
281 | 'invisible))) | |
282 | (set-extent-property ext 'invisible nil))) | |
283 | (move-to-column column force buffer) | |
284 | (dolist (ext-inv-spec ext-inv-specs) | |
285 | (set-extent-property (car ext-inv-spec) 'invisible | |
286 | (cadr ext-inv-spec)))) | |
287 | (move-to-column column force))) | |
621f83e4 CD |
288 | |
289 | (defun org-get-x-clipboard-compat (value) | |
290 | "Get the clipboard value on XEmacs or Emacs 21" | |
291 | (cond (org-xemacs-p (org-no-warnings (get-selection-no-error value))) | |
292 | ((fboundp 'x-get-selection) | |
293 | (condition-case nil | |
294 | (or (x-get-selection value 'UTF8_STRING) | |
295 | (x-get-selection value 'COMPOUND_TEXT) | |
296 | (x-get-selection value 'STRING) | |
297 | (x-get-selection value 'TEXT)) | |
298 | (error nil))))) | |
299 | ||
300 | (defun org-propertize (string &rest properties) | |
301 | (if (featurep 'xemacs) | |
ce4fdcb9 CD |
302 | (progn |
303 | (add-text-properties 0 (length string) properties string) | |
304 | string) | |
621f83e4 | 305 | (apply 'propertize string properties))) |
71d35b24 | 306 | |
ce4fdcb9 CD |
307 | (defun org-substring-no-properties (string &optional from to) |
308 | (if (featurep 'xemacs) | |
db55f368 | 309 | (org-no-properties (substring string (or from 0) to)) |
ce4fdcb9 CD |
310 | (substring-no-properties string from to))) |
311 | ||
c8d0cf5c CD |
312 | (defun org-find-library-name (library) |
313 | (if (fboundp 'find-library-name) | |
314 | (file-name-directory (find-library-name library)) | |
315 | ; XEmacs does not have `find-library-name' | |
316 | (flet ((find-library-name-helper (filename ignored-codesys) | |
317 | filename) | |
318 | (find-library-name (library) | |
319 | (find-library library nil 'find-library-name-helper))) | |
320 | (file-name-directory (find-library-name library))))) | |
321 | ||
0bd48b37 CD |
322 | (defun org-count-lines (s) |
323 | "How many lines in string S?" | |
324 | (let ((start 0) (n 1)) | |
325 | (while (string-match "\n" s start) | |
326 | (setq start (match-end 0) n (1+ n))) | |
327 | (if (and (> (length s) 0) (= (aref s (1- (length s))) ?\n)) | |
328 | (setq n (1- n))) | |
329 | n)) | |
330 | ||
c8d0cf5c CD |
331 | (defun org-kill-new (string &rest args) |
332 | (remove-text-properties 0 (length string) '(line-prefix t wrap-prefix t) | |
333 | string) | |
334 | (apply 'kill-new string args)) | |
335 | ||
54a0dee5 CD |
336 | (defun org-select-frame-set-input-focus (frame) |
337 | "Select FRAME, raise it, and set input focus, if possible." | |
338 | (cond ((featurep 'xemacs) | |
339 | (if (fboundp 'select-frame-set-input-focus) | |
340 | (select-frame-set-input-focus frame) | |
341 | (raise-frame frame) | |
342 | (select-frame frame) | |
343 | (focus-frame frame))) | |
344 | ;; `select-frame-set-input-focus' defined in Emacs 21 will not | |
345 | ;; set the input focus. | |
346 | ((>= emacs-major-version 22) | |
347 | (select-frame-set-input-focus frame)) | |
348 | (t | |
349 | (raise-frame frame) | |
350 | (select-frame frame) | |
351 | (cond ((memq window-system '(x ns mac)) | |
352 | (x-focus-frame frame)) | |
353 | ((eq window-system 'w32) | |
354 | (w32-focus-frame frame))) | |
355 | (when focus-follows-mouse | |
356 | (set-mouse-position frame (1- (frame-width frame)) 0))))) | |
357 | ||
358 | (defun org-float-time (&optional time) | |
359 | "Convert time value TIME to a floating point number. | |
360 | TIME defaults to the current time." | |
361 | (if (featurep 'xemacs) | |
362 | (time-to-seconds (or time (current-time))) | |
363 | (float-time time))) | |
364 | ||
20908596 CD |
365 | (provide 'org-compat) |
366 | ||
88ac7b50 | 367 | ;; arch-tag: a0a0579f-e68c-4bdf-9e55-93768b846bbe |
b349f79f | 368 | |
20908596 | 369 | ;;; org-compat.el ends here |