lisp/org-macs.el

   1 ;;; org-macs.el --- Top-level Definitions for Org -*- 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 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-not-nil (v)
  49   "If V not nil, and also not the string \"nil\", then return V.
  50 Otherwise return nil."
  51   (and v (not (equal v "nil")) v))
  52
  53 (defmacro org-preserve-lc (&rest body)
  54   (declare (debug (body)))
  55   (org-with-gensyms (line col)
  56     `(let ((,line (org-current-line))
  57            (,col (current-column)))
  58        (unwind-protect
  59            (progn ,@body)
  60          (org-goto-line ,line)
  61          (org-move-to-column ,col)))))
  62
  63 ;; Use `org-with-silent-modifications' to ignore cosmetic changes and
  64 ;; `org-unmodified' to ignore real text modifications
  65 (defmacro org-unmodified (&rest body)
  66   "Run BODY while preserving the buffer's `buffer-modified-p' state."
  67   (declare (debug (body)))
  68   (org-with-gensyms (was-modified)
  69     `(let ((,was-modified (buffer-modified-p)))
  70        (unwind-protect
  71            (let ((buffer-undo-list t)
  72                  (inhibit-modification-hooks t))
  73              ,@body)
  74          (set-buffer-modified-p ,was-modified)))))
  75
  76 (defmacro org-without-partial-completion (&rest body)
  77   (declare (debug (body)))
  78   `(if (and (boundp 'partial-completion-mode)
  79             partial-completion-mode
  80             (fboundp 'partial-completion-mode))
  81        (unwind-protect
  82            (progn
  83              (partial-completion-mode -1)
  84              ,@body)
  85          (partial-completion-mode 1))
  86      ,@body))
  87
  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
  99 (defmacro org-with-remote-undo (buffer &rest body)
 100   "Execute BODY while recording undo information in two buffers."
 101   (declare (debug (form body)) (indent 1))
 102   (org-with-gensyms (cline cmd buf1 buf2 undo1 undo2 c1 c2)
 103     `(let ((,cline (org-current-line))
 104            (,cmd this-command)
 105            (,buf1 (current-buffer))
 106            (,buf2 ,buffer)
 107            (,undo1 buffer-undo-list)
 108            (,undo2 (with-current-buffer ,buffer buffer-undo-list))
 109            ,c1 ,c2)
 110        ,@body
 111        (when org-agenda-allow-remote-undo
 112          (setq ,c1 (org-verify-change-for-undo
 113                     ,undo1 (with-current-buffer ,buf1 buffer-undo-list))
 114                ,c2 (org-verify-change-for-undo
 115                     ,undo2 (with-current-buffer ,buf2 buffer-undo-list)))
 116          (when (or ,c1 ,c2)
 117            ;; make sure there are undo boundaries
 118            (and ,c1 (with-current-buffer ,buf1 (undo-boundary)))
 119            (and ,c2 (with-current-buffer ,buf2 (undo-boundary)))
 120            ;; remember which buffer to undo
 121            (push (list ,cmd ,cline ,buf1 ,c1 ,buf2 ,c2)
 122                  org-agenda-undo-list))))))
 123
 124 (defmacro org-no-read-only (&rest body)
 125   "Inhibit read-only for BODY."
 126   (declare (debug (body)))
 127   `(let ((inhibit-read-only t)) ,@body))
 128
 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
 134 (defsubst org-no-properties (s &optional restricted)
 135   "Remove all text properties from string S.
 136 When RESTRICTED is non-nil, only remove the properties listed
 137 in `org-rm-props'."
 138   (if restricted (remove-text-properties 0 (length s) org-rm-props s)
 139     (set-text-properties 0 (length s) nil s))
 140   s)
 141
 142 (defsubst org-get-alist-option (option key)
 143   (cond ((eq key t) t)
 144         ((eq option t) t)
 145         ((assoc key option) (cdr (assoc key option)))
 146         (t (let ((r (cdr (assq 'default option))))
 147              (if (listp r) (delq nil r) r)))))
 148
 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
 161 (defsubst org-last (list)
 162   "Return the last element of LIST."
 163   (car (last list)))
 164
 165 (defun org-let (list &rest body)
 166   (eval (cons 'let (cons list body))))
 167 (put 'org-let 'lisp-indent-function 1)
 168
 169 (defun org-let2 (list1 list2 &rest body)
 170   (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body)))))))
 171 (put 'org-let2 'lisp-indent-function 2)
 172
 173 (defsubst org-call-with-arg (command arg)
 174   "Call COMMAND interactively, but pretend prefix arg was ARG."
 175   (let ((current-prefix-arg arg)) (call-interactively command)))
 176
 177 (defsubst org-current-line (&optional pos)
 178   (save-excursion
 179     (and pos (goto-char pos))
 180     ;; works also in narrowed buffer, because we start at 1, not point-min
 181     (+ (if (bolp) 1 0) (count-lines 1 (point)))))
 182
 183 (defsubst org-goto-line (N)
 184   (save-restriction
 185     (widen)
 186     (goto-char (point-min))
 187     (forward-line (1- N))))
 188
 189 (defsubst org-current-line-string (&optional to-here)
 190   (buffer-substring (point-at-bol) (if to-here (point) (point-at-eol))))
 191
 192 (defsubst org-pos-in-match-range (pos n)
 193   (and (match-beginning n)
 194        (<= (match-beginning n) pos)
 195        (>= (match-end n) pos)))
 196
 197 (defun org-match-line (re)
 198   "Looking-at at the beginning of the current line."
 199   (save-excursion
 200     (goto-char (point-at-bol))
 201     (looking-at re)))
 202
 203 (defun org-plist-delete (plist property)
 204   "Delete PROPERTY from PLIST.
 205 This is in contrast to merely setting it to 0."
 206   (let (p)
 207     (while plist
 208       (if (not (eq property (car plist)))
 209           (setq p (plist-put p (car plist) (nth 1 plist))))
 210       (setq plist (cddr plist)))
 211     p))
 212
 213 (defmacro org-save-outline-visibility (use-markers &rest body)
 214   "Save and restore outline visibility around BODY.
 215 If USE-MARKERS is non-nil, use markers for the positions.
 216 This means that the buffer may change while running BODY,
 217 but it also means that the buffer should stay alive
 218 during the operation, because otherwise all these markers will
 219 point nowhere."
 220   (declare (debug (form body)) (indent 1))
 221   (org-with-gensyms (data)
 222     `(let ((,data (org-outline-overlay-data ,use-markers)))
 223        (unwind-protect
 224            (prog1 (progn ,@body)
 225              (org-set-outline-overlay-data ,data))
 226          (when ,use-markers
 227            (dolist (c ,data)
 228              (when (markerp (car c)) (move-marker (car c) nil))
 229              (when (markerp (cdr c)) (move-marker (cdr c) nil))))))))
 230
 231 (defmacro org-with-wide-buffer (&rest body)
 232   "Execute body while temporarily widening the buffer."
 233   (declare (debug (body)))
 234   `(save-excursion
 235      (save-restriction
 236        (widen)
 237        ,@body)))
 238
 239 (defmacro org-with-limited-levels (&rest body)
 240   "Execute BODY with limited number of outline levels."
 241   (declare (debug (body)))
 242   `(progn
 243      (defvar org-called-with-limited-levels)
 244      (defvar org-outline-regexp)
 245      (defvar outline-regexp)
 246      (defvar org-outline-regexp-bol)
 247      (let* ((org-called-with-limited-levels t)
 248             (org-outline-regexp (org-get-limited-outline-regexp))
 249             (outline-regexp org-outline-regexp)
 250             (org-outline-regexp-bol (concat "^" org-outline-regexp)))
 251        ,@body)))
 252
 253 (defvar org-outline-regexp) ; defined in org.el
 254 (defvar org-odd-levels-only) ; defined in org.el
 255 (defvar org-inlinetask-min-level) ; defined in org-inlinetask.el
 256 (defun org-get-limited-outline-regexp ()
 257   "Return outline-regexp with limited number of levels.
 258 The number of levels is controlled by `org-inlinetask-min-level'"
 259   (cond ((not (derived-mode-p 'org-mode))
 260          outline-regexp)
 261         ((not (featurep 'org-inlinetask))
 262          org-outline-regexp)
 263         (t
 264          (let* ((limit-level (1- org-inlinetask-min-level))
 265                 (nstars (if org-odd-levels-only
 266                             (1- (* limit-level 2))
 267                           limit-level)))
 268            (format "\\*\\{1,%d\\} " nstars)))))
 269
 270 (defmacro org-eval-in-environment (environment form)
 271   (declare (debug (form form)) (indent 1))
 272   `(eval (list 'let ,environment ',form)))
 273
 274 (defun org-make-parameter-alist (flat)
 275   "Return alist based on FLAT.
 276 FLAT is a list with alternating symbol names and values.  The
 277 returned alist is a list of lists with the symbol name in car and
 278 the value in cdr."
 279   (when flat
 280     (cons (list (car flat) (cadr flat))
 281           (org-make-parameter-alist (cddr flat)))))
 282
 283 ;;;###autoload
 284 (defmacro org-load-noerror-mustsuffix (file)
 285   "Load FILE with optional arguments NOERROR and MUSTSUFFIX."
 286   `(load ,file 'noerror nil nil 'mustsuffix))
 287
 288 (defun org-unbracket-string (pre post string)
 289   "Remove PRE/POST from the beginning/end of STRING.
 290 Both PRE and POST must be pre-/suffixes of STRING, or neither is
 291 removed."
 292   (if (and (string-prefix-p pre string)
 293            (string-suffix-p post string))
 294       (substring string (length pre) (- (length post)))
 295     string))
 296
 297 (provide 'org-macs)
 298
 299 ;;; org-macs.el ends here