org-macs.el 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324
  1. ;;; org-macs.el --- Top-level Definitions for Org -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
  3. ;; Author: Carsten Dominik <carsten at orgmode dot org>
  4. ;; Keywords: outlines, hypermedia, calendar, wp
  5. ;; Homepage: http://orgmode.org
  6. ;;
  7. ;; This file is part of GNU Emacs.
  8. ;;
  9. ;; GNU Emacs is free software: you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation, either version 3 of the License, or
  12. ;; (at your option) any later version.
  13. ;; GNU Emacs is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;; GNU General Public License for more details.
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. ;;
  21. ;;; Commentary:
  22. ;; This file contains macro definitions, defsubst definitions, other
  23. ;; stuff needed for compilation and top-level forms in Org mode, as
  24. ;; well lots of small functions that are not Org mode specific but
  25. ;; simply generally useful stuff.
  26. ;;; Code:
  27. (defmacro org-with-gensyms (symbols &rest body)
  28. (declare (debug (sexp body)) (indent 1))
  29. `(let ,(mapcar (lambda (s)
  30. `(,s (make-symbol (concat "--" (symbol-name ',s)))))
  31. symbols)
  32. ,@body))
  33. (defun org-string-nw-p (s)
  34. "Return S if S is a string containing a non-blank character.
  35. Otherwise, return nil."
  36. (and (stringp s)
  37. (string-match-p "[^ \r\t\n]" s)
  38. s))
  39. (defun org-not-nil (v)
  40. "If V not nil, and also not the string \"nil\", then return V.
  41. Otherwise return nil."
  42. (and v (not (equal v "nil")) v))
  43. (defun org-substitute-posix-classes (re)
  44. "Substitute posix classes in regular expression RE."
  45. (let ((ss re))
  46. (save-match-data
  47. (while (string-match "\\[:alnum:\\]" ss)
  48. (setq ss (replace-match "a-zA-Z0-9" t t ss)))
  49. (while (string-match "\\[:word:\\]" ss)
  50. (setq ss (replace-match "a-zA-Z0-9" t t ss)))
  51. (while (string-match "\\[:alpha:\\]" ss)
  52. (setq ss (replace-match "a-zA-Z" t t ss)))
  53. (while (string-match "\\[:punct:\\]" ss)
  54. (setq ss (replace-match "\001-@[-`{-~" t t ss)))
  55. ss)))
  56. (defmacro org-preserve-lc (&rest body)
  57. (declare (debug (body)))
  58. (org-with-gensyms (line col)
  59. `(let ((,line (org-current-line))
  60. (,col (current-column)))
  61. (unwind-protect
  62. (progn ,@body)
  63. (org-goto-line ,line)
  64. (org-move-to-column ,col)))))
  65. ;; Use `org-with-silent-modifications' to ignore cosmetic changes and
  66. ;; `org-unmodified' to ignore real text modifications
  67. (defmacro org-unmodified (&rest body)
  68. "Run BODY while preserving the buffer's `buffer-modified-p' state."
  69. (declare (debug (body)))
  70. (org-with-gensyms (was-modified)
  71. `(let ((,was-modified (buffer-modified-p)))
  72. (unwind-protect
  73. (let ((buffer-undo-list t)
  74. (inhibit-modification-hooks t))
  75. ,@body)
  76. (set-buffer-modified-p ,was-modified)))))
  77. (defmacro org-without-partial-completion (&rest body)
  78. (declare (debug (body)))
  79. `(if (and (boundp 'partial-completion-mode)
  80. partial-completion-mode
  81. (fboundp 'partial-completion-mode))
  82. (unwind-protect
  83. (progn
  84. (partial-completion-mode -1)
  85. ,@body)
  86. (partial-completion-mode 1))
  87. ,@body))
  88. (defmacro org-with-point-at (pom &rest body)
  89. "Move to buffer and point of point-or-marker POM for the duration of BODY."
  90. (declare (debug (form body)) (indent 1))
  91. (org-with-gensyms (mpom)
  92. `(let ((,mpom ,pom))
  93. (save-excursion
  94. (if (markerp ,mpom) (set-buffer (marker-buffer ,mpom)))
  95. (org-with-wide-buffer
  96. (goto-char (or ,mpom (point)))
  97. ,@body)))))
  98. (defmacro org-no-warnings (&rest body)
  99. (declare (debug (body)))
  100. (cons (if (fboundp 'with-no-warnings) 'with-no-warnings 'progn) body))
  101. (defmacro org-with-remote-undo (buffer &rest body)
  102. "Execute BODY while recording undo information in two buffers."
  103. (declare (debug (form body)) (indent 1))
  104. (org-with-gensyms (cline cmd buf1 buf2 undo1 undo2 c1 c2)
  105. `(let ((,cline (org-current-line))
  106. (,cmd this-command)
  107. (,buf1 (current-buffer))
  108. (,buf2 ,buffer)
  109. (,undo1 buffer-undo-list)
  110. (,undo2 (with-current-buffer ,buffer buffer-undo-list))
  111. ,c1 ,c2)
  112. ,@body
  113. (when org-agenda-allow-remote-undo
  114. (setq ,c1 (org-verify-change-for-undo
  115. ,undo1 (with-current-buffer ,buf1 buffer-undo-list))
  116. ,c2 (org-verify-change-for-undo
  117. ,undo2 (with-current-buffer ,buf2 buffer-undo-list)))
  118. (when (or ,c1 ,c2)
  119. ;; make sure there are undo boundaries
  120. (and ,c1 (with-current-buffer ,buf1 (undo-boundary)))
  121. (and ,c2 (with-current-buffer ,buf2 (undo-boundary)))
  122. ;; remember which buffer to undo
  123. (push (list ,cmd ,cline ,buf1 ,c1 ,buf2 ,c2)
  124. org-agenda-undo-list))))))
  125. (defmacro org-no-read-only (&rest body)
  126. "Inhibit read-only for BODY."
  127. (declare (debug (body)))
  128. `(let ((inhibit-read-only t)) ,@body))
  129. (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
  130. rear-nonsticky t mouse-map t fontified t
  131. org-emphasis t)
  132. "Properties to remove when a string without properties is wanted.")
  133. (defsubst org-no-properties (s &optional restricted)
  134. "Remove all text properties from string S.
  135. When RESTRICTED is non-nil, only remove the properties listed
  136. in `org-rm-props'."
  137. (if (fboundp 'set-text-properties)
  138. (set-text-properties 0 (length s) nil s)
  139. (if restricted
  140. (remove-text-properties 0 (length s) org-rm-props s)
  141. (set-text-properties 0 (length s) nil s)))
  142. s)
  143. (defsubst org-get-alist-option (option key)
  144. (cond ((eq key t) t)
  145. ((eq option t) t)
  146. ((assoc key option) (cdr (assoc key option)))
  147. (t (let ((r (cdr (assq 'default option))))
  148. (if (listp r) (delq nil r) r)))))
  149. (defsubst org-check-external-command (cmd &optional use no-error)
  150. "Check if external program CMD for USE exists, error if not.
  151. When the program does exist, return its path.
  152. When it does not exist and NO-ERROR is set, return nil.
  153. Otherwise, throw an error. The optional argument USE can describe what this
  154. program is needed for, so that the error message can be more informative."
  155. (or (executable-find cmd)
  156. (if no-error
  157. nil
  158. (error "Can't find `%s'%s" cmd
  159. (if use (format " (%s)" use) "")))))
  160. (defsubst org-last (list)
  161. "Return the last element of LIST."
  162. (car (last list)))
  163. (defun org-let (list &rest body)
  164. (eval (cons 'let (cons list body))))
  165. (put 'org-let 'lisp-indent-function 1)
  166. (defun org-let2 (list1 list2 &rest body)
  167. (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body)))))))
  168. (put 'org-let2 'lisp-indent-function 2)
  169. (defsubst org-call-with-arg (command arg)
  170. "Call COMMAND interactively, but pretend prefix arg was ARG."
  171. (let ((current-prefix-arg arg)) (call-interactively command)))
  172. (defsubst org-current-line (&optional pos)
  173. (save-excursion
  174. (and pos (goto-char pos))
  175. ;; works also in narrowed buffer, because we start at 1, not point-min
  176. (+ (if (bolp) 1 0) (count-lines 1 (point)))))
  177. (defsubst org-goto-line (N)
  178. (save-restriction
  179. (widen)
  180. (goto-char (point-min))
  181. (forward-line (1- N))))
  182. (defsubst org-current-line-string (&optional to-here)
  183. (buffer-substring (point-at-bol) (if to-here (point) (point-at-eol))))
  184. (defsubst org-pos-in-match-range (pos n)
  185. (and (match-beginning n)
  186. (<= (match-beginning n) pos)
  187. (>= (match-end n) pos)))
  188. (defun org-match-line (re)
  189. "Looking-at at the beginning of the current line."
  190. (save-excursion
  191. (goto-char (point-at-bol))
  192. (looking-at re)))
  193. (defun org-plist-delete (plist property)
  194. "Delete PROPERTY from PLIST.
  195. This is in contrast to merely setting it to 0."
  196. (let (p)
  197. (while plist
  198. (if (not (eq property (car plist)))
  199. (setq p (plist-put p (car plist) (nth 1 plist))))
  200. (setq plist (cddr plist)))
  201. p))
  202. (defun org-replace-match-keep-properties (newtext &optional fixedcase
  203. literal string)
  204. "Like `replace-match', but add the text properties found original text."
  205. (setq newtext (org-add-props newtext (text-properties-at
  206. (match-beginning 0) string)))
  207. (replace-match newtext fixedcase literal string))
  208. (defmacro org-save-outline-visibility (use-markers &rest body)
  209. "Save and restore outline visibility around BODY.
  210. If USE-MARKERS is non-nil, use markers for the positions.
  211. This means that the buffer may change while running BODY,
  212. but it also means that the buffer should stay alive
  213. during the operation, because otherwise all these markers will
  214. point nowhere."
  215. (declare (debug (form body)) (indent 1))
  216. (org-with-gensyms (data)
  217. `(let ((,data (org-outline-overlay-data ,use-markers)))
  218. (unwind-protect
  219. (prog1 (progn ,@body)
  220. (org-set-outline-overlay-data ,data))
  221. (when ,use-markers
  222. (dolist (c ,data)
  223. (when (markerp (car c)) (move-marker (car c) nil))
  224. (when (markerp (cdr c)) (move-marker (cdr c) nil))))))))
  225. (defmacro org-with-wide-buffer (&rest body)
  226. "Execute body while temporarily widening the buffer."
  227. (declare (debug (body)))
  228. `(save-excursion
  229. (save-restriction
  230. (widen)
  231. ,@body)))
  232. (defmacro org-with-limited-levels (&rest body)
  233. "Execute BODY with limited number of outline levels."
  234. (declare (debug (body)))
  235. `(progn
  236. (defvar org-called-with-limited-levels)
  237. (defvar org-outline-regexp)
  238. (defvar outline-regexp)
  239. (defvar org-outline-regexp-bol)
  240. (let* ((org-called-with-limited-levels t)
  241. (org-outline-regexp (org-get-limited-outline-regexp))
  242. (outline-regexp org-outline-regexp)
  243. (org-outline-regexp-bol (concat "^" org-outline-regexp)))
  244. ,@body)))
  245. (defvar org-outline-regexp) ; defined in org.el
  246. (defvar org-odd-levels-only) ; defined in org.el
  247. (defvar org-inlinetask-min-level) ; defined in org-inlinetask.el
  248. (defun org-get-limited-outline-regexp ()
  249. "Return outline-regexp with limited number of levels.
  250. The number of levels is controlled by `org-inlinetask-min-level'"
  251. (cond ((not (derived-mode-p 'org-mode))
  252. outline-regexp)
  253. ((not (featurep 'org-inlinetask))
  254. org-outline-regexp)
  255. (t
  256. (let* ((limit-level (1- org-inlinetask-min-level))
  257. (nstars (if org-odd-levels-only
  258. (1- (* limit-level 2))
  259. limit-level)))
  260. (format "\\*\\{1,%d\\} " nstars)))))
  261. (defun org-format-seconds (string seconds)
  262. "Compatibility function replacing format-seconds."
  263. (if (fboundp 'format-seconds)
  264. (format-seconds string seconds)
  265. (format-time-string string (seconds-to-time seconds))))
  266. (defmacro org-eval-in-environment (environment form)
  267. (declare (debug (form form)) (indent 1))
  268. `(eval (list 'let ,environment ',form)))
  269. (defun org-make-parameter-alist (flat)
  270. "Return alist based on FLAT.
  271. FLAT is a list with alternating symbol names and values. The
  272. returned alist is a list of lists with the symbol name in car and
  273. the value in cdr."
  274. (when flat
  275. (cons (list (car flat) (cadr flat))
  276. (org-make-parameter-alist (cddr flat)))))
  277. ;;;###autoload
  278. (defmacro org-load-noerror-mustsuffix (file)
  279. "Load FILE with optional arguments NOERROR and MUSTSUFFIX."
  280. `(load ,file 'noerror nil nil 'mustsuffix))
  281. (provide 'org-macs)
  282. ;;; org-macs.el ends here