org-macs.el (58968B)
1 ;;; org-macs.el --- Top-level Definitions for Org -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2004-2023 Free Software Foundation, Inc. 4 5 ;; Author: Carsten Dominik <carsten.dominik@gmail.com> 6 ;; Keywords: outlines, hypermedia, calendar, wp 7 ;; URL: 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 (require 'cl-lib) 35 (require 'format-spec) 36 37 ;;; Org version verification. 38 39 (defmacro org-assert-version () 40 "Assert compile time and runtime version match." 41 ;; We intentionally use a more permissive `org-release' instead of 42 ;; `org-git-version' to work around deficiencies in Elisp 43 ;; compilation after pulling latest changes. Unchanged files will 44 ;; not be re-compiled and thus their macro-expanded 45 ;; `org-assert-version' calls would fail using strict 46 ;; `org-git-version' check because the generated Org version strings 47 ;; will not match. 48 `(unless (equal (org-release) ,(org-release)) 49 (warn "Org version mismatch. Make sure that correct `load-path' is set early in init.el 50 This warning usually appears when a built-in Org version is loaded 51 prior to the more recent Org version. 52 53 Version mismatch is commonly encountered in the following situations: 54 55 1. Emacs is loaded using literate Org config and more recent Org 56 version is loaded inside the file loaded by `org-babel-load-file'. 57 `org-babel-load-file' triggers the built-in Org version clashing 58 the newer Org version attempt to be loaded later. 59 60 It is recommended to move the Org loading code before the 61 `org-babel-load-file' call. 62 63 2. New Org version is loaded manually by setting `load-path', but some 64 other package depending on Org is loaded before the `load-path' is 65 configured. 66 This \"other package\" is triggering built-in Org version, again 67 causing the version mismatch. 68 69 It is recommended to set `load-path' as early in the config as 70 possible. 71 72 3. New Org version is loaded using straight.el package manager and 73 other package depending on Org is loaded before straight triggers 74 loading of the newer Org version. 75 76 It is recommended to put 77 78 %s 79 80 early in the config. Ideally, right after the straight.el 81 bootstrap. Moving `use-package' :straight declaration may not be 82 sufficient if the corresponding `use-package' statement is 83 deferring the loading." 84 ;; Avoid `warn' replacing "'" with "’" (see `format-message'). 85 "(straight-use-package 'org)") 86 (error "Org version mismatch. Make sure that correct `load-path' is set early in init.el"))) 87 88 ;; We rely on org-macs when generating Org version. Checking Org 89 ;; version here will interfere with Org build process. 90 ;; (org-assert-version) 91 92 (declare-function org-mode "org" ()) 93 (declare-function org-agenda-files "org" (&optional unrestricted archives)) 94 (declare-function org-time-string-to-seconds "org" (s)) 95 (declare-function org-fold-show-context "org-fold" (&optional key)) 96 (declare-function org-fold-save-outline-visibility "org-fold" (use-markers &rest body)) 97 (declare-function org-fold-next-visibility-change "org-fold" (&optional pos limit ignore-hidden-p previous-p)) 98 (declare-function org-fold-core-with-forced-fontification "org-fold" (&rest body)) 99 (declare-function org-fold-folded-p "org-fold" (&optional pos limit ignore-hidden-p previous-p)) 100 (declare-function string-collate-lessp "org-compat" (s1 s2 &optional locale ignore-case)) 101 (declare-function org-time-convert-to-integer "org-compat" (time)) 102 103 (defvar org-ts-regexp0) 104 (defvar ffap-url-regexp) 105 (defvar org-fold-core-style) 106 107 108 ;;; Macros 109 110 (defmacro org-with-gensyms (symbols &rest body) 111 (declare (debug (sexp body)) (indent 1)) 112 `(let ,(mapcar (lambda (s) 113 `(,s (make-symbol (concat "--" (symbol-name ',s))))) 114 symbols) 115 ,@body)) 116 117 ;; Use `with-silent-modifications' to ignore cosmetic changes and 118 ;; `org-unmodified' to ignore real text modifications. 119 (defmacro org-unmodified (&rest body) 120 "Run BODY while preserving the buffer's `buffer-modified-p' state." 121 (declare (debug (body))) 122 (org-with-gensyms (was-modified) 123 `(let ((,was-modified (buffer-modified-p))) 124 (unwind-protect 125 (let ((buffer-undo-list t) 126 (inhibit-modification-hooks t)) 127 ,@body) 128 (set-buffer-modified-p ,was-modified))))) 129 130 (defmacro org-with-base-buffer (buffer &rest body) 131 "Run BODY in base buffer for BUFFER. 132 If BUFFER is nil, use base buffer for `current-buffer'." 133 (declare (debug (body)) (indent 1)) 134 `(with-current-buffer (or (buffer-base-buffer ,buffer) 135 (or ,buffer (current-buffer))) 136 ,@body)) 137 138 (defmacro org-with-point-at (pom &rest body) 139 "Move to buffer and point of point-or-marker POM for the duration of BODY." 140 (declare (debug (form body)) (indent 1)) 141 (org-with-gensyms (mpom) 142 `(let ((,mpom ,pom)) 143 (save-excursion 144 (when (markerp ,mpom) (set-buffer (marker-buffer ,mpom))) 145 (org-with-wide-buffer 146 (goto-char (or ,mpom (point))) 147 ,@body))))) 148 149 (defmacro org-with-remote-undo (buffer &rest body) 150 "Execute BODY while recording undo information in two buffers." 151 (declare (debug (form body)) (indent 1)) 152 (org-with-gensyms (cline cmd buf1 buf2 undo1 undo2 c1 c2) 153 `(let ((,cline (org-current-line)) 154 (,cmd this-command) 155 (,buf1 (current-buffer)) 156 (,buf2 ,buffer) 157 (,undo1 buffer-undo-list) 158 (,undo2 (with-current-buffer ,buffer buffer-undo-list)) 159 ,c1 ,c2) 160 ,@body 161 (when org-agenda-allow-remote-undo 162 (setq ,c1 (org-verify-change-for-undo 163 ,undo1 (with-current-buffer ,buf1 buffer-undo-list)) 164 ,c2 (org-verify-change-for-undo 165 ,undo2 (with-current-buffer ,buf2 buffer-undo-list))) 166 (when (or ,c1 ,c2) 167 ;; make sure there are undo boundaries 168 (and ,c1 (with-current-buffer ,buf1 (undo-boundary))) 169 (and ,c2 (with-current-buffer ,buf2 (undo-boundary))) 170 ;; remember which buffer to undo 171 (push (list ,cmd ,cline ,buf1 ,c1 ,buf2 ,c2) 172 org-agenda-undo-list)))))) 173 174 (defmacro org-no-read-only (&rest body) 175 "Inhibit read-only for BODY." 176 (declare (debug (body))) 177 `(let ((inhibit-read-only t)) ,@body)) 178 179 (defalias 'org-save-outline-visibility #'org-fold-save-outline-visibility) 180 181 (defmacro org-with-wide-buffer (&rest body) 182 "Execute body while temporarily widening the buffer." 183 (declare (debug (body))) 184 `(save-excursion 185 (save-restriction 186 (widen) 187 ,@body))) 188 189 (defmacro org-with-limited-levels (&rest body) 190 "Execute BODY with limited number of outline levels." 191 (declare (debug (body))) 192 `(progn 193 (defvar org-called-with-limited-levels) 194 (defvar org-outline-regexp) 195 (defvar outline-regexp) 196 (defvar org-outline-regexp-bol) 197 (let* ((org-called-with-limited-levels t) 198 (org-outline-regexp (org-get-limited-outline-regexp)) 199 (outline-regexp org-outline-regexp) 200 (org-outline-regexp-bol (concat "^" org-outline-regexp))) 201 ,@body))) 202 203 (defmacro org-eval-in-environment (environment form) 204 (declare (debug (form form)) (indent 1) (obsolete cl-progv "2021")) 205 `(eval (list 'let ,environment ',form))) 206 207 ;;;###autoload 208 (defmacro org-load-noerror-mustsuffix (file) 209 "Load FILE with optional arguments NOERROR and MUSTSUFFIX." 210 `(load ,file 'noerror nil nil 'mustsuffix)) 211 212 (defmacro org-preserve-local-variables (&rest body) 213 "Execute BODY while preserving local variables." 214 (declare (debug (body))) 215 `(let ((local-variables 216 (org-with-wide-buffer 217 (goto-char (point-max)) 218 (let ((case-fold-search t)) 219 (and (re-search-backward "^[ \t]*# +Local Variables:" 220 (max (- (point) 3000) 1) 221 t) 222 (let ((buffer-undo-list t)) 223 (delete-and-extract-region (point) (point-max))))))) 224 (tick-counter-before (buffer-modified-tick))) 225 (unwind-protect (progn ,@body) 226 (when local-variables 227 (org-with-wide-buffer 228 (goto-char (point-max)) 229 (unless (bolp) (insert "\n")) 230 (let ((modified (< tick-counter-before (buffer-modified-tick))) 231 (buffer-undo-list t)) 232 (insert local-variables) 233 (unless modified 234 (restore-buffer-modified-p nil)))))))) 235 236 (defmacro org-no-popups (&rest body) 237 "Suppress popup windows and evaluate BODY." 238 `(let (pop-up-frames pop-up-windows) 239 ,@body)) 240 241 (defmacro org-element-with-disabled-cache (&rest body) 242 "Run BODY without active org-element-cache." 243 (declare (debug (form body)) (indent 0)) 244 `(cl-letf (((symbol-function #'org-element--cache-active-p) (lambda (&rest _) nil))) 245 ,@body)) 246 247 248 ;;; Buffer and windows 249 250 (defun org-base-buffer (buffer) 251 "Return the base buffer of BUFFER, if it has one. Else return the buffer." 252 (when buffer 253 (or (buffer-base-buffer buffer) 254 buffer))) 255 256 (defun org-find-base-buffer-visiting (file) 257 "Like `find-buffer-visiting' but always return the base buffer and 258 not an indirect buffer." 259 (let ((buf (or (get-file-buffer file) 260 (find-buffer-visiting file)))) 261 (org-base-buffer buf))) 262 263 (defun org-switch-to-buffer-other-window (&rest args) 264 "Switch to buffer in a second window on the current frame. 265 In particular, do not allow pop-up frames. 266 Returns the newly created buffer." 267 (org-no-popups (apply #'switch-to-buffer-other-window args))) 268 269 (defun org-fit-window-to-buffer (&optional window max-height min-height 270 shrink-only) 271 "Fit WINDOW to the buffer, but only if it is not a side-by-side window. 272 WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are 273 passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call 274 `shrink-window-if-larger-than-buffer' instead, the height limit is 275 ignored in this case." 276 (cond ((not (window-full-width-p window)) 277 ;; Do nothing if another window would suffer. 278 ) 279 ((not shrink-only) 280 (fit-window-to-buffer window max-height min-height)) 281 (t (shrink-window-if-larger-than-buffer window))) 282 (or window (selected-window))) 283 284 (defun org-buffer-list (&optional predicate exclude-tmp) 285 "Return a list of Org buffers. 286 PREDICATE can be `export', `files' or `agenda'. 287 288 export restrict the list to Export buffers. 289 files restrict the list to buffers visiting Org files. 290 agenda restrict the list to buffers visiting agenda files. 291 292 If EXCLUDE-TMP is non-nil, ignore temporary buffers." 293 (let* ((bfn nil) 294 (agenda-files (and (eq predicate 'agenda) 295 (mapcar 'file-truename (org-agenda-files t)))) 296 (filter 297 (cond 298 ((eq predicate 'files) 299 (lambda (b) (with-current-buffer b (derived-mode-p 'org-mode)))) 300 ((eq predicate 'export) 301 (lambda (b) (string-match "\\*Org .*Export" (buffer-name b)))) 302 ((eq predicate 'agenda) 303 (lambda (b) 304 (with-current-buffer b 305 (and (derived-mode-p 'org-mode) 306 (setq bfn (buffer-file-name b)) 307 (member (file-truename bfn) agenda-files))))) 308 (t (lambda (b) (with-current-buffer b 309 (or (derived-mode-p 'org-mode) 310 (string-match "\\*Org .*Export" 311 (buffer-name b))))))))) 312 (delq nil 313 (mapcar 314 (lambda(b) 315 (if (and (funcall filter b) 316 (or (not exclude-tmp) 317 (not (string-match "tmp" (buffer-name b))))) 318 b 319 nil)) 320 (buffer-list))))) 321 322 323 324 ;;; File 325 326 (defun org-file-newer-than-p (file time) 327 "Non-nil if FILE modification time is greater than TIME. 328 TIME should be obtained earlier for the same FILE name using 329 330 \(file-attribute-modification-time (file-attributes file)) 331 332 If TIME is nil (file did not exist) then any existing FILE 333 is considered as a newer one. Some file systems have coarse 334 timestamp resolution, for example 1 second on HFS+ or 2 seconds on FAT, 335 so nil may be returned when file is updated twice within a short period 336 of time. File timestamp and system clock `current-time' may have 337 different resolution, so attempts to compare them may give unexpected 338 results. 339 340 Consider `file-newer-than-file-p' to check up to date state 341 in target-prerequisite files relation." 342 (let ((mtime (file-attribute-modification-time (file-attributes file)))) 343 (and mtime (or (not time) (time-less-p time mtime))))) 344 345 (defun org-compile-file (source process ext &optional err-msg log-buf spec) 346 "Compile a SOURCE file using PROCESS. 347 348 PROCESS is either a function or a list of shell commands, as 349 strings. EXT is a file extension, without the leading dot, as 350 a string. It is used to check if the process actually succeeded. 351 352 PROCESS must create a file with the same base name and directory 353 as SOURCE, but ending with EXT. The function then returns its 354 filename. Otherwise, it raises an error. The error message can 355 then be refined by providing string ERR-MSG, which is appended to 356 the standard message. 357 358 If PROCESS is a function, it is called with a single argument: 359 the SOURCE file. 360 361 If it is a list of commands, each of them is called using 362 `shell-command'. By default, in each command, %b, %f, %F, %o and 363 %O are replaced with, respectively, SOURCE base name, name, full 364 name, directory and absolute output file name. It is possible, 365 however, to use more place-holders by specifying them in optional 366 argument SPEC, as an alist following the pattern 367 368 (CHARACTER . REPLACEMENT-STRING). 369 370 When PROCESS is a list of commands, optional argument LOG-BUF can 371 be set to a buffer or a buffer name. `shell-command' then uses 372 it for output." 373 (let* ((base-name (file-name-base source)) 374 (full-name (file-truename source)) 375 (relative-name (file-relative-name source)) 376 (out-dir (if (file-name-directory source) 377 ;; Expand "~". Shell expansion will be disabled 378 ;; in the shell command call. 379 (file-name-directory full-name) 380 "./")) 381 (output (expand-file-name (concat base-name "." ext) out-dir)) 382 (time (file-attribute-modification-time (file-attributes output))) 383 (err-msg (if (stringp err-msg) (concat ". " err-msg) ""))) 384 (save-window-excursion 385 (pcase process 386 ((pred functionp) (funcall process (shell-quote-argument relative-name))) 387 ((pred consp) 388 (let ((log-buf (and log-buf (get-buffer-create log-buf))) 389 (spec (append spec 390 `((?b . ,(shell-quote-argument base-name)) 391 (?f . ,(shell-quote-argument relative-name)) 392 (?F . ,(shell-quote-argument full-name)) 393 (?o . ,(shell-quote-argument out-dir)) 394 (?O . ,(shell-quote-argument output)))))) 395 ;; Combine output of all commands in PROCESS. 396 (with-current-buffer log-buf 397 (let (buffer-read-only) 398 (erase-buffer))) 399 (let ((shell-command-dont-erase-buffer t)) 400 (dolist (command process) 401 (shell-command (format-spec command spec) log-buf))) 402 (when log-buf (with-current-buffer log-buf (compilation-mode))))) 403 (_ (error "No valid command to process %S%s" source err-msg)))) 404 ;; Check for process failure. Output file is expected to be 405 ;; located in the same directory as SOURCE. 406 (unless (org-file-newer-than-p output time) 407 (error (format "File %S wasn't produced%s" output err-msg))) 408 output)) 409 410 411 412 ;;; Indentation 413 414 (defmacro org-current-text-indentation () 415 "Like `current-indentation', but ignore display/invisible properties." 416 `(let ((buffer-invisibility-spec nil)) 417 (current-indentation))) 418 419 (defun org-do-remove-indentation (&optional n skip-fl) 420 "Remove the maximum common indentation from the buffer. 421 When optional argument N is a positive integer, remove exactly 422 that much characters from indentation, if possible. When 423 optional argument SKIP-FL is non-nil, skip the first 424 line. Return nil if it fails." 425 (catch :exit 426 (goto-char (point-min)) 427 ;; Find maximum common indentation, if not specified. 428 (let ((n (or n 429 (let ((min-ind (point-max))) 430 (save-excursion 431 (when skip-fl (forward-line)) 432 (while (re-search-forward "^[ \t]*\\S-" nil t) 433 (let ((ind (org-current-text-indentation))) 434 (if (zerop ind) (throw :exit nil) 435 (setq min-ind (min min-ind ind)))))) 436 min-ind)))) 437 (if (zerop n) (throw :exit nil) 438 ;; Remove exactly N indentation, but give up if not possible. 439 (when skip-fl (forward-line)) 440 (while (not (eobp)) 441 (let ((ind (progn (skip-chars-forward " \t") (current-column)))) 442 (cond ((eolp) (delete-region (line-beginning-position) (point))) 443 ((< ind n) (throw :exit nil)) 444 (t (indent-line-to (- ind n)))) 445 (forward-line))) 446 ;; Signal success. 447 t)))) 448 449 450 451 ;;; Input 452 453 (defun org-read-function (prompt &optional allow-empty?) 454 "Prompt for a function. 455 If ALLOW-EMPTY? is non-nil, return nil rather than raising an 456 error when the user input is empty." 457 (let ((func (completing-read prompt obarray #'fboundp t))) 458 (cond ((not (string= func "")) 459 (intern func)) 460 (allow-empty? nil) 461 (t (user-error "Empty input is not valid"))))) 462 463 (declare-function org-time-stamp-inactive "org" (&optional arg)) 464 465 (defun org-completing-read (&rest args) 466 "Completing-read with SPACE being a normal character." 467 (let ((enable-recursive-minibuffers t) 468 (minibuffer-local-completion-map 469 (copy-keymap minibuffer-local-completion-map))) 470 (define-key minibuffer-local-completion-map " " #'self-insert-command) 471 (define-key minibuffer-local-completion-map "?" #'self-insert-command) 472 (define-key minibuffer-local-completion-map (kbd "C-c !") 473 #'org-time-stamp-inactive) 474 (apply #'completing-read args))) 475 476 (defun org--mks-read-key (allowed-keys prompt navigation-keys) 477 "Read a key and ensure it is a member of ALLOWED-KEYS. 478 Enable keys to scroll the window if NAVIGATION-KEYS is set. 479 TAB, SPC and RET are treated equivalently." 480 (setq header-line-format (when navigation-keys "Use C-n, C-p, C-v, M-v to navigate.")) 481 (let ((char-key (read-char-exclusive prompt))) 482 (if (and navigation-keys (memq char-key '(14 16 22 134217846))) 483 (progn 484 (org-scroll char-key) 485 (org--mks-read-key allowed-keys prompt navigation-keys)) 486 (let ((key (char-to-string 487 (pcase char-key 488 ((or ?\s ?\t ?\r) ?\t) 489 (char char))))) 490 (if (member key allowed-keys) 491 key 492 (message "Invalid key: `%s'" key) 493 (sit-for 1) 494 (org--mks-read-key allowed-keys prompt navigation-keys)))))) 495 496 (defun org-mks (table title &optional prompt specials) 497 "Select a member of an alist with multiple keys. 498 499 TABLE is the alist which should contain entries where the car is a string. 500 There should be two types of entries. 501 502 1. prefix descriptions like (\"a\" \"Description\") 503 This indicates that `a' is a prefix key for multi-letter selection, and 504 that there are entries following with keys like \"ab\", \"ax\"... 505 506 2. Select-able members must have more than two elements, with the first 507 being the string of keys that lead to selecting it, and the second a 508 short description string of the item. 509 510 The command will then make a temporary buffer listing all entries 511 that can be selected with a single key, and all the single key 512 prefixes. When you press the key for a single-letter entry, it is selected. 513 When you press a prefix key, the commands (and maybe further prefixes) 514 under this key will be shown and offered for selection. 515 516 TITLE will be placed over the selection in the temporary buffer, 517 PROMPT will be used when prompting for a key. SPECIALS is an 518 alist with (\"key\" \"description\") entries. When one of these 519 is selected, only the bare key is returned." 520 (save-window-excursion 521 (let ((inhibit-quit t) 522 (buffer (org-switch-to-buffer-other-window "*Org Select*")) 523 (prompt (or prompt "Select: ")) 524 case-fold-search 525 current) 526 (unwind-protect 527 (catch 'exit 528 (while t 529 (erase-buffer) 530 (insert title "\n\n") 531 (let ((des-keys nil) 532 (allowed-keys '("\C-g")) 533 (tab-alternatives '("\s" "\t" "\r")) 534 (cursor-type nil)) 535 ;; Populate allowed keys and descriptions keys 536 ;; available with CURRENT selector. 537 (let ((re (format "\\`%s\\(.\\)\\'" 538 (if current (regexp-quote current) ""))) 539 (prefix (if current (concat current " ") ""))) 540 (dolist (entry table) 541 (pcase entry 542 ;; Description. 543 (`(,(and key (pred (string-match re))) ,desc) 544 (let ((k (match-string 1 key))) 545 (push k des-keys) 546 ;; Keys ending in tab, space or RET are equivalent. 547 (if (member k tab-alternatives) 548 (push "\t" allowed-keys) 549 (push k allowed-keys)) 550 (insert prefix "[" k "]" "..." " " desc "..." "\n"))) 551 ;; Usable entry. 552 (`(,(and key (pred (string-match re))) ,desc . ,_) 553 (let ((k (match-string 1 key))) 554 (insert prefix "[" k "]" " " desc "\n") 555 (push k allowed-keys))) 556 (_ nil)))) 557 ;; Insert special entries, if any. 558 (when specials 559 (insert "----------------------------------------------------\ 560 ---------------------------\n") 561 (pcase-dolist (`(,key ,description) specials) 562 (insert (format "[%s] %s\n" key description)) 563 (push key allowed-keys))) 564 ;; Display UI and let user select an entry or 565 ;; a sub-level prefix. 566 (goto-char (point-min)) 567 (org-fit-window-to-buffer) 568 (message "") ; With this line the prompt appears in 569 ; the minibuffer. Else keystrokes may 570 ; appear, which is spurious. 571 (let ((pressed (org--mks-read-key 572 allowed-keys prompt 573 (not (pos-visible-in-window-p (1- (point-max))))))) 574 (setq current (concat current pressed)) 575 (cond 576 ((equal pressed "\C-g") (user-error "Abort")) 577 ;; Selection is a prefix: open a new menu. 578 ((member pressed des-keys)) 579 ;; Selection matches an association: return it. 580 ((let ((entry (assoc current table))) 581 (and entry (throw 'exit entry)))) 582 ;; Selection matches a special entry: return the 583 ;; selection prefix. 584 ((assoc current specials) (throw 'exit current)) 585 (t (error "No entry available"))))))) 586 (when buffer (kill-buffer buffer)))))) 587 588 589 ;;; List manipulation 590 591 (defsubst org-get-alist-option (option key) 592 (cond ((eq key t) t) 593 ((eq option t) t) 594 ((assoc key option) (cdr (assoc key option))) 595 (t (let ((r (cdr (assq 'default option)))) 596 (if (listp r) (delq nil r) r))))) 597 598 (defsubst org-last (list) 599 "Return the last element of LIST." 600 (car (last list))) 601 602 (defsubst org-uniquify (list) 603 "Non-destructively remove duplicate elements from LIST." 604 (let ((res (copy-sequence list))) (delete-dups res))) 605 606 (defun org-uniquify-alist (alist) 607 "Merge elements of ALIST with the same key. 608 609 For example, in this alist: 610 611 \(org-uniquify-alist \\='((a 1) (b 2) (a 3))) 612 => ((a 1 3) (b 2)) 613 614 merge (a 1) and (a 3) into (a 1 3). 615 616 The function returns the new ALIST." 617 (let (rtn) 618 (dolist (e alist rtn) 619 (let (n) 620 (if (not (assoc (car e) rtn)) 621 (push e rtn) 622 (setq n (cons (car e) (append (cdr (assoc (car e) rtn)) (cdr e)))) 623 (setq rtn (assq-delete-all (car e) rtn)) 624 (push n rtn)))))) 625 626 (defun org-delete-all (elts list) 627 "Remove all elements in ELTS from LIST. 628 Comparison is done with `equal'. It is a destructive operation 629 that may remove elements by altering the list structure." 630 (while elts 631 (setq list (delete (pop elts) list))) 632 list) 633 634 (defun org-plist-delete-all (plist props) 635 "Delete all elements in PROPS from PLIST." 636 (dolist (e props plist) 637 (setq plist (org-plist-delete plist e)))) 638 639 (defun org-plist-delete (plist property) 640 "Delete PROPERTY from PLIST. 641 This is in contrast to merely setting it to 0." 642 (let (p) 643 (while plist 644 (if (not (eq property (car plist))) 645 (setq p (plist-put p (car plist) (nth 1 plist)))) 646 (setq plist (cddr plist))) 647 p)) 648 649 (defun org-combine-plists (&rest plists) 650 "Create a single property list from all plists in PLISTS. 651 The process starts by copying the first list, and then setting properties 652 from the other lists. Settings in the last list are the most significant 653 ones and overrule settings in the other lists." 654 (let ((rtn (copy-sequence (pop plists))) 655 p v ls) 656 (while plists 657 (setq ls (pop plists)) 658 (while ls 659 (setq p (pop ls) v (pop ls)) 660 (setq rtn (plist-put rtn p v)))) 661 rtn)) 662 663 664 665 ;;; Local variables 666 667 (defconst org-unique-local-variables 668 '(org-element--cache 669 org-element--headline-cache 670 org-element--cache-change-tic 671 org-element--cache-last-buffer-size 672 org-element--cache-change-warning 673 org-element--cache-gapless 674 org-element--cache-hash-left 675 org-element--cache-hash-right 676 org-element--cache-size 677 org-element--headline-cache-size 678 org-element--cache-sync-keys-value 679 org-element--cache-diagnostics-ring 680 org-element--cache-diagnostics-ring-size 681 org-element--cache-sync-keys 682 org-element--cache-sync-requests 683 org-element--cache-sync-timer) 684 "List of local variables that cannot be transferred to another buffer.") 685 686 (defun org-get-local-variables () 687 "Return a list of all local variables in an Org mode buffer." 688 (delq nil 689 (mapcar 690 (lambda (x) 691 (let* ((binding (if (symbolp x) (list x) (list (car x) (cdr x)))) 692 (name (car binding))) 693 (and (not (get name 'org-state)) 694 (not (memq name org-unique-local-variables)) 695 (string-match-p 696 "\\`\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|\ 697 auto-fill\\|normal-auto-fill\\|fill-paragraph\\|indent-\\)" 698 (symbol-name name)) 699 binding))) 700 (with-temp-buffer 701 (org-mode) 702 (buffer-local-variables))))) 703 704 (defun org-clone-local-variables (from-buffer &optional regexp) 705 "Clone local variables from FROM-BUFFER. 706 Optional argument REGEXP selects variables to clone." 707 (dolist (pair (buffer-local-variables from-buffer)) 708 (pcase pair 709 (`(,name . ,value) ;ignore unbound variables 710 (when (and (not (memq name org-unique-local-variables)) 711 (or (null regexp) (string-match-p regexp (symbol-name name)))) 712 (ignore-errors (set (make-local-variable name) value))))))) 713 714 715 ;;; Miscellaneous 716 717 (defsubst org-call-with-arg (command arg) 718 "Call COMMAND interactively, but pretend prefix arg was ARG." 719 (let ((current-prefix-arg arg)) (call-interactively command))) 720 721 (defsubst org-check-external-command (cmd &optional use no-error) 722 "Check if external program CMD for USE exists, error if not. 723 When the program does exist, return its path. 724 When it does not exist and NO-ERROR is set, return nil. 725 Otherwise, throw an error. The optional argument USE can describe what this 726 program is needed for, so that the error message can be more informative." 727 (or (executable-find cmd) 728 (if no-error 729 nil 730 (error "Can't find `%s'%s" cmd 731 (if use (format " (%s)" use) ""))))) 732 733 (defun org-display-warning (message) 734 "Display the given MESSAGE as a warning." 735 (display-warning 'org message :warning)) 736 737 (defun org-unlogged-message (&rest args) 738 "Display a message, but avoid logging it in the *Messages* buffer." 739 (let ((message-log-max nil)) 740 (apply #'message args))) 741 742 (defmacro org-dlet (binders &rest body) 743 "Like `let*' but using dynamic scoping." 744 (declare (indent 1) (debug let)) 745 (let ((vars (mapcar (lambda (binder) 746 (if (consp binder) (car binder) binder)) 747 binders))) 748 `(progn 749 (with-no-warnings 750 ,@(mapcar (lambda (var) `(defvar ,var)) vars)) 751 (let* ,binders ,@body)))) 752 753 (defmacro org-pushnew-to-end (val var) 754 "Like `cl-pushnew' but pushes to the end of the list. 755 Uses `equal' for comparisons. 756 757 Beware: this performs O(N) memory allocations, so if you use it in a loop, you 758 get an unnecessary O(N²) space complexity, so you're usually better off using 759 `cl-pushnew' (with a final `reverse' if you care about the order of elements)." 760 (declare (debug (form gv-place))) 761 (let ((v (make-symbol "v"))) 762 `(let ((,v ,val)) 763 (unless (member ,v ,var) 764 (setf ,var (append ,var (list ,v))))))) 765 766 (defun org-eval (form) 767 "Eval FORM and return result." 768 (condition-case error 769 (eval form t) 770 (error (format "%%![Error: %s]" error)))) 771 772 (defvar org-outline-regexp) ; defined in org.el 773 (defvar org-odd-levels-only) ; defined in org.el 774 (defvar org-inlinetask-min-level) ; defined in org-inlinetask.el 775 (defun org-get-limited-outline-regexp () 776 "Return outline-regexp with limited number of levels. 777 The number of levels is controlled by `org-inlinetask-min-level'." 778 (cond ((not (derived-mode-p 'org-mode)) 779 outline-regexp) 780 ((not (featurep 'org-inlinetask)) 781 org-outline-regexp) 782 (t 783 (let* ((limit-level (1- org-inlinetask-min-level)) 784 (nstars (if org-odd-levels-only 785 (1- (* limit-level 2)) 786 limit-level))) 787 (format "\\*\\{1,%d\\} " nstars))))) 788 789 (defun org--line-empty-p (n) 790 "Is the Nth next line empty? 791 Counts the current line as N = 1 and the previous line as N = 0; 792 see `beginning-of-line'." 793 (and (not (bobp)) 794 (save-excursion 795 (beginning-of-line n) 796 (looking-at-p "[ \t]*$")))) 797 798 (defun org-previous-line-empty-p () 799 "Is the previous line a blank line? 800 When NEXT is non-nil, check the next line instead." 801 (org--line-empty-p 0)) 802 803 (defun org-next-line-empty-p () 804 "Is the previous line a blank line? 805 When NEXT is non-nil, check the next line instead." 806 (org--line-empty-p 2)) 807 808 809 810 ;;; Motion 811 812 (defsubst org-goto-line (N) 813 (save-restriction 814 (widen) 815 (goto-char (point-min)) 816 (forward-line (1- N)))) 817 818 (defsubst org-current-line (&optional pos) 819 (save-excursion 820 (and pos (goto-char pos)) 821 ;; works also in narrowed buffer, because we start at 1, not point-min 822 (+ (if (bolp) 1 0) (count-lines 1 (point))))) 823 824 825 826 ;;; Overlays and text properties 827 828 (defun org-overlay-display (ovl text &optional face evap) 829 "Make overlay OVL display TEXT with face FACE." 830 (overlay-put ovl 'display text) 831 (when face (overlay-put ovl 'face face)) 832 (when evap (overlay-put ovl 'evaporate t))) 833 834 (defun org-overlay-before-string (ovl text &optional face evap) 835 "Make overlay OVL display TEXT with face FACE." 836 (when face (org-add-props text nil 'face face)) 837 (overlay-put ovl 'before-string text) 838 (when evap (overlay-put ovl 'evaporate t))) 839 840 (defun org-find-overlays (prop &optional pos delete) 841 "Find all overlays specifying PROP at POS or point. 842 If DELETE is non-nil, delete all those overlays." 843 (let (found) 844 (dolist (ov (overlays-at (or pos (point))) found) 845 (cond ((not (overlay-get ov prop))) 846 (delete (delete-overlay ov)) 847 (t (push ov found)))))) 848 849 (defun org-find-text-property-region (pos prop) 850 "Find a region around POS containing same non-nil value of PROP text property. 851 Return nil when PROP is not set at POS." 852 (let* ((beg (and (get-text-property pos prop) pos)) 853 (end beg)) 854 (when beg 855 (unless (or (equal beg (point-min)) 856 (not (eq (get-text-property beg prop) 857 (get-text-property (1- beg) prop)))) 858 (setq beg (previous-single-property-change pos prop nil (point-min)))) 859 (unless (or (equal end (point-max)) 860 ;; (not (eq (get-text-property end prop) 861 ;; (get-text-property (1+ end) prop))) 862 ) 863 (setq end (next-single-property-change pos prop nil (point-max)))) 864 (cons beg end)))) 865 866 867 ;;; Regexp matching 868 869 (defsubst org-pos-in-match-range (pos n) 870 (and (match-beginning n) 871 (<= (match-beginning n) pos) 872 (>= (match-end n) pos))) 873 874 (defun org-skip-whitespace () 875 "Skip over space, tabs and newline characters." 876 (skip-chars-forward " \t\n\r")) 877 878 (defun org-match-line (regexp) 879 "Match REGEXP at the beginning of the current line." 880 (save-excursion 881 (beginning-of-line) 882 (looking-at regexp))) 883 884 (defun org-match-any-p (re list) 885 "Non-nil if regexp RE matches an element in LIST." 886 (cl-some (lambda (x) (string-match-p re x)) list)) 887 888 (defun org-in-regexp (regexp &optional nlines visually) 889 "Check if point is inside a match of REGEXP. 890 891 Normally only the current line is checked, but you can include 892 NLINES extra lines around point into the search. If VISUALLY is 893 set, require that the cursor is not after the match but really 894 on, so that the block visually is on the match. 895 896 Return nil or a cons cell (BEG . END) where BEG and END are, 897 respectively, the positions at the beginning and the end of the 898 match." 899 (catch :exit 900 (let ((pos (point)) 901 (eol (line-end-position (if nlines (1+ nlines) 1)))) 902 (save-excursion 903 (beginning-of-line (- 1 (or nlines 0))) 904 (while (and (re-search-forward regexp eol t) 905 (<= (match-beginning 0) pos)) 906 (let ((end (match-end 0))) 907 (when (or (> end pos) (and (= end pos) (not visually))) 908 (throw :exit (cons (match-beginning 0) (match-end 0)))))))))) 909 910 (defun org-point-in-group (point group &optional context) 911 "Check if POINT is in match-group GROUP. 912 If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the 913 match. If the match group does not exist or point is not inside it, 914 return nil." 915 (and (match-beginning group) 916 (>= point (match-beginning group)) 917 (<= point (match-end group)) 918 (if context 919 (list context (match-beginning group) (match-end group)) 920 t))) 921 922 (defun org-url-p (s) 923 "Non-nil if string S is a URL." 924 (require 'ffap) 925 (and ffap-url-regexp (string-match-p ffap-url-regexp s))) 926 927 928 ;;; String manipulation 929 930 (defun org-string< (a b) 931 (string-collate-lessp a b)) 932 933 (defun org-string<= (a b) 934 (or (string= a b) (string-collate-lessp a b))) 935 936 (defun org-string>= (a b) 937 (not (string-collate-lessp a b))) 938 939 (defun org-string> (a b) 940 (and (not (string= a b)) 941 (not (string-collate-lessp a b)))) 942 943 (defun org-string<> (a b) 944 (not (string= a b))) 945 946 (defsubst org-trim (s &optional keep-lead) 947 "Remove whitespace at the beginning and the end of string S. 948 When optional argument KEEP-LEAD is non-nil, removing blank lines 949 at the beginning of the string does not affect leading indentation." 950 (replace-regexp-in-string 951 (if keep-lead "\\`\\([ \t]*\n\\)+" "\\`[ \t\n\r]+") "" 952 (replace-regexp-in-string "[ \t\n\r]+\\'" "" s))) 953 954 (defun org-string-nw-p (s) 955 "Return S if S is a string containing a non-blank character. 956 Otherwise, return nil." 957 (and (stringp s) 958 (string-match-p "[^ \r\t\n]" s) 959 s)) 960 961 (defun org-reverse-string (string) 962 "Return the reverse of STRING." 963 (apply #'string (nreverse (string-to-list string)))) 964 965 (defun org-split-string (string &optional separators) 966 "Splits STRING into substrings at SEPARATORS. 967 968 SEPARATORS is a regular expression. When nil, it defaults to 969 \"[ \f\t\n\r\v]+\". 970 971 Unlike `split-string', matching SEPARATORS at the beginning and 972 end of string are ignored." 973 (let ((separators (or separators "[ \f\t\n\r\v]+"))) 974 (if (not (string-match separators string)) (list string) 975 (let ((i (match-end 0)) 976 (results 977 (and (/= 0 (match-beginning 0)) ;skip leading separator 978 (list (substring string 0 (match-beginning 0)))))) 979 (while (string-match separators string i) 980 (push (substring string i (match-beginning 0)) 981 results) 982 (setq i (match-end 0))) 983 (nreverse (if (= i (length string)) 984 results ;skip trailing separator 985 (cons (substring string i) results))))))) 986 987 (defun org--string-from-props (s property beg end) 988 "Return the visible part of string S. 989 Visible part is determined according to text PROPERTY, which is 990 either `invisible' or `display'. BEG and END are 0-indices 991 delimiting S." 992 (let ((width 0) 993 (cursor beg)) 994 (while (setq beg (text-property-not-all beg end property nil s)) 995 (let* ((next (next-single-property-change beg property s end)) 996 (spec (get-text-property beg property s)) 997 (value 998 (pcase property 999 (`invisible 1000 ;; If `invisible' property means text is to be 1001 ;; invisible, return 0. Otherwise return nil so as 1002 ;; to resume search. 1003 (and (or (eq t buffer-invisibility-spec) 1004 (assoc-string spec buffer-invisibility-spec)) 1005 0)) 1006 (`display 1007 (pcase spec 1008 (`nil nil) 1009 (`(space . ,props) 1010 (let ((width (plist-get props :width))) 1011 (and (wholenump width) width))) 1012 (`(image . ,_) 1013 (and (fboundp 'image-size) 1014 (ceiling (car (image-size spec))))) 1015 ((pred stringp) 1016 ;; Displayed string could contain invisible parts, 1017 ;; but no nested display. 1018 (org--string-from-props spec 'invisible 0 (length spec))) 1019 (_ 1020 ;; Un-handled `display' value. Ignore it. 1021 ;; Consider the original string instead. 1022 nil))) 1023 (_ (error "Unknown property: %S" property))))) 1024 (when value 1025 (cl-incf width 1026 ;; When looking for `display' parts, we still need 1027 ;; to look for `invisible' property elsewhere. 1028 (+ (cond ((eq property 'display) 1029 (org--string-from-props s 'invisible cursor beg)) 1030 ((= cursor beg) 0) 1031 (t (string-width (substring s cursor beg)))) 1032 value)) 1033 (setq cursor next)) 1034 (setq beg next))) 1035 (+ width 1036 ;; Look for `invisible' property in the last part of the 1037 ;; string. See above. 1038 (cond ((eq property 'display) 1039 (org--string-from-props s 'invisible cursor end)) 1040 ((= cursor end) 0) 1041 (t (string-width (substring s cursor end))))))) 1042 1043 (defun org--string-width-1 (string) 1044 "Return width of STRING when displayed in the current buffer. 1045 Unlike `string-width', this function takes into consideration 1046 `invisible' and `display' text properties. It supports the 1047 latter in a limited way, mostly for combinations used in Org. 1048 Results may be off sometimes if it cannot handle a given 1049 `display' value." 1050 (org--string-from-props string 'display 0 (length string))) 1051 1052 (defun org-string-width (string &optional pixels) 1053 "Return width of STRING when displayed in the current buffer. 1054 Return width in pixels when PIXELS is non-nil." 1055 (if (and (version< emacs-version "28") (not pixels)) 1056 ;; FIXME: Fallback to old limited version, because 1057 ;; `window-pixel-width' is buggy in older Emacs. 1058 (org--string-width-1 string) 1059 ;; Wrap/line prefix will make `window-text-pizel-size' return too 1060 ;; large value including the prefix. 1061 (remove-text-properties 0 (length string) 1062 '(wrap-prefix t line-prefix t) 1063 string) 1064 ;; Face should be removed to make sure that all the string symbols 1065 ;; are using default face with constant width. Constant char width 1066 ;; is critical to get right string width from pixel width (not needed 1067 ;; when PIXELS are requested though). 1068 (unless pixels 1069 (remove-text-properties 0 (length string) '(face t) string)) 1070 (let (;; We need to remove the folds to make sure that folded table 1071 ;; alignment is not messed up. 1072 (current-invisibility-spec 1073 (or (and (not (listp buffer-invisibility-spec)) 1074 buffer-invisibility-spec) 1075 (let (result) 1076 (dolist (el buffer-invisibility-spec) 1077 (unless (or (memq el 1078 '(org-fold-drawer 1079 org-fold-block 1080 org-fold-outline)) 1081 (and (listp el) 1082 (memq (car el) 1083 '(org-fold-drawer 1084 org-fold-block 1085 org-fold-outline)))) 1086 (push el result))) 1087 result))) 1088 (current-char-property-alias-alist char-property-alias-alist)) 1089 (with-temp-buffer 1090 (setq-local display-line-numbers nil) 1091 (setq-local buffer-invisibility-spec 1092 (if (listp current-invisibility-spec) 1093 (mapcar (lambda (el) 1094 ;; Consider ellipsis to have 0 width. 1095 ;; It is what Emacs 28+ does, but we have 1096 ;; to force it in earlier Emacs versions. 1097 (if (and (consp el) (cdr el)) 1098 (list (car el)) 1099 el)) 1100 current-invisibility-spec) 1101 current-invisibility-spec)) 1102 (setq-local char-property-alias-alist 1103 current-char-property-alias-alist) 1104 (let (pixel-width symbol-width) 1105 (with-silent-modifications 1106 (erase-buffer) 1107 (insert string) 1108 (setq pixel-width 1109 (if (get-buffer-window (current-buffer)) 1110 (car (window-text-pixel-size 1111 nil (line-beginning-position) (point-max))) 1112 (let ((dedicatedp (window-dedicated-p)) 1113 (oldbuffer (window-buffer))) 1114 (unwind-protect 1115 (progn 1116 ;; Do not throw error in dedicated windows. 1117 (set-window-dedicated-p nil nil) 1118 (set-window-buffer nil (current-buffer)) 1119 (car (window-text-pixel-size 1120 nil (line-beginning-position) (point-max)))) 1121 (set-window-buffer nil oldbuffer) 1122 (set-window-dedicated-p nil dedicatedp))))) 1123 (unless pixels 1124 (erase-buffer) 1125 (insert "a") 1126 (setq symbol-width 1127 (if (get-buffer-window (current-buffer)) 1128 (car (window-text-pixel-size 1129 nil (line-beginning-position) (point-max))) 1130 (let ((dedicatedp (window-dedicated-p)) 1131 (oldbuffer (window-buffer))) 1132 (unwind-protect 1133 (progn 1134 ;; Do not throw error in dedicated windows. 1135 (set-window-dedicated-p nil nil) 1136 (set-window-buffer nil (current-buffer)) 1137 (car (window-text-pixel-size 1138 nil (line-beginning-position) (point-max)))) 1139 (set-window-buffer nil oldbuffer) 1140 (set-window-dedicated-p nil dedicatedp))))))) 1141 (if pixels 1142 pixel-width 1143 (/ pixel-width symbol-width))))))) 1144 1145 (defmacro org-current-text-column () 1146 "Like `current-column' but ignore display properties." 1147 `(string-width (buffer-substring-no-properties 1148 (line-beginning-position) (point)))) 1149 1150 (defun org-not-nil (v) 1151 "If V not nil, and also not the string \"nil\", then return V. 1152 Otherwise return nil." 1153 (and v (not (equal v "nil")) v)) 1154 1155 (defun org-unbracket-string (pre post string) 1156 "Remove PRE/POST from the beginning/end of STRING. 1157 Both PRE and POST must be pre-/suffixes of STRING, or neither is 1158 removed. Return the new string. If STRING is nil, return nil." 1159 (declare (indent 2)) 1160 (and string 1161 (if (and (string-prefix-p pre string) 1162 (string-suffix-p post string)) 1163 (substring string (length pre) 1164 (and (not (string-equal "" post)) (- (length post)))) 1165 string))) 1166 1167 (defun org-strip-quotes (string) 1168 "Strip double quotes from around STRING, if applicable. 1169 If STRING is nil, return nil." 1170 (org-unbracket-string "\"" "\"" string)) 1171 1172 (defsubst org-current-line-string (&optional to-here) 1173 "Return current line, as a string. 1174 If optional argument TO-HERE is non-nil, return string from 1175 beginning of line up to point." 1176 (buffer-substring (line-beginning-position) 1177 (if to-here (point) (line-end-position)))) 1178 1179 (defun org-shorten-string (s maxlength) 1180 "Shorten string S so that it is no longer than MAXLENGTH characters. 1181 If the string is shorter or has length MAXLENGTH, just return the 1182 original string. If it is longer, the functions finds a space in the 1183 string, breaks this string off at that locations and adds three dots 1184 as ellipsis. Including the ellipsis, the string will not be longer 1185 than MAXLENGTH. If finding a good breaking point in the string does 1186 not work, the string is just chopped off in the middle of a word 1187 if necessary." 1188 (if (<= (length s) maxlength) 1189 s 1190 (let* ((n (max (- maxlength 4) 1)) 1191 (re (concat "\\`\\(.\\{1," (number-to-string n) 1192 "\\}[^ ]\\)\\([ ]\\|\\'\\)"))) 1193 (if (string-match re s) 1194 (concat (match-string 1 s) "...") 1195 (concat (substring s 0 (max (- maxlength 3) 0)) "..."))))) 1196 1197 (defun org-remove-tabs (s &optional width) 1198 "Replace tabulators in S with spaces. 1199 Assumes that s is a single line, starting in column 0." 1200 (setq width (or width tab-width)) 1201 (while (string-match "\t" s) 1202 (setq s (replace-match 1203 (make-string 1204 (- (* width (/ (+ (match-beginning 0) width) width)) 1205 (match-beginning 0)) ?\ ) 1206 t t s))) 1207 s) 1208 1209 (defun org-wrap (string &optional width lines) 1210 "Wrap string to either a number of lines, or a width in characters. 1211 If WIDTH is non-nil, the string is wrapped to that width, however many lines 1212 that costs. If there is a word longer than WIDTH, the text is actually 1213 wrapped to the length of that word. 1214 IF WIDTH is nil and LINES is non-nil, the string is forced into at most that 1215 many lines, whatever width that takes. 1216 The return value is a list of lines, without newlines at the end." 1217 (let* ((words (split-string string)) 1218 (maxword (apply #'max (mapcar #'org-string-width words))) 1219 w ll) 1220 (cond (width 1221 (org--do-wrap words (max maxword width))) 1222 (lines 1223 (setq w maxword) 1224 (setq ll (org--do-wrap words maxword)) 1225 (if (<= (length ll) lines) 1226 ll 1227 (setq ll words) 1228 (while (> (length ll) lines) 1229 (setq w (1+ w)) 1230 (setq ll (org--do-wrap words w))) 1231 ll)) 1232 (t (error "Cannot wrap this"))))) 1233 1234 (defun org--do-wrap (words width) 1235 "Create lines of maximum width WIDTH (in characters) from word list WORDS." 1236 (let (lines line) 1237 (while words 1238 (setq line (pop words)) 1239 (while (and words (< (+ (length line) (length (car words))) width)) 1240 (setq line (concat line " " (pop words)))) 1241 (setq lines (push line lines))) 1242 (nreverse lines))) 1243 1244 (defun org-remove-indentation (code &optional n) 1245 "Remove maximum common indentation in string CODE and return it. 1246 N may optionally be the number of columns to remove. Return CODE 1247 as-is if removal failed." 1248 (with-temp-buffer 1249 (insert code) 1250 (if (org-do-remove-indentation n) (buffer-string) code))) 1251 1252 (defun org-fill-template (template alist) 1253 "Find each %key of ALIST in TEMPLATE and replace it." 1254 (let ((case-fold-search nil)) 1255 (dolist (entry (sort (copy-sequence alist) 1256 ; Sort from longest key to shortest, so that 1257 ; "noweb-ref" and "tangle-mode" get processed 1258 ; before "noweb" and "tangle", respectively. 1259 (lambda (a b) (< (length (car b)) (length (car a)))))) 1260 (setq template 1261 (replace-regexp-in-string 1262 (concat "%" (regexp-quote (car entry))) 1263 (or (cdr entry) "") template t t))) 1264 template)) 1265 1266 (defun org-replace-escapes (string table) 1267 "Replace %-escapes in STRING with values in TABLE. 1268 TABLE is an association list with keys like \"%a\" and string values. 1269 The sequences in STRING may contain normal field width and padding information, 1270 for example \"%-5s\". Replacements happen in the sequence given by TABLE, 1271 so values can contain further %-escapes if they are define later in TABLE." 1272 (let ((tbl (copy-alist table)) 1273 (case-fold-search nil) 1274 (pchg 0) 1275 re rpl) 1276 (dolist (e tbl) 1277 (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) 1278 (when (and (cdr e) (string-match re (cdr e))) 1279 (let ((sref (substring (cdr e) (match-beginning 0) (match-end 0))) 1280 (safe "SREF")) 1281 (add-text-properties 0 3 (list 'sref sref) safe) 1282 (setcdr e (replace-match safe t t (cdr e))))) 1283 (while (string-match re string) 1284 (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s") 1285 (cdr e))) 1286 (setq string (replace-match rpl t t string)))) 1287 (while (setq pchg (next-property-change pchg string)) 1288 (let ((sref (get-text-property pchg 'sref string))) 1289 (when (and sref (string-match "SREF" string pchg)) 1290 (setq string (replace-match sref t t string))))) 1291 string)) 1292 1293 1294 ;;; Text properties 1295 1296 (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t 1297 rear-nonsticky t mouse-map t fontified t 1298 org-emphasis t) 1299 "Properties to remove when a string without properties is wanted.") 1300 1301 (defun org-buffer-substring-fontified (beg end) 1302 "Return fontified region between BEG and END." 1303 (when (bound-and-true-p jit-lock-mode) 1304 (when (text-property-not-all beg end 'fontified t) 1305 (save-excursion (save-match-data (font-lock-fontify-region beg end))))) 1306 (buffer-substring beg end)) 1307 1308 (defun org-looking-at-fontified (re) 1309 "Call `looking-at' RE and make sure that the match is fontified." 1310 (prog1 (looking-at re) 1311 (when (bound-and-true-p jit-lock-mode) 1312 (when (text-property-not-all 1313 (match-beginning 0) (match-end 0) 1314 'fontified t) 1315 (save-excursion 1316 (save-match-data 1317 (font-lock-fontify-region (match-beginning 0) 1318 (match-end 0)))))))) 1319 1320 (defsubst org-no-properties (s &optional restricted) 1321 "Remove all text properties from string S. 1322 When RESTRICTED is non-nil, only remove the properties listed 1323 in `org-rm-props'." 1324 (if restricted (remove-text-properties 0 (length s) org-rm-props s) 1325 (set-text-properties 0 (length s) nil s)) 1326 s) 1327 (defun org-add-props (string plist &rest props) 1328 "Add text properties to entire string, from beginning to end. 1329 PLIST may be a list of properties, PROPS are individual properties and values 1330 that will be added to PLIST. Returns the string that was modified." 1331 (declare (indent 2)) 1332 (add-text-properties 1333 0 (length string) (if props (append plist props) plist) string) 1334 string) 1335 1336 (defun org-make-parameter-alist (plist) 1337 "Return alist based on PLIST. 1338 PLIST is a property list with alternating symbol names and values. 1339 The returned alist is a list of lists with the symbol name in `car' 1340 and the value in `cadr'." 1341 (when plist 1342 (cons (list (car plist) (cadr plist)) 1343 (org-make-parameter-alist (cddr plist))))) 1344 1345 (defsubst org-get-at-bol (property) 1346 "Get text property PROPERTY at the beginning of line." 1347 (get-text-property (line-beginning-position) property)) 1348 1349 (defun org-get-at-eol (property n) 1350 "Get text property PROPERTY at the end of line less N characters." 1351 (get-text-property (- (line-end-position) n) property)) 1352 1353 (defun org-find-text-property-in-string (prop s) 1354 "Return the first non-nil value of property PROP in string S." 1355 (or (get-text-property 0 prop s) 1356 (get-text-property (or (next-single-property-change 0 prop s) 0) 1357 prop s))) 1358 1359 ;; FIXME: move to org-fold? 1360 (defun org-invisible-p (&optional pos folding-only) 1361 "Non-nil if the character after POS is invisible. 1362 If POS is nil, use `point' instead. When optional argument 1363 FOLDING-ONLY is non-nil, only consider invisible parts due to 1364 folding of a headline, a block or a drawer, i.e., not because of 1365 fontification." 1366 (let ((value (invisible-p (or pos (point))))) 1367 (cond ((not value) nil) 1368 (folding-only (org-fold-folded-p (or pos (point)))) 1369 (t value)))) 1370 1371 (defun org-truly-invisible-p () 1372 "Check if point is at a character currently not visible. 1373 This version does not only check the character property, but also 1374 `visible-mode'." 1375 (unless (bound-and-true-p visible-mode) 1376 (org-invisible-p))) 1377 1378 (defun org-invisible-p2 () 1379 "Check if point is at a character currently not visible. 1380 If the point is at EOL (and not at the beginning of a buffer too), 1381 move it back by one char before doing this check." 1382 (save-excursion 1383 (when (and (eolp) (not (bobp))) 1384 (backward-char 1)) 1385 (org-invisible-p))) 1386 1387 (defun org-region-invisible-p (beg end) 1388 "Check if region if completely hidden." 1389 (org-with-wide-buffer 1390 (and (org-invisible-p beg) 1391 (org-invisible-p (org-fold-next-visibility-change beg end))))) 1392 1393 (defun org-find-visible () 1394 "Return closest visible buffer position, or `point-max'." 1395 (if (org-invisible-p) 1396 (org-fold-next-visibility-change (point)) 1397 (point))) 1398 1399 (defun org-find-invisible () 1400 "Return closest invisible buffer position, or `point-max'." 1401 (if (org-invisible-p) 1402 (point) 1403 (org-fold-next-visibility-change (point)))) 1404 1405 1406 ;;; Time 1407 1408 (defun org-2ft (s) 1409 "Convert S to a floating point time. 1410 If S is already a number, just return it. If it is a string, 1411 parse it as a time string and apply `float-time' to it. If S is 1412 nil, just return 0." 1413 (cond 1414 ((numberp s) s) 1415 ((stringp s) 1416 (condition-case nil 1417 (org-time-string-to-seconds s) 1418 (error 0))) 1419 (t 0))) 1420 1421 (defun org-time= (a b) 1422 (let ((a (org-2ft a)) 1423 (b (org-2ft b))) 1424 (and (> a 0) (> b 0) (= a b)))) 1425 1426 (defun org-time< (a b) 1427 (let ((a (org-2ft a)) 1428 (b (org-2ft b))) 1429 (and (> a 0) (> b 0) (< a b)))) 1430 1431 (defun org-time<= (a b) 1432 (let ((a (org-2ft a)) 1433 (b (org-2ft b))) 1434 (and (> a 0) (> b 0) (<= a b)))) 1435 1436 (defun org-time> (a b) 1437 (let ((a (org-2ft a)) 1438 (b (org-2ft b))) 1439 (and (> a 0) (> b 0) (> a b)))) 1440 1441 (defun org-time>= (a b) 1442 (let ((a (org-2ft a)) 1443 (b (org-2ft b))) 1444 (and (> a 0) (> b 0) (>= a b)))) 1445 1446 (defun org-time<> (a b) 1447 (let ((a (org-2ft a)) 1448 (b (org-2ft b))) 1449 (and (> a 0) (> b 0) (\= a b)))) 1450 1451 (defmacro org-encode-time (&rest time) 1452 "Compatibility and convenience helper for `encode-time'. 1453 TIME may be a 9 components list (SECONDS ... YEAR IGNORED DST ZONE) 1454 as the recommended way since Emacs-27 or 6 or 9 separate arguments 1455 similar to the only possible variant for Emacs-26 and earlier. 1456 6 elements list as the only argument causes wrong type argument till 1457 Emacs-29. 1458 1459 Warning: use -1 for DST to guess the actual value, nil means no 1460 daylight saving time and may be wrong at particular time. 1461 1462 DST value is ignored prior to Emacs-27. Since Emacs-27 DST value matters 1463 even when multiple arguments is passed to this macro and such 1464 behavior is different from `encode-time'. See 1465 Info node `(elisp)Time Conversion' for details and caveats, 1466 preferably the latest version." 1467 (if (version< emacs-version "27.1") 1468 (if (cdr time) 1469 `(encode-time ,@time) 1470 `(apply #'encode-time ,@time)) 1471 (if (ignore-errors (with-no-warnings (encode-time '(0 0 0 1 1 1971)))) 1472 (pcase (length time) ; Emacs-29 since d75e2c12eb 1473 (1 `(encode-time ,@time)) 1474 ((or 6 9) `(encode-time (list ,@time))) 1475 (_ (error "`org-encode-time' may be called with 1, 6, or 9 arguments but %d given" 1476 (length time)))) 1477 (pcase (length time) 1478 (1 `(encode-time ,@time)) 1479 (6 `(encode-time (list ,@time nil -1 nil))) 1480 (9 `(encode-time (list ,@time))) 1481 (_ (error "`org-encode-time' may be called with 1, 6, or 9 arguments but %d given" 1482 (length time))))))) 1483 1484 (defun org-parse-time-string (s &optional nodefault) 1485 "Parse Org time string S. 1486 1487 If time is not given, defaults to 0:00. However, with optional 1488 NODEFAULT, hour and minute fields are nil if not given. 1489 1490 Throw an error if S does not contain a valid Org time string. 1491 Note that the first match for YYYY-MM-DD will be used (e.g., 1492 \"-52000-02-03\" will be taken as \"2000-02-03\"). 1493 1494 This should be a lot faster than the `parse-time-string'." 1495 (unless (string-match org-ts-regexp0 s) 1496 (error "Not an Org time string: %s" s)) 1497 (list 0 1498 (cond ((match-beginning 8) (string-to-number (match-string 8 s))) 1499 (nodefault nil) 1500 (t 0)) 1501 (cond ((match-beginning 7) (string-to-number (match-string 7 s))) 1502 (nodefault nil) 1503 (t 0)) 1504 (string-to-number (match-string 4 s)) 1505 (string-to-number (match-string 3 s)) 1506 (string-to-number (match-string 2 s)) 1507 nil -1 nil)) 1508 1509 (defun org-matcher-time (s) 1510 "Interpret a time comparison value S as a floating point time. 1511 1512 S can be an Org time stamp, a modifier, e.g., \"<+2d>\", or the 1513 following special strings: \"<now>\", \"<today>\", 1514 \"<tomorrow>\", and \"<yesterday>\". 1515 1516 Return 0. if S is not recognized as a valid value." 1517 (let ((today (float-time (org-encode-time 1518 (append '(0 0 0) (nthcdr 3 (decode-time))))))) 1519 (save-match-data 1520 (cond 1521 ((string= s "<now>") (float-time)) 1522 ((string= s "<today>") today) 1523 ((string= s "<tomorrow>") (+ 86400.0 today)) 1524 ((string= s "<yesterday>") (- today 86400.0)) 1525 ((string-match "\\`<\\([-+][0-9]+\\)\\([hdwmy]\\)>\\'" s) 1526 (+ (if (string= (match-string 2 s) "h") (float-time) today) 1527 (* (string-to-number (match-string 1 s)) 1528 (cdr (assoc (match-string 2 s) 1529 '(("h" . 3600.0) 1530 ("d" . 86400.0) ("w" . 604800.0) 1531 ("m" . 2678400.0) ("y" . 31557600.0))))))) 1532 ((string-match org-ts-regexp0 s) (org-2ft s)) 1533 (t 0.))))) 1534 1535 (defun org-scroll (key &optional additional-keys) 1536 "Receive KEY and scroll the current window accordingly. 1537 When ADDITIONAL-KEYS is not nil, also include SPC and DEL in the 1538 allowed keys for scrolling, as expected in the export dispatch 1539 window." 1540 (let ((scrlup (if additional-keys '(?\s ?\C-v) ?\C-v)) 1541 (scrldn (if additional-keys `(?\d ?\M-v) ?\M-v))) 1542 (pcase key 1543 (?\C-n (if (not (pos-visible-in-window-p (point-max))) 1544 (ignore-errors (scroll-up 1)) 1545 (message "End of buffer") 1546 (sit-for 1))) 1547 (?\C-p (if (not (pos-visible-in-window-p (point-min))) 1548 (ignore-errors (scroll-down 1)) 1549 (message "Beginning of buffer") 1550 (sit-for 1))) 1551 ;; SPC or 1552 ((guard (memq key scrlup)) 1553 (if (not (pos-visible-in-window-p (point-max))) 1554 (scroll-up nil) 1555 (message "End of buffer") 1556 (sit-for 1))) 1557 ;; DEL 1558 ((guard (memq key scrldn)) 1559 (if (not (pos-visible-in-window-p (point-min))) 1560 (scroll-down nil) 1561 (message "Beginning of buffer") 1562 (sit-for 1)))))) 1563 1564 (cl-defun org-knuth-hash (number &optional (base 32)) 1565 "Calculate Knuth's multiplicative hash for NUMBER. 1566 BASE is the maximum bitcount. 1567 Credit: https://stackoverflow.com/questions/11871245/knuth-multiplicative-hash#41537995" 1568 (cl-assert (and (<= 0 base 32))) 1569 (ash (* number 2654435769) (- base 32))) 1570 1571 (provide 'org-macs) 1572 1573 ;; Local variables: 1574 ;; generated-autoload-file: "org-loaddefs.el" 1575 ;; End: 1576 1577 ;;; org-macs.el ends here