lisp/org-compat.el

   1 ;;; org-compat.el --- Compatibility code for Org-mode
   2
   3 ;; Copyright (C) 2004-2016 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 ;;
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  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
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;;
  25 ;;; Commentary:
  26
  27 ;; This file contains code needed for compatibility with older
  28 ;; versions of GNU Emacs.
  29
  30 ;;; Code:
  31
  32 (eval-when-compile
  33   (require 'cl))
  34 (require 'org-macs)
  35
  36 ;; As of Emacs 25.1, `outline-mode' functions are under the 'outline-'
  37 ;; prefix, `find-tag' is replaced with `xref-find-definition' and
  38 ;; `x-get-selection' with `gui-get-selection'.
  39 (when (< emacs-major-version 25)
  40   (defalias 'outline-hide-entry 'hide-entry)
  41   (defalias 'outline-hide-sublevels 'hide-sublevels)
  42   (defalias 'outline-hide-subtree 'hide-subtree)
  43   (defalias 'outline-show-all 'show-all)
  44   (defalias 'outline-show-branches 'show-branches)
  45   (defalias 'outline-show-children 'show-children)
  46   (defalias 'outline-show-entry 'show-entry)
  47   (defalias 'outline-show-subtree 'show-subtree)
  48   (defalias 'xref-find-definitions 'find-tag)
  49   (defalias 'gui-get-selection 'x-get-selection))
  50
  51 (defun org-compatible-face (inherits specs)
  52   "Make a compatible face specification.
  53 If INHERITS is an existing face and if the Emacs version supports it,
  54 just inherit the face.  If INHERITS is set and the Emacs version does
  55 not support it, copy the face specification from the inheritance face.
  56 If INHERITS is not given and SPECS is, use SPECS to define the face."
  57   (when (and inherits (facep inherits) (not specs))
  58     (setq specs (or specs
  59                     (get inherits 'saved-face)
  60                     (get inherits 'face-defface-spec))))
  61   (cond
  62    ((and inherits (facep inherits)
  63          (>= emacs-major-version 22)
  64          ;; do not inherit outline faces before Emacs 23
  65          (or (>= emacs-major-version 23)
  66              (not (string-match "\\`outline-[0-9]+"
  67                                 (symbol-name inherits)))))
  68     (list (list t :inherit inherits)))
  69    ((< emacs-major-version 22)
  70     ;; These do not understand the `min-colors' attribute.
  71     (let (r e a)
  72       (while (setq e (pop specs))
  73         (cond
  74          ((memq (car e) '(t default)) (push e r))
  75          ((setq a (member '(min-colors 8) (car e)))
  76           (nconc r (list (cons (cons '(type tty) (delq (car a) (car e)))
  77                                (cdr e)))))
  78          ((setq a (assq 'min-colors (car e)))
  79           (setq e (cons (delq a (car e)) (cdr e)))
  80           (or (assoc (car e) r) (push e r)))
  81          (t (or (assoc (car e) r) (push e r)))))
  82       (nreverse r)))
  83    (t specs)))
  84 (put 'org-compatible-face 'lisp-indent-function 1)
  85
  86 (defun org-version-check (version feature level)
  87   (let* ((v1 (mapcar 'string-to-number (split-string version "[.]")))
  88          (v2 (mapcar 'string-to-number (split-string emacs-version "[.]")))
  89          (rmaj (or (nth 0 v1) 99))
  90          (rmin (or (nth 1 v1) 99))
  91          (rbld (or (nth 2 v1) 99))
  92          (maj (or (nth 0 v2) 0))
  93          (min (or (nth 1 v2) 0))
  94          (bld (or (nth 2 v2) 0)))
  95     (if (or (< maj rmaj)
  96             (and (= maj rmaj)
  97                  (< min rmin))
  98             (and (= maj rmaj)
  99                  (= min rmin)
 100                  (< bld rbld)))
 101         (if (eq level :predicate)
 102             ;; just return if we have the version
 103             nil
 104           (let ((msg (format "Emacs %s or greater is recommended for %s"
 105                              version feature)))
 106             (display-warning 'org msg level)
 107             t))
 108       t)))
 109
 110 \f
 111 ;;; Emacs/XEmacs compatibility
 112
 113 (eval-and-compile
 114   (defun org-defvaralias (new-alias base-variable &optional docstring)
 115     "Compatibility function for defvaralias.
 116 Don't do the aliasing when `defvaralias' is not bound."
 117     (declare (indent 1))
 118     (when (fboundp 'defvaralias)
 119       (defvaralias new-alias base-variable docstring)))
 120
 121   (when (and (not (boundp 'user-emacs-directory))
 122              (boundp 'user-init-directory))
 123     (org-defvaralias 'user-emacs-directory 'user-init-directory)))
 124
 125 (define-obsolete-function-alias 'org-add-hook 'add-hook "Org 9.0")
 126 (define-obsolete-function-alias 'org-decompose-region 'decompose-region "Org 9.0")
 127 (define-obsolete-function-alias 'org-detach-overlay 'delete-overlay "Org 9.0")
 128 (define-obsolete-function-alias 'org-file-equal-p 'file-equal-p "Org 9.0")
 129 (define-obsolete-function-alias 'org-float-time 'float-time "Org 9.0")
 130 (define-obsolete-function-alias 'org-indent-line-to 'indent-line-to "Org 9.0")
 131 (define-obsolete-function-alias 'org-indent-to-column 'indent-to-column "Org 9.0")
 132 (define-obsolete-function-alias 'org-looking-at-p 'looking-at-p "Org 9.0")
 133 (define-obsolete-function-alias 'org-looking-back 'looking-back "Org 9.0")
 134 (define-obsolete-function-alias 'org-match-string-no-properties 'match-string-properties "Org 9.0")
 135 (define-obsolete-function-alias 'org-propertize 'propertize "Org 9.0")
 136 (define-obsolete-function-alias 'org-select-frame-set-input-focus 'select-frame-set-input-focus "Org 9.0")
 137
 138 (defmacro org-re (s)
 139   "Replace posix classes in regular expression."
 140   (declare (debug (form)))
 141   s)
 142 (make-obsolete 'org-re "It is now a no-op.  Please remove it altogether." "Org 9.0")
 143
 144 ;;; Miscellaneous functions
 145
 146 (defun org-get-x-clipboard (value)
 147   "Get the value of the X or Windows clipboard."
 148   (cond ((eq window-system 'x)
 149          (org-no-properties
 150           (ignore-errors
 151             (or (gui-get-selection value 'UTF8_STRING)
 152                 (gui-get-selection value 'COMPOUND_TEXT)
 153                 (gui-get-selection value 'STRING)
 154                 (gui-get-selection value 'TEXT)))))
 155         ((and (eq window-system 'w32) (fboundp 'w32-get-clipboard-data))
 156          (w32-get-clipboard-data))))
 157
 158 (defun org-add-props (string plist &rest props)
 159   "Add text properties to entire string, from beginning to end.
 160 PLIST may be a list of properties, PROPS are individual properties and values
 161 that will be added to PLIST.  Returns the string that was modified."
 162   (add-text-properties
 163    0 (length string) (if props (append plist props) plist) string)
 164   string)
 165 (put 'org-add-props 'lisp-indent-function 2)
 166
 167 (defun org-fit-window-to-buffer (&optional window max-height min-height
 168                                            shrink-only)
 169   "Fit WINDOW to the buffer, but only if it is not a side-by-side window.
 170 WINDOW defaults to the selected window.  MAX-HEIGHT and MIN-HEIGHT are
 171 passed through to `fit-window-to-buffer'.  If SHRINK-ONLY is set, call
 172 `shrink-window-if-larger-than-buffer' instead, the height limit is
 173 ignored in this case."
 174   (cond ((if (fboundp 'window-full-width-p)
 175              (not (window-full-width-p window))
 176            ;; do nothing if another window would suffer
 177            (> (frame-width) (window-width window))))
 178         ((and (fboundp 'fit-window-to-buffer) (not shrink-only))
 179          (fit-window-to-buffer window max-height min-height))
 180         ((fboundp 'shrink-window-if-larger-than-buffer)
 181          (shrink-window-if-larger-than-buffer window)))
 182   (or window (selected-window)))
 183
 184 (defun org-number-sequence (from &optional to inc)
 185   "Call `number-sequence' or emulate it."
 186   (if (fboundp 'number-sequence)
 187       (number-sequence from to inc)
 188     (if (or (not to) (= from to))
 189         (list from)
 190       (or inc (setq inc 1))
 191       (when (zerop inc) (error "The increment can not be zero"))
 192       (let (seq (n 0) (next from))
 193         (if (> inc 0)
 194             (while (<= next to)
 195               (setq seq (cons next seq)
 196                     n (1+ n)
 197                     next (+ from (* n inc))))
 198           (while (>= next to)
 199             (setq seq (cons next seq)
 200                   n (1+ n)
 201                   next (+ from (* n inc)))))
 202         (nreverse seq)))))
 203
 204 ;; `set-transient-map' is only in Emacs >= 24.4
 205 (defalias 'org-set-transient-map
 206   (if (fboundp 'set-transient-map)
 207       'set-transient-map
 208     'set-temporary-overlay-map))
 209
 210 ;;; Region compatibility
 211
 212 (defvar org-ignore-region nil
 213   "Non-nil means temporarily disable the active region.")
 214
 215 (defun org-region-active-p ()
 216   "Is `transient-mark-mode' on and the region active?"
 217   (if org-ignore-region
 218       nil
 219     (if (fboundp 'use-region-p)
 220         (use-region-p)
 221       (and transient-mark-mode mark-active)))) ; Emacs 22 and before
 222
 223 (defun org-cursor-to-region-beginning ()
 224   (when (and (org-region-active-p)
 225              (> (point) (region-beginning)))
 226     (exchange-point-and-mark)))
 227
 228 ;;; Old alias for emacs 22 compatibility, now dropped
 229 (define-obsolete-function-alias 'org-activate-mark 'activate-mark)
 230
 231 ;;; Invisibility compatibility
 232
 233 (defun org-remove-from-invisibility-spec (arg)
 234   "Remove elements from `buffer-invisibility-spec'."
 235   (if (fboundp 'remove-from-invisibility-spec)
 236       (remove-from-invisibility-spec arg)
 237     (if (consp buffer-invisibility-spec)
 238         (setq buffer-invisibility-spec
 239               (delete arg buffer-invisibility-spec)))))
 240
 241 (defun org-in-invisibility-spec-p (arg)
 242   "Is ARG a member of `buffer-invisibility-spec'?"
 243   (if (consp buffer-invisibility-spec)
 244       (member arg buffer-invisibility-spec)))
 245
 246 (defun org-move-to-column (column &optional force buffer)
 247   "Move to column COLUMN.
 248 Pass COLUMN and FORCE to `move-to-column'."
 249   (let ((buffer-invisibility-spec
 250          (if (listp buffer-invisibility-spec)
 251              (remove '(org-filtered) buffer-invisibility-spec)
 252            buffer-invisibility-spec)))
 253     (move-to-column column force)))
 254
 255 (defmacro org-find-library-dir (library)
 256   `(file-name-directory (or (locate-library ,library) "")))
 257
 258 (defun org-count-lines (s)
 259   "How many lines in string S?"
 260   (let ((start 0) (n 1))
 261     (while (string-match "\n" s start)
 262       (setq start (match-end 0) n (1+ n)))
 263     (if (and (> (length s) 0) (= (aref s (1- (length s))) ?\n))
 264         (setq n (1- n)))
 265     n))
 266
 267 (defun org-kill-new (string &rest args)
 268   (remove-text-properties 0 (length string) '(line-prefix t wrap-prefix t)
 269                           string)
 270   (apply 'kill-new string args))
 271
 272 ;; `user-error' is only available from 24.2.50 on
 273 (unless (fboundp 'user-error)
 274   (defalias 'user-error 'error))
 275
 276 ;; ‘format-message’ is available only from 25 on
 277 (unless (fboundp 'format-message)
 278   (defalias 'format-message 'format))
 279
 280 ;; `font-lock-ensure' is only available from 24.4.50 on
 281 (defalias 'org-font-lock-ensure
 282   (if (fboundp 'font-lock-ensure)
 283       #'font-lock-ensure
 284     (lambda (&optional _beg _end)
 285       (with-no-warnings (font-lock-fontify-buffer)))))
 286
 287 (defmacro org-no-popups (&rest body)
 288   "Suppress popup windows.
 289 Let-bind some variables to nil around BODY to achieve the desired
 290 effect, which variables to use depends on the Emacs version."
 291   (if (org-version-check "24.2.50" "" :predicate)
 292       `(let (pop-up-frames display-buffer-alist)
 293          ,@body)
 294     `(let (pop-up-frames special-display-buffer-names special-display-regexps special-display-function)
 295        ,@body)))
 296
 297 (if (fboundp 'string-match-p)
 298     (defalias 'org-string-match-p 'string-match-p)
 299   (defun org-string-match-p (regexp string &optional start)
 300     (save-match-data
 301       (funcall 'string-match regexp string start))))
 302
 303 (defun org-floor* (x &optional y)
 304   "Return a list of the floor of X and the fractional part of X.
 305 With two arguments, return floor and remainder of their quotient."
 306   (let ((q (floor x y)))
 307     (list q (- x (if y (* y q) q)))))
 308
 309 ;; `pop-to-buffer-same-window' has been introduced in Emacs 24.1.
 310 (defun org-pop-to-buffer-same-window
 311   (&optional buffer-or-name norecord label)
 312   "Pop to buffer specified by BUFFER-OR-NAME in the selected window."
 313   (if (fboundp 'pop-to-buffer-same-window)
 314       (funcall
 315        'pop-to-buffer-same-window buffer-or-name norecord)
 316     (funcall 'switch-to-buffer buffer-or-name norecord)))
 317
 318 ;; RECURSIVE has been introduced with Emacs 23.2.
 319 ;; This is copying and adapted from `tramp-compat-delete-directory'
 320 (defun org-delete-directory (directory &optional recursive)
 321   "Compatibility function for `delete-directory'."
 322   (if (null recursive)
 323       (delete-directory directory)
 324     (condition-case nil
 325         (funcall 'delete-directory directory recursive)
 326       ;; This Emacs version does not support the RECURSIVE flag.  We
 327       ;; use the implementation from Emacs 23.2.
 328       (wrong-number-of-arguments
 329        (setq directory (directory-file-name (expand-file-name directory)))
 330        (if (not (file-symlink-p directory))
 331            (mapc (lambda (file)
 332                    (if (eq t (car (file-attributes file)))
 333                        (org-delete-directory file recursive)
 334                      (delete-file file)))
 335                  (directory-files
 336                   directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
 337        (delete-directory directory)))))
 338
 339 ;;;###autoload
 340 (defmacro org-check-version ()
 341   "Try very hard to provide sensible version strings."
 342   (let* ((org-dir        (org-find-library-dir "org"))
 343          (org-version.el (concat org-dir "org-version.el"))
 344          (org-fixup.el   (concat org-dir "../mk/org-fixup.el")))
 345     (if (require 'org-version org-version.el 'noerror)
 346         '(progn
 347            (autoload 'org-release     "org-version.el")
 348            (autoload 'org-git-version "org-version.el"))
 349       (if (require 'org-fixup org-fixup.el 'noerror)
 350           '(org-fixup)
 351         ;; provide fallback definitions and complain
 352         (warn "Could not define org version correctly.  Check installation!")
 353         '(progn
 354            (defun org-release () "N/A")
 355            (defun org-git-version () "N/A !!check installation!!"))))))
 356
 357 ;; `buffer-narrowed-p' is available for Emacs >=24.3
 358 (defun org-buffer-narrowed-p ()
 359   "Compatibility function for `buffer-narrowed-p'."
 360   (if (fboundp 'buffer-narrowed-p)
 361       (buffer-narrowed-p)
 362     (/= (- (point-max) (point-min)) (buffer-size))))
 363
 364 (defmacro org-with-silent-modifications (&rest body)
 365   (if (fboundp 'with-silent-modifications)
 366       `(with-silent-modifications ,@body)
 367     `(org-unmodified ,@body)))
 368 (def-edebug-spec org-with-silent-modifications (body))
 369
 370 ;; Remove this when support for Emacs < 24.4 is dropped.
 371 (defun org-define-error (name message)
 372   "Define NAME as a new error signal.
 373 MESSAGE is a string that will be output to the echo area if such
 374 an error is signaled without being caught by a `condition-case'.
 375 Implements `define-error' for older emacsen."
 376   (if (fboundp 'define-error) (define-error name message)
 377     (put name 'error-conditions
 378          (copy-sequence (cons name (get 'error 'error-conditions))))))
 379
 380 ;;; Functions from cl-lib that Org used to have its own implementation of
 381 (define-obsolete-function-alias 'org-count 'cl-count "Org 9.0")
 382 (define-obsolete-function-alias 'org-remove-if 'cl-remove-if "Org 9.0")
 383 (define-obsolete-function-alias 'org-remove-if-not 'cl-remove-if-not "Org 9.0")
 384 (define-obsolete-function-alias 'org-reduce 'cl-reduce "Org 9.0")
 385 (define-obsolete-function-alias 'org-every 'cl-every "Org 9.0")
 386 (define-obsolete-function-alias 'org-some 'cl-some "Org 9.0")
 387
 388 (provide 'org-compat)
 389
 390 ;;; org-compat.el ends here