| commit | author | age | ||
| 76bbd0 | 1 | ;;; org-macs.el --- Top-level Definitions for Org -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2004-2018 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
| 6 | ;; Keywords: outlines, hypermedia, calendar, wp | |
| 7 | ;; Homepage: https://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 <https://www.gnu.org/licenses/>. | |
| 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 24 | ;; | |
| 25 | ;;; Commentary: | |
| 26 | ||
| 27 | ;; This file contains macro definitions, defsubst definitions, other | |
| 28 | ;; stuff needed for compilation and top-level forms in Org mode, as | |
| 29 | ;; well lots of small functions that are not Org mode specific but | |
| 30 | ;; simply generally useful stuff. | |
| 31 | ||
| 32 | ;;; Code: | |
| 33 | ||
| 34 | (defmacro org-with-gensyms (symbols &rest body) | |
| 35 | (declare (debug (sexp body)) (indent 1)) | |
| 36 | `(let ,(mapcar (lambda (s) | |
| 37 | `(,s (make-symbol (concat "--" (symbol-name ',s))))) | |
| 38 | symbols) | |
| 39 | ,@body)) | |
| 40 | ||
| 41 | (defun org-string-nw-p (s) | |
| 42 | "Return S if S is a string containing a non-blank character. | |
| 43 | Otherwise, return nil." | |
| 44 | (and (stringp s) | |
| 45 | (string-match-p "[^ \r\t\n]" s) | |
| 46 | s)) | |
| 47 | ||
| 48 | (defun org-split-string (string &optional separators) | |
| 49 | "Splits STRING into substrings at SEPARATORS. | |
| 50 | ||
| 51 | SEPARATORS is a regular expression. When nil, it defaults to | |
| 52 | \"[ \f\t\n\r\v]+\". | |
| 53 | ||
| 54 | Unlike `split-string', matching SEPARATORS at the beginning and | |
| 55 | end of string are ignored." | |
| 56 | (let ((separators (or separators "[ \f\t\n\r\v]+"))) | |
| 57 | (when (string-match (concat "\\`" separators) string) | |
| 58 | (setq string (replace-match "" nil nil string))) | |
| 59 | (when (string-match (concat separators "\\'") string) | |
| 60 | (setq string (replace-match "" nil nil string))) | |
| 61 | (split-string string separators))) | |
| 62 | ||
| 63 | (defun org-string-display (string) | |
| 64 | "Return STRING as it is displayed in the current buffer. | |
| 65 | This function takes into consideration `invisible' and `display' | |
| 66 | text properties." | |
| 67 | (let* ((build-from-parts | |
| 68 | (lambda (s property filter) | |
| 69 | ;; Build a new string out of string S. On every group of | |
| 70 | ;; contiguous characters with the same PROPERTY value, | |
| 71 | ;; call FILTER on the properties list at the beginning of | |
| 72 | ;; the group. If it returns a string, replace the | |
| 73 | ;; characters in the group with it. Otherwise, preserve | |
| 74 | ;; those characters. | |
| 75 | (let ((len (length s)) | |
| 76 | (new "") | |
| 77 | (i 0) | |
| 78 | (cursor 0)) | |
| 79 | (while (setq i (text-property-not-all i len property nil s)) | |
| 80 | (let ((end (next-single-property-change i property s len)) | |
| 81 | (value (funcall filter (text-properties-at i s)))) | |
| 82 | (when value | |
| 83 | (setq new (concat new (substring s cursor i) value)) | |
| 84 | (setq cursor end)) | |
| 85 | (setq i end))) | |
| 86 | (concat new (substring s cursor))))) | |
| 87 | (prune-invisible | |
| 88 | (lambda (s) | |
| 89 | (funcall build-from-parts s 'invisible | |
| 90 | (lambda (props) | |
| 91 | ;; If `invisible' property in PROPS means text | |
| 92 | ;; is to be invisible, return the empty string. | |
| 93 | ;; Otherwise return nil so that the part is | |
| 94 | ;; skipped. | |
| 95 | (and (or (eq t buffer-invisibility-spec) | |
| 96 | (assoc-string (plist-get props 'invisible) | |
| 97 | buffer-invisibility-spec)) | |
| 98 | ""))))) | |
| 99 | (replace-display | |
| 100 | (lambda (s) | |
| 101 | (funcall build-from-parts s 'display | |
| 102 | (lambda (props) | |
| 103 | ;; If there is any string specification in | |
| 104 | ;; `display' property return it. Also attach | |
| 105 | ;; other text properties on the part to that | |
| 106 | ;; string (face...). | |
| 107 | (let* ((display (plist-get props 'display)) | |
| 108 | (value (if (stringp display) display | |
| 109 | (cl-some #'stringp display)))) | |
| 110 | (when value | |
| 111 | (apply #'propertize | |
| 112 | ;; Displayed string could contain | |
| 113 | ;; invisible parts, but no nested | |
| 114 | ;; display. | |
| 115 | (funcall prune-invisible value) | |
| 116 | 'display | |
| 117 | (and (not (stringp display)) | |
| 118 | (cl-remove-if #'stringp display)) | |
| 119 | props)))))))) | |
| 120 | ;; `display' property overrides `invisible' one. So we first | |
| 121 | ;; replace characters with `display' property. Then we remove | |
| 122 | ;; invisible characters. | |
| 123 | (funcall prune-invisible (funcall replace-display string)))) | |
| 124 | ||
| 125 | (defun org-string-width (string) | |
| 126 | "Return width of STRING when displayed in the current buffer. | |
| 127 | Unlike `string-width', this function takes into consideration | |
| 128 | `invisible' and `display' text properties." | |
| 129 | (string-width (org-string-display string))) | |
| 130 | ||
| 131 | (defun org-not-nil (v) | |
| 132 | "If V not nil, and also not the string \"nil\", then return V. | |
| 133 | Otherwise return nil." | |
| 134 | (and v (not (equal v "nil")) v)) | |
| 135 | ||
| 136 | (defmacro org-preserve-lc (&rest body) | |
| 137 | (declare (debug (body))) | |
| 138 | (org-with-gensyms (line col) | |
| 139 | `(let ((,line (org-current-line)) | |
| 140 | (,col (current-column))) | |
| 141 | (unwind-protect | |
| 142 | (progn ,@body) | |
| 143 | (org-goto-line ,line) | |
| 144 | (org-move-to-column ,col))))) | |
| 145 | ||
| 146 | ;; Use `org-with-silent-modifications' to ignore cosmetic changes and | |
| 147 | ;; `org-unmodified' to ignore real text modifications | |
| 148 | (defmacro org-unmodified (&rest body) | |
| 149 | "Run BODY while preserving the buffer's `buffer-modified-p' state." | |
| 150 | (declare (debug (body))) | |
| 151 | (org-with-gensyms (was-modified) | |
| 152 | `(let ((,was-modified (buffer-modified-p))) | |
| 153 | (unwind-protect | |
| 154 | (let ((buffer-undo-list t) | |
| 155 | (inhibit-modification-hooks t)) | |
| 156 | ,@body) | |
| 157 | (set-buffer-modified-p ,was-modified))))) | |
| 158 | ||
| 159 | (defmacro org-without-partial-completion (&rest body) | |
| 160 | (declare (debug (body))) | |
| 161 | `(if (and (boundp 'partial-completion-mode) | |
| 162 | partial-completion-mode | |
| 163 | (fboundp 'partial-completion-mode)) | |
| 164 | (unwind-protect | |
| 165 | (progn | |
| 166 | (partial-completion-mode -1) | |
| 167 | ,@body) | |
| 168 | (partial-completion-mode 1)) | |
| 169 | ,@body)) | |
| 170 | ||
| 171 | (defmacro org-with-point-at (pom &rest body) | |
| 172 | "Move to buffer and point of point-or-marker POM for the duration of BODY." | |
| 173 | (declare (debug (form body)) (indent 1)) | |
| 174 | (org-with-gensyms (mpom) | |
| 175 | `(let ((,mpom ,pom)) | |
| 176 | (save-excursion | |
| 177 | (if (markerp ,mpom) (set-buffer (marker-buffer ,mpom))) | |
| 178 | (org-with-wide-buffer | |
| 179 | (goto-char (or ,mpom (point))) | |
| 180 | ,@body))))) | |
| 181 | ||
| 182 | (defmacro org-with-remote-undo (buffer &rest body) | |
| 183 | "Execute BODY while recording undo information in two buffers." | |
| 184 | (declare (debug (form body)) (indent 1)) | |
| 185 | (org-with-gensyms (cline cmd buf1 buf2 undo1 undo2 c1 c2) | |
| 186 | `(let ((,cline (org-current-line)) | |
| 187 | (,cmd this-command) | |
| 188 | (,buf1 (current-buffer)) | |
| 189 | (,buf2 ,buffer) | |
| 190 | (,undo1 buffer-undo-list) | |
| 191 | (,undo2 (with-current-buffer ,buffer buffer-undo-list)) | |
| 192 | ,c1 ,c2) | |
| 193 | ,@body | |
| 194 | (when org-agenda-allow-remote-undo | |
| 195 | (setq ,c1 (org-verify-change-for-undo | |
| 196 | ,undo1 (with-current-buffer ,buf1 buffer-undo-list)) | |
| 197 | ,c2 (org-verify-change-for-undo | |
| 198 | ,undo2 (with-current-buffer ,buf2 buffer-undo-list))) | |
| 199 | (when (or ,c1 ,c2) | |
| 200 | ;; make sure there are undo boundaries | |
| 201 | (and ,c1 (with-current-buffer ,buf1 (undo-boundary))) | |
| 202 | (and ,c2 (with-current-buffer ,buf2 (undo-boundary))) | |
| 203 | ;; remember which buffer to undo | |
| 204 | (push (list ,cmd ,cline ,buf1 ,c1 ,buf2 ,c2) | |
| 205 | org-agenda-undo-list)))))) | |
| 206 | ||
| 207 | (defmacro org-no-read-only (&rest body) | |
| 208 | "Inhibit read-only for BODY." | |
| 209 | (declare (debug (body))) | |
| 210 | `(let ((inhibit-read-only t)) ,@body)) | |
| 211 | ||
| 212 | (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t | |
| 213 | rear-nonsticky t mouse-map t fontified t | |
| 214 | org-emphasis t) | |
| 215 | "Properties to remove when a string without properties is wanted.") | |
| 216 | ||
| 217 | (defsubst org-no-properties (s &optional restricted) | |
| 218 | "Remove all text properties from string S. | |
| 219 | When RESTRICTED is non-nil, only remove the properties listed | |
| 220 | in `org-rm-props'." | |
| 221 | (if restricted (remove-text-properties 0 (length s) org-rm-props s) | |
| 222 | (set-text-properties 0 (length s) nil s)) | |
| 223 | s) | |
| 224 | ||
| 225 | (defsubst org-get-alist-option (option key) | |
| 226 | (cond ((eq key t) t) | |
| 227 | ((eq option t) t) | |
| 228 | ((assoc key option) (cdr (assoc key option))) | |
| 229 | (t (let ((r (cdr (assq 'default option)))) | |
| 230 | (if (listp r) (delq nil r) r))))) | |
| 231 | ||
| 232 | (defsubst org-check-external-command (cmd &optional use no-error) | |
| 233 | "Check if external program CMD for USE exists, error if not. | |
| 234 | When the program does exist, return its path. | |
| 235 | When it does not exist and NO-ERROR is set, return nil. | |
| 236 | Otherwise, throw an error. The optional argument USE can describe what this | |
| 237 | program is needed for, so that the error message can be more informative." | |
| 238 | (or (executable-find cmd) | |
| 239 | (if no-error | |
| 240 | nil | |
| 241 | (error "Can't find `%s'%s" cmd | |
| 242 | (if use (format " (%s)" use) ""))))) | |
| 243 | ||
| 244 | (defsubst org-last (list) | |
| 245 | "Return the last element of LIST." | |
| 246 | (car (last list))) | |
| 247 | ||
| 248 | (defun org-let (list &rest body) | |
| 249 | (eval (cons 'let (cons list body)))) | |
| 250 | (put 'org-let 'lisp-indent-function 1) | |
| 251 | ||
| 252 | (defun org-let2 (list1 list2 &rest body) | |
| 253 | (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) | |
| 254 | (put 'org-let2 'lisp-indent-function 2) | |
| 255 | ||
| 256 | (defsubst org-call-with-arg (command arg) | |
| 257 | "Call COMMAND interactively, but pretend prefix arg was ARG." | |
| 258 | (let ((current-prefix-arg arg)) (call-interactively command))) | |
| 259 | ||
| 260 | (defsubst org-current-line (&optional pos) | |
| 261 | (save-excursion | |
| 262 | (and pos (goto-char pos)) | |
| 263 | ;; works also in narrowed buffer, because we start at 1, not point-min | |
| 264 | (+ (if (bolp) 1 0) (count-lines 1 (point))))) | |
| 265 | ||
| 266 | (defsubst org-goto-line (N) | |
| 267 | (save-restriction | |
| 268 | (widen) | |
| 269 | (goto-char (point-min)) | |
| 270 | (forward-line (1- N)))) | |
| 271 | ||
| 272 | (defsubst org-current-line-string (&optional to-here) | |
| 273 | (buffer-substring (point-at-bol) (if to-here (point) (point-at-eol)))) | |
| 274 | ||
| 275 | (defsubst org-pos-in-match-range (pos n) | |
| 276 | (and (match-beginning n) | |
| 277 | (<= (match-beginning n) pos) | |
| 278 | (>= (match-end n) pos))) | |
| 279 | ||
| 280 | (defun org-match-line (regexp) | |
| 281 | "Match REGEXP at the beginning of the current line." | |
| 282 | (save-excursion | |
| 283 | (beginning-of-line) | |
| 284 | (looking-at regexp))) | |
| 285 | ||
| 286 | (defun org-plist-delete (plist property) | |
| 287 | "Delete PROPERTY from PLIST. | |
| 288 | This is in contrast to merely setting it to 0." | |
| 289 | (let (p) | |
| 290 | (while plist | |
| 291 | (if (not (eq property (car plist))) | |
| 292 | (setq p (plist-put p (car plist) (nth 1 plist)))) | |
| 293 | (setq plist (cddr plist))) | |
| 294 | p)) | |
| 295 | ||
| 296 | (defmacro org-save-outline-visibility (use-markers &rest body) | |
| 297 | "Save and restore outline visibility around BODY. | |
| 298 | If USE-MARKERS is non-nil, use markers for the positions. | |
| 299 | This means that the buffer may change while running BODY, | |
| 300 | but it also means that the buffer should stay alive | |
| 301 | during the operation, because otherwise all these markers will | |
| 302 | point nowhere." | |
| 303 | (declare (debug (form body)) (indent 1)) | |
| 304 | (org-with-gensyms (data) | |
| 305 | `(let ((,data (org-outline-overlay-data ,use-markers))) | |
| 306 | (unwind-protect | |
| 307 | (prog1 (progn ,@body) | |
| 308 | (org-set-outline-overlay-data ,data)) | |
| 309 | (when ,use-markers | |
| 310 | (dolist (c ,data) | |
| 311 | (when (markerp (car c)) (move-marker (car c) nil)) | |
| 312 | (when (markerp (cdr c)) (move-marker (cdr c) nil)))))))) | |
| 313 | ||
| 314 | (defmacro org-with-wide-buffer (&rest body) | |
| 315 | "Execute body while temporarily widening the buffer." | |
| 316 | (declare (debug (body))) | |
| 317 | `(save-excursion | |
| 318 | (save-restriction | |
| 319 | (widen) | |
| 320 | ,@body))) | |
| 321 | ||
| 322 | (defmacro org-with-limited-levels (&rest body) | |
| 323 | "Execute BODY with limited number of outline levels." | |
| 324 | (declare (debug (body))) | |
| 325 | `(progn | |
| 326 | (defvar org-called-with-limited-levels) | |
| 327 | (defvar org-outline-regexp) | |
| 328 | (defvar outline-regexp) | |
| 329 | (defvar org-outline-regexp-bol) | |
| 330 | (let* ((org-called-with-limited-levels t) | |
| 331 | (org-outline-regexp (org-get-limited-outline-regexp)) | |
| 332 | (outline-regexp org-outline-regexp) | |
| 333 | (org-outline-regexp-bol (concat "^" org-outline-regexp))) | |
| 334 | ,@body))) | |
| 335 | ||
| 336 | (defvar org-outline-regexp) ; defined in org.el | |
| 337 | (defvar org-odd-levels-only) ; defined in org.el | |
| 338 | (defvar org-inlinetask-min-level) ; defined in org-inlinetask.el | |
| 339 | (defun org-get-limited-outline-regexp () | |
| 340 | "Return outline-regexp with limited number of levels. | |
| 341 | The number of levels is controlled by `org-inlinetask-min-level'" | |
| 342 | (cond ((not (derived-mode-p 'org-mode)) | |
| 343 | outline-regexp) | |
| 344 | ((not (featurep 'org-inlinetask)) | |
| 345 | org-outline-regexp) | |
| 346 | (t | |
| 347 | (let* ((limit-level (1- org-inlinetask-min-level)) | |
| 348 | (nstars (if org-odd-levels-only | |
| 349 | (1- (* limit-level 2)) | |
| 350 | limit-level))) | |
| 351 | (format "\\*\\{1,%d\\} " nstars))))) | |
| 352 | ||
| 353 | (defmacro org-eval-in-environment (environment form) | |
| 354 | (declare (debug (form form)) (indent 1)) | |
| 355 | `(eval (list 'let ,environment ',form))) | |
| 356 | ||
| 357 | (defun org-make-parameter-alist (flat) | |
| 358 | "Return alist based on FLAT. | |
| 359 | FLAT is a list with alternating symbol names and values. The | |
| 360 | returned alist is a list of lists with the symbol name in car and | |
| 361 | the value in cdr." | |
| 362 | (when flat | |
| 363 | (cons (list (car flat) (cadr flat)) | |
| 364 | (org-make-parameter-alist (cddr flat))))) | |
| 365 | ||
| 366 | ;;;###autoload | |
| 367 | (defmacro org-load-noerror-mustsuffix (file) | |
| 368 | "Load FILE with optional arguments NOERROR and MUSTSUFFIX." | |
| 369 | `(load ,file 'noerror nil nil 'mustsuffix)) | |
| 370 | ||
| 371 | (defun org-unbracket-string (pre post string) | |
| 372 | "Remove PRE/POST from the beginning/end of STRING. | |
| 373 | Both PRE and POST must be pre-/suffixes of STRING, or neither is | |
| 374 | removed." | |
| 375 | (if (and (string-prefix-p pre string) | |
| 376 | (string-suffix-p post string)) | |
| 377 | (substring string (length pre) (- (length post))) | |
| 378 | string)) | |
| 379 | ||
| 380 | (defun org-read-function (prompt &optional allow-empty?) | |
| 381 | "Prompt for a function. | |
| 382 | If ALLOW-EMPTY? is non-nil, return nil rather than raising an | |
| 383 | error when the user input is empty." | |
| 384 | (let ((func (completing-read prompt obarray #'fboundp t))) | |
| 385 | (cond ((not (string= func "")) | |
| 386 | (intern func)) | |
| 387 | (allow-empty? nil) | |
| 388 | (t (user-error "Empty input is not valid"))))) | |
| 389 | ||
| 390 | (defconst org-unique-local-variables | |
| 391 | '(org-element--cache | |
| 392 | org-element--cache-objects | |
| 393 | org-element--cache-sync-keys | |
| 394 | org-element--cache-sync-requests | |
| 395 | org-element--cache-sync-timer) | |
| 396 | "List of local variables that cannot be transferred to another buffer.") | |
| 397 | ||
| 398 | (defun org-get-local-variables () | |
| 399 | "Return a list of all local variables in an Org mode buffer." | |
| 400 | (delq nil | |
| 401 | (mapcar | |
| 402 | (lambda (x) | |
| 403 | (let* ((binding (if (symbolp x) (list x) (list (car x) (cdr x)))) | |
| 404 | (name (car binding))) | |
| 405 | (and (not (get name 'org-state)) | |
| 406 | (not (memq name org-unique-local-variables)) | |
| 407 | (string-match-p | |
| 408 | "\\`\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|\ | |
| 409 | auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)" | |
| 410 | (symbol-name name)) | |
| 411 | binding))) | |
| 412 | (with-temp-buffer | |
| 413 | (org-mode) | |
| 414 | (buffer-local-variables))))) | |
| 415 | ||
| 416 | (defun org-clone-local-variables (from-buffer &optional regexp) | |
| 417 | "Clone local variables from FROM-BUFFER. | |
| 418 | Optional argument REGEXP selects variables to clone." | |
| 419 | (dolist (pair (buffer-local-variables from-buffer)) | |
| 420 | (pcase pair | |
| 421 | (`(,name . ,value) ;ignore unbound variables | |
| 422 | (when (and (not (memq name org-unique-local-variables)) | |
| 423 | (or (null regexp) (string-match-p regexp (symbol-name name)))) | |
| 424 | (ignore-errors (set (make-local-variable name) value))))))) | |
| 425 | ||
| 426 | ||
| 427 | (provide 'org-macs) | |
| 428 | ||
| 429 | ;;; org-macs.el ends here | |
