lisp/org-compat.el

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