2008-03-22 15:52:18 +00:00
|
|
|
|
;;; org-compat.el --- Compatibility code for Org-mode
|
|
|
|
|
|
2013-01-08 14:04:32 +00:00
|
|
|
|
;; Copyright (C) 2004-2013 Free Software Foundation, Inc.
|
2008-03-22 15:52:18 +00:00
|
|
|
|
|
|
|
|
|
;; Author: Carsten Dominik <carsten at orgmode dot org>
|
|
|
|
|
;; Keywords: outlines, hypermedia, calendar, wp
|
|
|
|
|
;; Homepage: http://orgmode.org
|
|
|
|
|
;;
|
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
;;
|
2008-05-06 12:45:52 +00:00
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
2008-03-22 15:52:18 +00:00
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
2008-05-06 12:45:52 +00:00
|
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
;; (at your option) any later version.
|
2008-03-22 15:52:18 +00:00
|
|
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
2008-05-06 12:45:52 +00:00
|
|
|
|
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
2008-03-22 15:52:18 +00:00
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
;;
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
|
|
|
|
;; This file contains code needed for compatibility with XEmacs and older
|
|
|
|
|
;; versions of GNU Emacs.
|
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
2009-04-07 17:08:24 +00:00
|
|
|
|
(eval-when-compile
|
|
|
|
|
(require 'cl))
|
|
|
|
|
|
2008-09-21 19:39:28 +00:00
|
|
|
|
(require 'org-macs)
|
|
|
|
|
|
2009-09-30 07:20:28 +00:00
|
|
|
|
(declare-function w32-focus-frame "term/w32-win" (frame))
|
2009-04-06 05:23:46 +00:00
|
|
|
|
|
2010-04-22 13:30:12 +00:00
|
|
|
|
;; The following constant is for backward compatibility. We do not use
|
|
|
|
|
;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs)
|
|
|
|
|
;; at compilation time and can therefore optimize code better.
|
|
|
|
|
(defconst org-xemacs-p (featurep 'xemacs))
|
2008-03-22 15:52:18 +00:00
|
|
|
|
(defconst org-format-transports-properties-p
|
|
|
|
|
(let ((x "a"))
|
|
|
|
|
(add-text-properties 0 1 '(test t) x)
|
|
|
|
|
(get-text-property 0 'test (format "%s" x)))
|
|
|
|
|
"Does format transport text properties?")
|
|
|
|
|
|
|
|
|
|
(defun org-compatible-face (inherits specs)
|
|
|
|
|
"Make a compatible face specification.
|
|
|
|
|
If INHERITS is an existing face and if the Emacs version supports it,
|
2009-06-02 12:50:19 +00:00
|
|
|
|
just inherit the face. If INHERITS is set and the Emacs version does
|
|
|
|
|
not support it, copy the face specification from the inheritance face.
|
|
|
|
|
If INHERITS is not given and SPECS is, use SPECS to define the face.
|
2008-03-22 15:52:18 +00:00
|
|
|
|
XEmacs and Emacs 21 do not know about the `min-colors' attribute.
|
|
|
|
|
For them we convert a (min-colors 8) entry to a `tty' entry and move it
|
|
|
|
|
to the top of the list. The `min-colors' attribute will be removed from
|
|
|
|
|
any other entries, and any resulting duplicates will be removed entirely."
|
2009-06-02 12:50:19 +00:00
|
|
|
|
(when (and inherits (facep inherits) (not specs))
|
|
|
|
|
(setq specs (or specs
|
|
|
|
|
(get inherits 'saved-face)
|
|
|
|
|
(get inherits 'face-defface-spec))))
|
2008-03-22 15:52:18 +00:00
|
|
|
|
(cond
|
|
|
|
|
((and inherits (facep inherits)
|
2009-05-29 07:37:05 +00:00
|
|
|
|
(not (featurep 'xemacs))
|
2009-06-02 12:50:19 +00:00
|
|
|
|
(>= emacs-major-version 22)
|
|
|
|
|
;; do not inherit outline faces before Emacs 23
|
|
|
|
|
(or (>= emacs-major-version 23)
|
|
|
|
|
(not (string-match "\\`outline-[0-9]+"
|
|
|
|
|
(symbol-name inherits)))))
|
2008-03-22 15:52:18 +00:00
|
|
|
|
(list (list t :inherit inherits)))
|
|
|
|
|
((or (featurep 'xemacs) (< emacs-major-version 22))
|
|
|
|
|
;; These do not understand the `min-colors' attribute.
|
|
|
|
|
(let (r e a)
|
|
|
|
|
(while (setq e (pop specs))
|
|
|
|
|
(cond
|
|
|
|
|
((memq (car e) '(t default)) (push e r))
|
|
|
|
|
((setq a (member '(min-colors 8) (car e)))
|
|
|
|
|
(nconc r (list (cons (cons '(type tty) (delq (car a) (car e)))
|
|
|
|
|
(cdr e)))))
|
|
|
|
|
((setq a (assq 'min-colors (car e)))
|
|
|
|
|
(setq e (cons (delq a (car e)) (cdr e)))
|
|
|
|
|
(or (assoc (car e) r) (push e r)))
|
|
|
|
|
(t (or (assoc (car e) r) (push e r)))))
|
|
|
|
|
(nreverse r)))
|
|
|
|
|
(t specs)))
|
|
|
|
|
(put 'org-compatible-face 'lisp-indent-function 1)
|
|
|
|
|
|
2010-07-06 08:23:41 +00:00
|
|
|
|
(defun org-version-check (version feature level)
|
|
|
|
|
(let* ((v1 (mapcar 'string-to-number (split-string version "[.]")))
|
|
|
|
|
(v2 (mapcar 'string-to-number (split-string emacs-version "[.]")))
|
|
|
|
|
(rmaj (or (nth 0 v1) 99))
|
|
|
|
|
(rmin (or (nth 1 v1) 99))
|
|
|
|
|
(rbld (or (nth 2 v1) 99))
|
|
|
|
|
(maj (or (nth 0 v2) 0))
|
|
|
|
|
(min (or (nth 1 v2) 0))
|
|
|
|
|
(bld (or (nth 2 v2) 0)))
|
|
|
|
|
(if (or (< maj rmaj)
|
|
|
|
|
(and (= maj rmaj)
|
|
|
|
|
(< min rmin))
|
|
|
|
|
(and (= maj rmaj)
|
|
|
|
|
(= min rmin)
|
|
|
|
|
(< bld rbld)))
|
|
|
|
|
(if (eq level :predicate)
|
|
|
|
|
;; just return if we have the version
|
|
|
|
|
nil
|
|
|
|
|
(let ((msg (format "Emacs %s or greater is recommended for %s"
|
|
|
|
|
version feature)))
|
|
|
|
|
(display-warning 'org msg level)
|
|
|
|
|
t))
|
|
|
|
|
t)))
|
|
|
|
|
|
2012-08-13 14:17:46 +00:00
|
|
|
|
|
2008-03-22 15:52:18 +00:00
|
|
|
|
;;;; Emacs/XEmacs compatibility
|
|
|
|
|
|
2013-03-14 12:53:52 +00:00
|
|
|
|
(defun org-defvaralias (new-alias base-variable &optional docstring)
|
|
|
|
|
"Compatibility function for defvaralias.
|
|
|
|
|
Don't do the aliasing when `defvaralias' is not bound."
|
2013-03-15 11:06:44 +00:00
|
|
|
|
(declare (indent 1))
|
2013-03-14 12:53:52 +00:00
|
|
|
|
(when (fboundp 'defvaralias)
|
|
|
|
|
(defvaralias new-alias base-variable docstring)))
|
|
|
|
|
|
2013-01-12 11:06:20 +00:00
|
|
|
|
(eval-and-compile
|
|
|
|
|
(when (and (not (boundp 'user-emacs-directory))
|
|
|
|
|
(boundp 'user-init-directory))
|
2013-03-14 12:53:52 +00:00
|
|
|
|
(org-defvaralias 'user-emacs-directory 'user-init-directory)))
|
2013-01-12 11:06:20 +00:00
|
|
|
|
|
2010-04-21 06:38:09 +00:00
|
|
|
|
;; Keys
|
|
|
|
|
(defconst org-xemacs-key-equivalents
|
|
|
|
|
'(([mouse-1] . [button1])
|
|
|
|
|
([mouse-2] . [button2])
|
|
|
|
|
([mouse-3] . [button3])
|
|
|
|
|
([C-mouse-4] . [(control mouse-4)])
|
|
|
|
|
([C-mouse-5] . [(control mouse-5)]))
|
2010-07-15 20:26:51 +00:00
|
|
|
|
"Translation alist for a couple of keys.")
|
2010-04-21 06:38:09 +00:00
|
|
|
|
|
2008-03-22 15:52:18 +00:00
|
|
|
|
;; Overlay compatibility functions
|
|
|
|
|
(defun org-detach-overlay (ovl)
|
|
|
|
|
(if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl)))
|
|
|
|
|
(defun org-overlay-display (ovl text &optional face evap)
|
|
|
|
|
"Make overlay OVL display TEXT with face FACE."
|
|
|
|
|
(if (featurep 'xemacs)
|
|
|
|
|
(let ((gl (make-glyph text)))
|
|
|
|
|
(and face (set-glyph-face gl face))
|
|
|
|
|
(set-extent-property ovl 'invisible t)
|
|
|
|
|
(set-extent-property ovl 'end-glyph gl))
|
|
|
|
|
(overlay-put ovl 'display text)
|
|
|
|
|
(if face (overlay-put ovl 'face face))
|
|
|
|
|
(if evap (overlay-put ovl 'evaporate t))))
|
|
|
|
|
(defun org-overlay-before-string (ovl text &optional face evap)
|
|
|
|
|
"Make overlay OVL display TEXT with face FACE."
|
|
|
|
|
(if (featurep 'xemacs)
|
|
|
|
|
(let ((gl (make-glyph text)))
|
|
|
|
|
(and face (set-glyph-face gl face))
|
|
|
|
|
(set-extent-property ovl 'begin-glyph gl))
|
|
|
|
|
(if face (org-add-props text nil 'face face))
|
|
|
|
|
(overlay-put ovl 'before-string text)
|
|
|
|
|
(if evap (overlay-put ovl 'evaporate t))))
|
|
|
|
|
(defun org-find-overlays (prop &optional pos delete)
|
|
|
|
|
"Find all overlays specifying PROP at POS or point.
|
|
|
|
|
If DELETE is non-nil, delete all those overlays."
|
2010-04-20 10:17:06 +00:00
|
|
|
|
(let ((overlays (overlays-at (or pos (point))))
|
2008-03-22 15:52:18 +00:00
|
|
|
|
ov found)
|
|
|
|
|
(while (setq ov (pop overlays))
|
2010-04-18 14:37:42 +00:00
|
|
|
|
(if (overlay-get ov prop)
|
|
|
|
|
(if delete (delete-overlay ov) (push ov found))))
|
2008-03-22 15:52:18 +00:00
|
|
|
|
found))
|
|
|
|
|
|
2009-10-13 07:41:40 +00:00
|
|
|
|
(defun org-get-x-clipboard (value)
|
|
|
|
|
"Get the value of the x clipboard, compatible with XEmacs, and GNU Emacs 21."
|
|
|
|
|
(if (eq window-system 'x)
|
|
|
|
|
(let ((x (org-get-x-clipboard-compat value)))
|
|
|
|
|
(if x (org-no-properties x)))))
|
|
|
|
|
|
2010-10-17 16:35:02 +00:00
|
|
|
|
(defsubst org-decompose-region (beg end)
|
|
|
|
|
"Decompose from BEG to END."
|
|
|
|
|
(if (featurep 'xemacs)
|
|
|
|
|
(let ((modified-p (buffer-modified-p))
|
|
|
|
|
(buffer-read-only nil))
|
|
|
|
|
(remove-text-properties beg end '(composition nil))
|
|
|
|
|
(set-buffer-modified-p modified-p))
|
|
|
|
|
(decompose-region beg end)))
|
|
|
|
|
|
2010-04-18 17:58:24 +00:00
|
|
|
|
;; Miscellaneous functions
|
|
|
|
|
|
2008-03-22 15:52:18 +00:00
|
|
|
|
(defun org-add-hook (hook function &optional append local)
|
|
|
|
|
"Add-hook, compatible with both Emacsen."
|
|
|
|
|
(if (and local (featurep 'xemacs))
|
|
|
|
|
(add-local-hook hook function append)
|
|
|
|
|
(add-hook hook function append local)))
|
|
|
|
|
|
|
|
|
|
(defun org-add-props (string plist &rest props)
|
|
|
|
|
"Add text properties to entire string, from beginning to end.
|
|
|
|
|
PLIST may be a list of properties, PROPS are individual properties and values
|
|
|
|
|
that will be added to PLIST. Returns the string that was modified."
|
|
|
|
|
(add-text-properties
|
|
|
|
|
0 (length string) (if props (append plist props) plist) string)
|
|
|
|
|
string)
|
|
|
|
|
(put 'org-add-props 'lisp-indent-function 2)
|
|
|
|
|
|
2008-11-03 12:38:25 +00:00
|
|
|
|
(defun org-fit-window-to-buffer (&optional window max-height min-height
|
|
|
|
|
shrink-only)
|
|
|
|
|
"Fit WINDOW to the buffer, but only if it is not a side-by-side window.
|
|
|
|
|
WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are
|
|
|
|
|
passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call
|
2010-07-15 20:26:51 +00:00
|
|
|
|
`shrink-window-if-larger-than-buffer' instead, the height limit is
|
2008-11-03 12:38:25 +00:00
|
|
|
|
ignored in this case."
|
2009-01-09 08:09:42 +00:00
|
|
|
|
(cond ((if (fboundp 'window-full-width-p)
|
2009-01-18 20:21:29 +00:00
|
|
|
|
(not (window-full-width-p window))
|
2012-12-19 16:43:57 +00:00
|
|
|
|
;; do nothing if another window would suffer
|
|
|
|
|
(> (frame-width) (window-width window))))
|
2008-11-03 12:38:25 +00:00
|
|
|
|
((and (fboundp 'fit-window-to-buffer) (not shrink-only))
|
|
|
|
|
(fit-window-to-buffer window max-height min-height))
|
2008-10-25 16:01:22 +00:00
|
|
|
|
((fboundp 'shrink-window-if-larger-than-buffer)
|
2008-11-03 12:38:25 +00:00
|
|
|
|
(shrink-window-if-larger-than-buffer window)))
|
|
|
|
|
(or window (selected-window)))
|
2008-10-25 16:01:22 +00:00
|
|
|
|
|
2010-10-18 12:23:38 +00:00
|
|
|
|
(defun org-number-sequence (from &optional to inc)
|
|
|
|
|
"Call `number-sequence or emulate it."
|
|
|
|
|
(if (fboundp 'number-sequence)
|
|
|
|
|
(number-sequence from to inc)
|
|
|
|
|
(if (or (not to) (= from to))
|
|
|
|
|
(list from)
|
|
|
|
|
(or inc (setq inc 1))
|
|
|
|
|
(when (zerop inc) (error "The increment can not be zero"))
|
|
|
|
|
(let (seq (n 0) (next from))
|
|
|
|
|
(if (> inc 0)
|
|
|
|
|
(while (<= next to)
|
|
|
|
|
(setq seq (cons next seq)
|
|
|
|
|
n (1+ n)
|
|
|
|
|
next (+ from (* n inc))))
|
|
|
|
|
(while (>= next to)
|
|
|
|
|
(setq seq (cons next seq)
|
|
|
|
|
n (1+ n)
|
|
|
|
|
next (+ from (* n inc)))))
|
|
|
|
|
(nreverse seq)))))
|
|
|
|
|
|
2008-03-22 15:52:18 +00:00
|
|
|
|
;; Region compatibility
|
|
|
|
|
|
|
|
|
|
(defvar org-ignore-region nil
|
|
|
|
|
"To temporarily disable the active region.")
|
|
|
|
|
|
|
|
|
|
(defun org-region-active-p ()
|
|
|
|
|
"Is `transient-mark-mode' on and the region active?
|
|
|
|
|
Works on both Emacs and XEmacs."
|
|
|
|
|
(if org-ignore-region
|
|
|
|
|
nil
|
|
|
|
|
(if (featurep 'xemacs)
|
|
|
|
|
(and zmacs-regions (region-active-p))
|
|
|
|
|
(if (fboundp 'use-region-p)
|
|
|
|
|
(use-region-p)
|
|
|
|
|
(and transient-mark-mode mark-active))))) ; Emacs 22 and before
|
|
|
|
|
|
2009-02-20 16:20:46 +00:00
|
|
|
|
(defun org-cursor-to-region-beginning ()
|
|
|
|
|
(when (and (org-region-active-p)
|
|
|
|
|
(> (point) (region-beginning)))
|
|
|
|
|
(exchange-point-and-mark)))
|
|
|
|
|
|
2011-05-29 18:50:18 +00:00
|
|
|
|
;; Emacs 22 misses `activate-mark'
|
|
|
|
|
(if (fboundp 'activate-mark)
|
|
|
|
|
(defalias 'org-activate-mark 'activate-mark)
|
|
|
|
|
(defun org-activate-mark ()
|
|
|
|
|
(when (mark t)
|
|
|
|
|
(setq mark-active t)
|
2011-10-21 20:36:53 +00:00
|
|
|
|
(when (and (boundp 'transient-mark-mode)
|
|
|
|
|
(not transient-mark-mode))
|
|
|
|
|
(setq transient-mark-mode 'lambda))
|
|
|
|
|
(when (boundp 'zmacs-regions)
|
|
|
|
|
(setq zmacs-regions t)))))
|
|
|
|
|
|
2008-03-22 15:52:18 +00:00
|
|
|
|
;; Invisibility compatibility
|
|
|
|
|
|
|
|
|
|
(defun org-remove-from-invisibility-spec (arg)
|
|
|
|
|
"Remove elements from `buffer-invisibility-spec'."
|
|
|
|
|
(if (fboundp 'remove-from-invisibility-spec)
|
|
|
|
|
(remove-from-invisibility-spec arg)
|
|
|
|
|
(if (consp buffer-invisibility-spec)
|
|
|
|
|
(setq buffer-invisibility-spec
|
|
|
|
|
(delete arg buffer-invisibility-spec)))))
|
|
|
|
|
|
|
|
|
|
(defun org-in-invisibility-spec-p (arg)
|
|
|
|
|
"Is ARG a member of `buffer-invisibility-spec'?"
|
|
|
|
|
(if (consp buffer-invisibility-spec)
|
|
|
|
|
(member arg buffer-invisibility-spec)
|
|
|
|
|
nil))
|
|
|
|
|
|
2010-04-18 17:58:24 +00:00
|
|
|
|
(defmacro org-xemacs-without-invisibility (&rest body)
|
2012-01-10 10:56:15 +00:00
|
|
|
|
"Turn off extents with invisibility while executing BODY."
|
2010-04-18 17:58:24 +00:00
|
|
|
|
`(let ((ext-inv (extent-list nil (point-at-bol) (point-at-eol)
|
|
|
|
|
'all-extents-closed-open 'invisible))
|
|
|
|
|
ext-inv-specs)
|
|
|
|
|
(dolist (ext ext-inv)
|
|
|
|
|
(when (extent-property ext 'invisible)
|
|
|
|
|
(add-to-list 'ext-inv-specs (list ext (extent-property
|
|
|
|
|
ext 'invisible)))
|
|
|
|
|
(set-extent-property ext 'invisible nil)))
|
|
|
|
|
,@body
|
|
|
|
|
(dolist (ext-inv-spec ext-inv-specs)
|
|
|
|
|
(set-extent-property (car ext-inv-spec) 'invisible
|
|
|
|
|
(cadr ext-inv-spec)))))
|
Provide edebug specifications for macros
* org-macs.el (org-with-gensyms, org-called-interactively-p)
(with-silent-modifications, org-bound-and-true-p)
(org-unmodified, org-re, org-preserve-lc)
(org-without-partial-completion, org-with-point-at)
(org-no-warnings, org-if-unprotected, org-if-unprotected-1)
(org-if-unprotected-at, org-with-remote-undo)
(org-no-read-only, org-save-outline-visibility)
(org-with-wide-buffer, org-with-limited-levels)
(org-eval-in-environment): Provide edebug specifications.
* org-src.el (org-src-do-at-code-block): Dto.
* org-publish.el (org-publish-with-aux-preprocess-maybe): Dto.
* org-compat.el (org-xemacs-without-invisibility): Dto.
* org-clock.el (org-with-clock-position, org-with-clock): Dto.
* org-agenda.el (org-agenda-with-point-at-orig-entry)
(org-batch-agenda, org-batch-agenda-csv)
(org-batch-store-agenda-views): Dto.
* ob.el (org-babel-do-in-edit-buffer)
(org-babel-map-src-blocks, org-babel-map-inline-src-blocks): Dto.
* ob-tangle.el (org-babel-with-temp-filebuffer): Dto.
* ob-table.el (sbe): Dto.
* ob-exp.el (org-babel-exp-in-export-file): Dto.
* ob-comint.el (org-babel-comint-in-buffer)
(org-babel-comint-with-output): Dto.
2011-08-11 06:57:25 +00:00
|
|
|
|
(def-edebug-spec org-xemacs-without-invisibility (body))
|
2010-04-18 17:58:24 +00:00
|
|
|
|
|
2008-04-24 14:44:12 +00:00
|
|
|
|
(defun org-indent-to-column (column &optional minimum buffer)
|
|
|
|
|
"Work around a bug with extents with invisibility in XEmacs."
|
2008-10-14 14:50:02 +00:00
|
|
|
|
(if (featurep 'xemacs)
|
2010-04-18 17:58:24 +00:00
|
|
|
|
(org-xemacs-without-invisibility (indent-to-column column minimum buffer))
|
2008-10-14 14:50:02 +00:00
|
|
|
|
(indent-to-column column minimum)))
|
2008-04-24 14:44:12 +00:00
|
|
|
|
|
|
|
|
|
(defun org-indent-line-to (column)
|
|
|
|
|
"Work around a bug with extents with invisibility in XEmacs."
|
2008-10-14 14:50:02 +00:00
|
|
|
|
(if (featurep 'xemacs)
|
2010-04-18 17:58:24 +00:00
|
|
|
|
(org-xemacs-without-invisibility (indent-line-to column))
|
2008-10-14 14:50:02 +00:00
|
|
|
|
(indent-line-to column)))
|
2008-04-24 14:44:12 +00:00
|
|
|
|
|
|
|
|
|
(defun org-move-to-column (column &optional force buffer)
|
2008-10-14 14:50:02 +00:00
|
|
|
|
(if (featurep 'xemacs)
|
2010-04-18 17:58:24 +00:00
|
|
|
|
(org-xemacs-without-invisibility (move-to-column column force buffer))
|
2008-10-14 14:50:02 +00:00
|
|
|
|
(move-to-column column force)))
|
2008-09-21 05:35:39 +00:00
|
|
|
|
|
|
|
|
|
(defun org-get-x-clipboard-compat (value)
|
2010-07-15 20:26:51 +00:00
|
|
|
|
"Get the clipboard value on XEmacs or Emacs 21."
|
2010-04-22 13:30:12 +00:00
|
|
|
|
(cond ((featurep 'xemacs)
|
|
|
|
|
(org-no-warnings (get-selection-no-error value)))
|
2008-09-21 05:35:39 +00:00
|
|
|
|
((fboundp 'x-get-selection)
|
|
|
|
|
(condition-case nil
|
|
|
|
|
(or (x-get-selection value 'UTF8_STRING)
|
|
|
|
|
(x-get-selection value 'COMPOUND_TEXT)
|
|
|
|
|
(x-get-selection value 'STRING)
|
|
|
|
|
(x-get-selection value 'TEXT))
|
|
|
|
|
(error nil)))))
|
|
|
|
|
|
|
|
|
|
(defun org-propertize (string &rest properties)
|
|
|
|
|
(if (featurep 'xemacs)
|
2008-11-21 08:14:26 +00:00
|
|
|
|
(progn
|
|
|
|
|
(add-text-properties 0 (length string) properties string)
|
|
|
|
|
string)
|
2008-09-21 05:35:39 +00:00
|
|
|
|
(apply 'propertize string properties)))
|
2008-10-14 14:50:02 +00:00
|
|
|
|
|
2012-05-07 20:37:31 +00:00
|
|
|
|
(defmacro org-find-library-dir (library)
|
2012-10-07 13:01:39 +00:00
|
|
|
|
`(file-name-directory (or (locate-library ,library) "")))
|
2009-04-06 05:23:46 +00:00
|
|
|
|
|
2009-01-19 22:13:58 +00:00
|
|
|
|
(defun org-count-lines (s)
|
|
|
|
|
"How many lines in string S?"
|
|
|
|
|
(let ((start 0) (n 1))
|
|
|
|
|
(while (string-match "\n" s start)
|
|
|
|
|
(setq start (match-end 0) n (1+ n)))
|
|
|
|
|
(if (and (> (length s) 0) (= (aref s (1- (length s))) ?\n))
|
|
|
|
|
(setq n (1- n)))
|
|
|
|
|
n))
|
|
|
|
|
|
2009-06-30 05:24:57 +00:00
|
|
|
|
(defun org-kill-new (string &rest args)
|
|
|
|
|
(remove-text-properties 0 (length string) '(line-prefix t wrap-prefix t)
|
|
|
|
|
string)
|
|
|
|
|
(apply 'kill-new string args))
|
|
|
|
|
|
2009-09-01 14:30:33 +00:00
|
|
|
|
(defun org-select-frame-set-input-focus (frame)
|
|
|
|
|
"Select FRAME, raise it, and set input focus, if possible."
|
|
|
|
|
(cond ((featurep 'xemacs)
|
|
|
|
|
(if (fboundp 'select-frame-set-input-focus)
|
|
|
|
|
(select-frame-set-input-focus frame)
|
|
|
|
|
(raise-frame frame)
|
|
|
|
|
(select-frame frame)
|
|
|
|
|
(focus-frame frame)))
|
|
|
|
|
;; `select-frame-set-input-focus' defined in Emacs 21 will not
|
|
|
|
|
;; set the input focus.
|
|
|
|
|
((>= emacs-major-version 22)
|
|
|
|
|
(select-frame-set-input-focus frame))
|
|
|
|
|
(t
|
|
|
|
|
(raise-frame frame)
|
|
|
|
|
(select-frame frame)
|
|
|
|
|
(cond ((memq window-system '(x ns mac))
|
|
|
|
|
(x-focus-frame frame))
|
|
|
|
|
((eq window-system 'w32)
|
|
|
|
|
(w32-focus-frame frame)))
|
|
|
|
|
(when focus-follows-mouse
|
|
|
|
|
(set-mouse-position frame (1- (frame-width frame)) 0)))))
|
|
|
|
|
|
2009-09-02 12:37:47 +00:00
|
|
|
|
(defun org-float-time (&optional time)
|
|
|
|
|
"Convert time value TIME to a floating point number.
|
|
|
|
|
TIME defaults to the current time."
|
|
|
|
|
(if (featurep 'xemacs)
|
|
|
|
|
(time-to-seconds (or time (current-time)))
|
|
|
|
|
(float-time time)))
|
|
|
|
|
|
2012-12-19 16:43:57 +00:00
|
|
|
|
;; `user-error' is only available from 24.2.50 on
|
|
|
|
|
(unless (fboundp 'user-error)
|
|
|
|
|
(defalias 'user-error 'error))
|
|
|
|
|
|
2012-12-20 09:18:02 +00:00
|
|
|
|
(defmacro org-no-popups (&rest body)
|
|
|
|
|
"Suppress popup windows.
|
|
|
|
|
Let-bind some variables to nil around BODY to achieve the desired
|
|
|
|
|
effect, which variables to use depends on the Emacs version."
|
|
|
|
|
(if (org-version-check "24.2.50" "" :predicate)
|
|
|
|
|
`(let (pop-up-frames display-buffer-alist)
|
|
|
|
|
,@body)
|
|
|
|
|
`(let (pop-up-frames special-display-buffer-names special-display-regexps special-display-function)
|
|
|
|
|
,@body)))
|
|
|
|
|
|
2010-10-29 13:28:31 +00:00
|
|
|
|
(if (fboundp 'string-match-p)
|
|
|
|
|
(defalias 'org-string-match-p 'string-match-p)
|
|
|
|
|
(defun org-string-match-p (regexp string &optional start)
|
2010-06-03 08:24:04 +00:00
|
|
|
|
(save-match-data
|
2010-10-29 13:28:31 +00:00
|
|
|
|
(funcall 'string-match regexp string start))))
|
2010-06-03 08:24:04 +00:00
|
|
|
|
|
2010-10-29 13:28:31 +00:00
|
|
|
|
(if (fboundp 'looking-at-p)
|
|
|
|
|
(defalias 'org-looking-at-p 'looking-at-p)
|
|
|
|
|
(defun org-looking-at-p (&rest args)
|
2010-06-03 08:24:04 +00:00
|
|
|
|
(save-match-data
|
2010-08-17 04:32:55 +00:00
|
|
|
|
(apply 'looking-at args))))
|
2010-06-03 08:24:04 +00:00
|
|
|
|
|
2012-12-19 16:43:57 +00:00
|
|
|
|
;; XEmacs does not have `looking-back'.
|
2009-11-23 11:44:49 +00:00
|
|
|
|
(if (fboundp 'looking-back)
|
|
|
|
|
(defalias 'org-looking-back 'looking-back)
|
|
|
|
|
(defun org-looking-back (regexp &optional limit greedy)
|
|
|
|
|
"Return non-nil if text before point matches regular expression REGEXP.
|
|
|
|
|
Like `looking-at' except matches before point, and is slower.
|
|
|
|
|
LIMIT if non-nil speeds up the search by specifying a minimum
|
|
|
|
|
starting position, to avoid checking matches that would start
|
|
|
|
|
before LIMIT.
|
|
|
|
|
|
|
|
|
|
If GREEDY is non-nil, extend the match backwards as far as
|
|
|
|
|
possible, stopping when a single additional previous character
|
|
|
|
|
cannot be part of a match for REGEXP. When the match is
|
|
|
|
|
extended, its starting position is allowed to occur before
|
|
|
|
|
LIMIT."
|
|
|
|
|
(let ((start (point))
|
|
|
|
|
(pos
|
|
|
|
|
(save-excursion
|
|
|
|
|
(and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
|
|
|
|
|
(point)))))
|
|
|
|
|
(if (and greedy pos)
|
|
|
|
|
(save-restriction
|
|
|
|
|
(narrow-to-region (point-min) start)
|
|
|
|
|
(while (and (> pos (point-min))
|
|
|
|
|
(save-excursion
|
|
|
|
|
(goto-char pos)
|
|
|
|
|
(backward-char 1)
|
|
|
|
|
(looking-at (concat "\\(?:" regexp "\\)\\'"))))
|
|
|
|
|
(setq pos (1- pos)))
|
|
|
|
|
(save-excursion
|
|
|
|
|
(goto-char pos)
|
|
|
|
|
(looking-at (concat "\\(?:" regexp "\\)\\'")))))
|
|
|
|
|
(not (null pos)))))
|
|
|
|
|
|
2010-12-03 09:20:41 +00:00
|
|
|
|
(defun org-floor* (x &optional y)
|
|
|
|
|
"Return a list of the floor of X and the fractional part of X.
|
|
|
|
|
With two arguments, return floor and remainder of their quotient."
|
|
|
|
|
(let ((q (floor x y)))
|
|
|
|
|
(list q (- x (if y (* y q) q)))))
|
|
|
|
|
|
2012-07-12 08:30:33 +00:00
|
|
|
|
;; `pop-to-buffer-same-window' has been introduced in Emacs 24.1.
|
2011-07-18 17:25:10 +00:00
|
|
|
|
(defun org-pop-to-buffer-same-window
|
|
|
|
|
(&optional buffer-or-name norecord label)
|
|
|
|
|
"Pop to buffer specified by BUFFER-OR-NAME in the selected window."
|
|
|
|
|
(if (fboundp 'pop-to-buffer-same-window)
|
|
|
|
|
(funcall
|
2011-09-02 16:18:56 +00:00
|
|
|
|
'pop-to-buffer-same-window buffer-or-name norecord)
|
2011-07-18 17:25:10 +00:00
|
|
|
|
(funcall 'switch-to-buffer buffer-or-name norecord)))
|
|
|
|
|
|
2012-12-24 12:51:48 +00:00
|
|
|
|
;; RECURSIVE has been introduced with Emacs 23.2.
|
|
|
|
|
;; This is copying and adapted from `tramp-compat-delete-directory'
|
|
|
|
|
(defun org-delete-directory (directory &optional recursive)
|
|
|
|
|
"Compatibility function for `delete-directory'."
|
|
|
|
|
(if (null recursive)
|
|
|
|
|
(delete-directory directory)
|
|
|
|
|
(condition-case nil
|
|
|
|
|
(funcall 'delete-directory directory recursive)
|
|
|
|
|
;; This Emacs version does not support the RECURSIVE flag. We
|
|
|
|
|
;; use the implementation from Emacs 23.2.
|
|
|
|
|
(wrong-number-of-arguments
|
|
|
|
|
(setq directory (directory-file-name (expand-file-name directory)))
|
|
|
|
|
(if (not (file-symlink-p directory))
|
|
|
|
|
(mapc (lambda (file)
|
|
|
|
|
(if (eq t (car (file-attributes file)))
|
|
|
|
|
(org-delete-directory file recursive)
|
|
|
|
|
(delete-file file)))
|
|
|
|
|
(directory-files
|
|
|
|
|
directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
|
|
|
|
|
(delete-directory directory)))))
|
|
|
|
|
|
2012-08-26 18:04:41 +00:00
|
|
|
|
;;;###autoload
|
2012-07-15 08:41:27 +00:00
|
|
|
|
(defmacro org-check-version ()
|
|
|
|
|
"Try very hard to provide sensible version strings."
|
|
|
|
|
(let* ((org-dir (org-find-library-dir "org"))
|
|
|
|
|
(org-version.el (concat org-dir "org-version.el"))
|
2012-08-26 12:03:20 +00:00
|
|
|
|
(org-fixup.el (concat org-dir "../mk/org-fixup.el")))
|
2012-07-15 08:41:27 +00:00
|
|
|
|
(if (require 'org-version org-version.el 'noerror)
|
|
|
|
|
'(progn
|
|
|
|
|
(autoload 'org-release "org-version.el")
|
|
|
|
|
(autoload 'org-git-version "org-version.el"))
|
|
|
|
|
(if (require 'org-fixup org-fixup.el 'noerror)
|
|
|
|
|
'(org-fixup)
|
|
|
|
|
;; provide fallback definitions and complain
|
|
|
|
|
(warn "Could not define org version correctly. Check installation!")
|
|
|
|
|
'(progn
|
|
|
|
|
(defun org-release () "N/A")
|
|
|
|
|
(defun org-git-version () "N/A !!check installation!!"))))))
|
|
|
|
|
|
2013-02-19 17:01:03 +00:00
|
|
|
|
(defun org-file-equal-p (f1 f2)
|
|
|
|
|
"Return t if files F1 and F2 are the same.
|
|
|
|
|
Implements `file-equal-p' for older emacsen and XEmacs."
|
|
|
|
|
(if (fboundp 'file-equal-p)
|
|
|
|
|
(file-equal-p f1 f2)
|
|
|
|
|
(let (f1-attr f2-attr)
|
|
|
|
|
(and (setq f1-attr (file-attributes (file-truename f1)))
|
|
|
|
|
(setq f2-attr (file-attributes (file-truename f2)))
|
|
|
|
|
(equal f1-attr f2-attr)))))
|
|
|
|
|
|
2013-03-13 09:57:49 +00:00
|
|
|
|
;; `buffer-narrowed-p' is available for Emacs >=24.3
|
|
|
|
|
(defun org-buffer-narrowed-p ()
|
|
|
|
|
"Compatibility function for `buffer-narrowed-p'."
|
|
|
|
|
(if (fboundp 'buffer-narrowed-p)
|
|
|
|
|
(buffer-narrowed-p)
|
|
|
|
|
(/= (- (point-max) (point-min)) (buffer-size))))
|
|
|
|
|
|
2013-02-25 10:44:27 +00:00
|
|
|
|
(defmacro org-with-silent-modifications (&rest body)
|
|
|
|
|
(if (fboundp 'with-silent-modifications)
|
|
|
|
|
`(with-silent-modifications ,@body)
|
|
|
|
|
`(org-unmodified ,@body)))
|
|
|
|
|
(def-edebug-spec org-with-silent-modifications (body))
|
|
|
|
|
|
2008-03-22 15:52:18 +00:00
|
|
|
|
(provide 'org-compat)
|
|
|
|
|
|
|
|
|
|
;;; org-compat.el ends here
|