diff options
Diffstat (limited to 'lisp/org-element.el')
| -rw-r--r-- | lisp/org-element.el | 4857 |
1 files changed, 2919 insertions, 1938 deletions
diff --git a/lisp/org-element.el b/lisp/org-element.el index eb8ff41..c7e76e8 100644 --- a/lisp/org-element.el +++ b/lisp/org-element.el @@ -1,6 +1,6 @@ ;;; org-element.el --- Parser And Applications for Org syntax -;; Copyright (C) 2012-2014 Free Software Foundation, Inc. +;; Copyright (C) 2012-2015 Free Software Foundation, Inc. ;; Author: Nicolas Goaziou <n.goaziou at gmail dot com> ;; Keywords: outlines, hypermedia, calendar, wp @@ -31,7 +31,7 @@ ;; ;; An element always starts and ends at the beginning of a line. With ;; a few exceptions (`clock', `headline', `inlinetask', `item', -;; `planning', `node-property', `quote-section' `section' and +;; `planning', `property-drawer', `node-property', `section' and ;; `table-row' types), it can also accept a fixed set of keywords as ;; attributes. Those are called "affiliated keywords" to distinguish ;; them from other keywords, which are full-fledged elements. Almost @@ -48,10 +48,9 @@ ;; Other element types are: `babel-call', `clock', `comment', ;; `comment-block', `diary-sexp', `example-block', `export-block', ;; `fixed-width', `horizontal-rule', `keyword', `latex-environment', -;; `node-property', `paragraph', `planning', `quote-section', -;; `src-block', `table', `table-row' and `verse-block'. Among them, -;; `paragraph' and `verse-block' types can contain Org objects and -;; plain text. +;; `node-property', `paragraph', `planning', `src-block', `table', +;; `table-row' and `verse-block'. Among them, `paragraph' and +;; `verse-block' types can contain Org objects and plain text. ;; ;; Objects are related to document's contents. Some of them are ;; recursive. Associated types are of the following: `bold', `code', @@ -75,9 +74,9 @@ ;; refers to the element or object containing it. Greater elements, ;; elements and objects containing objects will also have ;; `:contents-begin' and `:contents-end' properties to delimit -;; contents. Eventually, greater elements and elements accepting -;; affiliated keywords will have a `:post-affiliated' property, -;; referring to the buffer position after all such keywords. +;; contents. Eventually, All elements have a `:post-affiliated' +;; property referring to the buffer position after all affiliated +;; keywords, if any, or to their beginning position otherwise. ;; ;; At the lowest level, a `:parent' property is also attached to any ;; string, as a text property. @@ -111,13 +110,15 @@ ;; ;; The library ends by furnishing `org-element-at-point' function, and ;; a way to give information about document structure around point -;; with `org-element-context'. +;; with `org-element-context'. A cache mechanism is also provided for +;; these functions. ;;; Code: (eval-when-compile (require 'cl)) (require 'org) +(require 'avl-tree) @@ -127,56 +128,111 @@ ;; along with the affiliated keywords recognized. Also set up ;; restrictions on recursive objects combinations. ;; -;; These variables really act as a control center for the parsing -;; process. - -(defconst org-element-paragraph-separate - (concat "^\\(?:" - ;; Headlines, inlinetasks. - org-outline-regexp "\\|" - ;; Footnote definitions. - "\\[\\(?:[0-9]+\\|fn:[-_[:word:]]+\\)\\]" "\\|" - ;; Diary sexps. - "%%(" "\\|" - "[ \t]*\\(?:" - ;; Empty lines. - "$" "\\|" - ;; Tables (any type). - "\\(?:|\\|\\+-[-+]\\)" "\\|" - ;; Blocks (any type), Babel calls and keywords. Note: this - ;; is only an indication and need some thorough check. - "#\\(?:[+ ]\\|$\\)" "\\|" - ;; Drawers (any type) and fixed-width areas. This is also - ;; only an indication. - ":" "\\|" - ;; Horizontal rules. - "-\\{5,\\}[ \t]*$" "\\|" - ;; LaTeX environments. - "\\\\begin{\\([A-Za-z0-9]+\\*?\\)}" "\\|" - ;; Planning and Clock lines. - (regexp-opt (list org-scheduled-string - org-deadline-string - org-closed-string - org-clock-string)) - "\\|" - ;; Lists. - (let ((term (case org-plain-list-ordered-item-terminator - (?\) ")") (?. "\\.") (otherwise "[.)]"))) - (alpha (and org-list-allow-alphabetical "\\|[A-Za-z]"))) - (concat "\\(?:[-+*]\\|\\(?:[0-9]+" alpha "\\)" term "\\)" - "\\(?:[ \t]\\|$\\)")) - "\\)\\)") +;; `org-element-update-syntax' builds proper syntax regexps according +;; to current setup. + +(defvar org-element-paragraph-separate nil "Regexp to separate paragraphs in an Org buffer. In the case of lines starting with \"#\" and \":\", this regexp is not sufficient to know if point is at a paragraph ending. See `org-element-paragraph-parser' for more information.") +(defvar org-element--object-regexp nil + "Regexp possibly matching the beginning of an object. +This regexp allows false positives. Dedicated parser (e.g., +`org-export-bold-parser') will take care of further filtering. +Radio links are not matched by this regexp, as they are treated +specially in `org-element--object-lex'.") + +(defun org-element--set-regexps () + "Build variable syntax regexps." + (setq org-element-paragraph-separate + (concat "^\\(?:" + ;; Headlines, inlinetasks. + org-outline-regexp "\\|" + ;; Footnote definitions. + "\\[\\(?:[0-9]+\\|fn:[-_[:word:]]+\\)\\]" "\\|" + ;; Diary sexps. + "%%(" "\\|" + "[ \t]*\\(?:" + ;; Empty lines. + "$" "\\|" + ;; Tables (any type). + "|" "\\|" + "\\+\\(?:-+\\+\\)+[ \t]*$" "\\|" + ;; Comments, keyword-like or block-like constructs. + ;; Blocks and keywords with dual values need to be + ;; double-checked. + "#\\(?: \\|$\\|\\+\\(?:" + "BEGIN_\\S-+" "\\|" + "\\S-+\\(?:\\[.*\\]\\)?:[ \t]*\\)\\)" + "\\|" + ;; Drawers (any type) and fixed-width areas. Drawers + ;; need to be double-checked. + ":\\(?: \\|$\\|[-_[:word:]]+:[ \t]*$\\)" "\\|" + ;; Horizontal rules. + "-\\{5,\\}[ \t]*$" "\\|" + ;; LaTeX environments. + "\\\\begin{\\([A-Za-z0-9*]+\\)}" "\\|" + ;; Clock lines. + (regexp-quote org-clock-string) "\\|" + ;; Lists. + (let ((term (case org-plain-list-ordered-item-terminator + (?\) ")") (?. "\\.") (otherwise "[.)]"))) + (alpha (and org-list-allow-alphabetical "\\|[A-Za-z]"))) + (concat "\\(?:[-+*]\\|\\(?:[0-9]+" alpha "\\)" term "\\)" + "\\(?:[ \t]\\|$\\)")) + "\\)\\)") + org-element--object-regexp + (mapconcat #'identity + (let ((link-types (regexp-opt org-link-types))) + (list + ;; Sub/superscript. + "\\(?:[_^][-{(*+.,[:alnum:]]\\)" + ;; Bold, code, italic, strike-through, underline + ;; and verbatim. + (concat "[*~=+_/]" + (format "[^%s]" + (nth 2 org-emphasis-regexp-components))) + ;; Plain links. + (concat "\\<" link-types ":") + ;; Objects starting with "[": regular link, + ;; footnote reference, statistics cookie, + ;; timestamp (inactive). + "\\[\\(?:fn:\\|\\(?:[0-9]\\|\\(?:%\\|/[0-9]*\\)\\]\\)\\|\\[\\)" + ;; Objects starting with "@": export snippets. + "@@" + ;; Objects starting with "{": macro. + "{{{" + ;; Objects starting with "<" : timestamp + ;; (active, diary), target, radio target and + ;; angular links. + (concat "<\\(?:%%\\|<\\|[0-9]\\|" link-types "\\)") + ;; Objects starting with "$": latex fragment. + "\\$" + ;; Objects starting with "\": line break, + ;; entity, latex fragment. + "\\\\\\(?:[a-zA-Z[(]\\|\\\\[ \t]*$\\|_ +\\)" + ;; Objects starting with raw text: inline Babel + ;; source block, inline Babel call. + "\\(?:call\\|src\\)_")) + "\\|"))) + +(org-element--set-regexps) + +;;;###autoload +(defun org-element-update-syntax () + "Update parser internals." + (interactive) + (org-element--set-regexps) + (org-element-cache-reset 'all)) + (defconst org-element-all-elements '(babel-call center-block clock comment comment-block diary-sexp drawer dynamic-block example-block export-block fixed-width footnote-definition headline horizontal-rule inlinetask item keyword latex-environment node-property paragraph plain-list - planning property-drawer quote-block quote-section section + planning property-drawer quote-block section special-block src-block table table-row verse-block) "Complete list of element types.") @@ -186,23 +242,6 @@ is not sufficient to know if point is at a paragraph ending. See special-block table) "List of recursive element types aka Greater Elements.") -(defconst org-element-all-successors - '(link export-snippet footnote-reference inline-babel-call - inline-src-block latex-or-entity line-break macro plain-link - radio-target statistics-cookie sub/superscript table-cell target - text-markup timestamp) - "Complete list of successors.") - -(defconst org-element-object-successor-alist - '((subscript . sub/superscript) (superscript . sub/superscript) - (bold . text-markup) (code . text-markup) (italic . text-markup) - (strike-through . text-markup) (underline . text-markup) - (verbatim . text-markup) (entity . latex-or-entity) - (latex-fragment . latex-or-entity)) - "Alist of translations between object type and successor name. -Sharing the same successor comes handy when, for example, the -regexp matching one object can also match the other object.") - (defconst org-element-all-objects '(bold code entity export-snippet footnote-reference inline-babel-call inline-src-block italic line-break latex-fragment link macro @@ -211,10 +250,14 @@ regexp matching one object can also match the other object.") "Complete list of object types.") (defconst org-element-recursive-objects - '(bold italic link subscript radio-target strike-through superscript - table-cell underline) + '(bold footnote-reference italic link subscript radio-target strike-through + superscript table-cell underline) "List of recursive object types.") +(defconst org-element-object-containers + (append org-element-recursive-objects '(paragraph table-row verse-block)) + "List of object or element types that can directly contain objects.") + (defvar org-element-block-name-alist '(("CENTER" . org-element-center-block-parser) ("COMMENT" . org-element-comment-block-parser) @@ -226,12 +269,6 @@ regexp matching one object can also match the other object.") Names must be uppercase. Any block whose name has no association is parsed with `org-element-special-block-parser'.") -(defconst org-element-link-type-is-file - '("file" "file+emacs" "file+sys" "docview") - "List of link types equivalent to \"file\". -Only these types can accept search options and an explicit -application to open them.") - (defconst org-element-affiliated-keywords '("CAPTION" "DATA" "HEADER" "HEADERS" "LABEL" "NAME" "PLOT" "RESNAME" "RESULT" "RESULTS" "SOURCE" "SRCNAME" "TBLNAME") @@ -268,6 +305,13 @@ strings and objects. This list is checked after translations have been applied. See `org-element-keyword-translation-alist'.") +(defconst org-element--parsed-properties-alist + (mapcar (lambda (k) (cons k (intern (concat ":" (downcase k))))) + org-element-parsed-keywords) + "Alist of parsed keywords and associated properties. +This is generated from `org-element-parsed-keywords', which +see.") + (defconst org-element-dual-keywords '("CAPTION" "RESULTS") "List of affiliated keywords which can have a secondary value. @@ -280,13 +324,8 @@ associated to a hash value with the following: This list is checked after translations have been applied. See `org-element-keyword-translation-alist'.") -(defconst org-element-document-properties '("AUTHOR" "DATE" "TITLE") - "List of properties associated to the whole document. -Any keyword in this list will have its value parsed and stored as -a secondary string.") - (defconst org-element--affiliated-re - (format "[ \t]*#\\+\\(?:%s\\):\\(?: \\|$\\)" + (format "[ \t]*#\\+\\(?:%s\\):[ \t]*" (concat ;; Dual affiliated keywords. (format "\\(?1:%s\\)\\(?:\\[\\(.*\\)\\]\\)?" @@ -296,8 +335,7 @@ a secondary string.") (format "\\(?1:%s\\)" (regexp-opt (org-remove-if - #'(lambda (keyword) - (member keyword org-element-dual-keywords)) + (lambda (k) (member k org-element-dual-keywords)) org-element-affiliated-keywords))) "\\|" ;; Export attributes. @@ -311,8 +349,7 @@ match group 2. Don't modify it, set `org-element-affiliated-keywords' instead.") (defconst org-element-object-restrictions - (let* ((standard-set - (remq 'plain-link (remq 'table-cell org-element-all-successors))) + (let* ((standard-set (remq 'table-cell org-element-all-objects)) (standard-set-no-line-break (remq 'line-break standard-set))) `((bold ,@standard-set) (footnote-reference ,@standard-set) @@ -320,30 +357,33 @@ Don't modify it, set `org-element-affiliated-keywords' instead.") (inlinetask ,@standard-set-no-line-break) (italic ,@standard-set) (item ,@standard-set-no-line-break) - (keyword ,@standard-set) + (keyword ,@(remq 'footnote-reference standard-set)) ;; Ignore all links excepted plain links in a link description. ;; Also ignore radio-targets and line breaks. - (link export-snippet inline-babel-call inline-src-block latex-or-entity - macro plain-link statistics-cookie sub/superscript text-markup) + (link bold code entity export-snippet inline-babel-call inline-src-block + italic latex-fragment macro plain-link statistics-cookie + strike-through subscript superscript underline verbatim) (paragraph ,@standard-set) ;; Remove any variable object from radio target as it would ;; prevent it from being properly recognized. - (radio-target latex-or-entity sub/superscript text-markup) + (radio-target bold code entity italic latex-fragment strike-through + subscript superscript underline superscript) (strike-through ,@standard-set) (subscript ,@standard-set) (superscript ,@standard-set) ;; Ignore inline babel call and inline src block as formulas are ;; possible. Also ignore line breaks and statistics cookies. - (table-cell link export-snippet footnote-reference latex-or-entity macro - radio-target sub/superscript target text-markup timestamp) + (table-cell bold code entity export-snippet footnote-reference italic + latex-fragment link macro radio-target strike-through + subscript superscript target timestamp underline verbatim) (table-row table-cell) (underline ,@standard-set) (verse-block ,@standard-set))) "Alist of objects restrictions. -CAR is an element or object type containing objects and CDR is -a list of successors that will be called within an element or -object of such type. +key is an element or object type containing objects and value is +a list of types that can be contained within an element or object +of such type. For example, in a `radio-target' object, one can only find entities, latex-fragments, subscript, superscript and text @@ -354,11 +394,19 @@ This alist also applies to secondary string. For example, an still has an entry since one of its properties (`:title') does.") (defconst org-element-secondary-value-alist - '((headline . :title) - (inlinetask . :title) - (item . :tag) - (footnote-reference . :inline-definition)) - "Alist between element types and location of secondary value.") + '((headline :title) + (inlinetask :title) + (item :tag)) + "Alist between element types and locations of secondary values.") + +(defconst org-element--pair-square-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (dolist (char '(?\{ ?\} ?\( ?\) ?\< ?\>) table) + (modify-syntax-entry char " " table))) + "Table used internally to pair only square brackets. +Other brackets are treated as spaces.") @@ -368,10 +416,16 @@ still has an entry since one of its properties (`:title') does.") ;; `org-element-contents' and `org-element-restriction'. ;; ;; Setter functions allow to modify elements by side effect. There is -;; `org-element-put-property', `org-element-set-contents', -;; `org-element-set-element' and `org-element-adopt-element'. Note -;; that `org-element-set-element' and `org-element-adopt-elements' are -;; higher level functions since also update `:parent' property. +;; `org-element-put-property', `org-element-set-contents'. These +;; low-level functions are useful to build a parse tree. +;; +;; `org-element-adopt-element', `org-element-set-element', +;; `org-element-extract-element' and `org-element-insert-before' are +;; high-level functions useful to modify a parse tree. +;; +;; `org-element-secondary-p' is a predicate used to know if a given +;; object belongs to a secondary string. `org-element-copy' returns +;; an element or object, stripping its parent property in the process. (defsubst org-element-type (element) "Return type of ELEMENT. @@ -411,29 +465,22 @@ Return modified element." element)) (defsubst org-element-set-contents (element &rest contents) - "Set ELEMENT contents to CONTENTS. -Return modified element." + "Set ELEMENT contents to CONTENTS." (cond ((not element) (list contents)) ((not (symbolp (car element))) contents) ((cdr element) (setcdr (cdr element) contents)) (t (nconc element contents)))) -(defsubst org-element-set-element (old new) - "Replace element or object OLD with element or object NEW. -The function takes care of setting `:parent' property for NEW." - ;; Since OLD is going to be changed into NEW by side-effect, first - ;; make sure that every element or object within NEW has OLD as - ;; parent. - (mapc (lambda (blob) (org-element-put-property blob :parent old)) - (org-element-contents new)) - ;; Transfer contents. - (apply 'org-element-set-contents old (org-element-contents new)) - ;; Ensure NEW has same parent as OLD, then overwrite OLD properties - ;; with NEW's. - (org-element-put-property new :parent (org-element-property :parent old)) - (setcar (cdr old) (nth 1 new)) - ;; Transfer type. - (setcar old (car new))) +(defun org-element-secondary-p (object) + "Non-nil when OBJECT directly belongs to a secondary string. +Return value is the property name, as a keyword, or nil." + (let* ((parent (org-element-property :parent object)) + (properties (cdr (assq (org-element-type parent) + org-element-secondary-value-alist)))) + (catch 'exit + (dolist (p properties) + (and (memq object (org-element-property p parent)) + (throw 'exit p)))))) (defsubst org-element-adopt-elements (parent &rest children) "Append elements to the contents of another element. @@ -443,18 +490,109 @@ objects, or a strings. The function takes care of setting `:parent' property for CHILD. Return parent element." - ;; Link every child to PARENT. If PARENT is nil, it is a secondary - ;; string: parent is the list itself. - (mapc (lambda (child) - (org-element-put-property child :parent (or parent children))) - children) - ;; Add CHILDREN at the end of PARENT contents. - (when parent - (apply 'org-element-set-contents - parent - (nconc (org-element-contents parent) children))) - ;; Return modified PARENT element. - (or parent children)) + (if (not children) parent + ;; Link every child to PARENT. If PARENT is nil, it is a secondary + ;; string: parent is the list itself. + (dolist (child children) + (org-element-put-property child :parent (or parent children))) + ;; Add CHILDREN at the end of PARENT contents. + (when parent + (apply #'org-element-set-contents + parent + (nconc (org-element-contents parent) children))) + ;; Return modified PARENT element. + (or parent children))) + +(defun org-element-extract-element (element) + "Extract ELEMENT from parse tree. +Remove element from the parse tree by side-effect, and return it +with its `:parent' property stripped out." + (let ((parent (org-element-property :parent element)) + (secondary (org-element-secondary-p element))) + (if secondary + (org-element-put-property + parent secondary + (delq element (org-element-property secondary parent))) + (apply #'org-element-set-contents + parent + (delq element (org-element-contents parent)))) + ;; Return ELEMENT with its :parent removed. + (org-element-put-property element :parent nil))) + +(defun org-element-insert-before (element location) + "Insert ELEMENT before LOCATION in parse tree. +LOCATION is an element, object or string within the parse tree. +Parse tree is modified by side effect." + (let* ((parent (org-element-property :parent location)) + (property (org-element-secondary-p location)) + (siblings (if property (org-element-property property parent) + (org-element-contents parent))) + ;; Special case: LOCATION is the first element of an + ;; independent secondary string (e.g. :title property). Add + ;; ELEMENT in-place. + (specialp (and (not property) + (eq siblings parent) + (eq (car parent) location)))) + ;; Install ELEMENT at the appropriate POSITION within SIBLINGS. + (cond (specialp) + ((or (null siblings) (eq (car siblings) location)) + (push element siblings)) + ((null location) (nconc siblings (list element))) + (t (let ((previous (cadr (memq location (reverse siblings))))) + (if (not previous) + (error "No location found to insert element") + (let ((next (memq previous siblings))) + (setcdr next (cons element (cdr next)))))))) + ;; Store SIBLINGS at appropriate place in parse tree. + (cond + (specialp (setcdr parent (copy-sequence parent)) (setcar parent element)) + (property (org-element-put-property parent property siblings)) + (t (apply #'org-element-set-contents parent siblings))) + ;; Set appropriate :parent property. + (org-element-put-property element :parent parent))) + +(defun org-element-set-element (old new) + "Replace element or object OLD with element or object NEW. +The function takes care of setting `:parent' property for NEW." + ;; Ensure OLD and NEW have the same parent. + (org-element-put-property new :parent (org-element-property :parent old)) + (if (or (memq (org-element-type old) '(plain-text nil)) + (memq (org-element-type new) '(plain-text nil))) + ;; We cannot replace OLD with NEW since one of them is not an + ;; object or element. We take the long path. + (progn (org-element-insert-before new old) + (org-element-extract-element old)) + ;; Since OLD is going to be changed into NEW by side-effect, first + ;; make sure that every element or object within NEW has OLD as + ;; parent. + (dolist (blob (org-element-contents new)) + (org-element-put-property blob :parent old)) + ;; Transfer contents. + (apply #'org-element-set-contents old (org-element-contents new)) + ;; Overwrite OLD's properties with NEW's. + (setcar (cdr old) (nth 1 new)) + ;; Transfer type. + (setcar old (car new)))) + +(defun org-element-create (type &optional props &rest children) + "Create a new element of type TYPE. +Optional argument PROPS, when non-nil, is a plist defining the +properties of the element. CHILDREN can be elements, objects or +strings." + (apply #'org-element-adopt-elements (list type props) children)) + +(defun org-element-copy (datum) + "Return a copy of DATUM. +DATUM is an element, object, string or nil. `:parent' property +is cleared and contents are removed in the process." + (when datum + (let ((type (org-element-type datum))) + (case type + (org-data (list 'org-data nil)) + (plain-text (substring-no-properties datum)) + ((nil) (copy-sequence datum)) + (otherwise + (list type (plist-put (copy-sequence (nth 1 datum)) :parent nil))))))) @@ -467,7 +605,7 @@ Return parent element." ;; Most of them accepts no argument. Though, exceptions exist. Hence ;; every element containing a secondary string (see ;; `org-element-secondary-value-alist') will accept an optional -;; argument to toggle parsing of that secondary string. Moreover, +;; argument to toggle parsing of these secondary strings. Moreover, ;; `item' parser requires current list's structure as its first ;; element. ;; @@ -503,8 +641,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `center-block' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +containing `:begin', `:end', `:contents-begin', `:contents-end', +`:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the block." (let ((case-fold-search t)) @@ -520,7 +658,6 @@ Assume point is at the beginning of the block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -531,7 +668,6 @@ Assume point is at the beginning of the block." (nconc (list :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -555,7 +691,7 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `drawer' and CDR is a plist containing -`:drawer-name', `:begin', `:end', `:hiddenp', `:contents-begin', +`:drawer-name', `:begin', `:end', `:contents-begin', `:contents-end', `:post-blank' and `:post-affiliated' keywords. Assume point is at beginning of drawer." @@ -574,7 +710,6 @@ Assume point is at beginning of drawer." (and (< (point) drawer-end-line) (point)))) (contents-end (and contents-begin drawer-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char drawer-end-line) (forward-line) (point))) @@ -585,7 +720,6 @@ Assume point is at beginning of drawer." (list :begin begin :end end :drawer-name name - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -611,9 +745,9 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `dynamic-block' and CDR is a plist -containing `:block-name', `:begin', `:end', `:hiddenp', -`:contents-begin', `:contents-end', `:arguments', `:post-blank' -and `:post-affiliated' keywords. +containing `:block-name', `:begin', `:end', `:contents-begin', +`:contents-end', `:arguments', `:post-blank' and +`:post-affiliated' keywords. Assume point is at beginning of dynamic block." (let ((case-fold-search t)) @@ -633,7 +767,6 @@ Assume point is at beginning of dynamic block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -645,7 +778,6 @@ Assume point is at beginning of dynamic block." :end end :block-name name :arguments arguments - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -722,16 +854,52 @@ CONTENTS is the contents of the footnote-definition." ;;;; Headline +(defun org-element--get-node-properties () + "Return node properties associated to headline at point. +Upcase property names. It avoids confusion between properties +obtained through property drawer and default properties from the +parser (e.g. `:end' and :END:). Return value is a plist." + (save-excursion + (forward-line) + (when (org-looking-at-p org-planning-line-re) (forward-line)) + (when (looking-at org-property-drawer-re) + (forward-line) + (let ((end (match-end 0)) properties) + (while (< (line-end-position) end) + (looking-at org-property-re) + (push (org-match-string-no-properties 3) properties) + (push (intern (concat ":" (upcase (match-string 2)))) properties) + (forward-line)) + properties)))) + +(defun org-element--get-time-properties () + "Return time properties associated to headline at point. +Return value is a plist." + (save-excursion + (when (progn (forward-line) (looking-at org-planning-line-re)) + (let ((end (line-end-position)) plist) + (while (re-search-forward org-keyword-time-not-clock-regexp end t) + (goto-char (match-end 1)) + (skip-chars-forward " \t") + (let ((keyword (match-string 1)) + (time (org-element-timestamp-parser))) + (cond ((equal keyword org-scheduled-string) + (setq plist (plist-put plist :scheduled time))) + ((equal keyword org-deadline-string) + (setq plist (plist-put plist :deadline time))) + (t (setq plist (plist-put plist :closed time)))))) + plist)))) + (defun org-element-headline-parser (limit &optional raw-secondary-p) "Parse a headline. Return a list whose CAR is `headline' and CDR is a plist -containing `:raw-value', `:title', `:alt-title', `:begin', -`:end', `:pre-blank', `:hiddenp', `:contents-begin', -`:contents-end', `:level', `:priority', `:tags', -`:todo-keyword',`:todo-type', `:scheduled', `:deadline', -`:closed', `:quotedp', `:archivedp', `:commentedp', -`:footnote-section-p' and `:post-blank' keywords. +containing `:raw-value', `:title', `:begin', `:end', +`:pre-blank', `:contents-begin' and `:contents-end', `:level', +`:priority', `:tags', `:todo-keyword',`:todo-type', `:scheduled', +`:deadline', `:closed', `:archivedp', `:commentedp' +`:footnote-section-p', `:post-blank' and `:post-affiliated' +keywords. The plist also contains any property set in the property drawer, with its name in upper cases and colons added at the @@ -744,80 +912,47 @@ parsed as a secondary string, but as a plain string instead. Assume point is at beginning of the headline." (save-excursion - (let* ((components (org-heading-components)) - (level (nth 1 components)) - (todo (nth 2 components)) + (let* ((begin (point)) + (level (prog1 (org-reduced-level (skip-chars-forward "*")) + (skip-chars-forward " \t"))) + (todo (and org-todo-regexp + (let (case-fold-search) (looking-at org-todo-regexp)) + (progn (goto-char (match-end 0)) + (skip-chars-forward " \t") + (match-string 0)))) (todo-type (and todo (if (member todo org-done-keywords) 'done 'todo))) - (tags (let ((raw-tags (nth 5 components))) - (and raw-tags (org-split-string raw-tags ":")))) - (raw-value (or (nth 4 components) "")) - (quotedp - (let ((case-fold-search nil)) - (string-match (format "^%s\\( \\|$\\)" org-quote-string) - raw-value))) + (priority (and (looking-at "\\[#.\\][ \t]*") + (progn (goto-char (match-end 0)) + (aref (match-string 0) 2)))) (commentedp - (let ((case-fold-search nil)) - (string-match (format "^%s\\( \\|$\\)" org-comment-string) - raw-value))) + (and (let (case-fold-search) (looking-at org-comment-string)) + (goto-char (match-end 0)))) + (title-start (point)) + (tags (when (re-search-forward + (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (line-end-position) + 'move) + (goto-char (match-beginning 0)) + (org-split-string (match-string 1) ":"))) + (title-end (point)) + (raw-value (org-trim + (buffer-substring-no-properties title-start title-end))) (archivedp (member org-archive-tag tags)) (footnote-section-p (and org-footnote-section (string= org-footnote-section raw-value))) - ;; Upcase property names. It avoids confusion between - ;; properties obtained through property drawer and default - ;; properties from the parser (e.g. `:end' and :END:) - (standard-props - (let (plist) - (mapc - (lambda (p) - (setq plist - (plist-put plist - (intern (concat ":" (upcase (car p)))) - (cdr p)))) - (org-entry-properties nil 'standard)) - plist)) - (time-props - ;; Read time properties on the line below the headline. - (save-excursion - (when (progn (forward-line) - (looking-at org-planning-or-clock-line-re)) - (let ((end (line-end-position)) plist) - (while (re-search-forward - org-keyword-time-not-clock-regexp end t) - (goto-char (match-end 1)) - (skip-chars-forward " \t") - (let ((keyword (match-string 1)) - (time (org-element-timestamp-parser))) - (cond ((equal keyword org-scheduled-string) - (setq plist (plist-put plist :scheduled time))) - ((equal keyword org-deadline-string) - (setq plist (plist-put plist :deadline time))) - (t (setq plist (plist-put plist :closed time)))))) - plist)))) - (begin (point)) + (standard-props (org-element--get-node-properties)) + (time-props (org-element--get-time-properties)) (end (min (save-excursion (org-end-of-subtree t t)) limit)) (pos-after-head (progn (forward-line) (point))) (contents-begin (save-excursion (skip-chars-forward " \r\t\n" end) (and (/= (point) end) (line-beginning-position)))) - (hidden (org-invisible-p2)) (contents-end (and contents-begin (progn (goto-char end) (skip-chars-backward " \r\t\n") (forward-line) (point))))) - ;; Clean RAW-VALUE from any quote or comment string. - (when (or quotedp commentedp) - (let ((case-fold-search nil)) - (setq raw-value - (replace-regexp-in-string - (concat - (regexp-opt (list org-quote-string org-comment-string)) - "\\(?: \\|$\\)") - "" - raw-value)))) - ;; Clean TAGS from archive tag, if any. - (when archivedp (setq tags (delete org-archive-tag tags))) (let ((headline (list 'headline (nconc @@ -827,11 +962,10 @@ Assume point is at beginning of the headline." :pre-blank (if (not contents-begin) 0 (count-lines pos-after-head contents-begin)) - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :level level - :priority (nth 3 components) + :priority priority :tags tags :todo-keyword todo :todo-type todo-type @@ -841,21 +975,23 @@ Assume point is at beginning of the headline." :footnote-section-p footnote-section-p :archivedp archivedp :commentedp commentedp - :quotedp quotedp) + :post-affiliated begin) time-props standard-props)))) - (let ((alt-title (org-element-property :ALT_TITLE headline))) - (when alt-title - (org-element-put-property - headline :alt-title - (if raw-secondary-p alt-title - (org-element-parse-secondary-string - alt-title (org-element-restriction 'headline) headline))))) (org-element-put-property headline :title (if raw-secondary-p raw-value - (org-element-parse-secondary-string - raw-value (org-element-restriction 'headline) headline))))))) + (let ((title (org-element--parse-objects + (progn (goto-char title-start) + (skip-chars-forward " \t") + (point)) + (progn (goto-char title-end) + (skip-chars-backward " \t") + (point)) + nil + (org-element-restriction 'headline)))) + (dolist (datum title title) + (org-element-put-property datum :parent headline))))))))) (defun org-element-headline-interpreter (headline contents) "Interpret HEADLINE element as Org syntax. @@ -865,22 +1001,17 @@ CONTENTS is the contents of the element." (priority (org-element-property :priority headline)) (title (org-element-interpret-data (org-element-property :title headline))) - (tags (let ((tag-list (if (org-element-property :archivedp headline) - (cons org-archive-tag - (org-element-property :tags headline)) - (org-element-property :tags headline)))) + (tags (let ((tag-list (org-element-property :tags headline))) (and tag-list (format ":%s:" (mapconcat #'identity tag-list ":"))))) (commentedp (org-element-property :commentedp headline)) - (quotedp (org-element-property :quotedp headline)) (pre-blank (or (org-element-property :pre-blank headline) 0)) (heading (concat (make-string (if org-odd-levels-only (1- (* level 2)) level) ?*) (and todo (concat " " todo)) - (and quotedp (concat " " org-quote-string)) (and commentedp (concat " " org-comment-string)) - (and priority (format " [#%s]" (char-to-string priority))) + (and priority (format " [#%c]" priority)) " " (if (and org-footnote-section (org-element-property :footnote-section-p headline)) @@ -912,10 +1043,10 @@ CONTENTS is the contents of the element." "Parse an inline task. Return a list whose CAR is `inlinetask' and CDR is a plist -containing `:title', `:begin', `:end', `:hiddenp', -`:contents-begin' and `:contents-end', `:level', `:priority', -`:raw-value', `:tags', `:todo-keyword', `:todo-type', -`:scheduled', `:deadline', `:closed' and `:post-blank' keywords. +containing `:title', `:begin', `:end', `:contents-begin' and +`:contents-end', `:level', `:priority', `:raw-value', `:tags', +`:todo-keyword', `:todo-type', `:scheduled', `:deadline', +`:closed', `:post-blank' and `:post-affiliated' keywords. The plist also contains any property set in the property drawer, with its name in upper cases and colons added at the @@ -928,53 +1059,37 @@ string instead. Assume point is at beginning of the inline task." (save-excursion (let* ((begin (point)) - (components (org-heading-components)) - (todo (nth 2 components)) + (level (prog1 (org-reduced-level (skip-chars-forward "*")) + (skip-chars-forward " \t"))) + (todo (and org-todo-regexp + (let (case-fold-search) (looking-at org-todo-regexp)) + (progn (goto-char (match-end 0)) + (skip-chars-forward " \t") + (match-string 0)))) (todo-type (and todo (if (member todo org-done-keywords) 'done 'todo))) - (tags (let ((raw-tags (nth 5 components))) - (and raw-tags (org-split-string raw-tags ":")))) - (raw-value (or (nth 4 components) "")) - ;; Upcase property names. It avoids confusion between - ;; properties obtained through property drawer and default - ;; properties from the parser (e.g. `:end' and :END:) - (standard-props - (let (plist) - (mapc - (lambda (p) - (setq plist - (plist-put plist - (intern (concat ":" (upcase (car p)))) - (cdr p)))) - (org-entry-properties nil 'standard)) - plist)) - (time-props - ;; Read time properties on the line below the inlinetask - ;; opening string. - (save-excursion - (when (progn (forward-line) - (looking-at org-planning-or-clock-line-re)) - (let ((end (line-end-position)) plist) - (while (re-search-forward - org-keyword-time-not-clock-regexp end t) - (goto-char (match-end 1)) - (skip-chars-forward " \t") - (let ((keyword (match-string 1)) - (time (org-element-timestamp-parser))) - (cond ((equal keyword org-scheduled-string) - (setq plist (plist-put plist :scheduled time))) - ((equal keyword org-deadline-string) - (setq plist (plist-put plist :deadline time))) - (t (setq plist (plist-put plist :closed time)))))) - plist)))) + (priority (and (looking-at "\\[#.\\][ \t]*") + (progn (goto-char (match-end 0)) + (aref (match-string 0) 2)))) + (title-start (point)) + (tags (when (re-search-forward + (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (line-end-position) + 'move) + (goto-char (match-beginning 0)) + (org-split-string (match-string 1) ":"))) + (title-end (point)) + (raw-value (org-trim + (buffer-substring-no-properties title-start title-end))) (task-end (save-excursion (end-of-line) (and (re-search-forward org-outline-regexp-bol limit t) (org-looking-at-p "END[ \t]*$") (line-beginning-position)))) + (standard-props (and task-end (org-element--get-node-properties))) + (time-props (and task-end (org-element--get-time-properties))) (contents-begin (progn (forward-line) (and task-end (< (point) task-end) (point)))) - (hidden (and contents-begin (org-invisible-p2))) (contents-end (and contents-begin task-end)) (before-blank (if (not task-end) (point) (goto-char task-end) @@ -988,24 +1103,31 @@ Assume point is at beginning of the inline task." (list :raw-value raw-value :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end - :level (nth 1 components) - :priority (nth 3 components) + :level level + :priority priority :tags tags :todo-keyword todo :todo-type todo-type - :post-blank (count-lines before-blank end)) + :post-blank (count-lines before-blank end) + :post-affiliated begin) time-props standard-props)))) (org-element-put-property inlinetask :title (if raw-secondary-p raw-value - (org-element-parse-secondary-string - raw-value - (org-element-restriction 'inlinetask) - inlinetask)))))) + (let ((title (org-element--parse-objects + (progn (goto-char title-start) + (skip-chars-forward " \t") + (point)) + (progn (goto-char title-end) + (skip-chars-backward " \t") + (point)) + nil + (org-element-restriction 'inlinetask)))) + (dolist (datum title title) + (org-element-put-property datum :parent inlinetask)))))))) (defun org-element-inlinetask-interpreter (inlinetask contents) "Interpret INLINETASK element as Org syntax. @@ -1020,8 +1142,7 @@ CONTENTS is the contents of inlinetask." (format ":%s:" (mapconcat 'identity tag-list ":"))))) (task (concat (make-string level ?*) (and todo (concat " " todo)) - (and priority - (format " [#%s]" (char-to-string priority))) + (and priority (format " [#%c]" priority)) (and title (concat " " title))))) (concat task ;; Align tags. @@ -1055,8 +1176,8 @@ STRUCT is the structure of the plain list. Return a list whose CAR is `item' and CDR is a plist containing `:bullet', `:begin', `:end', `:contents-begin', `:contents-end', -`:checkbox', `:counter', `:tag', `:structure', `:hiddenp' and -`:post-blank' keywords. +`:checkbox', `:counter', `:tag', `:structure', `:post-blank' and +`:post-affiliated' keywords. When optional argument RAW-SECONDARY-P is non-nil, item's tag, if any, will not be parsed as a secondary string, but as a plain @@ -1068,11 +1189,11 @@ Assume point is at the beginning of the item." (looking-at org-list-full-item-re) (let* ((begin (point)) (bullet (org-match-string-no-properties 1)) - (checkbox (let ((box (org-match-string-no-properties 3))) + (checkbox (let ((box (match-string 3))) (cond ((equal "[ ]" box) 'off) ((equal "[X]" box) 'on) ((equal "[-]" box) 'trans)))) - (counter (let ((c (org-match-string-no-properties 2))) + (counter (let ((c (match-string 2))) (save-match-data (cond ((not c) nil) @@ -1081,9 +1202,8 @@ Assume point is at the beginning of the item." 64)) ((string-match "[0-9]+" c) (string-to-number (match-string 0 c))))))) - (end (save-excursion (goto-char (org-list-get-item-end begin struct)) - (unless (bolp) (forward-line)) - (point))) + (end (progn (goto-char (nth 6 (assq (point) struct))) + (if (bolp) (point) (line-beginning-position 2)))) (contents-begin (progn (goto-char ;; Ignore tags in un-ordered lists: they are just @@ -1092,40 +1212,38 @@ Assume point is at the beginning of the item." (save-match-data (string-match "[.)]" bullet))) (match-beginning 4) (match-end 0))) - (skip-chars-forward " \r\t\n" limit) - ;; If first line isn't empty, contents really start - ;; at the text after item's meta-data. - (if (= (point-at-bol) begin) (point) (point-at-bol)))) - (hidden (progn (forward-line) - (and (not (= (point) end)) (org-invisible-p2)))) - (contents-end (progn (goto-char end) - (skip-chars-backward " \r\t\n") - (forward-line) - (point))) + (skip-chars-forward " \r\t\n" end) + (cond ((= (point) end) nil) + ;; If first line isn't empty, contents really + ;; start at the text after item's meta-data. + ((= (line-beginning-position) begin) (point)) + (t (line-beginning-position))))) + (contents-end (and contents-begin + (progn (goto-char end) + (skip-chars-backward " \r\t\n") + (line-beginning-position 2)))) (item (list 'item (list :bullet bullet :begin begin :end end - ;; CONTENTS-BEGIN and CONTENTS-END may be - ;; mixed up in the case of an empty item - ;; separated from the next by a blank line. - ;; Thus ensure the former is always the - ;; smallest. - :contents-begin (min contents-begin contents-end) - :contents-end (max contents-begin contents-end) + :contents-begin contents-begin + :contents-end contents-end :checkbox checkbox :counter counter - :hiddenp hidden :structure struct - :post-blank (count-lines contents-end end))))) + :post-blank (count-lines (or contents-end begin) end) + :post-affiliated begin)))) (org-element-put-property item :tag - (let ((raw-tag (org-list-get-tag begin struct))) - (and raw-tag - (if raw-secondary-p raw-tag - (org-element-parse-secondary-string - raw-tag (org-element-restriction 'item) item)))))))) + (let ((raw (org-list-get-tag begin struct))) + (when raw + (if raw-secondary-p raw + (let ((tag (org-element--parse-objects + (match-beginning 4) (match-end 4) nil + (org-element-restriction 'item)))) + (dolist (datum tag tag) + (org-element-put-property datum :parent item)))))))))) (defun org-element-item-interpreter (item contents) "Interpret ITEM element as Org syntax. @@ -1168,9 +1286,6 @@ CONTENTS is the contents of the element." (let ((case-fold-search t) (top-ind limit) (item-re (org-item-re)) - (drawers-re (concat ":\\(" - (mapconcat 'regexp-quote org-drawers "\\|") - "\\):[ \t]*$")) (inlinetask-re (and (featurep 'org-inlinetask) "^\\*+ ")) items struct) (save-excursion @@ -1226,7 +1341,8 @@ CONTENTS is the contents of the element." (goto-char origin))))) ;; At some text line. Check if it ends any previous item. (t - (let ((ind (progn (skip-chars-forward " \t") (current-column)))) + (let ((ind (save-excursion (skip-chars-forward " \t") + (current-column)))) (when (<= ind top-ind) (skip-chars-backward " \r\t\n") (forward-line)) @@ -1235,15 +1351,14 @@ CONTENTS is the contents of the element." (setcar (nthcdr 6 item) (line-beginning-position)) (push item struct) (unless items - (throw 'exit (sort struct 'car-less-than-car)))))) + (throw 'exit (sort struct #'car-less-than-car)))))) ;; Skip blocks (any type) and drawers contents. (cond - ((and (looking-at "#\\+BEGIN\\(:\\|_\\S-+\\)") + ((and (looking-at "[ \t]*#\\+BEGIN\\(:\\|_\\S-+\\)") (re-search-forward - (format "^[ \t]*#\\+END%s[ \t]*$" - (org-match-string-no-properties 1)) + (format "^[ \t]*#\\+END%s[ \t]*$" (match-string 1)) limit t))) - ((and (looking-at drawers-re) + ((and (looking-at org-drawer-regexp) (re-search-forward "^[ \t]*:END:[ \t]*$" limit t)))) (forward-line)))))))) @@ -1264,15 +1379,20 @@ containing `:type', `:begin', `:end', `:contents-begin' and Assume point is at the beginning of the list." (save-excursion (let* ((struct (or structure (org-element--list-struct limit))) - (prevs (org-list-prevs-alist struct)) - (type (org-list-get-list-type (point) struct prevs)) + (type (cond ((org-looking-at-p "[ \t]*[A-Za-z0-9]") 'ordered) + ((nth 5 (assq (point) struct)) 'descriptive) + (t 'unordered))) (contents-begin (point)) (begin (car affiliated)) - (contents-end - (progn (goto-char (org-list-get-list-end (point) struct prevs)) - (unless (bolp) (forward-line)) - (point))) - (end (progn (skip-chars-forward " \r\t\n" limit) + (contents-end (let* ((item (assq contents-begin struct)) + (ind (nth 1 item)) + (pos (nth 6 item))) + (while (and (setq item (assq pos struct)) + (= (nth 1 item) ind)) + (setq pos (nth 6 item))) + pos)) + (end (progn (goto-char contents-end) + (skip-chars-forward " \r\t\n" limit) (if (= (point) limit) limit (line-beginning-position))))) ;; Return value. (list 'plain-list @@ -1299,49 +1419,33 @@ CONTENTS is the contents of the element." ;;;; Property Drawer -(defun org-element-property-drawer-parser (limit affiliated) +(defun org-element-property-drawer-parser (limit) "Parse a property drawer. -LIMIT bounds the search. AFFILIATED is a list of which CAR is -the buffer position at the beginning of the first affiliated -keyword and CDR is a plist of affiliated keywords along with -their value. +LIMIT bounds the search. -Return a list whose CAR is `property-drawer' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +Return a list whose car is `property-drawer' and cdr is a plist +containing `:begin', `:end', `:contents-begin', `:contents-end', +`:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the property drawer." - (let ((case-fold-search t)) - (if (not (save-excursion (re-search-forward "^[ \t]*:END:[ \t]*$" limit t))) - ;; Incomplete drawer: parse it as a paragraph. - (org-element-paragraph-parser limit affiliated) - (save-excursion - (let* ((drawer-end-line (match-beginning 0)) - (begin (car affiliated)) - (post-affiliated (point)) - (contents-begin - (progn - (forward-line) - (and (re-search-forward org-property-re drawer-end-line t) - (line-beginning-position)))) - (contents-end (and contents-begin drawer-end-line)) - (hidden (org-invisible-p2)) - (pos-before-blank (progn (goto-char drawer-end-line) - (forward-line) - (point))) - (end (progn (skip-chars-forward " \r\t\n" limit) - (if (eobp) (point) (line-beginning-position))))) - (list 'property-drawer - (nconc - (list :begin begin - :end end - :hiddenp hidden - :contents-begin contents-begin - :contents-end contents-end - :post-blank (count-lines pos-before-blank end) - :post-affiliated post-affiliated) - (cdr affiliated)))))))) + (save-excursion + (let ((case-fold-search t) + (begin (point)) + (contents-begin (line-beginning-position 2))) + (re-search-forward "^[ \t]*:END:[ \t]*$" limit t) + (let ((contents-end (and (> (match-beginning 0) contents-begin) + (match-beginning 0))) + (before-blank (progn (forward-line) (point))) + (end (progn (skip-chars-forward " \r\t\n" limit) + (if (eobp) (point) (line-beginning-position))))) + (list 'property-drawer + (list :begin begin + :end end + :contents-begin (and contents-end contents-begin) + :contents-end contents-end + :post-blank (count-lines before-blank end) + :post-affiliated begin)))))) (defun org-element-property-drawer-interpreter (property-drawer contents) "Interpret PROPERTY-DRAWER element as Org syntax. @@ -1360,8 +1464,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `quote-block' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:contents-begin', -`:contents-end', `:post-blank' and `:post-affiliated' keywords. +containing `:begin', `:end', `:contents-begin', `:contents-end', +`:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the block." (let ((case-fold-search t)) @@ -1378,7 +1482,6 @@ Assume point is at the beginning of the block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -1388,7 +1491,6 @@ Assume point is at the beginning of the block." (nconc (list :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -1409,8 +1511,8 @@ CONTENTS is the contents of the element." LIMIT bounds the search. Return a list whose CAR is `section' and CDR is a plist -containing `:begin', `:end', `:contents-begin', `contents-end' -and `:post-blank' keywords." +containing `:begin', `:end', `:contents-begin', `contents-end', +`:post-blank' and `:post-affiliated' keywords." (save-excursion ;; Beginning of section is the beginning of the first non-blank ;; line after previous headline. @@ -1425,7 +1527,8 @@ and `:post-blank' keywords." :end end :contents-begin begin :contents-end pos-before-blank - :post-blank (count-lines pos-before-blank end)))))) + :post-blank (count-lines pos-before-blank end) + :post-affiliated begin))))) (defun org-element-section-interpreter (section contents) "Interpret SECTION element as Org syntax. @@ -1444,14 +1547,13 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `special-block' and CDR is a plist -containing `:type', `:begin', `:end', `:hiddenp', -`:contents-begin', `:contents-end', `:post-blank' and -`:post-affiliated' keywords. +containing `:type', `:begin', `:end', `:contents-begin', +`:contents-end', `:post-blank' and `:post-affiliated' keywords. Assume point is at the beginning of the block." (let* ((case-fold-search t) (type (progn (looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)") - (upcase (match-string-no-properties 1))))) + (match-string-no-properties 1)))) (if (not (save-excursion (re-search-forward (format "^[ \t]*#\\+END_%s[ \t]*$" (regexp-quote type)) @@ -1467,7 +1569,6 @@ Assume point is at the beginning of the block." (and (< (point) block-end-line) (point)))) (contents-end (and contents-begin block-end-line)) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char block-end-line) (forward-line) (point))) @@ -1478,7 +1579,6 @@ Assume point is at the beginning of the block." (list :type type :begin begin :end end - :hiddenp hidden :contents-begin contents-begin :contents-end contents-end :post-blank (count-lines pos-before-blank end) @@ -1512,28 +1612,41 @@ CONTENTS is the contents of the element." (defun org-element-babel-call-parser (limit affiliated) "Parse a babel call. -LIMIT bounds the search. AFFILIATED is a list of which CAR is +LIMIT bounds the search. AFFILIATED is a list of which car is the buffer position at the beginning of the first affiliated -keyword and CDR is a plist of affiliated keywords along with +keyword and cdr is a plist of affiliated keywords along with their value. -Return a list whose CAR is `babel-call' and CDR is a plist -containing `:begin', `:end', `:info', `:post-blank' and +Return a list whose car is `babel-call' and cdr is a plist +containing `:call', `:inside-header', `:arguments', +`:end-header', `:begin', `:end', `:value', `:post-blank' and `:post-affiliated' as keywords." (save-excursion - (let ((case-fold-search t) - (info (progn (looking-at org-babel-block-lob-one-liner-regexp) - (org-babel-lob-get-info))) - (begin (car affiliated)) - (post-affiliated (point)) - (pos-before-blank (progn (forward-line) (point))) - (end (progn (skip-chars-forward " \r\t\n" limit) - (if (eobp) (point) (line-beginning-position))))) + (let* ((begin (car affiliated)) + (post-affiliated (point)) + (value (progn (search-forward ":" nil t) + (org-trim + (buffer-substring-no-properties + (point) (line-end-position))))) + (pos-before-blank (progn (forward-line) (point))) + (end (progn (skip-chars-forward " \r\t\n" limit) + (if (eobp) (point) (line-beginning-position)))) + (valid-value + (string-match + "\\([^()\n]+?\\)\\(?:\\[\\(.*?\\)\\]\\)?(\\(.*\\))[ \t]*\\(.*\\)" + value))) (list 'babel-call (nconc - (list :begin begin + (list :call (and valid-value (match-string 1 value)) + :inside-header (and valid-value + (org-string-nw-p (match-string 2 value))) + :arguments (and valid-value + (org-string-nw-p (match-string 3 value))) + :end-header (and valid-value + (org-string-nw-p (match-string 4 value))) + :begin begin :end end - :info info + :value value :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated)))))) @@ -1541,14 +1654,13 @@ containing `:begin', `:end', `:info', `:post-blank' and (defun org-element-babel-call-interpreter (babel-call contents) "Interpret BABEL-CALL element as Org syntax. CONTENTS is nil." - (let* ((babel-info (org-element-property :info babel-call)) - (main (car babel-info)) - (post-options (nth 1 babel-info))) - (concat "#+CALL: " - (if (not (string-match "\\[\\(\\[.*?\\]\\)\\]" main)) main - ;; Remove redundant square brackets. - (replace-match (match-string 1 main) nil nil main)) - (and post-options (format "[%s]" post-options))))) + (concat "#+CALL: " + (org-element-property :call babel-call) + (let ((h (org-element-property :inside-header babel-call))) + (and h (format "[%s]" h))) + (concat "(" (org-element-property :arguments babel-call) ")") + (let ((h (org-element-property :end-header babel-call))) + (and h (concat " " h))))) ;;;; Clock @@ -1559,8 +1671,8 @@ CONTENTS is nil." LIMIT bounds the search. Return a list whose CAR is `clock' and CDR is a plist containing -`:status', `:value', `:time', `:begin', `:end' and `:post-blank' -as keywords." +`:status', `:value', `:time', `:begin', `:end', `:post-blank' and +`:post-affiliated' as keywords." (save-excursion (let* ((case-fold-search nil) (begin (point)) @@ -1584,7 +1696,8 @@ as keywords." :duration duration :begin begin :end end - :post-blank post-blank))))) + :post-blank post-blank + :post-affiliated begin))))) (defun org-element-clock-interpreter (clock contents) "Interpret CLOCK element as Org syntax. @@ -1664,8 +1777,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `comment-block' and CDR is a plist -containing `:begin', `:end', `:hiddenp', `:value', `:post-blank' -and `:post-affiliated' keywords. +containing `:begin', `:end', `:value', `:post-blank' and +`:post-affiliated' keywords. Assume point is at comment block beginning." (let ((case-fold-search t)) @@ -1678,7 +1791,6 @@ Assume point is at comment block beginning." (let* ((begin (car affiliated)) (post-affiliated (point)) (contents-begin (progn (forward-line) (point))) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -1691,7 +1803,6 @@ Assume point is at comment block beginning." (list :begin begin :end end :value value - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -1700,7 +1811,9 @@ Assume point is at comment block beginning." "Interpret COMMENT-BLOCK element as Org syntax. CONTENTS is nil." (format "#+BEGIN_COMMENT\n%s#+END_COMMENT" - (org-remove-indentation (org-element-property :value comment-block)))) + (org-element-normalize-string + (org-remove-indentation + (org-element-property :value comment-block))))) ;;;; Diary Sexp @@ -1741,35 +1854,6 @@ CONTENTS is nil." ;;;; Example Block -(defun org-element--remove-indentation (s &optional n) - "Remove maximum common indentation in string S and return it. -When optional argument N is a positive integer, remove exactly -that much characters from indentation, if possible, or return -S as-is otherwise. Unlike to `org-remove-indentation', this -function doesn't call `untabify' on S." - (catch 'exit - (with-temp-buffer - (insert s) - (goto-char (point-min)) - ;; Find maximum common indentation, if not specified. - (setq n (or n - (let ((min-ind (point-max))) - (save-excursion - (while (re-search-forward "^[ \t]*\\S-" nil t) - (let ((ind (1- (current-column)))) - (if (zerop ind) (throw 'exit s) - (setq min-ind (min min-ind ind)))))) - min-ind))) - (if (zerop n) s - ;; Remove exactly N indentation, but give up if not possible. - (while (not (eobp)) - (let ((ind (progn (skip-chars-forward " \t") (current-column)))) - (cond ((eolp) (delete-region (line-beginning-position) (point))) - ((< ind n) (throw 'exit s)) - (t (org-indent-line-to (- ind n)))) - (forward-line))) - (buffer-string))))) - (defun org-element-example-block-parser (limit affiliated) "Parse an example block. @@ -1780,9 +1864,8 @@ their value. Return a list whose CAR is `example-block' and CDR is a plist containing `:begin', `:end', `:number-lines', `:preserve-indent', -`:retain-labels', `:use-labels', `:label-fmt', `:hiddenp', -`:switches', `:value', `:post-blank' and `:post-affiliated' -keywords." +`:retain-labels', `:use-labels', `:label-fmt', `:switches', +`:value', `:post-blank' and `:post-affiliated' keywords." (let ((case-fold-search t)) (if (not (save-excursion (re-search-forward "^[ \t]*#\\+END_EXAMPLE[ \t]*$" limit t))) @@ -1800,8 +1883,7 @@ keywords." ((string-match "-n\\>" switches) 'new) ((string-match "+n\\>" switches) 'continued))) (preserve-indent - (or org-src-preserve-indentation - (and switches (string-match "-i\\>" switches)))) + (and switches (string-match "-i\\>" switches))) ;; Should labels be retained in (or stripped from) example ;; blocks? (retain-labels @@ -1823,12 +1905,11 @@ keywords." (post-affiliated (point)) (block-ind (progn (skip-chars-forward " \t") (current-column))) (contents-begin (progn (forward-line) (point))) - (hidden (org-invisible-p2)) - (value (org-element--remove-indentation + (value (org-element-remove-indentation (org-unescape-code-in-string (buffer-substring-no-properties contents-begin contents-end)) - (and preserve-indent block-ind))) + block-ind)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -1845,7 +1926,6 @@ keywords." :retain-labels retain-labels :use-labels use-labels :label-fmt label-fmt - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -1853,10 +1933,15 @@ keywords." (defun org-element-example-block-interpreter (example-block contents) "Interpret EXAMPLE-BLOCK element as Org syntax. CONTENTS is nil." - (let ((switches (org-element-property :switches example-block))) + (let ((switches (org-element-property :switches example-block)) + (value (org-element-property :value example-block))) (concat "#+BEGIN_EXAMPLE" (and switches (concat " " switches)) "\n" - (org-escape-code-in-string - (org-element-property :value example-block)) + (org-element-normalize-string + (org-escape-code-in-string + (if (or org-src-preserve-indentation + (org-element-property :preserve-indent example-block)) + value + (org-element-remove-indentation value)))) "#+END_EXAMPLE"))) @@ -1871,8 +1956,8 @@ keyword and CDR is a plist of affiliated keywords along with their value. Return a list whose CAR is `export-block' and CDR is a plist -containing `:begin', `:end', `:type', `:hiddenp', `:value', -`:post-blank' and `:post-affiliated' keywords. +containing `:begin', `:end', `:type', `:value', `:post-blank' and +`:post-affiliated' keywords. Assume point is at export-block beginning." (let* ((case-fold-search t) @@ -1888,7 +1973,6 @@ Assume point is at export-block beginning." (let* ((begin (car affiliated)) (post-affiliated (point)) (contents-begin (progn (forward-line) (point))) - (hidden (org-invisible-p2)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -1902,7 +1986,6 @@ Assume point is at export-block beginning." :end end :type type :value value - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -2015,7 +2098,10 @@ Return a list whose CAR is `keyword' and CDR is a plist containing `:key', `:value', `:begin', `:end', `:post-blank' and `:post-affiliated' keywords." (save-excursion - (let ((begin (car affiliated)) + ;; An orphaned affiliated keyword is considered as a regular + ;; keyword. In this case AFFILIATED is nil, so we take care of + ;; this corner case. + (let ((begin (or (car affiliated) (point))) (post-affiliated (point)) (key (progn (looking-at "[ \t]*#\\+\\(\\S-+*\\):") (upcase (org-match-string-no-properties 1)))) @@ -2044,6 +2130,18 @@ CONTENTS is nil." ;;;; Latex Environment +(defconst org-element--latex-begin-environment + "^[ \t]*\\\\begin{\\([A-Za-z0-9*]+\\)}" + "Regexp matching the beginning of a LaTeX environment. +The environment is captured by the first group. + +See also `org-element--latex-end-environment'.") + +(defconst org-element--latex-end-environment + "\\\\end{%s}[ \t]*$" + "Format string matching the ending of a LaTeX environment. +See also `org-element--latex-begin-environment'.") + (defun org-element-latex-environment-parser (limit affiliated) "Parse a LaTeX environment. @@ -2060,8 +2158,8 @@ Assume point is at the beginning of the latex environment." (save-excursion (let ((case-fold-search t) (code-begin (point))) - (looking-at "[ \t]*\\\\begin{\\([A-Za-z0-9]+\\*?\\)}") - (if (not (re-search-forward (format "^[ \t]*\\\\end{%s}[ \t]*$" + (looking-at org-element--latex-begin-environment) + (if (not (re-search-forward (format org-element--latex-end-environment (regexp-quote (match-string 1))) limit t)) ;; Incomplete latex environment: parse it as a paragraph. @@ -2094,10 +2192,11 @@ CONTENTS is nil." LIMIT bounds the search. Return a list whose CAR is `node-property' and CDR is a plist -containing `:key', `:value', `:begin', `:end' and `:post-blank' -keywords." +containing `:key', `:value', `:begin', `:end', `:post-blank' and +`:post-affiliated' keywords." (looking-at org-property-re) - (let ((begin (point)) + (let ((case-fold-search t) + (begin (point)) (key (org-match-string-no-properties 2)) (value (org-match-string-no-properties 3)) (end (save-excursion @@ -2110,7 +2209,8 @@ keywords." :value value :begin begin :end end - :post-blank 0)))) + :post-blank 0 + :post-affiliated begin)))) (defun org-element-node-property-interpreter (node-property contents) "Interpret NODE-PROPERTY element as Org syntax. @@ -2141,66 +2241,42 @@ Assume point is at the beginning of the paragraph." (before-blank (let ((case-fold-search t)) (end-of-line) - (if (not (re-search-forward - org-element-paragraph-separate limit 'm)) - limit - ;; A matching `org-element-paragraph-separate' is not - ;; necessarily the end of the paragraph. In - ;; particular, lines starting with # or : as a first - ;; non-space character are ambiguous. We have to - ;; check if they are valid Org syntax (e.g., not an - ;; incomplete keyword). - (beginning-of-line) - (while (not - (or - ;; There's no ambiguity for other symbols or - ;; empty lines: stop here. - (looking-at "[ \t]*\\(?:[^:#]\\|$\\)") - ;; Stop at valid fixed-width areas. - (looking-at "[ \t]*:\\(?: \\|$\\)") - ;; Stop at drawers. - (and (looking-at org-drawer-regexp) - (save-excursion - (re-search-forward - "^[ \t]*:END:[ \t]*$" limit t))) - ;; Stop at valid comments. - (looking-at "[ \t]*#\\(?: \\|$\\)") - ;; Stop at valid dynamic blocks. - (and (looking-at org-dblock-start-re) - (save-excursion - (re-search-forward - "^[ \t]*#\\+END:?[ \t]*$" limit t))) - ;; Stop at valid blocks. - (and (looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)") - (save-excursion - (re-search-forward - (format "^[ \t]*#\\+END_%s[ \t]*$" - (regexp-quote - (org-match-string-no-properties 1))) - limit t))) - ;; Stop at valid latex environments. - (and (looking-at - "[ \t]*\\\\begin{\\([A-Za-z0-9]+\\*?\\)}") - (save-excursion - (re-search-forward - (format "^[ \t]*\\\\end{%s}[ \t]*$" - (regexp-quote - (org-match-string-no-properties 1))) - limit t))) - ;; Stop at valid keywords. - (looking-at "[ \t]*#\\+\\S-+:") - ;; Skip everything else. - (not - (progn - (end-of-line) - (re-search-forward org-element-paragraph-separate - limit 'm))))) - (beginning-of-line))) + ;; A matching `org-element-paragraph-separate' is not + ;; necessarily the end of the paragraph. In particular, + ;; drawers, blocks or LaTeX environments opening lines + ;; must be closed. Moreover keywords with a secondary + ;; value must belong to "dual keywords". + (while (not + (cond + ((not (and (re-search-forward + org-element-paragraph-separate limit 'move) + (progn (beginning-of-line) t)))) + ((looking-at org-drawer-regexp) + (save-excursion + (re-search-forward "^[ \t]*:END:[ \t]*$" limit t))) + ((looking-at "[ \t]*#\\+BEGIN_\\(\\S-+\\)") + (save-excursion + (re-search-forward + (format "^[ \t]*#\\+END_%s[ \t]*$" + (regexp-quote (match-string 1))) + limit t))) + ((looking-at org-element--latex-begin-environment) + (save-excursion + (re-search-forward + (format org-element--latex-end-environment + (regexp-quote (match-string 1))) + limit t))) + ((looking-at "[ \t]*#\\+\\(\\S-+\\)\\[.*\\]:") + (member-ignore-case (match-string 1) + org-element-dual-keywords)) + ;; Everything else is unambiguous. + (t))) + (end-of-line)) (if (= (point) limit) limit (goto-char (line-beginning-position))))) - (contents-end (progn (skip-chars-backward " \r\t\n" contents-begin) - (forward-line) - (point))) + (contents-end (save-excursion + (skip-chars-backward " \r\t\n" contents-begin) + (line-beginning-position 2))) (end (progn (skip-chars-forward " \r\t\n" limit) (if (eobp) (point) (line-beginning-position))))) (list 'paragraph @@ -2227,8 +2303,8 @@ CONTENTS is the contents of the element." LIMIT bounds the search. Return a list whose CAR is `planning' and CDR is a plist -containing `:closed', `:deadline', `:scheduled', `:begin', `:end' -and `:post-blank' keywords." +containing `:closed', `:deadline', `:scheduled', `:begin', +`:end', `:post-blank' and `:post-affiliated' keywords." (save-excursion (let* ((case-fold-search nil) (begin (point)) @@ -2254,7 +2330,8 @@ and `:post-blank' keywords." :scheduled scheduled :begin begin :end end - :post-blank post-blank))))) + :post-blank post-blank + :post-affiliated begin))))) (defun org-element-planning-interpreter (planning contents) "Interpret PLANNING element as Org syntax. @@ -2277,37 +2354,6 @@ CONTENTS is nil." " ")) -;;;; Quote Section - -(defun org-element-quote-section-parser (limit) - "Parse a quote section. - -LIMIT bounds the search. - -Return a list whose CAR is `quote-section' and CDR is a plist -containing `:begin', `:end', `:value' and `:post-blank' keywords. - -Assume point is at beginning of the section." - (save-excursion - (let* ((begin (point)) - (end (progn (org-with-limited-levels (outline-next-heading)) - (point))) - (pos-before-blank (progn (skip-chars-backward " \r\t\n") - (forward-line) - (point))) - (value (buffer-substring-no-properties begin pos-before-blank))) - (list 'quote-section - (list :begin begin - :end end - :value value - :post-blank (count-lines pos-before-blank end)))))) - -(defun org-element-quote-section-interpreter (quote-section contents) - "Interpret QUOTE-SECTION element as Org syntax. -CONTENTS is nil." - (org-element-property :value quote-section)) - - ;;;; Src Block (defun org-element-src-block-parser (limit affiliated) @@ -2320,9 +2366,9 @@ their value. Return a list whose CAR is `src-block' and CDR is a plist containing `:language', `:switches', `:parameters', `:begin', -`:end', `:hiddenp', `:number-lines', `:retain-labels', -`:use-labels', `:label-fmt', `:preserve-indent', `:value', -`:post-blank' and `:post-affiliated' keywords. +`:end', `:number-lines', `:retain-labels', `:use-labels', +`:label-fmt', `:preserve-indent', `:value', `:post-blank' and +`:post-affiliated' keywords. Assume point is at the beginning of the block." (let ((case-fold-search t)) @@ -2352,9 +2398,8 @@ Assume point is at the beginning of the block." (cond ((not switches) nil) ((string-match "-n\\>" switches) 'new) ((string-match "+n\\>" switches) 'continued))) - (preserve-indent (or org-src-preserve-indentation - (and switches - (string-match "-i\\>" switches)))) + (preserve-indent (and switches + (string-match "-i\\>" switches))) (label-fmt (and switches (string-match "-l +\"\\([^\"\n]+\\)\"" switches) @@ -2373,14 +2418,12 @@ Assume point is at the beginning of the block." (not (string-match "-k\\>" switches))))) ;; Indentation. (block-ind (progn (skip-chars-forward " \t") (current-column))) - ;; Get visibility status. - (hidden (progn (forward-line) (org-invisible-p2))) ;; Retrieve code. - (value (org-element--remove-indentation + (value (org-element-remove-indentation (org-unescape-code-in-string (buffer-substring-no-properties - (point) contents-end)) - (and preserve-indent block-ind))) + (progn (forward-line) (point)) contents-end)) + block-ind)) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -2401,7 +2444,6 @@ Assume point is at the beginning of the block." :retain-labels retain-labels :use-labels use-labels :label-fmt label-fmt - :hiddenp hidden :value value :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) @@ -2413,20 +2455,22 @@ CONTENTS is nil." (let ((lang (org-element-property :language src-block)) (switches (org-element-property :switches src-block)) (params (org-element-property :parameters src-block)) - (value (let ((val (org-element-property :value src-block))) - (cond - ((org-element-property :preserve-indent src-block) val) - ((zerop org-edit-src-content-indentation) val) - (t - (let ((ind (make-string - org-edit-src-content-indentation 32))) - (replace-regexp-in-string - "\\(^\\)[ \t]*\\S-" ind val nil nil 1))))))) + (value + (let ((val (org-element-property :value src-block))) + (cond + ((or org-src-preserve-indentation + (org-element-property :preserve-indent src-block)) + val) + ((zerop org-edit-src-content-indentation) val) + (t + (let ((ind (make-string org-edit-src-content-indentation ?\s))) + (replace-regexp-in-string + "\\(^\\)[ \t]*\\S-" ind val nil nil 1))))))) (concat (format "#+BEGIN_SRC%s\n" (concat (and lang (concat " " lang)) (and switches (concat " " switches)) (and params (concat " " params)))) - (org-escape-code-in-string value) + (org-element-normalize-string (org-escape-code-in-string value)) "#+END_SRC"))) @@ -2449,10 +2493,12 @@ Assume point is at the beginning of the table." (save-excursion (let* ((case-fold-search t) (table-begin (point)) - (type (if (org-at-table.el-p) 'table.el 'org)) + (type (if (looking-at "[ \t]*|") 'org 'table.el)) + (end-re (format "^[ \t]*\\($\\|[^| \t%s]\\)" + (if (eq type 'org) "" "+"))) (begin (car affiliated)) (table-end - (if (re-search-forward org-table-any-border-regexp limit 'm) + (if (re-search-forward end-re limit 'move) (goto-char (match-beginning 0)) (point))) (tblfm (let (acc) @@ -2503,7 +2549,7 @@ LIMIT bounds the search. Return a list whose CAR is `table-row' and CDR is a plist containing `:begin', `:end', `:contents-begin', `:contents-end', -`:type' and `:post-blank' keywords." +`:type', `:post-blank' and `:post-affiliated' keywords." (save-excursion (let* ((type (if (looking-at "^[ \t]*|-") 'rule 'standard)) (begin (point)) @@ -2517,14 +2563,15 @@ containing `:begin', `:end', `:contents-begin', `:contents-end', (end-of-line) (skip-chars-backward " \t") (point)))) - (end (progn (forward-line) (point)))) + (end (line-beginning-position 2))) (list 'table-row (list :type type :begin begin :end end :contents-begin contents-begin :contents-end contents-end - :post-blank 0))))) + :post-blank 0 + :post-affiliated begin))))) (defun org-element-table-row-interpreter (table-row contents) "Interpret TABLE-ROW element as Org syntax. @@ -2545,7 +2592,7 @@ their value. Return a list whose CAR is `verse-block' and CDR is a plist containing `:begin', `:end', `:contents-begin', `:contents-end', -`:hiddenp', `:post-blank' and `:post-affiliated' keywords. +`:post-blank' and `:post-affiliated' keywords. Assume point is at beginning of the block." (let ((case-fold-search t)) @@ -2557,8 +2604,7 @@ Assume point is at beginning of the block." (save-excursion (let* ((begin (car affiliated)) (post-affiliated (point)) - (hidden (progn (forward-line) (org-invisible-p2))) - (contents-begin (point)) + (contents-begin (progn (forward-line) (point))) (pos-before-blank (progn (goto-char contents-end) (forward-line) (point))) @@ -2570,7 +2616,6 @@ Assume point is at beginning of the block." :end end :contents-begin contents-begin :contents-end contents-end - :hiddenp hidden :post-blank (count-lines pos-before-blank end) :post-affiliated post-affiliated) (cdr affiliated))))))))) @@ -2584,104 +2629,75 @@ CONTENTS is verse block contents." ;;; Objects ;; -;; Unlike to elements, interstices can be found between objects. -;; That's why, along with the parser, successor functions are provided -;; for each object. Some objects share the same successor (e.g., -;; `code' and `verbatim' objects). -;; -;; A successor must accept a single argument bounding the search. It -;; will return either a cons cell whose CAR is the object's type, as -;; a symbol, and CDR the position of its next occurrence, or nil. -;; -;; Successors follow the naming convention: -;; org-element-NAME-successor, where NAME is the name of the -;; successor, as defined in `org-element-all-successors'. +;; Unlike to elements, raw text can be found between objects. Hence, +;; `org-element--object-lex' is provided to find the next object in +;; buffer. ;; ;; Some object types (e.g., `italic') are recursive. Restrictions on ;; object types they can contain will be specified in ;; `org-element-object-restrictions'. ;; -;; Adding a new type of object is simple. Implement a successor, -;; a parser, and an interpreter for it, all following the naming -;; convention. Register type in `org-element-all-objects' and -;; successor in `org-element-all-successors'. Maybe tweak -;; restrictions about it, and that's it. - +;; Creating a new type of object requires to alter +;; `org-element--object-regexp' and `org-element--object-lex', add the +;; new type in `org-element-all-objects', and possibly add +;; restrictions in `org-element-object-restrictions'. ;;;; Bold (defun org-element-bold-parser () - "Parse bold object at point. + "Parse bold object at point, if any. -Return a list whose CAR is `bold' and CDR is a plist with -`:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at a bold object, return a list whose car is `bold' and cdr +is a plist with `:begin', `:end', `:contents-begin' and +`:contents-end' and `:post-blank' keywords. Otherwise, return +nil. Assume point is at the first star marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'bold - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'bold + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-bold-interpreter (bold contents) "Interpret BOLD object as Org syntax. CONTENTS is the contents of the object." (format "*%s*" contents)) -(defun org-element-text-markup-successor () - "Search for the next text-markup object. - -Return value is a cons cell whose CAR is a symbol among `bold', -`italic', `underline', `strike-through', `code' and `verbatim' -and CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (when (re-search-forward org-emph-re nil t) - (let ((marker (match-string 3))) - (cons (cond - ((equal marker "*") 'bold) - ((equal marker "/") 'italic) - ((equal marker "_") 'underline) - ((equal marker "+") 'strike-through) - ((equal marker "~") 'code) - ((equal marker "=") 'verbatim) - (t (error "Unknown marker at %d" (match-beginning 3)))) - (match-beginning 2)))))) - ;;;; Code (defun org-element-code-parser () - "Parse code object at point. + "Parse code object at point, if any. -Return a list whose CAR is `code' and CDR is a plist with -`:value', `:begin', `:end' and `:post-blank' keywords. +When at a code object, return a list whose car is `code' and cdr +is a plist with `:value', `:begin', `:end' and `:post-blank' +keywords. Otherwise, return nil. Assume point is at the first tilde marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (value (org-match-string-no-properties 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'code - (list :value value - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (value (org-match-string-no-properties 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'code + (list :value value + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-code-interpreter (code contents) "Interpret CODE object as Org syntax. @@ -2692,35 +2708,37 @@ CONTENTS is nil." ;;;; Entity (defun org-element-entity-parser () - "Parse entity at point. + "Parse entity at point, if any. -Return a list whose CAR is `entity' and CDR a plist with -`:begin', `:end', `:latex', `:latex-math-p', `:html', `:latin1', -`:utf-8', `:ascii', `:use-brackets-p' and `:post-blank' as -keywords. +When at an entity, return a list whose car is `entity' and cdr +a plist with `:begin', `:end', `:latex', `:latex-math-p', +`:html', `:latin1', `:utf-8', `:ascii', `:use-brackets-p' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the beginning of the entity." - (save-excursion - (looking-at "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]]\\)") - (let* ((value (org-entity-get (match-string 1))) - (begin (match-beginning 0)) - (bracketsp (string= (match-string 2) "{}")) - (post-blank (progn (goto-char (match-end 1)) - (when bracketsp (forward-char 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'entity - (list :name (car value) - :latex (nth 1 value) - :latex-math-p (nth 2 value) - :html (nth 3 value) - :ascii (nth 4 value) - :latin1 (nth 5 value) - :utf-8 (nth 6 value) - :begin begin - :end end - :use-brackets-p bracketsp - :post-blank post-blank))))) + (catch 'no-object + (when (looking-at "\\\\\\(?:\\(?1:_ +\\)\\|\\(?1:there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\(?2:$\\|{}\\|[^[:alpha:]]\\)\\)") + (save-excursion + (let* ((value (or (org-entity-get (match-string 1)) + (throw 'no-object nil))) + (begin (match-beginning 0)) + (bracketsp (string= (match-string 2) "{}")) + (post-blank (progn (goto-char (match-end 1)) + (when bracketsp (forward-char 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'entity + (list :name (car value) + :latex (nth 1 value) + :latex-math-p (nth 2 value) + :html (nth 3 value) + :ascii (nth 4 value) + :latin1 (nth 5 value) + :utf-8 (nth 6 value) + :begin begin + :end end + :use-brackets-p bracketsp + :post-blank post-blank))))))) (defun org-element-entity-interpreter (entity contents) "Interpret ENTITY object as Org syntax. @@ -2729,59 +2747,37 @@ CONTENTS is nil." (org-element-property :name entity) (when (org-element-property :use-brackets-p entity) "{}"))) -(defun org-element-latex-or-entity-successor () - "Search for the next latex-fragment or entity object. - -Return value is a cons cell whose CAR is `entity' or -`latex-fragment' and CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (let ((matchers (cdr org-latex-regexps)) - ;; ENTITY-RE matches both LaTeX commands and Org entities. - (entity-re - "\\\\\\(there4\\|sup[123]\\|frac[13][24]\\|[a-zA-Z]+\\)\\($\\|{}\\|[^[:alpha:]]\\)")) - (when (re-search-forward - (concat (mapconcat #'cadr matchers "\\|") "\\|" entity-re) nil t) - (goto-char (match-beginning 0)) - (if (looking-at entity-re) - ;; Determine if it's a real entity or a LaTeX command. - (cons (if (org-entity-get (match-string 1)) 'entity 'latex-fragment) - (match-beginning 0)) - ;; No entity nor command: point is at a LaTeX fragment. - ;; Determine its type to get the correct beginning position. - (cons 'latex-fragment - (catch 'return - (dolist (e matchers) - (when (looking-at (nth 1 e)) - (throw 'return (match-beginning (nth 2 e))))) - (point)))))))) - ;;;; Export Snippet (defun org-element-export-snippet-parser () "Parse export snippet at point. -Return a list whose CAR is `export-snippet' and CDR a plist with -`:begin', `:end', `:back-end', `:value' and `:post-blank' as -keywords. +When at an export snippet, return a list whose car is +`export-snippet' and cdr a plist with `:begin', `:end', +`:back-end', `:value' and `:post-blank' as keywords. Otherwise, +return nil. Assume point is at the beginning of the snippet." (save-excursion - (re-search-forward "@@\\([-A-Za-z0-9]+\\):" nil t) - (let* ((begin (match-beginning 0)) - (back-end (org-match-string-no-properties 1)) - (value (buffer-substring-no-properties - (point) - (progn (re-search-forward "@@" nil t) (match-beginning 0)))) - (post-blank (skip-chars-forward " \t")) - (end (point))) - (list 'export-snippet - (list :back-end back-end - :value value - :begin begin - :end end - :post-blank post-blank))))) + (let (contents-end) + (when (and (looking-at "@@\\([-A-Za-z0-9]+\\):") + (setq contents-end + (save-match-data (goto-char (match-end 0)) + (re-search-forward "@@" nil t) + (match-beginning 0)))) + (let* ((begin (match-beginning 0)) + (back-end (org-match-string-no-properties 1)) + (value (buffer-substring-no-properties + (match-end 0) contents-end)) + (post-blank (skip-chars-forward " \t")) + (end (point))) + (list 'export-snippet + (list :back-end back-end + :value value + :begin begin + :end end + :post-blank post-blank))))))) (defun org-element-export-snippet-interpreter (export-snippet contents) "Interpret EXPORT-SNIPPET object as Org syntax. @@ -2790,163 +2786,124 @@ CONTENTS is nil." (org-element-property :back-end export-snippet) (org-element-property :value export-snippet))) -(defun org-element-export-snippet-successor () - "Search for the next export-snippet object. - -Return value is a cons cell whose CAR is `export-snippet' and CDR -its beginning position." - (save-excursion - (let (beg) - (when (and (re-search-forward "@@[-A-Za-z0-9]+:" nil t) - (setq beg (match-beginning 0)) - (search-forward "@@" nil t)) - (cons 'export-snippet beg))))) - ;;;; Footnote Reference (defun org-element-footnote-reference-parser () - "Parse footnote reference at point. - -Return a list whose CAR is `footnote-reference' and CDR a plist -with `:label', `:type', `:inline-definition', `:begin', `:end' -and `:post-blank' as keywords." - (save-excursion - (looking-at org-footnote-re) - (let* ((begin (point)) - (label (or (org-match-string-no-properties 2) + "Parse footnote reference at point, if any. + +When at a footnote reference, return a list whose car is +`footnote-reference' and cdr a plist with `:label', `:type', +`:begin', `:end', `:content-begin', `:contents-end' and +`:post-blank' as keywords. Otherwise, return nil." + (when (looking-at org-footnote-re) + (let ((closing (with-syntax-table org-element--pair-square-table + (ignore-errors (scan-lists (point) 1 0))))) + (when closing + (save-excursion + (let* ((begin (point)) + (label + (or (org-match-string-no-properties 2) (org-match-string-no-properties 3) (and (match-string 1) (concat "fn:" (org-match-string-no-properties 1))))) - (type (if (or (not label) (match-string 1)) 'inline 'standard)) - (inner-begin (match-end 0)) - (inner-end - (let ((count 1)) - (forward-char) - (while (and (> count 0) (re-search-forward "[][]" nil t)) - (if (equal (match-string 0) "[") (incf count) (decf count))) - (1- (point)))) - (post-blank (progn (goto-char (1+ inner-end)) - (skip-chars-forward " \t"))) - (end (point)) - (footnote-reference + (type (if (or (not label) (match-string 1)) 'inline 'standard)) + (inner-begin (match-end 0)) + (inner-end (1- closing)) + (post-blank (progn (goto-char closing) + (skip-chars-forward " \t"))) + (end (point))) (list 'footnote-reference (list :label label :type type :begin begin :end end - :post-blank post-blank)))) - (org-element-put-property - footnote-reference :inline-definition - (and (eq type 'inline) - (org-element-parse-secondary-string - (buffer-substring inner-begin inner-end) - (org-element-restriction 'footnote-reference) - footnote-reference)))))) + :contents-begin (and (eq type 'inline) inner-begin) + :contents-end (and (eq type 'inline) inner-end) + :post-blank post-blank)))))))) (defun org-element-footnote-reference-interpreter (footnote-reference contents) "Interpret FOOTNOTE-REFERENCE object as Org syntax. -CONTENTS is nil." - (let ((label (or (org-element-property :label footnote-reference) "fn:")) - (def - (let ((inline-def - (org-element-property :inline-definition footnote-reference))) - (if (not inline-def) "" - (concat ":" (org-element-interpret-data inline-def)))))) - (format "[%s]" (concat label def)))) - -(defun org-element-footnote-reference-successor () - "Search for the next footnote-reference object. - -Return value is a cons cell whose CAR is `footnote-reference' and -CDR is beginning position." - (save-excursion - (catch 'exit - (while (re-search-forward org-footnote-re nil t) - (save-excursion - (let ((beg (match-beginning 0)) - (count 1)) - (backward-char) - (while (re-search-forward "[][]" nil t) - (if (equal (match-string 0) "[") (incf count) (decf count)) - (when (zerop count) - (throw 'exit (cons 'footnote-reference beg)))))))))) +CONTENTS is its definition, when inline, or nil." + (format "[%s]" + (concat (or (org-element-property :label footnote-reference) "fn:") + (and contents (concat ":" contents))))) ;;;; Inline Babel Call (defun org-element-inline-babel-call-parser () - "Parse inline babel call at point. + "Parse inline babel call at point, if any. -Return a list whose CAR is `inline-babel-call' and CDR a plist -with `:begin', `:end', `:info' and `:post-blank' as keywords. +When at an inline babel call, return a list whose car is +`inline-babel-call' and cdr a plist with `:call', +`:inside-header', `:arguments', `:end-header', `:begin', `:end', +`:value' and `:post-blank' as keywords. Otherwise, return nil. Assume point is at the beginning of the babel call." (save-excursion (unless (bolp) (backward-char)) - (looking-at org-babel-inline-lob-one-liner-regexp) - (let ((info (save-match-data (org-babel-lob-get-info))) - (begin (match-end 1)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'inline-babel-call - (list :begin begin - :end end - :info info - :post-blank post-blank))))) + (when (let ((case-fold-search t)) + (looking-at org-babel-inline-lob-one-liner-regexp)) + (let ((begin (match-end 1)) + (call (org-match-string-no-properties 2)) + (inside-header (org-string-nw-p (org-match-string-no-properties 4))) + (arguments (org-string-nw-p (org-match-string-no-properties 6))) + (end-header (org-string-nw-p (org-match-string-no-properties 8))) + (value (buffer-substring-no-properties (match-end 1) (match-end 0))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'inline-babel-call + (list :call call + :inside-header inside-header + :arguments arguments + :end-header end-header + :begin begin + :end end + :value value + :post-blank post-blank)))))) (defun org-element-inline-babel-call-interpreter (inline-babel-call contents) "Interpret INLINE-BABEL-CALL object as Org syntax. CONTENTS is nil." - (let* ((babel-info (org-element-property :info inline-babel-call)) - (main-source (car babel-info)) - (post-options (nth 1 babel-info))) - (concat "call_" - (if (string-match "\\[\\(\\[.*?\\]\\)\\]" main-source) - ;; Remove redundant square brackets. - (replace-match - (match-string 1 main-source) nil nil main-source) - main-source) - (and post-options (format "[%s]" post-options))))) - -(defun org-element-inline-babel-call-successor () - "Search for the next inline-babel-call object. - -Return value is a cons cell whose CAR is `inline-babel-call' and -CDR is beginning position." - (save-excursion - (when (re-search-forward org-babel-inline-lob-one-liner-regexp nil t) - (cons 'inline-babel-call (match-end 1))))) + (concat "call_" + (org-element-property :call inline-babel-call) + (let ((h (org-element-property :inside-header inline-babel-call))) + (and h (format "[%s]" h))) + "(" (org-element-property :arguments inline-babel-call) ")" + (let ((h (org-element-property :end-header inline-babel-call))) + (and h (format "[%s]" h))))) ;;;; Inline Src Block (defun org-element-inline-src-block-parser () - "Parse inline source block at point. + "Parse inline source block at point, if any. -Return a list whose CAR is `inline-src-block' and CDR a plist -with `:begin', `:end', `:language', `:value', `:parameters' and -`:post-blank' as keywords. +When at an inline source block, return a list whose car is +`inline-src-block' and cdr a plist with `:begin', `:end', +`:language', `:value', `:parameters' and `:post-blank' as +keywords. Otherwise, return nil. Assume point is at the beginning of the inline src block." (save-excursion (unless (bolp) (backward-char)) - (looking-at org-babel-inline-src-block-regexp) - (let ((begin (match-beginning 1)) - (language (org-match-string-no-properties 2)) - (parameters (org-match-string-no-properties 4)) - (value (org-match-string-no-properties 5)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'inline-src-block - (list :language language - :value value - :parameters parameters - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at org-babel-inline-src-block-regexp) + (let ((begin (match-beginning 1)) + (language (org-match-string-no-properties 2)) + (parameters (org-match-string-no-properties 4)) + (value (org-match-string-no-properties 5)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'inline-src-block + (list :language language + :value value + :parameters parameters + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-inline-src-block-interpreter (inline-src-block contents) "Interpret INLINE-SRC-BLOCK object as Org syntax. @@ -2959,41 +2916,32 @@ CONTENTS is nil." (if arguments (format "[%s]" arguments) "") body))) -(defun org-element-inline-src-block-successor () - "Search for the next inline-babel-call element. - -Return value is a cons cell whose CAR is `inline-babel-call' and -CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (when (re-search-forward org-babel-inline-src-block-regexp nil t) - (cons 'inline-src-block (match-beginning 1))))) - ;;;; Italic (defun org-element-italic-parser () - "Parse italic object at point. + "Parse italic object at point, if any. -Return a list whose CAR is `italic' and CDR is a plist with -`:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at an italic object, return a list whose car is `italic' and +cdr is a plist with `:begin', `:end', `:contents-begin' and +`:contents-end' and `:post-blank' keywords. Otherwise, return +nil. Assume point is at the first slash marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'italic - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'italic + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-italic-interpreter (italic contents) "Interpret ITALIC object as Org syntax. @@ -3004,36 +2952,42 @@ CONTENTS is the contents of the object." ;;;; Latex Fragment (defun org-element-latex-fragment-parser () - "Parse LaTeX fragment at point. + "Parse LaTeX fragment at point, if any. -Return a list whose CAR is `latex-fragment' and CDR a plist with -`:value', `:begin', `:end', and `:post-blank' as keywords. +When at a LaTeX fragment, return a list whose car is +`latex-fragment' and cdr a plist with `:value', `:begin', `:end', +and `:post-blank' as keywords. Otherwise, return nil. Assume point is at the beginning of the LaTeX fragment." - (save-excursion - (let* ((begin (point)) - (substring-match - (catch 'exit - (dolist (e (cdr org-latex-regexps)) - (let ((latex-regexp (nth 1 e))) - (when (or (looking-at latex-regexp) - (and (not (bobp)) - (save-excursion - (backward-char) - (looking-at latex-regexp)))) - (throw 'exit (nth 2 e))))) - ;; None found: it's a macro. - (looking-at "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*") - 0)) - (value (org-match-string-no-properties substring-match)) - (post-blank (progn (goto-char (match-end substring-match)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'latex-fragment - (list :value value - :begin begin - :end end - :post-blank post-blank))))) + (catch 'no-object + (save-excursion + (let* ((begin (point)) + (after-fragment + (if (eq (char-after) ?$) + (if (eq (char-after (1+ (point))) ?$) + (search-forward "$$" nil t 2) + (and (not (eq (char-before) ?$)) + (search-forward "$" nil t 2) + (not (memq (char-before (match-beginning 0)) + '(?\s ?\t ?\n ?, ?.))) + (looking-at "\\(\\s.\\|\\s-\\|\\s(\\|\\s)\\|\\s\"\\|$\\)") + (point))) + (case (char-after (1+ (point))) + (?\( (search-forward "\\)" nil t)) + (?\[ (search-forward "\\]" nil t)) + (otherwise + ;; Macro. + (and (looking-at "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*") + (match-end 0)))))) + (post-blank (if (not after-fragment) (throw 'no-object nil) + (goto-char after-fragment) + (skip-chars-forward " \t"))) + (end (point))) + (list 'latex-fragment + (list :value (buffer-substring-no-properties begin after-fragment) + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-latex-fragment-interpreter (latex-fragment contents) "Interpret LATEX-FRAGMENT object as Org syntax. @@ -3043,138 +2997,146 @@ CONTENTS is nil." ;;;; Line Break (defun org-element-line-break-parser () - "Parse line break at point. + "Parse line break at point, if any. -Return a list whose CAR is `line-break', and CDR a plist with -`:begin', `:end' and `:post-blank' keywords. +When at a line break, return a list whose car is `line-break', +and cdr a plist with `:begin', `:end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the beginning of the line break." - (list 'line-break - (list :begin (point) - :end (progn (forward-line) (point)) - :post-blank 0))) + (when (and (org-looking-at-p "\\\\\\\\[ \t]*$") + (not (eq (char-before) ?\\))) + (list 'line-break + (list :begin (point) + :end (line-beginning-position 2) + :post-blank 0)))) (defun org-element-line-break-interpreter (line-break contents) "Interpret LINE-BREAK object as Org syntax. CONTENTS is nil." "\\\\\n") -(defun org-element-line-break-successor () - "Search for the next line-break object. - -Return value is a cons cell whose CAR is `line-break' and CDR is -beginning position." - (save-excursion - (let ((beg (and (re-search-forward "[^\\\\]\\(\\\\\\\\\\)[ \t]*$" nil t) - (goto-char (match-beginning 1))))) - ;; A line break can only happen on a non-empty line. - (when (and beg (re-search-backward "\\S-" (point-at-bol) t)) - (cons 'line-break beg))))) - ;;;; Link (defun org-element-link-parser () - "Parse link at point. + "Parse link at point, if any. -Return a list whose CAR is `link' and CDR a plist with `:type', -`:path', `:raw-link', `:application', `:search-option', `:begin', -`:end', `:contents-begin', `:contents-end' and `:post-blank' as -keywords. +When at a link, return a list whose car is `link' and cdr a plist +with `:type', `:path', `:raw-link', `:application', +`:search-option', `:begin', `:end', `:contents-begin', +`:contents-end' and `:post-blank' as keywords. Otherwise, return +nil. Assume point is at the beginning of the link." - (save-excursion + (catch 'no-object (let ((begin (point)) end contents-begin contents-end link-end post-blank path type raw-link link search-option application) (cond ;; Type 1: Text targeted from a radio target. - ((and org-target-link-regexp (looking-at org-target-link-regexp)) + ((and org-target-link-regexp + (save-excursion (or (bolp) (backward-char)) + (looking-at org-target-link-regexp))) (setq type "radio" - link-end (match-end 0) - path (org-match-string-no-properties 0) - contents-begin (match-beginning 0) - contents-end (match-end 0))) + link-end (match-end 1) + path (org-match-string-no-properties 1) + contents-begin (match-beginning 1) + contents-end (match-end 1))) ;; Type 2: Standard link, i.e. [[http://orgmode.org][homepage]] ((looking-at org-bracket-link-regexp) - (setq contents-begin (match-beginning 3) - contents-end (match-end 3) - link-end (match-end 0) - ;; RAW-LINK is the original link. Expand any - ;; abbreviation in it. - raw-link (org-translate-link + (setq contents-begin (match-beginning 3)) + (setq contents-end (match-end 3)) + (setq link-end (match-end 0)) + ;; RAW-LINK is the original link. Expand any + ;; abbreviation in it. + ;; + ;; Also treat any newline character and associated + ;; indentation as a single space character. This is not + ;; compatible with RFC 3986, which requires to ignore + ;; them altogether. However, doing so would require + ;; users to encode spaces on the fly when writing links + ;; (e.g., insert [[shell:ls%20*.org]] instead of + ;; [[shell:ls *.org]], which defeats Org's focus on + ;; simplicity. + (setq raw-link (org-translate-link (org-link-expand-abbrev - (org-match-string-no-properties 1)))) - ;; Determine TYPE of link and set PATH accordingly. + (replace-regexp-in-string + "[ \t]*\n[ \t]*" " " + (org-match-string-no-properties 1))))) + ;; Determine TYPE of link and set PATH accordingly. According + ;; to RFC 3986, remove whitespaces from URI in external links. + ;; In internal ones, treat indentation as a single space. (cond ;; File type. ((or (file-name-absolute-p raw-link) (string-match "\\`\\.\\.?/" raw-link)) - (setq type "file" path raw-link)) + (setq type "file") + (setq path raw-link)) ;; Explicit type (http, irc, bbdb...). See `org-link-types'. ((string-match org-link-types-re raw-link) - (setq type (match-string 1 raw-link) - ;; According to RFC 3986, extra whitespace should be - ;; ignored when a URI is extracted. - path (replace-regexp-in-string - "[ \t]*\n[ \t]*" "" (substring raw-link (match-end 0))))) + (setq type (match-string 1 raw-link)) + (setq path (substring raw-link (match-end 0)))) ;; Id type: PATH is the id. - ((string-match "\\`id:\\([-a-f0-9]+\\)" raw-link) + ((string-match "\\`id:\\([-a-f0-9]+\\)\\'" raw-link) (setq type "id" path (match-string 1 raw-link))) ;; Code-ref type: PATH is the name of the reference. - ((string-match "\\`(\\(.*\\))\\'" raw-link) - (setq type "coderef" path (match-string 1 raw-link))) + ((and (org-string-match-p "\\`(" raw-link) + (org-string-match-p ")\\'" raw-link)) + (setq type "coderef") + (setq path (substring raw-link 1 -1))) ;; Custom-id type: PATH is the name of the custom id. - ((= (aref raw-link 0) ?#) - (setq type "custom-id" path (substring raw-link 1))) + ((= (string-to-char raw-link) ?#) + (setq type "custom-id") + (setq path (substring raw-link 1))) ;; Fuzzy type: Internal link either matches a target, an ;; headline name or nothing. PATH is the target or ;; headline's name. - (t (setq type "fuzzy" path raw-link)))) + (t + (setq type "fuzzy") + (setq path raw-link)))) ;; Type 3: Plain link, e.g., http://orgmode.org ((looking-at org-plain-link-re) (setq raw-link (org-match-string-no-properties 0) type (org-match-string-no-properties 1) link-end (match-end 0) path (org-match-string-no-properties 2))) - ;; Type 4: Angular link, e.g., <http://orgmode.org> + ;; Type 4: Angular link, e.g., <http://orgmode.org>. Unlike to + ;; bracket links, follow RFC 3986 and remove any extra + ;; whitespace in URI. ((looking-at org-angle-link-re) - (setq raw-link (buffer-substring-no-properties - (match-beginning 1) (match-end 2)) - type (org-match-string-no-properties 1) - link-end (match-end 0) - path (org-match-string-no-properties 2)))) + (setq type (org-match-string-no-properties 1)) + (setq link-end (match-end 0)) + (setq raw-link + (buffer-substring-no-properties + (match-beginning 1) (match-end 2))) + (setq path (replace-regexp-in-string + "[ \t]*\n[ \t]*" "" (org-match-string-no-properties 2)))) + (t (throw 'no-object nil))) ;; In any case, deduce end point after trailing white space from ;; LINK-END variable. - (setq post-blank (progn (goto-char link-end) (skip-chars-forward " \t")) - end (point)) - ;; Special "file" type link processing. - (when (member type org-element-link-type-is-file) - ;; Extract opening application and search option. - (cond ((string-match "^file\\+\\(.*\\)$" type) - (setq application (match-string 1 type))) - ((not (string-match "^file" type)) - (setq application type))) - (when (string-match "::\\(.*\\)\\'" path) - (setq search-option (match-string 1 path) - path (replace-match "" nil nil path))) - ;; Normalize URI. - (when (and (not (org-string-match-p "\\`//" path)) - (file-name-absolute-p path)) - (setq path (concat "//" (expand-file-name path)))) - ;; Make sure TYPE always reports "file". - (setq type "file")) - (list 'link - (list :type type - :path path - :raw-link (or raw-link path) - :application application - :search-option search-option - :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (save-excursion + (setq post-blank (progn (goto-char link-end) (skip-chars-forward " \t")) + end (point)) + ;; Special "file" type link processing. Extract opening + ;; application and search option, if any. Also normalize URI. + (when (string-match "\\`file\\(?:\\+\\(.+\\)\\)?\\'" type) + (setq application (match-string 1 type) type "file") + (when (string-match "::\\(.*\\)\\'" path) + (setq search-option (match-string 1 path) + path (replace-match "" nil nil path))) + (setq path (replace-regexp-in-string "\\`/+" "/" path))) + (list 'link + (list :type type + :path path + :raw-link (or raw-link path) + :application application + :search-option search-option + :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-link-interpreter (link contents) "Interpret LINK object as Org syntax. @@ -3186,188 +3148,131 @@ CONTENTS is the contents of the object, or nil." raw-link (if contents (format "[%s]" contents) ""))))) -(defun org-element-link-successor () - "Search for the next link object. - -Return value is a cons cell whose CAR is `link' and CDR is -beginning position." - (save-excursion - (let ((link-regexp - (if (not org-target-link-regexp) org-any-link-re - (concat org-any-link-re "\\|" org-target-link-regexp)))) - (when (re-search-forward link-regexp nil t) - (cons 'link (match-beginning 0)))))) - -(defun org-element-plain-link-successor () - "Search for the next plain link object. - -Return value is a cons cell whose CAR is `link' and CDR is -beginning position." - (and (save-excursion (re-search-forward org-plain-link-re nil t)) - (cons 'link (match-beginning 0)))) - ;;;; Macro (defun org-element-macro-parser () - "Parse macro at point. + "Parse macro at point, if any. -Return a list whose CAR is `macro' and CDR a plist with `:key', -`:args', `:begin', `:end', `:value' and `:post-blank' as -keywords. +When at a macro, return a list whose car is `macro' and cdr +a plist with `:key', `:args', `:begin', `:end', `:value' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the macro." (save-excursion - (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}") - (let ((begin (point)) - (key (downcase (org-match-string-no-properties 1))) - (value (org-match-string-no-properties 0)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point)) - (args (let ((args (org-match-string-no-properties 3))) - (when args - ;; Do not use `org-split-string' since empty - ;; strings are meaningful here. - (split-string - (replace-regexp-in-string - "\\(\\\\*\\)\\(,\\)" - (lambda (str) - (let ((len (length (match-string 1 str)))) - (concat (make-string (/ len 2) ?\\) - (if (zerop (mod len 2)) "\000" ",")))) - args nil t) - "\000"))))) - (list 'macro - (list :key key - :value value - :args args - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}") + (let ((begin (point)) + (key (downcase (org-match-string-no-properties 1))) + (value (org-match-string-no-properties 0)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point)) + (args (let ((args (org-match-string-no-properties 3))) + (and args (org-macro-extract-arguments args))))) + (list 'macro + (list :key key + :value value + :args args + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-macro-interpreter (macro contents) "Interpret MACRO object as Org syntax. CONTENTS is nil." (org-element-property :value macro)) -(defun org-element-macro-successor () - "Search for the next macro object. - -Return value is cons cell whose CAR is `macro' and CDR is -beginning position." - (save-excursion - (when (re-search-forward - "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}" - nil t) - (cons 'macro (match-beginning 0))))) - ;;;; Radio-target (defun org-element-radio-target-parser () - "Parse radio target at point. + "Parse radio target at point, if any. -Return a list whose CAR is `radio-target' and CDR a plist with -`:begin', `:end', `:contents-begin', `:contents-end', `:value' -and `:post-blank' as keywords. +When at a radio target, return a list whose car is `radio-target' +and cdr a plist with `:begin', `:end', `:contents-begin', +`:contents-end', `:value' and `:post-blank' as keywords. +Otherwise, return nil. Assume point is at the radio target." (save-excursion - (looking-at org-radio-target-regexp) - (let ((begin (point)) - (contents-begin (match-beginning 1)) - (contents-end (match-end 1)) - (value (org-match-string-no-properties 1)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'radio-target - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank - :value value))))) + (when (looking-at org-radio-target-regexp) + (let ((begin (point)) + (contents-begin (match-beginning 1)) + (contents-end (match-end 1)) + (value (org-match-string-no-properties 1)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'radio-target + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank + :value value)))))) (defun org-element-radio-target-interpreter (target contents) "Interpret TARGET object as Org syntax. CONTENTS is the contents of the object." (concat "<<<" contents ">>>")) -(defun org-element-radio-target-successor () - "Search for the next radio-target object. - -Return value is a cons cell whose CAR is `radio-target' and CDR -is beginning position." - (save-excursion - (when (re-search-forward org-radio-target-regexp nil t) - (cons 'radio-target (match-beginning 0))))) - ;;;; Statistics Cookie (defun org-element-statistics-cookie-parser () - "Parse statistics cookie at point. + "Parse statistics cookie at point, if any. -Return a list whose CAR is `statistics-cookie', and CDR a plist -with `:begin', `:end', `:value' and `:post-blank' keywords. +When at a statistics cookie, return a list whose car is +`statistics-cookie', and cdr a plist with `:begin', `:end', +`:value' and `:post-blank' keywords. Otherwise, return nil. Assume point is at the beginning of the statistics-cookie." (save-excursion - (looking-at "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]") - (let* ((begin (point)) - (value (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'statistics-cookie - (list :begin begin - :end end - :value value - :post-blank post-blank))))) + (when (looking-at "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]") + (let* ((begin (point)) + (value (buffer-substring-no-properties + (match-beginning 0) (match-end 0))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'statistics-cookie + (list :begin begin + :end end + :value value + :post-blank post-blank)))))) (defun org-element-statistics-cookie-interpreter (statistics-cookie contents) "Interpret STATISTICS-COOKIE object as Org syntax. CONTENTS is nil." (org-element-property :value statistics-cookie)) -(defun org-element-statistics-cookie-successor () - "Search for the next statistics cookie object. - -Return value is a cons cell whose CAR is `statistics-cookie' and -CDR is beginning position." - (save-excursion - (when (re-search-forward "\\[[0-9]*\\(%\\|/[0-9]*\\)\\]" nil t) - (cons 'statistics-cookie (match-beginning 0))))) - ;;;; Strike-Through (defun org-element-strike-through-parser () - "Parse strike-through object at point. + "Parse strike-through object at point, if any. -Return a list whose CAR is `strike-through' and CDR is a plist -with `:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at a strike-through object, return a list whose car is +`strike-through' and cdr is a plist with `:begin', `:end', +`:contents-begin' and `:contents-end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the first plus sign marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'strike-through - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'strike-through + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-strike-through-interpreter (strike-through contents) "Interpret STRIKE-THROUGH object as Org syntax. @@ -3378,32 +3283,32 @@ CONTENTS is the contents of the object." ;;;; Subscript (defun org-element-subscript-parser () - "Parse subscript at point. + "Parse subscript at point, if any. -Return a list whose CAR is `subscript' and CDR a plist with -`:begin', `:end', `:contents-begin', `:contents-end', -`:use-brackets-p' and `:post-blank' as keywords. +When at a subscript object, return a list whose car is +`subscript' and cdr a plist with `:begin', `:end', +`:contents-begin', `:contents-end', `:use-brackets-p' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the underscore." (save-excursion (unless (bolp) (backward-char)) - (let ((bracketsp (if (looking-at org-match-substring-with-braces-regexp) - t - (not (looking-at org-match-substring-regexp)))) - (begin (match-beginning 2)) - (contents-begin (or (match-beginning 5) - (match-beginning 3))) - (contents-end (or (match-end 5) (match-end 3))) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'subscript - (list :begin begin - :end end - :use-brackets-p bracketsp - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-match-substring-regexp) + (let ((bracketsp (match-beginning 4)) + (begin (match-beginning 2)) + (contents-begin (or (match-beginning 4) + (match-beginning 3))) + (contents-end (or (match-end 4) (match-end 3))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'subscript + (list :begin begin + :end end + :use-brackets-p bracketsp + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-subscript-interpreter (subscript contents) "Interpret SUBSCRIPT object as Org syntax. @@ -3412,46 +3317,36 @@ CONTENTS is the contents of the object." (if (org-element-property :use-brackets-p subscript) "_{%s}" "_%s") contents)) -(defun org-element-sub/superscript-successor () - "Search for the next sub/superscript object. - -Return value is a cons cell whose CAR is either `subscript' or -`superscript' and CDR is beginning position." - (save-excursion - (unless (bolp) (backward-char)) - (when (re-search-forward org-match-substring-regexp nil t) - (cons (if (string= (match-string 2) "_") 'subscript 'superscript) - (match-beginning 2))))) - ;;;; Superscript (defun org-element-superscript-parser () - "Parse superscript at point. + "Parse superscript at point, if any. -Return a list whose CAR is `superscript' and CDR a plist with -`:begin', `:end', `:contents-begin', `:contents-end', -`:use-brackets-p' and `:post-blank' as keywords. +When at a superscript object, return a list whose car is +`superscript' and cdr a plist with `:begin', `:end', +`:contents-begin', `:contents-end', `:use-brackets-p' and +`:post-blank' as keywords. Otherwise, return nil. Assume point is at the caret." (save-excursion (unless (bolp) (backward-char)) - (let ((bracketsp (if (looking-at org-match-substring-with-braces-regexp) t - (not (looking-at org-match-substring-regexp)))) - (begin (match-beginning 2)) - (contents-begin (or (match-beginning 5) - (match-beginning 3))) - (contents-end (or (match-end 5) (match-end 3))) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'superscript - (list :begin begin - :end end - :use-brackets-p bracketsp - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-match-substring-regexp) + (let ((bracketsp (match-beginning 4)) + (begin (match-beginning 2)) + (contents-begin (or (match-beginning 4) + (match-beginning 3))) + (contents-end (or (match-end 4) (match-end 3))) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'superscript + (list :begin begin + :end end + :use-brackets-p bracketsp + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-superscript-interpreter (superscript contents) "Interpret SUPERSCRIPT object as Org syntax. @@ -3465,8 +3360,7 @@ CONTENTS is the contents of the object." (defun org-element-table-cell-parser () "Parse table cell at point. - -Return a list whose CAR is `table-cell' and CDR is a plist +Return a list whose car is `table-cell' and cdr is a plist containing `:begin', `:end', `:contents-begin', `:contents-end' and `:post-blank' keywords." (looking-at "[ \t]*\\(.*?\\)[ \t]*\\(?:|\\|$\\)") @@ -3486,291 +3380,270 @@ and `:post-blank' keywords." CONTENTS is the contents of the cell, or nil." (concat " " contents " |")) -(defun org-element-table-cell-successor () - "Search for the next table-cell object. - -Return value is a cons cell whose CAR is `table-cell' and CDR is -beginning position." - (when (looking-at "[ \t]*.*?[ \t]*\\(|\\|$\\)") (cons 'table-cell (point)))) - ;;;; Target (defun org-element-target-parser () - "Parse target at point. + "Parse target at point, if any. -Return a list whose CAR is `target' and CDR a plist with -`:begin', `:end', `:value' and `:post-blank' as keywords. +When at a target, return a list whose car is `target' and cdr +a plist with `:begin', `:end', `:value' and `:post-blank' as +keywords. Otherwise, return nil. Assume point is at the target." (save-excursion - (looking-at org-target-regexp) - (let ((begin (point)) - (value (org-match-string-no-properties 1)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'target - (list :begin begin - :end end - :value value - :post-blank post-blank))))) + (when (looking-at org-target-regexp) + (let ((begin (point)) + (value (org-match-string-no-properties 1)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'target + (list :begin begin + :end end + :value value + :post-blank post-blank)))))) (defun org-element-target-interpreter (target contents) "Interpret TARGET object as Org syntax. CONTENTS is nil." (format "<<%s>>" (org-element-property :value target))) -(defun org-element-target-successor () - "Search for the next target object. - -Return value is a cons cell whose CAR is `target' and CDR is -beginning position." - (save-excursion - (when (re-search-forward org-target-regexp nil t) - (cons 'target (match-beginning 0))))) - ;;;; Timestamp +(defconst org-element--timestamp-regexp + (concat org-ts-regexp-both + "\\|" + "\\(?:<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)" + "\\|" + "\\(?:<%%\\(?:([^>\n]+)\\)>\\)") + "Regexp matching any timestamp type object.") + (defun org-element-timestamp-parser () - "Parse time stamp at point. + "Parse time stamp at point, if any. -Return a list whose CAR is `timestamp', and CDR a plist with -`:type', `:raw-value', `:year-start', `:month-start', -`:day-start', `:hour-start', `:minute-start', `:year-end', -`:month-end', `:day-end', `:hour-end', `:minute-end', -`:repeater-type', `:repeater-value', `:repeater-unit', -`:warning-type', `:warning-value', `:warning-unit', `:begin', -`:end' and `:post-blank' keywords. +When at a time stamp, return a list whose car is `timestamp', and +cdr a plist with `:type', `:raw-value', `:year-start', +`:month-start', `:day-start', `:hour-start', `:minute-start', +`:year-end', `:month-end', `:day-end', `:hour-end', +`:minute-end', `:repeater-type', `:repeater-value', +`:repeater-unit', `:warning-type', `:warning-value', +`:warning-unit', `:begin', `:end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the beginning of the timestamp." - (save-excursion - (let* ((begin (point)) - (activep (eq (char-after) ?<)) - (raw-value - (progn - (looking-at "\\([<[]\\(%%\\)?.*?\\)[]>]\\(?:--\\([<[].*?[]>]\\)\\)?") - (match-string-no-properties 0))) - (date-start (match-string-no-properties 1)) - (date-end (match-string 3)) - (diaryp (match-beginning 2)) - (post-blank (progn (goto-char (match-end 0)) - (skip-chars-forward " \t"))) - (end (point)) - (time-range - (and (not diaryp) - (string-match - "[012]?[0-9]:[0-5][0-9]\\(-\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)" - date-start) - (cons (string-to-number (match-string 2 date-start)) - (string-to-number (match-string 3 date-start))))) - (type (cond (diaryp 'diary) - ((and activep (or date-end time-range)) 'active-range) - (activep 'active) - ((or date-end time-range) 'inactive-range) - (t 'inactive))) - (repeater-props - (and (not diaryp) - (string-match "\\([.+]?\\+\\)\\([0-9]+\\)\\([hdwmy]\\)" - raw-value) - (list - :repeater-type - (let ((type (match-string 1 raw-value))) - (cond ((equal "++" type) 'catch-up) - ((equal ".+" type) 'restart) - (t 'cumulate))) - :repeater-value (string-to-number (match-string 2 raw-value)) - :repeater-unit - (case (string-to-char (match-string 3 raw-value)) - (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) - (warning-props - (and (not diaryp) - (string-match "\\(-\\)?-\\([0-9]+\\)\\([hdwmy]\\)" raw-value) - (list - :warning-type (if (match-string 1 raw-value) 'first 'all) - :warning-value (string-to-number (match-string 2 raw-value)) - :warning-unit - (case (string-to-char (match-string 3 raw-value)) - (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) - year-start month-start day-start hour-start minute-start year-end - month-end day-end hour-end minute-end) - ;; Parse date-start. - (unless diaryp - (let ((date (org-parse-time-string date-start t))) - (setq year-start (nth 5 date) - month-start (nth 4 date) - day-start (nth 3 date) - hour-start (nth 2 date) - minute-start (nth 1 date)))) - ;; Compute date-end. It can be provided directly in time-stamp, - ;; or extracted from time range. Otherwise, it defaults to the - ;; same values as date-start. - (unless diaryp - (let ((date (and date-end (org-parse-time-string date-end t)))) - (setq year-end (or (nth 5 date) year-start) - month-end (or (nth 4 date) month-start) - day-end (or (nth 3 date) day-start) - hour-end (or (nth 2 date) (car time-range) hour-start) - minute-end (or (nth 1 date) (cdr time-range) minute-start)))) - (list 'timestamp - (nconc (list :type type - :raw-value raw-value - :year-start year-start - :month-start month-start - :day-start day-start - :hour-start hour-start - :minute-start minute-start - :year-end year-end - :month-end month-end - :day-end day-end - :hour-end hour-end - :minute-end minute-end - :begin begin - :end end - :post-blank post-blank) - repeater-props - warning-props))))) + (when (org-looking-at-p org-element--timestamp-regexp) + (save-excursion + (let* ((begin (point)) + (activep (eq (char-after) ?<)) + (raw-value + (progn + (looking-at "\\([<[]\\(%%\\)?.*?\\)[]>]\\(?:--\\([<[].*?[]>]\\)\\)?") + (match-string-no-properties 0))) + (date-start (match-string-no-properties 1)) + (date-end (match-string 3)) + (diaryp (match-beginning 2)) + (post-blank (progn (goto-char (match-end 0)) + (skip-chars-forward " \t"))) + (end (point)) + (time-range + (and (not diaryp) + (string-match + "[012]?[0-9]:[0-5][0-9]\\(-\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)" + date-start) + (cons (string-to-number (match-string 2 date-start)) + (string-to-number (match-string 3 date-start))))) + (type (cond (diaryp 'diary) + ((and activep (or date-end time-range)) 'active-range) + (activep 'active) + ((or date-end time-range) 'inactive-range) + (t 'inactive))) + (repeater-props + (and (not diaryp) + (string-match "\\([.+]?\\+\\)\\([0-9]+\\)\\([hdwmy]\\)" + raw-value) + (list + :repeater-type + (let ((type (match-string 1 raw-value))) + (cond ((equal "++" type) 'catch-up) + ((equal ".+" type) 'restart) + (t 'cumulate))) + :repeater-value (string-to-number (match-string 2 raw-value)) + :repeater-unit + (case (string-to-char (match-string 3 raw-value)) + (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) + (warning-props + (and (not diaryp) + (string-match "\\(-\\)?-\\([0-9]+\\)\\([hdwmy]\\)" raw-value) + (list + :warning-type (if (match-string 1 raw-value) 'first 'all) + :warning-value (string-to-number (match-string 2 raw-value)) + :warning-unit + (case (string-to-char (match-string 3 raw-value)) + (?h 'hour) (?d 'day) (?w 'week) (?m 'month) (t 'year))))) + year-start month-start day-start hour-start minute-start year-end + month-end day-end hour-end minute-end) + ;; Parse date-start. + (unless diaryp + (let ((date (org-parse-time-string date-start t))) + (setq year-start (nth 5 date) + month-start (nth 4 date) + day-start (nth 3 date) + hour-start (nth 2 date) + minute-start (nth 1 date)))) + ;; Compute date-end. It can be provided directly in time-stamp, + ;; or extracted from time range. Otherwise, it defaults to the + ;; same values as date-start. + (unless diaryp + (let ((date (and date-end (org-parse-time-string date-end t)))) + (setq year-end (or (nth 5 date) year-start) + month-end (or (nth 4 date) month-start) + day-end (or (nth 3 date) day-start) + hour-end (or (nth 2 date) (car time-range) hour-start) + minute-end (or (nth 1 date) (cdr time-range) minute-start)))) + (list 'timestamp + (nconc (list :type type + :raw-value raw-value + :year-start year-start + :month-start month-start + :day-start day-start + :hour-start hour-start + :minute-start minute-start + :year-end year-end + :month-end month-end + :day-end day-end + :hour-end hour-end + :minute-end minute-end + :begin begin + :end end + :post-blank post-blank) + repeater-props + warning-props)))))) (defun org-element-timestamp-interpreter (timestamp contents) "Interpret TIMESTAMP object as Org syntax. CONTENTS is nil." - ;; Use `:raw-value' if specified. - (or (org-element-property :raw-value timestamp) - ;; Otherwise, build timestamp string. - (let* ((repeat-string - (concat - (case (org-element-property :repeater-type timestamp) - (cumulate "+") (catch-up "++") (restart ".+")) - (let ((val (org-element-property :repeater-value timestamp))) - (and val (number-to-string val))) - (case (org-element-property :repeater-unit timestamp) - (hour "h") (day "d") (week "w") (month "m") (year "y")))) - (warning-string - (concat - (case (org-element-property :warning-type timestamp) - (first "--") - (all "-")) - (let ((val (org-element-property :warning-value timestamp))) - (and val (number-to-string val))) - (case (org-element-property :warning-unit timestamp) - (hour "h") (day "d") (week "w") (month "m") (year "y")))) - (build-ts-string - ;; Build an Org timestamp string from TIME. ACTIVEP is - ;; non-nil when time stamp is active. If WITH-TIME-P is - ;; non-nil, add a time part. HOUR-END and MINUTE-END - ;; specify a time range in the timestamp. REPEAT-STRING - ;; is the repeater string, if any. - (lambda (time activep &optional with-time-p hour-end minute-end) - (let ((ts (format-time-string - (funcall (if with-time-p 'cdr 'car) - org-time-stamp-formats) - time))) - (when (and hour-end minute-end) - (string-match "[012]?[0-9]:[0-5][0-9]" ts) - (setq ts - (replace-match - (format "\\&-%02d:%02d" hour-end minute-end) - nil nil ts))) - (unless activep (setq ts (format "[%s]" (substring ts 1 -1)))) - (dolist (s (list repeat-string warning-string)) - (when (org-string-nw-p s) - (setq ts (concat (substring ts 0 -1) - " " - s - (substring ts -1))))) - ;; Return value. - ts))) - (type (org-element-property :type timestamp))) - (case type - ((active inactive) - (let* ((minute-start (org-element-property :minute-start timestamp)) - (minute-end (org-element-property :minute-end timestamp)) - (hour-start (org-element-property :hour-start timestamp)) - (hour-end (org-element-property :hour-end timestamp)) - (time-range-p (and hour-start hour-end minute-start minute-end - (or (/= hour-start hour-end) - (/= minute-start minute-end))))) - (funcall - build-ts-string - (encode-time 0 - (or minute-start 0) - (or hour-start 0) - (org-element-property :day-start timestamp) - (org-element-property :month-start timestamp) - (org-element-property :year-start timestamp)) - (eq type 'active) - (and hour-start minute-start) - (and time-range-p hour-end) - (and time-range-p minute-end)))) - ((active-range inactive-range) - (let ((minute-start (org-element-property :minute-start timestamp)) - (minute-end (org-element-property :minute-end timestamp)) - (hour-start (org-element-property :hour-start timestamp)) - (hour-end (org-element-property :hour-end timestamp))) - (concat - (funcall - build-ts-string (encode-time - 0 - (or minute-start 0) - (or hour-start 0) - (org-element-property :day-start timestamp) - (org-element-property :month-start timestamp) - (org-element-property :year-start timestamp)) - (eq type 'active-range) - (and hour-start minute-start)) - "--" - (funcall build-ts-string - (encode-time 0 - (or minute-end 0) - (or hour-end 0) - (org-element-property :day-end timestamp) - (org-element-property :month-end timestamp) - (org-element-property :year-end timestamp)) - (eq type 'active-range) - (and hour-end minute-end))))))))) - -(defun org-element-timestamp-successor () - "Search for the next timestamp object. - -Return value is a cons cell whose CAR is `timestamp' and CDR is -beginning position." - (save-excursion - (when (re-search-forward - (concat org-ts-regexp-both - "\\|" - "\\(?:<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)" - "\\|" - "\\(?:<%%\\(?:([^>\n]+)\\)>\\)") - nil t) - (cons 'timestamp (match-beginning 0))))) + (let* ((repeat-string + (concat + (case (org-element-property :repeater-type timestamp) + (cumulate "+") (catch-up "++") (restart ".+")) + (let ((val (org-element-property :repeater-value timestamp))) + (and val (number-to-string val))) + (case (org-element-property :repeater-unit timestamp) + (hour "h") (day "d") (week "w") (month "m") (year "y")))) + (warning-string + (concat + (case (org-element-property :warning-type timestamp) + (first "--") + (all "-")) + (let ((val (org-element-property :warning-value timestamp))) + (and val (number-to-string val))) + (case (org-element-property :warning-unit timestamp) + (hour "h") (day "d") (week "w") (month "m") (year "y")))) + (build-ts-string + ;; Build an Org timestamp string from TIME. ACTIVEP is + ;; non-nil when time stamp is active. If WITH-TIME-P is + ;; non-nil, add a time part. HOUR-END and MINUTE-END + ;; specify a time range in the timestamp. REPEAT-STRING is + ;; the repeater string, if any. + (lambda (time activep &optional with-time-p hour-end minute-end) + (let ((ts (format-time-string + (funcall (if with-time-p 'cdr 'car) + org-time-stamp-formats) + time))) + (when (and hour-end minute-end) + (string-match "[012]?[0-9]:[0-5][0-9]" ts) + (setq ts + (replace-match + (format "\\&-%02d:%02d" hour-end minute-end) + nil nil ts))) + (unless activep (setq ts (format "[%s]" (substring ts 1 -1)))) + (dolist (s (list repeat-string warning-string)) + (when (org-string-nw-p s) + (setq ts (concat (substring ts 0 -1) + " " + s + (substring ts -1))))) + ;; Return value. + ts))) + (type (org-element-property :type timestamp))) + (case type + ((active inactive) + (let* ((minute-start (org-element-property :minute-start timestamp)) + (minute-end (org-element-property :minute-end timestamp)) + (hour-start (org-element-property :hour-start timestamp)) + (hour-end (org-element-property :hour-end timestamp)) + (time-range-p (and hour-start hour-end minute-start minute-end + (or (/= hour-start hour-end) + (/= minute-start minute-end))))) + (funcall + build-ts-string + (encode-time 0 + (or minute-start 0) + (or hour-start 0) + (org-element-property :day-start timestamp) + (org-element-property :month-start timestamp) + (org-element-property :year-start timestamp)) + (eq type 'active) + (and hour-start minute-start) + (and time-range-p hour-end) + (and time-range-p minute-end)))) + ((active-range inactive-range) + (let ((minute-start (org-element-property :minute-start timestamp)) + (minute-end (org-element-property :minute-end timestamp)) + (hour-start (org-element-property :hour-start timestamp)) + (hour-end (org-element-property :hour-end timestamp))) + (concat + (funcall + build-ts-string (encode-time + 0 + (or minute-start 0) + (or hour-start 0) + (org-element-property :day-start timestamp) + (org-element-property :month-start timestamp) + (org-element-property :year-start timestamp)) + (eq type 'active-range) + (and hour-start minute-start)) + "--" + (funcall build-ts-string + (encode-time 0 + (or minute-end 0) + (or hour-end 0) + (org-element-property :day-end timestamp) + (org-element-property :month-end timestamp) + (org-element-property :year-end timestamp)) + (eq type 'active-range) + (and hour-end minute-end))))) + (otherwise (org-element-property :raw-value timestamp))))) ;;;; Underline (defun org-element-underline-parser () - "Parse underline object at point. + "Parse underline object at point, if any. -Return a list whose CAR is `underline' and CDR is a plist with -`:begin', `:end', `:contents-begin' and `:contents-end' and -`:post-blank' keywords. +When at an underline object, return a list whose car is +`underline' and cdr is a plist with `:begin', `:end', +`:contents-begin' and `:contents-end' and `:post-blank' keywords. +Otherwise, return nil. Assume point is at the first underscore marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (contents-begin (match-beginning 4)) - (contents-end (match-end 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'underline - (list :begin begin - :end end - :contents-begin contents-begin - :contents-end contents-end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (contents-begin (match-beginning 4)) + (contents-end (match-end 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'underline + (list :begin begin + :end end + :contents-begin contents-begin + :contents-end contents-end + :post-blank post-blank)))))) (defun org-element-underline-interpreter (underline contents) "Interpret UNDERLINE object as Org syntax. @@ -3781,25 +3654,26 @@ CONTENTS is the contents of the object." ;;;; Verbatim (defun org-element-verbatim-parser () - "Parse verbatim object at point. + "Parse verbatim object at point, if any. -Return a list whose CAR is `verbatim' and CDR is a plist with -`:value', `:begin', `:end' and `:post-blank' keywords. +When at a verbatim object, return a list whose car is `verbatim' +and cdr is a plist with `:value', `:begin', `:end' and +`:post-blank' keywords. Otherwise, return nil. Assume point is at the first equal sign marker." (save-excursion (unless (bolp) (backward-char 1)) - (looking-at org-emph-re) - (let ((begin (match-beginning 2)) - (value (org-match-string-no-properties 4)) - (post-blank (progn (goto-char (match-end 2)) - (skip-chars-forward " \t"))) - (end (point))) - (list 'verbatim - (list :value value - :begin begin - :end end - :post-blank post-blank))))) + (when (looking-at org-emph-re) + (let ((begin (match-beginning 2)) + (value (org-match-string-no-properties 4)) + (post-blank (progn (goto-char (match-end 2)) + (skip-chars-forward " \t"))) + (end (point))) + (list 'verbatim + (list :value value + :begin begin + :end end + :post-blank post-blank)))))) (defun org-element-verbatim-interpreter (verbatim contents) "Interpret VERBATIM object as Org syntax. @@ -3818,10 +3692,9 @@ CONTENTS is nil." ;; are activated for fixed element chaining (e.g., `plain-list' > ;; `item') or fixed conditional element chaining (e.g., `headline' > ;; `section'). Special modes are: `first-section', `item', -;; `node-property', `quote-section', `section' and `table-row'. +;; `node-property', `section' and `table-row'. -(defun org-element--current-element - (limit &optional granularity special structure) +(defun org-element--current-element (limit &optional granularity mode structure) "Parse the element starting at point. Return value is a list like (TYPE PROPS) where TYPE is the type @@ -3838,12 +3711,12 @@ recursion. Allowed values are `headline', `greater-element', nil), secondary values will not be parsed, since they only contain objects. -Optional argument SPECIAL, when non-nil, can be either -`first-section', `item', `node-property', `quote-section', -`section', and `table-row'. +Optional argument MODE, when non-nil, can be either +`first-section', `section', `planning', `item', `node-property' +and `table-row'. -If STRUCTURE isn't provided but SPECIAL is set to `item', it will -be computed. +If STRUCTURE isn't provided but MODE is set to `item', it will be +computed. This function assumes point is always at the beginning of the element it has to parse." @@ -3855,30 +3728,33 @@ element it has to parse." (raw-secondary-p (and granularity (not (eq granularity 'object))))) (cond ;; Item. - ((eq special 'item) + ((eq mode 'item) (org-element-item-parser limit structure raw-secondary-p)) ;; Table Row. - ((eq special 'table-row) (org-element-table-row-parser limit)) + ((eq mode 'table-row) (org-element-table-row-parser limit)) ;; Node Property. - ((eq special 'node-property) (org-element-node-property-parser limit)) + ((eq mode 'node-property) (org-element-node-property-parser limit)) ;; Headline. ((org-with-limited-levels (org-at-heading-p)) (org-element-headline-parser limit raw-secondary-p)) ;; Sections (must be checked after headline). - ((eq special 'section) (org-element-section-parser limit)) - ((eq special 'quote-section) (org-element-quote-section-parser limit)) - ((eq special 'first-section) + ((eq mode 'section) (org-element-section-parser limit)) + ((eq mode 'first-section) (org-element-section-parser (or (save-excursion (org-with-limited-levels (outline-next-heading))) limit))) + ;; Planning. + ((and (eq mode 'planning) (looking-at org-planning-line-re)) + (org-element-planning-parser limit)) + ;; Property drawer. + ((and (memq mode '(planning property-drawer)) + (looking-at org-property-drawer-re)) + (org-element-property-drawer-parser limit)) ;; When not at bol, point is at the beginning of an item or ;; a footnote definition: next item is always a paragraph. ((not (bolp)) (org-element-paragraph-parser limit (list (point)))) - ;; Planning and Clock. - ((looking-at org-planning-or-clock-line-re) - (if (equal (match-string 1) org-clock-string) - (org-element-clock-parser limit) - (org-element-planning-parser limit))) + ;; Clock. + ((looking-at org-clock-line-re) (org-element-clock-parser limit)) ;; Inlinetask. ((org-at-heading-p) (org-element-inlinetask-parser limit raw-secondary-p)) @@ -3891,13 +3767,11 @@ element it has to parse." (goto-char (car affiliated)) (org-element-keyword-parser limit nil)) ;; LaTeX Environment. - ((looking-at "[ \t]*\\\\begin{\\([A-Za-z0-9]+\\*?\\)}\\(\\[.*?\\]\\|{.*?}\\)*[ \t]*$") + ((looking-at org-element--latex-begin-environment) (org-element-latex-environment-parser limit affiliated)) ;; Drawer and Property Drawer. ((looking-at org-drawer-regexp) - (if (equal (match-string 1) "PROPERTIES") - (org-element-property-drawer-parser limit affiliated) - (org-element-drawer-parser limit affiliated))) + (org-element-drawer-parser limit affiliated)) ;; Fixed Width ((looking-at "[ \t]*:\\( \\|$\\)") (org-element-fixed-width-parser limit affiliated)) @@ -3936,7 +3810,8 @@ element it has to parse." ((looking-at "%%(") (org-element-diary-sexp-parser limit affiliated)) ;; Table. - ((org-at-table-p t) (org-element-table-parser limit affiliated)) + ((looking-at "[ \t]*\\(|\\|\\+\\(-+\\+\\)+[ \t]*$\\)") + (org-element-table-parser limit affiliated)) ;; List. ((looking-at (org-item-re)) (org-element-plain-list-parser @@ -3980,7 +3855,7 @@ position of point and CDR is nil." (save-match-data (org-trim (buffer-substring-no-properties - (match-end 0) (point-at-eol))))) + (match-end 0) (line-end-position))))) ;; PARSEDP is non-nil when keyword should have its ;; value parsed. (parsedp (member kwd org-element-parsed-keywords)) @@ -3991,12 +3866,17 @@ position of point and CDR is nil." (and dualp (let ((sec (org-match-string-no-properties 2))) (if (or (not sec) (not parsedp)) sec - (org-element-parse-secondary-string sec restrict))))) + (org-element--parse-objects + (match-beginning 2) (match-end 2) nil restrict))))) ;; Attribute a property name to KWD. (kwd-sym (and kwd (intern (concat ":" (downcase kwd)))))) ;; Now set final shape for VALUE. (when parsedp - (setq value (org-element-parse-secondary-string value restrict))) + (setq value + (org-element--parse-objects + (match-end 0) + (progn (end-of-line) (skip-chars-backward " \t") (point)) + nil restrict))) (when dualp (setq value (and (or value dual-value) (cons value dual-value)))) (when (or (member kwd org-element-multiple-keywords) @@ -4089,23 +3969,28 @@ looked after. Optional argument PARENT, when non-nil, is the element or object containing the secondary string. It is used to set correctly -`:parent' property within the string." - (let ((local-variables (buffer-local-variables))) - (with-temp-buffer - (dolist (v local-variables) - (ignore-errors - (if (symbolp v) (makunbound v) - (org-set-local (car v) (cdr v))))) - (insert string) - (restore-buffer-modified-p nil) - (let ((secondary (org-element--parse-objects - (point-min) (point-max) nil restriction))) - (when parent - (dolist (o secondary) (org-element-put-property o :parent parent))) - secondary)))) +`:parent' property within the string. + +If STRING is the empty string or nil, return nil." + (cond + ((not string) nil) + ((equal string "") nil) + (t (let ((local-variables (buffer-local-variables))) + (with-temp-buffer + (dolist (v local-variables) + (ignore-errors + (if (symbolp v) (makunbound v) + (org-set-local (car v) (cdr v))))) + (insert string) + (restore-buffer-modified-p nil) + (let ((data (org-element--parse-objects + (point-min) (point-max) nil restriction))) + (when parent + (dolist (o data) (org-element-put-property o :parent parent))) + data)))))) (defun org-element-map - (data types fun &optional info first-match no-recursion with-affiliated) + (data types fun &optional info first-match no-recursion with-affiliated) "Map a function on selected elements or objects. DATA is a parse tree, an element, an object, a string, or a list @@ -4141,7 +4026,7 @@ Assuming TREE is a variable containing an Org buffer parse tree, the following example will return a flat list of all `src-block' and `example-block' elements in it: - \(org-element-map tree '(example-block src-block) 'identity) + \(org-element-map tree '(example-block src-block) #'identity) The following snippet will find the first headline with a level of 1 and a \"phone\" tag, and will return its beginning position: @@ -4156,7 +4041,7 @@ of 1 and a \"phone\" tag, and will return its beginning position: The next example will return a flat list of all `plain-list' type elements in TREE that are not a sub-list themselves: - \(org-element-map tree 'plain-list 'identity nil nil 'plain-list) + \(org-element-map tree 'plain-list #'identity nil nil 'plain-list) Eventually, this example will return a flat list of all `bold' type objects containing a `latex-snippet' type object, even @@ -4164,112 +4049,98 @@ looking into captions: \(org-element-map tree 'bold \(lambda (b) - \(and (org-element-map b 'latex-snippet 'identity nil t) b)) + \(and (org-element-map b 'latex-snippet #'identity nil t) b)) nil nil nil t)" ;; Ensure TYPES and NO-RECURSION are a list, even of one element. - (unless (listp types) (setq types (list types))) - (unless (listp no-recursion) (setq no-recursion (list no-recursion))) - ;; Recursion depth is determined by --CATEGORY. - (let* ((--category + (let* ((types (if (listp types) types (list types))) + (no-recursion (if (listp no-recursion) no-recursion + (list no-recursion))) + ;; Recursion depth is determined by --CATEGORY. + (--category (catch 'found - (let ((category 'greater-elements)) - (mapc (lambda (type) - (cond ((or (memq type org-element-all-objects) - (eq type 'plain-text)) - ;; If one object is found, the function - ;; has to recurse into every object. - (throw 'found 'objects)) - ((not (memq type org-element-greater-elements)) - ;; If one regular element is found, the - ;; function has to recurse, at least, - ;; into every element it encounters. - (and (not (eq category 'elements)) - (setq category 'elements))))) - types) - category))) - ;; Compute properties for affiliated keywords if necessary. - (--affiliated-alist - (and with-affiliated - (mapcar (lambda (kwd) - (cons kwd (intern (concat ":" (downcase kwd))))) - org-element-affiliated-keywords))) + (let ((category 'greater-elements) + (all-objects (cons 'plain-text org-element-all-objects))) + (dolist (type types category) + (cond ((memq type all-objects) + ;; If one object is found, the function has to + ;; recurse into every object. + (throw 'found 'objects)) + ((not (memq type org-element-greater-elements)) + ;; If one regular element is found, the + ;; function has to recurse, at least, into + ;; every element it encounters. + (and (not (eq category 'elements)) + (setq category 'elements)))))))) --acc --walk-tree (--walk-tree - (function - (lambda (--data) - ;; Recursively walk DATA. INFO, if non-nil, is a plist - ;; holding contextual information. - (let ((--type (org-element-type --data))) - (cond - ((not --data)) - ;; Ignored element in an export context. - ((and info (memq --data (plist-get info :ignore-list)))) - ;; List of elements or objects. - ((not --type) (mapc --walk-tree --data)) - ;; Unconditionally enter parse trees. - ((eq --type 'org-data) - (mapc --walk-tree (org-element-contents --data))) - (t - ;; Check if TYPE is matching among TYPES. If so, - ;; apply FUN to --DATA and accumulate return value - ;; into --ACC (or exit if FIRST-MATCH is non-nil). - (when (memq --type types) - (let ((result (funcall fun --data))) - (cond ((not result)) - (first-match (throw '--map-first-match result)) - (t (push result --acc))))) - ;; If --DATA has a secondary string that can contain - ;; objects with their type among TYPES, look into it. - (when (and (eq --category 'objects) (not (stringp --data))) - (let ((sec-prop - (assq --type org-element-secondary-value-alist))) - (when sec-prop - (funcall --walk-tree - (org-element-property (cdr sec-prop) --data))))) - ;; If --DATA has any affiliated keywords and - ;; WITH-AFFILIATED is non-nil, look for objects in - ;; them. - (when (and with-affiliated - (eq --category 'objects) - (memq --type org-element-all-elements)) - (mapc (lambda (kwd-pair) - (let ((kwd (car kwd-pair)) - (value (org-element-property - (cdr kwd-pair) --data))) - ;; Pay attention to the type of value. - ;; Preserve order for multiple keywords. - (cond - ((not value)) - ((and (member kwd org-element-multiple-keywords) - (member kwd org-element-dual-keywords)) - (mapc (lambda (line) - (funcall --walk-tree (cdr line)) - (funcall --walk-tree (car line))) - (reverse value))) - ((member kwd org-element-multiple-keywords) - (mapc (lambda (line) (funcall --walk-tree line)) - (reverse value))) - ((member kwd org-element-dual-keywords) - (funcall --walk-tree (cdr value)) - (funcall --walk-tree (car value))) - (t (funcall --walk-tree value))))) - --affiliated-alist)) - ;; Determine if a recursion into --DATA is possible. - (cond - ;; --TYPE is explicitly removed from recursion. - ((memq --type no-recursion)) - ;; --DATA has no contents. - ((not (org-element-contents --data))) - ;; Looking for greater elements but --DATA is simply - ;; an element or an object. - ((and (eq --category 'greater-elements) - (not (memq --type org-element-greater-elements)))) - ;; Looking for elements but --DATA is an object. - ((and (eq --category 'elements) - (memq --type org-element-all-objects))) - ;; In any other case, map contents. - (t (mapc --walk-tree (org-element-contents --data))))))))))) + (lambda (--data) + ;; Recursively walk DATA. INFO, if non-nil, is a plist + ;; holding contextual information. + (let ((--type (org-element-type --data))) + (cond + ((not --data)) + ;; Ignored element in an export context. + ((and info (memq --data (plist-get info :ignore-list)))) + ;; List of elements or objects. + ((not --type) (mapc --walk-tree --data)) + ;; Unconditionally enter parse trees. + ((eq --type 'org-data) + (mapc --walk-tree (org-element-contents --data))) + (t + ;; Check if TYPE is matching among TYPES. If so, + ;; apply FUN to --DATA and accumulate return value + ;; into --ACC (or exit if FIRST-MATCH is non-nil). + (when (memq --type types) + (let ((result (funcall fun --data))) + (cond ((not result)) + (first-match (throw '--map-first-match result)) + (t (push result --acc))))) + ;; If --DATA has a secondary string that can contain + ;; objects with their type among TYPES, look into it. + (when (and (eq --category 'objects) (not (stringp --data))) + (dolist (p (cdr (assq --type + org-element-secondary-value-alist))) + (funcall --walk-tree (org-element-property p --data)))) + ;; If --DATA has any parsed affiliated keywords and + ;; WITH-AFFILIATED is non-nil, look for objects in + ;; them. + (when (and with-affiliated + (eq --category 'objects) + (memq --type org-element-all-elements)) + (dolist (kwd-pair org-element--parsed-properties-alist) + (let ((kwd (car kwd-pair)) + (value (org-element-property (cdr kwd-pair) --data))) + ;; Pay attention to the type of parsed keyword. + ;; In particular, preserve order for multiple + ;; keywords. + (cond + ((not value)) + ((member kwd org-element-dual-keywords) + (if (member kwd org-element-multiple-keywords) + (dolist (line (reverse value)) + (funcall --walk-tree (cdr line)) + (funcall --walk-tree (car line))) + (funcall --walk-tree (cdr value)) + (funcall --walk-tree (car value)))) + ((member kwd org-element-multiple-keywords) + (mapc --walk-tree (reverse value))) + (t (funcall --walk-tree value)))))) + ;; Determine if a recursion into --DATA is possible. + (cond + ;; --TYPE is explicitly removed from recursion. + ((memq --type no-recursion)) + ;; --DATA has no contents. + ((not (org-element-contents --data))) + ;; Looking for greater elements but --DATA is simply + ;; an element or an object. + ((and (eq --category 'greater-elements) + (not (memq --type org-element-greater-elements)))) + ;; Looking for elements but --DATA is an object. + ((and (eq --category 'elements) + (memq --type org-element-all-objects))) + ;; In any other case, map contents. + (t (mapc --walk-tree (org-element-contents --data)))))))))) (catch '--map-first-match (funcall --walk-tree data) ;; Return value in a proper order. @@ -4282,24 +4153,37 @@ looking into captions: ;; level. ;; ;; The second one, `org-element--parse-objects' applies on all objects -;; of a paragraph or a secondary string. It uses -;; `org-element--get-next-object-candidates' to optimize the search of -;; the next object in the buffer. -;; -;; More precisely, that function looks for every allowed object type -;; first. Then, it discards failed searches, keeps further matches, -;; and searches again types matched behind point, for subsequent -;; calls. Thus, searching for a given type fails only once, and every -;; object is searched only once at top level (but sometimes more for -;; nested types). +;; of a paragraph or a secondary string. It calls +;; `org-element--object-lex' to find the next object in the current +;; container. + +(defsubst org-element--next-mode (type parentp) + "Return next special mode according to TYPE, or nil. +TYPE is a symbol representing the type of an element or object +containing next element if PARENTP is non-nil, or before it +otherwise. Modes can be either `first-section', `item', +`node-property', `planning', `property-drawer', `section', +`table-row' or nil." + (if parentp + (case type + (headline 'section) + (plain-list 'item) + (property-drawer 'node-property) + (section 'planning) + (table 'table-row)) + (case type + (item 'item) + (node-property 'node-property) + (planning 'property-drawer) + (table-row 'table-row)))) (defun org-element--parse-elements - (beg end special structure granularity visible-only acc) + (beg end mode structure granularity visible-only acc) "Parse elements between BEG and END positions. -SPECIAL prioritize some elements over the others. It can be set -to `first-section', `quote-section', `section' `item' or -`table-row'. +MODE prioritizes some elements over the others. It can be set to +`first-section', `section', `planning', `item', `node-property' +or `table-row'. When value is `item', STRUCTURE will be used as the current list structure. @@ -4325,7 +4209,7 @@ Elements are accumulated into ACC." ;; Find current element's type and parse it accordingly to ;; its category. (let* ((element (org-element--current-element - end granularity special structure)) + end granularity mode structure)) (type (org-element-type element)) (cbeg (org-element-property :contents-begin element))) (goto-char (org-element-property :end element)) @@ -4348,13 +4232,7 @@ Elements are accumulated into ACC." (org-element--parse-elements cbeg (org-element-property :contents-end element) ;; Possibly switch to a special mode. - (case type - (headline - (if (org-element-property :quotedp element) 'quote-section - 'section)) - (plain-list 'item) - (property-drawer 'node-property) - (table 'table-row)) + (org-element--next-mode type t) (and (memq type '(item plain-list)) (org-element-property :structure element)) granularity visible-only element)) @@ -4364,10 +4242,99 @@ Elements are accumulated into ACC." (org-element--parse-objects cbeg (org-element-property :contents-end element) element (org-element-restriction type)))) - (org-element-adopt-elements acc element))) + (org-element-adopt-elements acc element) + ;; Update mode. + (setq mode (org-element--next-mode type nil)))) ;; Return result. acc)) +(defun org-element--object-lex (restriction) + "Return next object in current buffer or nil. +RESTRICTION is a list of object types, as symbols, that should be +looked after. This function assumes that the buffer is narrowed +to an appropriate container (e.g., a paragraph)." + (if (memq 'table-cell restriction) (org-element-table-cell-parser) + (save-excursion + (let ((limit (and org-target-link-regexp + (save-excursion + (or (bolp) (backward-char)) + (re-search-forward org-target-link-regexp nil t)) + (match-beginning 1))) + found) + (while (and (not found) + (re-search-forward org-element--object-regexp limit t)) + (goto-char (match-beginning 0)) + (let ((result (match-string 0))) + (setq found + (cond + ((eq (compare-strings result nil nil "call_" nil nil t) t) + (and (memq 'inline-babel-call restriction) + (org-element-inline-babel-call-parser))) + ((eq (compare-strings result nil nil "src_" nil nil t) t) + (and (memq 'inline-src-block restriction) + (org-element-inline-src-block-parser))) + (t + (case (char-after) + (?^ (and (memq 'superscript restriction) + (org-element-superscript-parser))) + (?_ (or (and (memq 'subscript restriction) + (org-element-subscript-parser)) + (and (memq 'underline restriction) + (org-element-underline-parser)))) + (?* (and (memq 'bold restriction) + (org-element-bold-parser))) + (?/ (and (memq 'italic restriction) + (org-element-italic-parser))) + (?~ (and (memq 'code restriction) + (org-element-code-parser))) + (?= (and (memq 'verbatim restriction) + (org-element-verbatim-parser))) + (?+ (and (memq 'strike-through restriction) + (org-element-strike-through-parser))) + (?@ (and (memq 'export-snippet restriction) + (org-element-export-snippet-parser))) + (?{ (and (memq 'macro restriction) + (org-element-macro-parser))) + (?$ (and (memq 'latex-fragment restriction) + (org-element-latex-fragment-parser))) + (?< + (if (eq (aref result 1) ?<) + (or (and (memq 'radio-target restriction) + (org-element-radio-target-parser)) + (and (memq 'target restriction) + (org-element-target-parser))) + (or (and (memq 'timestamp restriction) + (org-element-timestamp-parser)) + (and (memq 'link restriction) + (org-element-link-parser))))) + (?\\ + (if (eq (aref result 1) ?\\) + (and (memq 'line-break restriction) + (org-element-line-break-parser)) + (or (and (memq 'entity restriction) + (org-element-entity-parser)) + (and (memq 'latex-fragment restriction) + (org-element-latex-fragment-parser))))) + (?\[ + (if (eq (aref result 1) ?\[) + (and (memq 'link restriction) + (org-element-link-parser)) + (or (and (memq 'footnote-reference restriction) + (org-element-footnote-reference-parser)) + (and (memq 'timestamp restriction) + (org-element-timestamp-parser)) + (and (memq 'statistics-cookie restriction) + (org-element-statistics-cookie-parser))))) + ;; This is probably a plain link. + (otherwise (and (or (memq 'link restriction) + (memq 'plain-link restriction)) + (org-element-link-parser))))))) + (or (eobp) (forward-char)))) + (cond (found) + ;; Radio link. + ((and limit (memq 'link restriction)) + (goto-char limit) (org-element-link-parser))))))) + (defun org-element--parse-objects (beg end acc restriction) "Parse objects between BEG and END and return recursive structure. @@ -4375,85 +4342,44 @@ Objects are accumulated in ACC. RESTRICTION is a list of object successors which are allowed in the current object." - (let ((candidates 'initial)) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (let (next-object) (while (and (not (eobp)) - (setq candidates - (org-element--get-next-object-candidates - restriction candidates))) - (let ((next-object - (let ((pos (apply 'min (mapcar 'cdr candidates)))) - (save-excursion - (goto-char pos) - (funcall (intern (format "org-element-%s-parser" - (car (rassq pos candidates))))))))) - ;; 1. Text before any object. Untabify it. - (let ((obj-beg (org-element-property :begin next-object))) - (unless (= (point) obj-beg) - (setq acc - (org-element-adopt-elements - acc - (replace-regexp-in-string - "\t" (make-string tab-width ? ) - (buffer-substring-no-properties (point) obj-beg)))))) - ;; 2. Object... - (let ((obj-end (org-element-property :end next-object)) - (cont-beg (org-element-property :contents-begin next-object))) - ;; Fill contents of NEXT-OBJECT by side-effect, if it has - ;; a recursive type. - (when (and cont-beg - (memq (car next-object) org-element-recursive-objects)) - (org-element--parse-objects - cont-beg (org-element-property :contents-end next-object) - next-object (org-element-restriction next-object))) - (setq acc (org-element-adopt-elements acc next-object)) - (goto-char obj-end)))) - ;; 3. Text after last object. Untabify it. - (unless (eobp) - (setq acc - (org-element-adopt-elements - acc - (replace-regexp-in-string - "\t" (make-string tab-width ? ) - (buffer-substring-no-properties (point) end))))) - ;; Result. - acc)))) - -(defun org-element--get-next-object-candidates (restriction objects) - "Return an alist of candidates for the next object. - -RESTRICTION is a list of object types, as symbols. Only -candidates with such types are looked after. - -OBJECTS is the previous candidates alist. If it is set to -`initial', no search has been done before, and all symbols in -RESTRICTION should be looked after. - -Return value is an alist whose CAR is the object type and CDR its -beginning position." - (delq - nil - (if (eq objects 'initial) - ;; When searching for the first time, look for every successor - ;; allowed in RESTRICTION. - (mapcar - (lambda (res) - (funcall (intern (format "org-element-%s-successor" res)))) - restriction) - ;; Focus on objects returned during last search. Keep those - ;; still after point. Search again objects before it. - (mapcar - (lambda (obj) - (if (>= (cdr obj) (point)) obj - (let* ((type (car obj)) - (succ (or (cdr (assq type org-element-object-successor-alist)) - type))) - (and succ - (funcall (intern (format "org-element-%s-successor" succ))))))) - objects)))) + (setq next-object (org-element--object-lex restriction))) + ;; 1. Text before any object. Untabify it. + (let ((obj-beg (org-element-property :begin next-object))) + (unless (= (point) obj-beg) + (setq acc + (org-element-adopt-elements + acc + (replace-regexp-in-string + "\t" (make-string tab-width ? ) + (buffer-substring-no-properties (point) obj-beg)))))) + ;; 2. Object... + (let ((obj-end (org-element-property :end next-object)) + (cont-beg (org-element-property :contents-begin next-object))) + ;; Fill contents of NEXT-OBJECT by side-effect, if it has + ;; a recursive type. + (when (and cont-beg + (memq (car next-object) org-element-recursive-objects)) + (org-element--parse-objects + cont-beg (org-element-property :contents-end next-object) + next-object (org-element-restriction next-object))) + (setq acc (org-element-adopt-elements acc next-object)) + (goto-char obj-end)))) + ;; 3. Text after last object. Untabify it. + (unless (eobp) + (setq acc + (org-element-adopt-elements + acc + (replace-regexp-in-string + "\t" (make-string tab-width ? ) + (buffer-substring-no-properties (point) end))))) + ;; Result. + acc))) @@ -4468,71 +4394,77 @@ beginning position." ;; `org-element--interpret-affiliated-keywords'. ;;;###autoload -(defun org-element-interpret-data (data &optional parent) +(defun org-element-interpret-data (data) "Interpret DATA as Org syntax. - DATA is a parse tree, an element, an object or a secondary string -to interpret. +to interpret. Return Org syntax as a string." + (org-element--interpret-data-1 data nil)) -Optional argument PARENT is used for recursive calls. It contains +(defun org-element--interpret-data-1 (data parent) + "Interpret DATA as Org syntax. + +DATA is a parse tree, an element, an object or a secondary string +to interpret. PARENT is used for recursive calls. It contains the element or object containing data, or nil. Return Org syntax as a string." (let* ((type (org-element-type data)) + ;; Find interpreter for current object or element. If it + ;; doesn't exist (e.g. this is a pseudo object or element), + ;; return contents, if any. + (interpret + (let ((fun (intern (format "org-element-%s-interpreter" type)))) + (if (fboundp fun) fun (lambda (data contents) contents)))) (results (cond ;; Secondary string. ((not type) (mapconcat - (lambda (obj) (org-element-interpret-data obj parent)) - data "")) + (lambda (obj) (org-element--interpret-data-1 obj parent)) data "")) ;; Full Org document. ((eq type 'org-data) - (mapconcat - (lambda (obj) (org-element-interpret-data obj parent)) - (org-element-contents data) "")) + (mapconcat (lambda (obj) (org-element--interpret-data-1 obj parent)) + (org-element-contents data) "")) ;; Plain text: return it. ((stringp data) data) - ;; Element/Object without contents. - ((not (org-element-contents data)) - (funcall (intern (format "org-element-%s-interpreter" type)) - data nil)) - ;; Element/Object with contents. + ;; Element or object without contents. + ((not (org-element-contents data)) (funcall interpret data nil)) + ;; Element or object with contents. (t - (let* ((greaterp (memq type org-element-greater-elements)) - (objectp (and (not greaterp) - (memq type org-element-recursive-objects))) - (contents - (mapconcat - (lambda (obj) (org-element-interpret-data obj data)) - (org-element-contents - (if (or greaterp objectp) data - ;; Elements directly containing objects must - ;; have their indentation normalized first. - (org-element-normalize-contents - data - ;; When normalizing first paragraph of an - ;; item or a footnote-definition, ignore - ;; first line's indentation. - (and (eq type 'paragraph) - (equal data (car (org-element-contents parent))) - (memq (org-element-type parent) - '(footnote-definition item)))))) - ""))) - (funcall (intern (format "org-element-%s-interpreter" type)) - data - (if greaterp (org-element-normalize-contents contents) - contents))))))) + (funcall interpret data + ;; Recursively interpret contents. + (mapconcat + (lambda (obj) (org-element--interpret-data-1 obj data)) + (org-element-contents + (if (not (memq type '(paragraph verse-block))) + data + ;; Fix indentation of elements containing + ;; objects. We ignore `table-row' elements + ;; as they are one line long anyway. + (org-element-normalize-contents + data + ;; When normalizing first paragraph of an + ;; item or a footnote-definition, ignore + ;; first line's indentation. + (and (eq type 'paragraph) + (equal data (car (org-element-contents parent))) + (memq (org-element-type parent) + '(footnote-definition item)))))) + "")))))) (if (memq type '(org-data plain-text nil)) results ;; Build white spaces. If no `:post-blank' property is ;; specified, assume its value is 0. (let ((post-blank (or (org-element-property :post-blank data) 0))) - (if (memq type org-element-all-objects) - (concat results (make-string post-blank 32)) + (if (or (memq type org-element-all-objects) + (and parent + (let ((type (org-element-type parent))) + (or (not type) + (memq type org-element-object-containers))))) + (concat results (make-string post-blank ?\s)) (concat (org-element--interpret-affiliated-keywords data) (org-element-normalize-string results) - (make-string post-blank 10))))))) + (make-string post-blank ?\n))))))) (defun org-element--interpret-affiliated-keywords (element) "Return ELEMENT's affiliated keywords as Org syntax. @@ -4616,25 +4548,29 @@ indentation is not done with TAB characters." (find-min-ind ;; Return minimal common indentation within BLOB. This is ;; done by walking recursively BLOB and updating MIN-IND - ;; along the way. FIRST-FLAG is non-nil when the first - ;; string hasn't been seen yet. It is required as this - ;; string is the only one whose indentation doesn't happen - ;; after a newline character. + ;; along the way. FIRST-FLAG is non-nil when the next + ;; object is expected to be a string that doesn't start with + ;; a newline character. It happens for strings at the + ;; beginnings of the contents or right after a line break. (lambda (blob first-flag) (dolist (object (org-element-contents blob)) - (when (and first-flag (stringp object)) + (when first-flag (setq first-flag nil) - (string-match "\\` *" object) - (let ((len (match-end 0))) - ;; An indentation of zero means no string will be - ;; modified. Quit the process. - (if (zerop len) (throw 'zero (setq min-ind 0)) - (setq min-ind (min len min-ind))))) + ;; Objects cannot start with spaces: in this case, + ;; indentation is 0. + (if (not (stringp object)) (throw 'zero (setq min-ind 0)) + (string-match "\\` *" object) + (let ((len (match-end 0))) + ;; An indentation of zero means no string will be + ;; modified. Quit the process. + (if (zerop len) (throw 'zero (setq min-ind 0)) + (setq min-ind (min len min-ind)))))) (cond ((stringp object) (dolist (line (cdr (org-split-string object " *\n"))) (unless (string= line "") (setq min-ind (min (org-get-indentation line) min-ind))))) + ((eq (org-element-type object) 'line-break) (setq first-flag t)) ((memq (org-element-type object) org-element-recursive-objects) (funcall find-min-ind object first-flag))))))) ;; Find minimal indentation in ELEMENT. @@ -4644,41 +4580,1056 @@ indentation is not done with TAB characters." ;; string minus common indentation. (let* (build ; For byte compiler. (build - (function - (lambda (blob first-flag) - ;; Return BLOB with all its strings indentation - ;; shortened from MIN-IND white spaces. FIRST-FLAG - ;; is non-nil when the first string hasn't been seen - ;; yet. - (setcdr (cdr blob) - (mapcar - #'(lambda (object) - (when (and first-flag (stringp object)) - (setq first-flag nil) - (setq object - (replace-regexp-in-string - (format "\\` \\{%d\\}" min-ind) - "" object))) - (cond - ((stringp object) - (replace-regexp-in-string - (format "\n \\{%d\\}" min-ind) "\n" object)) - ((memq (org-element-type object) - org-element-recursive-objects) - (funcall build object first-flag)) - (t object))) - (org-element-contents blob))) - blob)))) + (lambda (blob first-flag) + ;; Return BLOB with all its strings indentation + ;; shortened from MIN-IND white spaces. FIRST-FLAG is + ;; non-nil when the next object is expected to be + ;; a string that doesn't start with a newline + ;; character. + (setcdr (cdr blob) + (mapcar + (lambda (object) + (when first-flag + (setq first-flag nil) + (when (stringp object) + (setq object + (replace-regexp-in-string + (format "\\` \\{%d\\}" min-ind) + "" object)))) + (cond + ((stringp object) + (replace-regexp-in-string + (format "\n \\{%d\\}" min-ind) "\n" object)) + ((memq (org-element-type object) + org-element-recursive-objects) + (funcall build object first-flag)) + ((eq (org-element-type object) 'line-break) + (setq first-flag t) + object) + (t object))) + (org-element-contents blob))) + blob))) (funcall build element (not ignore-first)))))) +;;; Cache +;; +;; Implement a caching mechanism for `org-element-at-point' and +;; `org-element-context', which see. +;; +;; A single public function is provided: `org-element-cache-reset'. +;; +;; Cache is enabled by default, but can be disabled globally with +;; `org-element-use-cache'. `org-element-cache-sync-idle-time', +;; org-element-cache-sync-duration' and `org-element-cache-sync-break' +;; can be tweaked to control caching behaviour. +;; +;; Internally, parsed elements are stored in an AVL tree, +;; `org-element--cache'. This tree is updated lazily: whenever +;; a change happens to the buffer, a synchronization request is +;; registered in `org-element--cache-sync-requests' (see +;; `org-element--cache-submit-request'). During idle time, requests +;; are processed by `org-element--cache-sync'. Synchronization also +;; happens when an element is required from the cache. In this case, +;; the process stops as soon as the needed element is up-to-date. +;; +;; A synchronization request can only apply on a synchronized part of +;; the cache. Therefore, the cache is updated at least to the +;; location where the new request applies. Thus, requests are ordered +;; from left to right and all elements starting before the first +;; request are correct. This property is used by functions like +;; `org-element--cache-find' to retrieve elements in the part of the +;; cache that can be trusted. +;; +;; A request applies to every element, starting from its original +;; location (or key, see below). When a request is processed, it +;; moves forward and may collide the next one. In this case, both +;; requests are merged into a new one that starts from that element. +;; As a consequence, the whole synchronization complexity does not +;; depend on the number of pending requests, but on the number of +;; elements the very first request will be applied on. +;; +;; Elements cannot be accessed through their beginning position, which +;; may or may not be up-to-date. Instead, each element in the tree is +;; associated to a key, obtained with `org-element--cache-key'. This +;; mechanism is robust enough to preserve total order among elements +;; even when the tree is only partially synchronized. +;; +;; Objects contained in an element are stored in a hash table, +;; `org-element--cache-objects'. + + +(defvar org-element-use-cache t + "Non nil when Org parser should cache its results. +This is mostly for debugging purpose.") + +(defvar org-element-cache-sync-idle-time 0.6 + "Length, in seconds, of idle time before syncing cache.") + +(defvar org-element-cache-sync-duration (seconds-to-time 0.04) + "Maximum duration, as a time value, for a cache synchronization. +If the synchronization is not over after this delay, the process +pauses and resumes after `org-element-cache-sync-break' +seconds.") + +(defvar org-element-cache-sync-break (seconds-to-time 0.3) + "Duration, as a time value, of the pause between synchronizations. +See `org-element-cache-sync-duration' for more information.") + + +;;;; Data Structure + +(defvar org-element--cache nil + "AVL tree used to cache elements. +Each node of the tree contains an element. Comparison is done +with `org-element--cache-compare'. This cache is used in +`org-element-at-point'.") + +(defvar org-element--cache-objects nil + "Hash table used as to cache objects. +Key is an element, as returned by `org-element-at-point', and +value is an alist where each association is: + + \(PARENT COMPLETEP . OBJECTS) + +where PARENT is an element or object, COMPLETEP is a boolean, +non-nil when all direct children of parent are already cached and +OBJECTS is a list of such children, as objects, from farthest to +closest. + +In the following example, \\alpha, bold object and \\beta are +contained within a paragraph + + \\alpha *\\beta* + +If the paragraph is completely parsed, OBJECTS-DATA will be + + \((PARAGRAPH t BOLD-OBJECT ENTITY-OBJECT) + \(BOLD-OBJECT t ENTITY-OBJECT)) + +whereas in a partially parsed paragraph, it could be + + \((PARAGRAPH nil ENTITY-OBJECT)) + +This cache is used in `org-element-context'.") + +(defvar org-element--cache-sync-requests nil + "List of pending synchronization requests. + +A request is a vector with the following pattern: + + \[NEXT BEG END OFFSET PARENT PHASE] + +Processing a synchronization request consists of three phases: + + 0. Delete modified elements, + 1. Fill missing area in cache, + 2. Shift positions and re-parent elements after the changes. + +During phase 0, NEXT is the key of the first element to be +removed, BEG and END is buffer position delimiting the +modifications. Elements starting between them (inclusive) are +removed. So are elements whose parent is removed. PARENT, when +non-nil, is the parent of the first element to be removed. + +During phase 1, NEXT is the key of the next known element in +cache and BEG its beginning position. Parse buffer between that +element and the one before it in order to determine the parent of +the next element. Set PARENT to the element containing NEXT. + +During phase 2, NEXT is the key of the next element to shift in +the parse tree. All elements starting from this one have their +properties relatives to buffer positions shifted by integer +OFFSET and, if they belong to element PARENT, are adopted by it. + +PHASE specifies the phase number, as an integer.") + +(defvar org-element--cache-sync-timer nil + "Timer used for cache synchronization.") + +(defvar org-element--cache-sync-keys nil + "Hash table used to store keys during synchronization. +See `org-element--cache-key' for more information.") + +(defsubst org-element--cache-key (element) + "Return a unique key for ELEMENT in cache tree. + +Keys are used to keep a total order among elements in the cache. +Comparison is done with `org-element--cache-key-less-p'. + +When no synchronization is taking place, a key is simply the +beginning position of the element, or that position plus one in +the case of an first item (respectively row) in +a list (respectively a table). + +During a synchronization, the key is the one the element had when +the cache was synchronized for the last time. Elements added to +cache during the synchronization get a new key generated with +`org-element--cache-generate-key'. + +Such keys are stored in `org-element--cache-sync-keys'. The hash +table is cleared once the synchronization is complete." + (or (gethash element org-element--cache-sync-keys) + (let* ((begin (org-element-property :begin element)) + ;; Increase beginning position of items (respectively + ;; table rows) by one, so the first item can get + ;; a different key from its parent list (respectively + ;; table). + (key (if (memq (org-element-type element) '(item table-row)) + (1+ begin) + begin))) + (if org-element--cache-sync-requests + (puthash element key org-element--cache-sync-keys) + key)))) + +(defun org-element--cache-generate-key (lower upper) + "Generate a key between LOWER and UPPER. + +LOWER and UPPER are integers or lists, possibly empty. + +If LOWER and UPPER are equals, return LOWER. Otherwise, return +a unique key, as an integer or a list of integers, according to +the following rules: + + - LOWER and UPPER are compared level-wise until values differ. + + - If, at a given level, LOWER and UPPER differ from more than + 2, the new key shares all the levels above with LOWER and + gets a new level. Its value is the mean between LOWER and + UPPER: + + \(1 2) + (1 4) --> (1 3) + + - If LOWER has no value to compare with, it is assumed that its + value is `most-negative-fixnum'. E.g., + + \(1 1) + (1 1 2) + + is equivalent to + + \(1 1 m) + (1 1 2) + + where m is `most-negative-fixnum'. Likewise, if UPPER is + short of levels, the current value is `most-positive-fixnum'. + + - If they differ from only one, the new key inherits from + current LOWER level and fork it at the next level. E.g., + + \(2 1) + (3 3) + + is equivalent to + + \(2 1) + (2 M) + + where M is `most-positive-fixnum'. + + - If the key is only one level long, it is returned as an + integer: + + \(1 2) + (3 2) --> 2 + +When they are not equals, the function assumes that LOWER is +lesser than UPPER, per `org-element--cache-key-less-p'." + (if (equal lower upper) lower + (let ((lower (if (integerp lower) (list lower) lower)) + (upper (if (integerp upper) (list upper) upper)) + skip-upper key) + (catch 'exit + (while t + (let ((min (or (car lower) most-negative-fixnum)) + (max (cond (skip-upper most-positive-fixnum) + ((car upper)) + (t most-positive-fixnum)))) + (if (< (1+ min) max) + (let ((mean (+ (ash min -1) (ash max -1) (logand min max 1)))) + (throw 'exit (if key (nreverse (cons mean key)) mean))) + (when (and (< min max) (not skip-upper)) + ;; When at a given level, LOWER and UPPER differ from + ;; 1, ignore UPPER altogether. Instead create a key + ;; between LOWER and the greatest key with the same + ;; prefix as LOWER so far. + (setq skip-upper t)) + (push min key) + (setq lower (cdr lower) upper (cdr upper))))))))) + +(defsubst org-element--cache-key-less-p (a b) + "Non-nil if key A is less than key B. +A and B are either integers or lists of integers, as returned by +`org-element--cache-key'." + (if (integerp a) (if (integerp b) (< a b) (<= a (car b))) + (if (integerp b) (< (car a) b) + (catch 'exit + (while (and a b) + (cond ((car-less-than-car a b) (throw 'exit t)) + ((car-less-than-car b a) (throw 'exit nil)) + (t (setq a (cdr a) b (cdr b))))) + ;; If A is empty, either keys are equal (B is also empty) and + ;; we return nil, or A is lesser than B (B is longer) and we + ;; return a non-nil value. + ;; + ;; If A is not empty, B is necessarily empty and A is greater + ;; than B (A is longer). Therefore, return nil. + (and (null a) b))))) + +(defun org-element--cache-compare (a b) + "Non-nil when element A is located before element B." + (org-element--cache-key-less-p (org-element--cache-key a) + (org-element--cache-key b))) + +(defsubst org-element--cache-root () + "Return root value in cache. +This function assumes `org-element--cache' is a valid AVL tree." + (avl-tree--node-left (avl-tree--dummyroot org-element--cache))) + + +;;;; Tools + +(defsubst org-element--cache-active-p () + "Non-nil when cache is active in current buffer." + (and org-element-use-cache + (or (derived-mode-p 'org-mode) orgstruct-mode))) + +(defun org-element--cache-find (pos &optional side) + "Find element in cache starting at POS or before. + +POS refers to a buffer position. + +When optional argument SIDE is non-nil, the function checks for +elements starting at or past POS instead. If SIDE is `both', the +function returns a cons cell where car is the first element +starting at or before POS and cdr the first element starting +after POS. + +The function can only find elements in the synchronized part of +the cache." + (let ((limit (and org-element--cache-sync-requests + (aref (car org-element--cache-sync-requests) 0))) + (node (org-element--cache-root)) + lower upper) + (while node + (let* ((element (avl-tree--node-data node)) + (begin (org-element-property :begin element))) + (cond + ((and limit + (not (org-element--cache-key-less-p + (org-element--cache-key element) limit))) + (setq node (avl-tree--node-left node))) + ((> begin pos) + (setq upper element + node (avl-tree--node-left node))) + ((< begin pos) + (setq lower element + node (avl-tree--node-right node))) + ;; We found an element in cache starting at POS. If `side' + ;; is `both' we also want the next one in order to generate + ;; a key in-between. + ;; + ;; If the element is the first row or item in a table or + ;; a plain list, we always return the table or the plain + ;; list. + ;; + ;; In any other case, we return the element found. + ((eq side 'both) + (setq lower element) + (setq node (avl-tree--node-right node))) + ((and (memq (org-element-type element) '(item table-row)) + (let ((parent (org-element-property :parent element))) + (and (= (org-element-property :begin element) + (org-element-property :contents-begin parent)) + (setq node nil + lower parent + upper parent))))) + (t + (setq node nil + lower element + upper element))))) + (case side + (both (cons lower upper)) + ((nil) lower) + (otherwise upper)))) + +(defun org-element--cache-put (element &optional data) + "Store ELEMENT in current buffer's cache, if allowed. +When optional argument DATA is non-nil, assume is it object data +relative to ELEMENT and store it in the objects cache." + (cond ((not (org-element--cache-active-p)) nil) + ((not data) + (when org-element--cache-sync-requests + ;; During synchronization, first build an appropriate key + ;; for the new element so `avl-tree-enter' can insert it at + ;; the right spot in the cache. + (let ((keys (org-element--cache-find + (org-element-property :begin element) 'both))) + (puthash element + (org-element--cache-generate-key + (and (car keys) (org-element--cache-key (car keys))) + (cond ((cdr keys) (org-element--cache-key (cdr keys))) + (org-element--cache-sync-requests + (aref (car org-element--cache-sync-requests) 0)))) + org-element--cache-sync-keys))) + (avl-tree-enter org-element--cache element)) + ;; Headlines are not stored in cache, so objects in titles are + ;; not stored either. + ((eq (org-element-type element) 'headline) nil) + (t (puthash element data org-element--cache-objects)))) + +(defsubst org-element--cache-remove (element) + "Remove ELEMENT from cache. +Assume ELEMENT belongs to cache and that a cache is active." + (avl-tree-delete org-element--cache element) + (remhash element org-element--cache-objects)) + + +;;;; Synchronization + +(defsubst org-element--cache-set-timer (buffer) + "Set idle timer for cache synchronization in BUFFER." + (when org-element--cache-sync-timer + (cancel-timer org-element--cache-sync-timer)) + (setq org-element--cache-sync-timer + (run-with-idle-timer + (let ((idle (current-idle-time))) + (if idle (time-add idle org-element-cache-sync-break) + org-element-cache-sync-idle-time)) + nil + #'org-element--cache-sync + buffer))) + +(defsubst org-element--cache-interrupt-p (time-limit) + "Non-nil when synchronization process should be interrupted. +TIME-LIMIT is a time value or nil." + (and time-limit + (or (input-pending-p) + (time-less-p time-limit (current-time))))) + +(defsubst org-element--cache-shift-positions (element offset &optional props) + "Shift ELEMENT properties relative to buffer positions by OFFSET. + +Properties containing buffer positions are `:begin', `:end', +`:contents-begin', `:contents-end' and `:structure'. When +optional argument PROPS is a list of keywords, only shift +properties provided in that list. + +Properties are modified by side-effect." + (let ((properties (nth 1 element))) + ;; Shift `:structure' property for the first plain list only: it + ;; is the only one that really matters and it prevents from + ;; shifting it more than once. + (when (and (or (not props) (memq :structure props)) + (eq (org-element-type element) 'plain-list) + (not (eq (org-element-type (plist-get properties :parent)) + 'item))) + (dolist (item (plist-get properties :structure)) + (incf (car item) offset) + (incf (nth 6 item) offset))) + (dolist (key '(:begin :contents-begin :contents-end :end :post-affiliated)) + (let ((value (and (or (not props) (memq key props)) + (plist-get properties key)))) + (and value (plist-put properties key (+ offset value))))))) + +(defun org-element--cache-sync (buffer &optional threshold future-change) + "Synchronize cache with recent modification in BUFFER. + +When optional argument THRESHOLD is non-nil, do the +synchronization for all elements starting before or at threshold, +then exit. Otherwise, synchronize cache for as long as +`org-element-cache-sync-duration' or until Emacs leaves idle +state. + +FUTURE-CHANGE, when non-nil, is a buffer position where changes +not registered yet in the cache are going to happen. It is used +in `org-element--cache-submit-request', where cache is partially +updated before current modification are actually submitted." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((inhibit-quit t) request next) + (when org-element--cache-sync-timer + (cancel-timer org-element--cache-sync-timer)) + (catch 'interrupt + (while org-element--cache-sync-requests + (setq request (car org-element--cache-sync-requests) + next (nth 1 org-element--cache-sync-requests)) + (org-element--cache-process-request + request + (and next (aref next 0)) + threshold + (and (not threshold) + (time-add (current-time) + org-element-cache-sync-duration)) + future-change) + ;; Request processed. Merge current and next offsets and + ;; transfer ending position. + (when next + (incf (aref next 3) (aref request 3)) + (aset next 2 (aref request 2))) + (setq org-element--cache-sync-requests + (cdr org-element--cache-sync-requests)))) + ;; If more requests are awaiting, set idle timer accordingly. + ;; Otherwise, reset keys. + (if org-element--cache-sync-requests + (org-element--cache-set-timer buffer) + (clrhash org-element--cache-sync-keys)))))) + +(defun org-element--cache-process-request + (request next threshold time-limit future-change) + "Process synchronization REQUEST for all entries before NEXT. + +REQUEST is a vector, built by `org-element--cache-submit-request'. + +NEXT is a cache key, as returned by `org-element--cache-key'. + +When non-nil, THRESHOLD is a buffer position. Synchronization +stops as soon as a shifted element begins after it. + +When non-nil, TIME-LIMIT is a time value. Synchronization stops +after this time or when Emacs exits idle state. + +When non-nil, FUTURE-CHANGE is a buffer position where changes +not registered yet in the cache are going to happen. See +`org-element--cache-submit-request' for more information. + +Throw `interrupt' if the process stops before completing the +request." + (catch 'quit + (when (= (aref request 5) 0) + ;; Phase 0. + ;; + ;; Delete all elements starting after BEG, but not after buffer + ;; position END or past element with key NEXT. Also delete + ;; elements contained within a previously removed element + ;; (stored in `last-container'). + ;; + ;; At each iteration, we start again at tree root since + ;; a deletion modifies structure of the balanced tree. + (catch 'end-phase + (while t + (when (org-element--cache-interrupt-p time-limit) + (throw 'interrupt nil)) + ;; Find first element in cache with key BEG or after it. + (let ((beg (aref request 0)) + (end (aref request 2)) + (node (org-element--cache-root)) + data data-key last-container) + (while node + (let* ((element (avl-tree--node-data node)) + (key (org-element--cache-key element))) + (cond + ((org-element--cache-key-less-p key beg) + (setq node (avl-tree--node-right node))) + ((org-element--cache-key-less-p beg key) + (setq data element + data-key key + node (avl-tree--node-left node))) + (t (setq data element + data-key key + node nil))))) + (if data + (let ((pos (org-element-property :begin data))) + (if (if (or (not next) + (org-element--cache-key-less-p data-key next)) + (<= pos end) + (and last-container + (let ((up data)) + (while (and up (not (eq up last-container))) + (setq up (org-element-property :parent up))) + up))) + (progn (when (and (not last-container) + (> (org-element-property :end data) + end)) + (setq last-container data)) + (org-element--cache-remove data)) + (aset request 0 data-key) + (aset request 1 pos) + (aset request 5 1) + (throw 'end-phase nil))) + ;; No element starting after modifications left in + ;; cache: further processing is futile. + (throw 'quit t)))))) + (when (= (aref request 5) 1) + ;; Phase 1. + ;; + ;; Phase 0 left a hole in the cache. Some elements after it + ;; could have parents within. For example, in the following + ;; buffer: + ;; + ;; - item + ;; + ;; + ;; Paragraph1 + ;; + ;; Paragraph2 + ;; + ;; if we remove a blank line between "item" and "Paragraph1", + ;; everything down to "Paragraph2" is removed from cache. But + ;; the paragraph now belongs to the list, and its `:parent' + ;; property no longer is accurate. + ;; + ;; Therefore we need to parse again elements in the hole, or at + ;; least in its last section, so that we can re-parent + ;; subsequent elements, during phase 2. + ;; + ;; Note that we only need to get the parent from the first + ;; element in cache after the hole. + ;; + ;; When next key is lesser or equal to the current one, delegate + ;; phase 1 processing to next request in order to preserve key + ;; order among requests. + (let ((key (aref request 0))) + (when (and next (not (org-element--cache-key-less-p key next))) + (let ((next-request (nth 1 org-element--cache-sync-requests))) + (aset next-request 0 key) + (aset next-request 1 (aref request 1)) + (aset next-request 5 1)) + (throw 'quit t))) + ;; Next element will start at its beginning position plus + ;; offset, since it hasn't been shifted yet. Therefore, LIMIT + ;; contains the real beginning position of the first element to + ;; shift and re-parent. + (let ((limit (+ (aref request 1) (aref request 3)))) + (cond ((and threshold (> limit threshold)) (throw 'interrupt nil)) + ((and future-change (>= limit future-change)) + ;; Changes are going to happen around this element and + ;; they will trigger another phase 1 request. Skip the + ;; current one. + (aset request 5 2)) + (t + (let ((parent (org-element--parse-to limit t time-limit))) + (aset request 4 parent) + (aset request 5 2)))))) + ;; Phase 2. + ;; + ;; Shift all elements starting from key START, but before NEXT, by + ;; OFFSET, and re-parent them when appropriate. + ;; + ;; Elements are modified by side-effect so the tree structure + ;; remains intact. + ;; + ;; Once THRESHOLD, if any, is reached, or once there is an input + ;; pending, exit. Before leaving, the current synchronization + ;; request is updated. + (let ((start (aref request 0)) + (offset (aref request 3)) + (parent (aref request 4)) + (node (org-element--cache-root)) + (stack (list nil)) + (leftp t) + exit-flag) + ;; No re-parenting nor shifting planned: request is over. + (when (and (not parent) (zerop offset)) (throw 'quit t)) + (while node + (let* ((data (avl-tree--node-data node)) + (key (org-element--cache-key data))) + (if (and leftp (avl-tree--node-left node) + (not (org-element--cache-key-less-p key start))) + (progn (push node stack) + (setq node (avl-tree--node-left node))) + (unless (org-element--cache-key-less-p key start) + ;; We reached NEXT. Request is complete. + (when (equal key next) (throw 'quit t)) + ;; Handle interruption request. Update current request. + (when (or exit-flag (org-element--cache-interrupt-p time-limit)) + (aset request 0 key) + (aset request 4 parent) + (throw 'interrupt nil)) + ;; Shift element. + (unless (zerop offset) + (org-element--cache-shift-positions data offset) + ;; Shift associated objects data, if any. + (dolist (object-data (gethash data org-element--cache-objects)) + (dolist (object (cddr object-data)) + (org-element--cache-shift-positions object offset)))) + (let ((begin (org-element-property :begin data))) + ;; Update PARENT and re-parent DATA, only when + ;; necessary. Propagate new structures for lists. + (while (and parent + (<= (org-element-property :end parent) begin)) + (setq parent (org-element-property :parent parent))) + (cond ((and (not parent) (zerop offset)) (throw 'quit nil)) + ((and parent + (let ((p (org-element-property :parent data))) + (or (not p) + (< (org-element-property :begin p) + (org-element-property :begin parent))))) + (org-element-put-property data :parent parent) + (let ((s (org-element-property :structure parent))) + (when (and s (org-element-property :structure data)) + (org-element-put-property data :structure s))))) + ;; Cache is up-to-date past THRESHOLD. Request + ;; interruption. + (when (and threshold (> begin threshold)) (setq exit-flag t)))) + (setq node (if (setq leftp (avl-tree--node-right node)) + (avl-tree--node-right node) + (pop stack)))))) + ;; We reached end of tree: synchronization complete. + t))) + +(defun org-element--parse-to (pos &optional syncp time-limit) + "Parse elements in current section, down to POS. + +Start parsing from the closest between the last known element in +cache or headline above. Return the smallest element containing +POS. + +When optional argument SYNCP is non-nil, return the parent of the +element containing POS instead. In that case, it is also +possible to provide TIME-LIMIT, which is a time value specifying +when the parsing should stop. The function throws `interrupt' if +the process stopped before finding the expected result." + (catch 'exit + (org-with-wide-buffer + (goto-char pos) + (let* ((cached (and (org-element--cache-active-p) + (org-element--cache-find pos nil))) + (begin (org-element-property :begin cached)) + element next mode) + (cond + ;; Nothing in cache before point: start parsing from first + ;; element following headline above, or first element in + ;; buffer. + ((not cached) + (when (org-with-limited-levels (outline-previous-heading)) + (setq mode 'planning) + (forward-line)) + (skip-chars-forward " \r\t\n") + (beginning-of-line)) + ;; Cache returned exact match: return it. + ((= pos begin) + (throw 'exit (if syncp (org-element-property :parent cached) cached))) + ;; There's a headline between cached value and POS: cached + ;; value is invalid. Start parsing from first element + ;; following the headline. + ((re-search-backward + (org-with-limited-levels org-outline-regexp-bol) begin t) + (forward-line) + (skip-chars-forward " \r\t\n") + (beginning-of-line) + (setq mode 'planning)) + ;; Check if CACHED or any of its ancestors contain point. + ;; + ;; If there is such an element, we inspect it in order to know + ;; if we return it or if we need to parse its contents. + ;; Otherwise, we just start parsing from current location, + ;; which is right after the top-most element containing + ;; CACHED. + ;; + ;; As a special case, if POS is at the end of the buffer, we + ;; want to return the innermost element ending there. + ;; + ;; Also, if we find an ancestor and discover that we need to + ;; parse its contents, make sure we don't start from + ;; `:contents-begin', as we would otherwise go past CACHED + ;; again. Instead, in that situation, we will resume parsing + ;; from NEXT, which is located after CACHED or its higher + ;; ancestor not containing point. + (t + (let ((up cached) + (pos (if (= (point-max) pos) (1- pos) pos))) + (goto-char (or (org-element-property :contents-begin cached) begin)) + (while (let ((end (org-element-property :end up))) + (and (<= end pos) + (goto-char end) + (setq up (org-element-property :parent up))))) + (cond ((not up)) + ((eobp) (setq element up)) + (t (setq element up next (point))))))) + ;; Parse successively each element until we reach POS. + (let ((end (or (org-element-property :end element) + (save-excursion + (org-with-limited-levels (outline-next-heading)) + (point)))) + (parent element)) + (while t + (when syncp + (cond ((= (point) pos) (throw 'exit parent)) + ((org-element--cache-interrupt-p time-limit) + (throw 'interrupt nil)))) + (unless element + (setq element (org-element--current-element + end 'element mode + (org-element-property :structure parent))) + (org-element-put-property element :parent parent) + (org-element--cache-put element)) + (let ((elem-end (org-element-property :end element)) + (type (org-element-type element))) + (cond + ;; Skip any element ending before point. Also skip + ;; element ending at point (unless it is also the end of + ;; buffer) since we're sure that another element begins + ;; after it. + ((and (<= elem-end pos) (/= (point-max) elem-end)) + (goto-char elem-end) + (setq mode (org-element--next-mode type nil))) + ;; A non-greater element contains point: return it. + ((not (memq type org-element-greater-elements)) + (throw 'exit element)) + ;; Otherwise, we have to decide if ELEMENT really + ;; contains POS. In that case we start parsing from + ;; contents' beginning. + ;; + ;; If POS is at contents' beginning but it is also at + ;; the beginning of the first item in a list or a table. + ;; In that case, we need to create an anchor for that + ;; list or table, so return it. + ;; + ;; Also, if POS is at the end of the buffer, no element + ;; can start after it, but more than one may end there. + ;; Arbitrarily, we choose to return the innermost of + ;; such elements. + ((let ((cbeg (org-element-property :contents-begin element)) + (cend (org-element-property :contents-end element))) + (when (or syncp + (and cbeg cend + (or (< cbeg pos) + (and (= cbeg pos) + (not (memq type '(plain-list table))))) + (or (> cend pos) + (and (= cend pos) (= (point-max) pos))))) + (goto-char (or next cbeg)) + (setq next nil + mode (org-element--next-mode type t) + parent element + end cend)))) + ;; Otherwise, return ELEMENT as it is the smallest + ;; element containing POS. + (t (throw 'exit element)))) + (setq element nil))))))) + + +;;;; Staging Buffer Changes + +(defconst org-element--cache-sensitive-re + (concat + org-outline-regexp-bol "\\|" + "\\\\end{[A-Za-z0-9*]+}[ \t]*$" "\\|" + "^[ \t]*\\(?:" + "#\\+\\(?:BEGIN[:_]\\|END\\(?:_\\|:?[ \t]*$\\)\\)" "\\|" + "\\\\begin{[A-Za-z0-9*]+}" "\\|" + ":\\(?:\\w\\|[-_]\\)+:[ \t]*$" + "\\)") + "Regexp matching a sensitive line, structure wise. +A sensitive line is a headline, inlinetask, block, drawer, or +latex-environment boundary. When such a line is modified, +structure changes in the document may propagate in the whole +section, possibly making cache invalid.") + +(defvar org-element--cache-change-warning nil + "Non-nil when a sensitive line is about to be changed. +It is a symbol among nil, t and `headline'.") + +(defun org-element--cache-before-change (beg end) + "Request extension of area going to be modified if needed. +BEG and END are the beginning and end of the range of changed +text. See `before-change-functions' for more information." + (when (org-element--cache-active-p) + (org-with-wide-buffer + (goto-char beg) + (beginning-of-line) + (let ((bottom (save-excursion (goto-char end) (line-end-position)))) + (setq org-element--cache-change-warning + (save-match-data + (if (and (org-with-limited-levels (org-at-heading-p)) + (= (line-end-position) bottom)) + 'headline + (let ((case-fold-search t)) + (re-search-forward + org-element--cache-sensitive-re bottom t))))))))) + +(defun org-element--cache-after-change (beg end pre) + "Update buffer modifications for current buffer. +BEG and END are the beginning and end of the range of changed +text, and the length in bytes of the pre-change text replaced by +that range. See `after-change-functions' for more information." + (when (org-element--cache-active-p) + (org-with-wide-buffer + (goto-char beg) + (beginning-of-line) + (save-match-data + (let ((top (point)) + (bottom (save-excursion (goto-char end) (line-end-position)))) + ;; Determine if modified area needs to be extended, according + ;; to both previous and current state. We make a special + ;; case for headline editing: if a headline is modified but + ;; not removed, do not extend. + (when (case org-element--cache-change-warning + ((t) t) + (headline + (not (and (org-with-limited-levels (org-at-heading-p)) + (= (line-end-position) bottom)))) + (otherwise + (let ((case-fold-search t)) + (re-search-forward + org-element--cache-sensitive-re bottom t)))) + ;; Effectively extend modified area. + (org-with-limited-levels + (setq top (progn (goto-char top) + (when (outline-previous-heading) (forward-line)) + (point))) + (setq bottom (progn (goto-char bottom) + (if (outline-next-heading) (1- (point)) + (point)))))) + ;; Store synchronization request. + (let ((offset (- end beg pre))) + (org-element--cache-submit-request top (- bottom offset) offset))))) + ;; Activate a timer to process the request during idle time. + (org-element--cache-set-timer (current-buffer)))) + +(defun org-element--cache-for-removal (beg end offset) + "Return first element to remove from cache. + +BEG and END are buffer positions delimiting buffer modifications. +OFFSET is the size of the changes. + +Returned element is usually the first element in cache containing +any position between BEG and END. As an exception, greater +elements around the changes that are robust to contents +modifications are preserved and updated according to the +changes." + (let* ((elements (org-element--cache-find (1- beg) 'both)) + (before (car elements)) + (after (cdr elements))) + (if (not before) after + (let ((up before) + (robust-flag t)) + (while up + (if (let ((type (org-element-type up))) + (and (or (memq type '(center-block dynamic-block quote-block + special-block)) + ;; Drawers named "PROPERTIES" are probably + ;; a properties drawer being edited. Force + ;; parsing to check if editing is over. + (and (eq type 'drawer) + (not (string= + (org-element-property :drawer-name up) + "PROPERTIES")))) + (let ((cbeg (org-element-property :contents-begin up))) + (and cbeg + (<= cbeg beg) + (> (org-element-property :contents-end up) end))))) + ;; UP is a robust greater element containing changes. + ;; We only need to extend its ending boundaries. + (org-element--cache-shift-positions + up offset '(:contents-end :end)) + (setq before up) + (when robust-flag (setq robust-flag nil))) + (setq up (org-element-property :parent up))) + ;; We're at top level element containing ELEMENT: if it's + ;; altered by buffer modifications, it is first element in + ;; cache to be removed. Otherwise, that first element is the + ;; following one. + ;; + ;; As a special case, do not remove BEFORE if it is a robust + ;; container for current changes. + (if (or (< (org-element-property :end before) beg) robust-flag) after + before))))) + +(defun org-element--cache-submit-request (beg end offset) + "Submit a new cache synchronization request for current buffer. +BEG and END are buffer positions delimiting the minimal area +where cache data should be removed. OFFSET is the size of the +change, as an integer." + (let ((next (car org-element--cache-sync-requests)) + delete-to delete-from) + (if (and next + (zerop (aref next 5)) + (> (setq delete-to (+ (aref next 2) (aref next 3))) end) + (<= (setq delete-from (aref next 1)) end)) + ;; Current changes can be merged with first sync request: we + ;; can save a partial cache synchronization. + (progn + (incf (aref next 3) offset) + ;; If last change happened within area to be removed, extend + ;; boundaries of robust parents, if any. Otherwise, find + ;; first element to remove and update request accordingly. + (if (> beg delete-from) + (let ((up (aref next 4))) + (while up + (org-element--cache-shift-positions + up offset '(:contents-end :end)) + (setq up (org-element-property :parent up)))) + (let ((first (org-element--cache-for-removal beg delete-to offset))) + (when first + (aset next 0 (org-element--cache-key first)) + (aset next 1 (org-element-property :begin first)) + (aset next 4 (org-element-property :parent first)))))) + ;; Ensure cache is correct up to END. Also make sure that NEXT, + ;; if any, is no longer a 0-phase request, thus ensuring that + ;; phases are properly ordered. We need to provide OFFSET as + ;; optional parameter since current modifications are not known + ;; yet to the otherwise correct part of the cache (i.e, before + ;; the first request). + (when next (org-element--cache-sync (current-buffer) end beg)) + (let ((first (org-element--cache-for-removal beg end offset))) + (if first + (push (let ((beg (org-element-property :begin first)) + (key (org-element--cache-key first))) + (cond + ;; When changes happen before the first known + ;; element, re-parent and shift the rest of the + ;; cache. + ((> beg end) (vector key beg nil offset nil 1)) + ;; Otherwise, we find the first non robust + ;; element containing END. All elements between + ;; FIRST and this one are to be removed. + ((let ((first-end (org-element-property :end first))) + (and (> first-end end) + (vector key beg first-end offset first 0)))) + (t + (let* ((element (org-element--cache-find end)) + (end (org-element-property :end element)) + (up element)) + (while (and (setq up (org-element-property :parent up)) + (>= (org-element-property :begin up) beg)) + (setq end (org-element-property :end up) + element up)) + (vector key beg end offset element 0))))) + org-element--cache-sync-requests) + ;; No element to remove. No need to re-parent either. + ;; Simply shift additional elements, if any, by OFFSET. + (when org-element--cache-sync-requests + (incf (aref (car org-element--cache-sync-requests) 3) offset))))))) + + +;;;; Public Functions + +;;;###autoload +(defun org-element-cache-reset (&optional all) + "Reset cache in current buffer. +When optional argument ALL is non-nil, reset cache in all Org +buffers." + (interactive "P") + (dolist (buffer (if all (buffer-list) (list (current-buffer)))) + (with-current-buffer buffer + (when (org-element--cache-active-p) + (org-set-local 'org-element--cache + (avl-tree-create #'org-element--cache-compare)) + (org-set-local 'org-element--cache-objects (make-hash-table :test #'eq)) + (org-set-local 'org-element--cache-sync-keys + (make-hash-table :weakness 'key :test #'eq)) + (org-set-local 'org-element--cache-change-warning nil) + (org-set-local 'org-element--cache-sync-requests nil) + (org-set-local 'org-element--cache-sync-timer nil) + (add-hook 'before-change-functions + #'org-element--cache-before-change nil t) + (add-hook 'after-change-functions + #'org-element--cache-after-change nil t))))) + +;;;###autoload +(defun org-element-cache-refresh (pos) + "Refresh cache at position POS." + (when (org-element--cache-active-p) + (org-element--cache-sync (current-buffer) pos) + (org-element--cache-submit-request pos pos 0) + (org-element--cache-set-timer (current-buffer)))) + + + ;;; The Toolbox ;; ;; The first move is to implement a way to obtain the smallest element ;; containing point. This is the job of `org-element-at-point'. It ;; basically jumps back to the beginning of section containing point -;; and moves, element after element, with +;; and proceed, one element after the other, with ;; `org-element--current-element' until the container is found. Note: ;; When using `org-element-at-point', secondary values are never ;; parsed since the function focuses on elements, not on objects. @@ -4689,8 +5640,9 @@ indentation is not done with TAB characters." ;; `org-element-nested-p' and `org-element-swap-A-B' may be used ;; internally by navigation and manipulation tools. + ;;;###autoload -(defun org-element-at-point (&optional keep-trail) +(defun org-element-at-point () "Determine closest element around point. Return value is a list like (TYPE PROPS) where TYPE is the type @@ -4701,118 +5653,36 @@ Possible types are defined in `org-element-all-elements'. Properties depend on element or object type, but always include `:begin', `:end', `:parent' and `:post-blank' properties. -As a special case, if point is at the very beginning of a list or -sub-list, returned element will be that list instead of the first -item. In the same way, if point is at the beginning of the first -row of a table, returned element will be the table instead of the -first row. - -If optional argument KEEP-TRAIL is non-nil, the function returns -a list of elements leading to element at point. The list's CAR -is always the element at point. The following positions contain -element's siblings, then parents, siblings of parents, until the -first element of current section." +As a special case, if point is at the very beginning of the first +item in a list or sub-list, returned element will be that list +instead of the item. Likewise, if point is at the beginning of +the first row of a table, returned element will be the table +instead of the first row. + +When point is at the end of the buffer, return the innermost +element ending there." (org-with-wide-buffer - ;; If at a headline, parse it. It is the sole element that - ;; doesn't require to know about context. Be sure to disallow - ;; secondary string parsing, though. - (if (org-with-limited-levels (org-at-heading-p)) - (progn - (beginning-of-line) - (if (not keep-trail) (org-element-headline-parser (point-max) t) - (list (org-element-headline-parser (point-max) t)))) - ;; Otherwise move at the beginning of the section containing - ;; point. - (catch 'exit - (let ((origin (point)) - (end (save-excursion - (org-with-limited-levels (outline-next-heading)) (point))) - element type special-flag trail struct prevs parent) - (org-with-limited-levels - (if (org-before-first-heading-p) - ;; In empty lines at buffer's beginning, return nil. - (progn (goto-char (point-min)) - (org-skip-whitespace) - (when (or (eobp) (> (line-beginning-position) origin)) - (throw 'exit nil))) - (org-back-to-heading) - (forward-line) - (org-skip-whitespace) - (when (or (eobp) (> (line-beginning-position) origin)) - ;; In blank lines just after the headline, point still - ;; belongs to the headline. - (throw 'exit - (progn (skip-chars-backward " \r\t\n") - (beginning-of-line) - (if (not keep-trail) - (org-element-headline-parser (point-max) t) - (list (org-element-headline-parser - (point-max) t)))))))) - (beginning-of-line) - ;; Parse successively each element, skipping those ending - ;; before original position. - (while t - (setq element - (org-element--current-element end 'element special-flag struct) - type (car element)) - (org-element-put-property element :parent parent) - (when keep-trail (push element trail)) - (cond - ;; 1. Skip any element ending before point. Also skip - ;; element ending at point when we're sure that another - ;; element has started. - ((let ((elem-end (org-element-property :end element))) - (when (or (< elem-end origin) - (and (= elem-end origin) (/= elem-end end))) - (goto-char elem-end)))) - ;; 2. An element containing point is always the element at - ;; point. - ((not (memq type org-element-greater-elements)) - (throw 'exit (if keep-trail trail element))) - ;; 3. At any other greater element type, if point is - ;; within contents, move into it. - (t - (let ((cbeg (org-element-property :contents-begin element)) - (cend (org-element-property :contents-end element))) - (if (or (not cbeg) (not cend) (> cbeg origin) (< cend origin) - ;; Create an anchor for tables and plain lists: - ;; when point is at the very beginning of these - ;; elements, ignoring affiliated keywords, - ;; target them instead of their contents. - (and (= cbeg origin) (memq type '(plain-list table))) - ;; When point is at contents end, do not move - ;; into elements with an explicit ending, but - ;; return that element instead. - (and (= cend origin) - (or (memq type - '(center-block - drawer dynamic-block inlinetask - property-drawer quote-block - special-block)) - ;; Corner case: if a list ends at the - ;; end of a buffer without a final new - ;; line, return last element in last - ;; item instead. - (and (memq type '(item plain-list)) - (progn (goto-char cend) - (or (bolp) (not (eobp)))))))) - (throw 'exit (if keep-trail trail element)) - (setq parent element) - (case type - (plain-list - (setq special-flag 'item - struct (org-element-property :structure element))) - (item (setq special-flag nil)) - (property-drawer - (setq special-flag 'node-property struct nil)) - (table (setq special-flag 'table-row struct nil)) - (otherwise (setq special-flag nil struct nil))) - (setq end cend) - (goto-char cbeg))))))))))) + (let ((origin (point))) + (end-of-line) + (skip-chars-backward " \r\t\n") + (cond + ;; Within blank lines at the beginning of buffer, return nil. + ((bobp) nil) + ;; Within blank lines right after a headline, return that + ;; headline. + ((org-with-limited-levels (org-at-heading-p)) + (beginning-of-line) + (org-element-headline-parser (point-max) t)) + ;; Otherwise parse until we find element containing ORIGIN. + (t + (when (org-element--cache-active-p) + (if (not org-element--cache) (org-element-cache-reset) + (org-element--cache-sync (current-buffer) origin))) + (org-element--parse-to origin)))))) ;;;###autoload (defun org-element-context (&optional element) - "Return closest element or object around point. + "Return smallest element or object around point. Return value is a list like (TYPE PROPS) where TYPE is the type of the element or object and PROPS a plist of properties @@ -4823,34 +5693,36 @@ Possible types are defined in `org-element-all-elements' and object type, but always include `:begin', `:end', `:parent' and `:post-blank'. +As a special case, if point is right after an object and not at +the beginning of any other object, return that object. + Optional argument ELEMENT, when non-nil, is the closest element containing point, as returned by `org-element-at-point'. Providing it allows for quicker computation." (catch 'objects-forbidden (org-with-wide-buffer - (let* ((origin (point)) - (element (or element (org-element-at-point))) - (type (org-element-type element)) - context) - ;; Check if point is inside an element containing objects or at - ;; a secondary string. In that case, narrow buffer to the - ;; containing area. Otherwise, return ELEMENT. + (let* ((pos (point)) + (element (or element (org-element-at-point))) + (type (org-element-type element))) + ;; If point is inside an element containing objects or + ;; a secondary string, narrow buffer to the container and + ;; proceed with parsing. Otherwise, return ELEMENT. (cond ;; At a parsed affiliated keyword, check if we're inside main ;; or dual value. ((let ((post (org-element-property :post-affiliated element))) - (and post (< origin post))) + (and post (< pos post))) (beginning-of-line) (let ((case-fold-search t)) (looking-at org-element--affiliated-re)) (cond ((not (member-ignore-case (match-string 1) org-element-parsed-keywords)) (throw 'objects-forbidden element)) - ((< (match-end 0) origin) + ((< (match-end 0) pos) (narrow-to-region (match-end 0) (line-end-position))) ((and (match-beginning 2) - (>= origin (match-beginning 2)) - (< origin (match-end 2))) + (>= pos (match-beginning 2)) + (< pos (match-end 2))) (narrow-to-region (match-beginning 2) (match-end 2))) (t (throw 'objects-forbidden element))) ;; Also change type to retrieve correct restrictions. @@ -4862,15 +5734,14 @@ Providing it allows for quicker computation." (beginning-of-line) (search-forward tag (line-end-position)) (goto-char (match-beginning 0)) - (if (and (>= origin (point)) (< origin (match-end 0))) + (if (and (>= pos (point)) (< pos (match-end 0))) (narrow-to-region (point) (match-end 0)) (throw 'objects-forbidden element))))) - ;; At an headline or inlinetask, objects are located within - ;; their title. + ;; At an headline or inlinetask, objects are in title. ((memq type '(headline inlinetask)) (goto-char (org-element-property :begin element)) (skip-chars-forward "*") - (if (and (> origin (point)) (< origin (line-end-position))) + (if (and (> pos (point)) (< pos (line-end-position))) (narrow-to-region (point) (line-end-position)) (throw 'objects-forbidden element))) ;; At a paragraph, a table-row or a verse block, objects are @@ -4879,67 +5750,142 @@ Providing it allows for quicker computation." (let ((cbeg (org-element-property :contents-begin element)) (cend (org-element-property :contents-end element))) ;; CBEG is nil for table rules. - (if (and cbeg cend (>= origin cbeg) (< origin cend)) + (if (and cbeg cend (>= pos cbeg) + (or (< pos cend) (and (= pos cend) (eobp)))) (narrow-to-region cbeg cend) (throw 'objects-forbidden element)))) - ;; At a parsed keyword, objects are located within value. - ((eq type 'keyword) - (if (not (member (org-element-property :key element) - org-element-document-properties)) - (throw 'objects-forbidden element) - (beginning-of-line) - (search-forward ":") - (if (and (>= origin (point)) (< origin (line-end-position))) - (narrow-to-region (point) (line-end-position)) - (throw 'objects-forbidden element)))) ;; At a planning line, if point is at a timestamp, return it, ;; otherwise, return element. ((eq type 'planning) (dolist (p '(:closed :deadline :scheduled)) (let ((timestamp (org-element-property p element))) (when (and timestamp - (<= (org-element-property :begin timestamp) origin) - (> (org-element-property :end timestamp) origin)) + (<= (org-element-property :begin timestamp) pos) + (> (org-element-property :end timestamp) pos)) (throw 'objects-forbidden timestamp)))) + ;; All other locations cannot contain objects: bail out. (throw 'objects-forbidden element)) (t (throw 'objects-forbidden element))) (goto-char (point-min)) (let ((restriction (org-element-restriction type)) - (parent element) - (candidates 'initial)) - (catch 'exit - (while (setq candidates - (org-element--get-next-object-candidates - restriction candidates)) - (let ((closest-cand (rassq (apply 'min (mapcar 'cdr candidates)) - candidates))) - ;; If ORIGIN is before next object in element, there's - ;; no point in looking further. - (if (> (cdr closest-cand) origin) (throw 'exit parent) - (let* ((object - (progn (goto-char (cdr closest-cand)) - (funcall (intern (format "org-element-%s-parser" - (car closest-cand)))))) - (cbeg (org-element-property :contents-begin object)) - (cend (org-element-property :contents-end object)) - (obj-end (org-element-property :end object))) - (cond - ;; ORIGIN is after OBJECT, so skip it. - ((<= obj-end origin) (goto-char obj-end)) - ;; ORIGIN is within a non-recursive object or at - ;; an object boundaries: Return that object. - ((or (not cbeg) (< origin cbeg) (>= origin cend)) - (throw 'exit - (org-element-put-property object :parent parent))) - ;; Otherwise, move within current object and - ;; restrict search to the end of its contents. - (t (goto-char cbeg) - (narrow-to-region (point) cend) - (org-element-put-property object :parent parent) - (setq parent object - restriction (org-element-restriction object) - candidates 'initial))))))) - parent)))))) + (parent element) + (cache (cond ((not (org-element--cache-active-p)) nil) + (org-element--cache-objects + (gethash element org-element--cache-objects)) + (t (org-element-cache-reset) nil))) + next object-data last) + (prog1 + (catch 'exit + (while t + ;; When entering PARENT for the first time, get list + ;; of objects within known so far. Store it in + ;; OBJECT-DATA. + (unless next + (let ((data (assq parent cache))) + (if data (setq object-data data) + (push (setq object-data (list parent nil)) cache)))) + ;; Find NEXT object for analysis. + (catch 'found + ;; If NEXT is non-nil, we already exhausted the + ;; cache so we can parse buffer to find the object + ;; after it. + (if next (setq next (org-element--object-lex restriction)) + ;; Otherwise, check if cache can help us. + (let ((objects (cddr object-data)) + (completep (nth 1 object-data))) + (cond + ((and (not objects) completep) (throw 'exit parent)) + ((not objects) + (setq next (org-element--object-lex restriction))) + (t + (let ((cache-limit + (org-element-property :end (car objects)))) + (if (>= cache-limit pos) + ;; Cache contains the information needed. + (dolist (object objects (throw 'exit parent)) + (when (<= (org-element-property :begin object) + pos) + (if (>= (org-element-property :end object) + pos) + (throw 'found (setq next object)) + (throw 'exit parent)))) + (goto-char cache-limit) + (setq next + (org-element--object-lex restriction)))))))) + ;; If we have a new object to analyze, store it in + ;; cache. Otherwise record that there is nothing + ;; more to parse in this element at this depth. + (if next + (progn (org-element-put-property next :parent parent) + (push next (cddr object-data))) + (setcar (cdr object-data) t))) + ;; Process NEXT, if any, in order to know if we need + ;; to skip it, return it or move into it. + (if (or (not next) (> (org-element-property :begin next) pos)) + (throw 'exit (or last parent)) + (let ((end (org-element-property :end next)) + (cbeg (org-element-property :contents-begin next)) + (cend (org-element-property :contents-end next))) + (cond + ;; Skip objects ending before point. Also skip + ;; objects ending at point unless it is also the + ;; end of buffer, since we want to return the + ;; innermost object. + ((and (<= end pos) (/= (point-max) end)) + (goto-char end) + ;; For convenience, when object ends at POS, + ;; without any space, store it in LAST, as we + ;; will return it if no object starts here. + (when (and (= end pos) + (not (memq (char-before) '(?\s ?\t)))) + (setq last next))) + ;; If POS is within a container object, move + ;; into that object. + ((and cbeg cend + (>= pos cbeg) + (or (< pos cend) + ;; At contents' end, if there is no + ;; space before point, also move into + ;; object, for consistency with + ;; convenience feature above. + (and (= pos cend) + (or (= (point-max) pos) + (not (memq (char-before pos) + '(?\s ?\t))))))) + (goto-char cbeg) + (narrow-to-region (point) cend) + (setq parent next + restriction (org-element-restriction next) + next nil + object-data nil)) + ;; Otherwise, return NEXT. + (t (throw 'exit next))))))) + ;; Store results in cache, if applicable. + (org-element--cache-put element cache))))))) + +(defun org-element-lineage (blob &optional types with-self) + "List all ancestors of a given element or object. + +BLOB is an object or element. + +When optional argument TYPES is a list of symbols, return the +first element or object in the lineage whose type belongs to that +list. + +When optional argument WITH-SELF is non-nil, lineage includes +BLOB itself as the first element, and TYPES, if provided, also +apply to it. + +When BLOB is obtained through `org-element-context' or +`org-element-at-point', only ancestors from its section can be +found. There is no such limitation when BLOB belongs to a full +parse tree." + (let ((up (if with-self blob (org-element-property :parent blob))) + ancestors) + (while (and up (not (memq (org-element-type up) types))) + (unless types (push up ancestors)) + (setq up (org-element-property :parent up))) + (if types up (nreverse ancestors)))) (defun org-element-nested-p (elem-A elem-B) "Non-nil when elements ELEM-A and ELEM-B are nested." @@ -4982,15 +5928,23 @@ end of ELEM-A." (goto-char (org-element-property :end elem-B)) (skip-chars-backward " \r\t\n") (point-at-eol))) - ;; Store overlays responsible for visibility status. We - ;; also need to store their boundaries as they will be + ;; Store inner overlays responsible for visibility status. + ;; We also need to store their boundaries as they will be ;; removed from buffer. (overlays (cons - (mapcar (lambda (ov) (list ov (overlay-start ov) (overlay-end ov))) - (overlays-in beg-A end-A)) - (mapcar (lambda (ov) (list ov (overlay-start ov) (overlay-end ov))) - (overlays-in beg-B end-B)))) + (delq nil + (mapcar (lambda (o) + (and (>= (overlay-start o) beg-A) + (<= (overlay-end o) end-A) + (list o (overlay-start o) (overlay-end o)))) + (overlays-in beg-A end-A))) + (delq nil + (mapcar (lambda (o) + (and (>= (overlay-start o) beg-B) + (<= (overlay-end o) end-B) + (list o (overlay-start o) (overlay-end o)))) + (overlays-in beg-B end-B))))) ;; Get contents. (body-A (buffer-substring beg-A end-A)) (body-B (delete-and-extract-region beg-B end-B))) @@ -5001,20 +5955,47 @@ end of ELEM-A." (insert body-A) ;; Restore ex ELEM-A overlays. (let ((offset (- beg-B beg-A))) - (mapc (lambda (ov) - (move-overlay - (car ov) (+ (nth 1 ov) offset) (+ (nth 2 ov) offset))) - (car overlays)) + (dolist (o (car overlays)) + (move-overlay (car o) (+ (nth 1 o) offset) (+ (nth 2 o) offset))) (goto-char beg-A) (delete-region beg-A end-A) (insert body-B) ;; Restore ex ELEM-B overlays. - (mapc (lambda (ov) - (move-overlay - (car ov) (- (nth 1 ov) offset) (- (nth 2 ov) offset))) - (cdr overlays))) + (dolist (o (cdr overlays)) + (move-overlay (car o) (- (nth 1 o) offset) (- (nth 2 o) offset)))) (goto-char (org-element-property :end elem-B))))) +(defun org-element-remove-indentation (s &optional n) + "Remove maximum common indentation in string S and return it. +When optional argument N is a positive integer, remove exactly +that much characters from indentation, if possible, or return +S as-is otherwise. Unlike to `org-remove-indentation', this +function doesn't call `untabify' on S." + (catch 'exit + (with-temp-buffer + (insert s) + (goto-char (point-min)) + ;; Find maximum common indentation, if not specified. + (setq n (or n + (let ((min-ind (point-max))) + (save-excursion + (while (re-search-forward "^[ \t]*\\S-" nil t) + (let ((ind (1- (current-column)))) + (if (zerop ind) (throw 'exit s) + (setq min-ind (min min-ind ind)))))) + min-ind))) + (if (zerop n) s + ;; Remove exactly N indentation, but give up if not possible. + (while (not (eobp)) + (let ((ind (progn (skip-chars-forward " \t") (current-column)))) + (cond ((eolp) (delete-region (line-beginning-position) (point))) + ((< ind n) (throw 'exit s)) + (t (org-indent-line-to (- ind n)))) + (forward-line))) + (buffer-string))))) + + + (provide 'org-element) ;; Local variables: |