lisp/org-macro.el

   1 ;;; org-macro.el --- Macro Replacement Code for Org  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Nicolas Goaziou <n.goaziou@gmail.com>
   6 ;; Keywords: outlines, hypermedia, calendar, wp
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Macros are expanded with `org-macro-replace-all', which relies
  26 ;; internally on `org-macro-expand'.
  27
  28 ;; Default templates for expansion are stored in the buffer-local
  29 ;; variable `org-macro-templates'.  This variable is updated by
  30 ;; `org-macro-initialize-templates', which recursively calls
  31 ;; `org-macro--collect-macros' in order to read setup files.
  32
  33 ;; Argument in macros are separated with commas. Proper escaping rules
  34 ;; are implemented in `org-macro-escape-arguments' and arguments can
  35 ;; be extracted from a string with `org-macro-extract-arguments'.
  36
  37 ;; Along with macros defined through #+MACRO: keyword, default
  38 ;; templates include the following hard-coded macros:
  39 ;;   {{{time(format-string)}}},
  40 ;;   {{{property(node-property)}}},
  41 ;;   {{{input-file}}},
  42 ;;   {{{modification-time(format-string)}}},
  43 ;;   {{{n(counter,action}}}.
  44
  45 ;; Upon exporting, "ox.el" will also provide {{{author}}}, {{{date}}},
  46 ;; {{{email}}} and {{{title}}} macros.
  47
  48 ;;; Code:
  49 (require 'cl-lib)
  50 (require 'org-macs)
  51 (require 'org-compat)
  52
  53 (declare-function org-element-at-point "org-element" ())
  54 (declare-function org-element-context "org-element" (&optional element))
  55 (declare-function org-element-copy "org-element" (datum))
  56 (declare-function org-element-macro-parser "org-element" ())
  57 (declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
  58 (declare-function org-element-property "org-element" (property element))
  59 (declare-function org-element-restriction "org-element" (element))
  60 (declare-function org-element-type "org-element" (element))
  61 (declare-function org-file-contents "org" (file &optional noerror nocache))
  62 (declare-function org-file-url-p "org" (file))
  63 (declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
  64 (declare-function org-mode "org" ())
  65 (declare-function org-trim "org" (s &optional keep-lead))
  66 (declare-function vc-backend "vc-hooks" (f))
  67 (declare-function vc-call "vc-hooks" (fun file &rest args) t)
  68 (declare-function vc-exec-after "vc-dispatcher" (code))
  69
  70 ;;; Variables
  71
  72 (defvar-local org-macro-templates nil
  73   "Alist containing all macro templates in current buffer.
  74 Associations are in the shape of (NAME . TEMPLATE) where NAME
  75 stands for macro's name and template for its replacement value,
  76 both as strings.  This is an internal variable.  Do not set it
  77 directly, use instead:
  78
  79   #+MACRO: name template")
  80
  81 ;;; Functions
  82
  83 (defun org-macro--collect-macros ()
  84   "Collect macro definitions in current buffer and setup files.
  85 Return an alist containing all macro templates found."
  86   (letrec ((collect-macros
  87             (lambda (files templates)
  88               ;; Return an alist of macro templates.  FILES is a list
  89               ;; of setup files names read so far, used to avoid
  90               ;; circular dependencies.  TEMPLATES is the alist
  91               ;; collected so far.
  92               (let ((case-fold-search t))
  93                 (org-with-wide-buffer
  94                  (goto-char (point-min))
  95                  (while (re-search-forward
  96                          "^[ \t]*#\\+\\(MACRO\\|SETUPFILE\\):" nil t)
  97                    (let ((element (org-element-at-point)))
  98                      (when (eq (org-element-type element) 'keyword)
  99                        (let ((val (org-element-property :value element)))
 100                          (if (equal (org-element-property :key element) "MACRO")
 101                              ;; Install macro in TEMPLATES.
 102                              (when (string-match
 103                                     "^\\(.*?\\)\\(?:\\s-+\\(.*\\)\\)?\\s-*$" val)
 104                                (let* ((name (match-string 1 val))
 105                                       (template (or (match-string 2 val) ""))
 106                                       (old-cell (assoc name templates)))
 107                                  (if old-cell (setcdr old-cell template)
 108                                    (push (cons name template) templates))))
 109                            ;; Enter setup file.
 110                            (let* ((uri (org-unbracket-string "\"" "\"" (org-trim val)))
 111                                   (uri-is-url (org-file-url-p uri))
 112                                   (uri (if uri-is-url
 113                                            uri
 114                                          (expand-file-name uri))))
 115                              ;; Avoid circular dependencies.
 116                              (unless (member uri files)
 117                                (with-temp-buffer
 118                                  (unless uri-is-url
 119                                    (setq default-directory
 120                                          (file-name-directory uri)))
 121                                  (org-mode)
 122                                  (insert (org-file-contents uri 'noerror))
 123                                  (setq templates
 124                                        (funcall collect-macros (cons uri files)
 125                                                 templates)))))))))))
 126                 templates))))
 127     (funcall collect-macros nil nil)))
 128
 129 (defun org-macro-initialize-templates ()
 130   "Collect macro templates defined in current buffer.
 131 Templates are stored in buffer-local variable
 132 `org-macro-templates'.  In addition to buffer-defined macros, the
 133 function installs the following ones: \"property\",
 134 \"time\". and, if the buffer is associated to a file,
 135 \"input-file\" and \"modification-time\"."
 136   (let* ((templates (org-macro--collect-macros))
 137          (update-templates
 138           (lambda (cell)
 139             (let ((old-template (assoc (car cell) templates)))
 140               (if old-template (setcdr old-template (cdr cell))
 141                 (push cell templates))))))
 142     ;; Install "author, "date, "email", "keyword", "title" and
 143     ;; "results" macros.
 144     (mapc update-templates
 145           (list
 146            (cons "author" (org-macro--find-keyword-value "AUTHOR"))
 147            (cons "date"
 148                  (let* ((value (org-macro--find-keyword-value "DATE"))
 149                         (date (org-element-parse-secondary-string
 150                                value (org-element-restriction 'keyword))))
 151                    (if (and (consp date)
 152                             (not (cdr date))
 153                             (eq (org-element-type (car date)) 'timestamp))
 154                        (format "(eval (if (org-string-nw-p $1) %s %S))"
 155                                (format "(org-timestamp-format '%S $1)"
 156                                        (org-element-copy (car date)))
 157                                value)
 158                      value)))
 159            (cons "email" (org-macro--find-keyword-value "EMAIL"))
 160            (cons "keyword" "(eval (org-macro--find-keyword-value $1))")
 161            (cons "results" "$1")
 162            (cons "title" (org-macro--find-keyword-value "TITLE"))))
 163     ;; Install "property", "time" macros.
 164     (mapc update-templates
 165           (list (cons "property"
 166                       "(eval (save-excursion
 167         (let ((l $2))
 168           (when (org-string-nw-p l)
 169             (condition-case _
 170                 (let ((org-link-search-must-match-exact-headline t))
 171                   (org-link-search l nil t))
 172               (error
 173                (error \"Macro property failed: cannot find location %s\"
 174                       l)))))
 175         (org-entry-get nil $1 'selective)))")
 176                 (cons "time" "(eval (format-time-string $1))")))
 177     ;; Install "input-file", "modification-time" macros.
 178     (let ((visited-file (buffer-file-name (buffer-base-buffer))))
 179       (when (and visited-file (file-exists-p visited-file))
 180         (mapc update-templates
 181               (list (cons "input-file" (file-name-nondirectory visited-file))
 182                     (cons "modification-time"
 183                           (format "(eval
 184 \(format-time-string $1
 185                      (or (and (org-string-nw-p $2)
 186                               (org-macro--vc-modified-time %s))
 187                      '%s)))"
 188                                   (prin1-to-string visited-file)
 189                                   (prin1-to-string
 190                                    (nth 5 (file-attributes visited-file)))))))))
 191     ;; Initialize and install "n" macro.
 192     (org-macro--counter-initialize)
 193     (funcall update-templates
 194              (cons "n" "(eval (org-macro--counter-increment $1 $2))"))
 195     (setq org-macro-templates templates)))
 196
 197 (defun org-macro-expand (macro templates)
 198   "Return expanded MACRO, as a string.
 199 MACRO is an object, obtained, for example, with
 200 `org-element-context'.  TEMPLATES is an alist of templates used
 201 for expansion.  See `org-macro-templates' for a buffer-local
 202 default value.  Return nil if no template was found."
 203   (let ((template
 204          ;; Macro names are case-insensitive.
 205          (cdr (assoc-string (org-element-property :key macro) templates t))))
 206     (when template
 207       (let* ((eval? (string-match-p "\\`(eval\\>" template))
 208              (value
 209               (replace-regexp-in-string
 210                "\\$[0-9]+"
 211                (lambda (m)
 212                  (let ((arg (or (nth (1- (string-to-number (substring m 1)))
 213                                      (org-element-property :args macro))
 214                                 ;; No argument: remove place-holder.
 215                                 "")))
 216                    ;; `eval' implies arguments are strings.
 217                    (if eval? (format "%S" arg) arg)))
 218                template nil 'literal)))
 219         (when eval?
 220           (setq value (eval (condition-case nil (read value)
 221                               (error (debug))))))
 222         ;; Force return value to be a string.
 223         (format "%s" (or value ""))))))
 224
 225 (defun org-macro-replace-all (templates &optional keywords)
 226   "Replace all macros in current buffer by their expansion.
 227
 228 TEMPLATES is an alist of templates used for expansion.  See
 229 `org-macro-templates' for a buffer-local default value.
 230
 231 Optional argument KEYWORDS, when non-nil is a list of keywords,
 232 as strings, where macro expansion is allowed.
 233
 234 Return an error if a macro in the buffer cannot be associated to
 235 a definition in TEMPLATES."
 236   (org-with-wide-buffer
 237    (goto-char (point-min))
 238    (let ((properties-regexp (format "\\`EXPORT_%s\\+?\\'"
 239                                     (regexp-opt keywords)))
 240          record)
 241      (while (re-search-forward "{{{[-A-Za-z0-9_]" nil t)
 242        (unless (save-match-data (org-in-commented-heading-p))
 243          (let* ((datum (save-match-data (org-element-context)))
 244                 (type (org-element-type datum))
 245                 (macro
 246                  (cond
 247                   ((eq type 'macro) datum)
 248                   ;; In parsed keywords and associated node
 249                   ;; properties, force macro recognition.
 250                   ((or (and (eq type 'keyword)
 251                             (member (org-element-property :key datum) keywords))
 252                        (and (eq type 'node-property)
 253                             (string-match-p properties-regexp
 254                                             (org-element-property :key datum))))
 255                    (save-excursion
 256                      (goto-char (match-beginning 0))
 257                      (org-element-macro-parser))))))
 258            (when macro
 259              (let* ((value (org-macro-expand macro templates))
 260                     (begin (org-element-property :begin macro))
 261                     (signature (list begin
 262                                      macro
 263                                      (org-element-property :args macro))))
 264                ;; Avoid circular dependencies by checking if the same
 265                ;; macro with the same arguments is expanded at the
 266                ;; same position twice.
 267                (cond ((member signature record)
 268                       (error "Circular macro expansion: %s"
 269                              (org-element-property :key macro)))
 270                      (value
 271                       (push signature record)
 272                       (delete-region
 273                        begin
 274                        ;; Preserve white spaces after the macro.
 275                        (progn (goto-char (org-element-property :end macro))
 276                               (skip-chars-backward " \t")
 277                               (point)))
 278                       ;; Leave point before replacement in case of
 279                       ;; recursive expansions.
 280                       (save-excursion (insert value)))
 281                      (t
 282                       (error "Undefined Org macro: %s; aborting"
 283                              (org-element-property :key macro))))))))))))
 284
 285 (defun org-macro-escape-arguments (&rest args)
 286   "Build macro's arguments string from ARGS.
 287 ARGS are strings.  Return value is a string with arguments
 288 properly escaped and separated with commas.  This is the opposite
 289 of `org-macro-extract-arguments'."
 290   (let ((s ""))
 291     (dolist (arg (reverse args) (substring s 1))
 292       (setq s
 293             (concat
 294              ","
 295              (replace-regexp-in-string
 296               "\\(\\\\*\\),"
 297               (lambda (m)
 298                 (concat (make-string (1+ (* 2 (length (match-string 1 m)))) ?\\)
 299                         ","))
 300               ;; If a non-terminal argument ends on backslashes, make
 301               ;; sure to also escape them as they will be followed by
 302               ;; a comma.
 303               (concat arg (and (not (equal s ""))
 304                                (string-match "\\\\+\\'" arg)
 305                                (match-string 0 arg)))
 306               nil t)
 307              s)))))
 308
 309 (defun org-macro-extract-arguments (s)
 310   "Extract macro arguments from string S.
 311 S is a string containing comma separated values properly escaped.
 312 Return a list of arguments, as strings.  This is the opposite of
 313 `org-macro-escape-arguments'."
 314   ;; Do not use `org-split-string' since empty strings are
 315   ;; meaningful here.
 316   (split-string
 317    (replace-regexp-in-string
 318     "\\(\\\\*\\),"
 319     (lambda (str)
 320       (let ((len (length (match-string 1 str))))
 321         (concat (make-string (/ len 2) ?\\)
 322                 (if (zerop (mod len 2)) "\000" ","))))
 323     s nil t)
 324    "\000"))
 325
 326 \f
 327 ;;; Helper functions and variables for internal macros
 328
 329 (defun org-macro--find-keyword-value (name)
 330   "Find value for keyword NAME in current buffer.
 331 KEYWORD is a string.  Return value associated to the keywords
 332 named after NAME, as a string, or nil."
 333   (org-with-point-at 1
 334     (let ((regexp (format "^[ \t]*#\\+%s:" (regexp-quote name)))
 335           (case-fold-search t)
 336           (result nil))
 337       (while (re-search-forward regexp nil t)
 338         (let ((element (org-element-at-point)))
 339           (when (eq 'keyword (org-element-type element))
 340             (setq result (concat result
 341                                  " "
 342                                  (org-element-property :value element))))))
 343       (and result (org-trim result)))))
 344
 345 (defun org-macro--vc-modified-time (file)
 346   (save-window-excursion
 347     (when (vc-backend file)
 348       (let ((buf (get-buffer-create " *org-vc*"))
 349             (case-fold-search t)
 350             date)
 351         (unwind-protect
 352             (progn
 353               (vc-call print-log file buf nil nil 1)
 354               (with-current-buffer buf
 355                 (vc-exec-after
 356                  (lambda ()
 357                    (goto-char (point-min))
 358                    (when (re-search-forward "Date:?[ \t]*" nil t)
 359                      (let ((time (parse-time-string
 360                                   (buffer-substring
 361                                    (point) (line-end-position)))))
 362                        (when (cl-some #'identity time)
 363                          (setq date (apply #'encode-time time))))))))
 364               (let ((proc (get-buffer-process buf)))
 365                 (while (and proc (accept-process-output proc .5 nil t)))))
 366           (kill-buffer buf))
 367         date))))
 368
 369 (defvar org-macro--counter-table nil
 370   "Hash table containing counter value per name.")
 371
 372 (defun org-macro--counter-initialize ()
 373   "Initialize `org-macro--counter-table'."
 374   (setq org-macro--counter-table (make-hash-table :test #'equal)))
 375
 376 (defun org-macro--counter-increment (name &optional action)
 377   "Increment counter NAME.
 378 NAME is a string identifying the counter.
 379
 380 When non-nil, optional argument ACTION is a string.
 381
 382 If the string is \"-\", keep the NAME counter at its current
 383 value, i.e. do not increment.
 384
 385 If the string represents an integer, set the counter to this number.
 386
 387 Any other non-empty string resets the counter to 1."
 388   (let ((name-trimmed (org-trim name))
 389         (action-trimmed (when (org-string-nw-p action)
 390                           (org-trim action))))
 391     (puthash name-trimmed
 392              (cond ((not (org-string-nw-p action-trimmed))
 393                     (1+ (gethash name-trimmed org-macro--counter-table 0)))
 394                    ((string= "-" action-trimmed)
 395                     (gethash name-trimmed org-macro--counter-table 1))
 396                    ((string-match-p "\\`[0-9]+\\'" action-trimmed)
 397                     (string-to-number action-trimmed))
 398                    (t 1))
 399              org-macro--counter-table)))
 400
 401
 402 (provide 'org-macro)
 403 ;;; org-macro.el ends here