org-export: Fix selective export when a select tag is present

* contrib/lisp/org-export.el (org-export-populate-ignore-list): Fix
  docstring.
(org-export--selected-trees): Correctly search for headlines with
a select tag.
(org-export--skip-p): Fix selective export when a select tag is
present in the buffer.
* testing/lisp/test-org-export.el: Update tests.
This commit is contained in:
Nicolas Goaziou 2012-05-26 11:04:29 +02:00
parent 2a7321f70a
commit 68744bf19f
2 changed files with 25 additions and 23 deletions

View File

@ -1498,11 +1498,8 @@ associated numbering \(in the shape of a list of numbers\)."
(defun org-export-populate-ignore-list (data options) (defun org-export-populate-ignore-list (data options)
"Return list of elements and objects to ignore during export. "Return list of elements and objects to ignore during export.
DATA is the parse tree to traverse. OPTIONS is the plist holding DATA is the parse tree to traverse. OPTIONS is the plist holding
export options. export options."
Return elements or objects to ignore as a list."
(let (ignore (let (ignore
(walk-data (walk-data
(function (function
@ -1537,28 +1534,31 @@ INFO is a plist holding export options."
(function (function
(lambda (data genealogy) (lambda (data genealogy)
(case (org-element-type data) (case (org-element-type data)
(org-data (org-data (mapc (lambda (el) (funcall walk-data el genealogy))
(funcall walk-data (org-element-contents data) genealogy)) (org-element-contents data)))
(headline (headline
(let ((tags (org-element-property :tags headline))) (let ((tags (org-element-property :tags data)))
(if (loop for tag in (plist-get info :select-tags) (if (loop for tag in (plist-get info :select-tags)
thereis (member tag tags)) thereis (member tag tags))
;; When a select tag is found, mark as acceptable ;; When a select tag is found, mark full
;; full genealogy and every headline within the ;; genealogy and every headline within the tree
;; tree. ;; as acceptable.
(setq selected-trees (setq selected-trees
(append (append
(cons data genealogy) genealogy
(org-element-map data 'headline 'identity) (org-element-map data 'headline 'identity)
selected-trees)) selected-trees))
;; Else, continue searching in tree, recursively. ;; Else, continue searching in tree, recursively.
(funcall walk-data data (cons data genealogy)))))))))) (mapc
(lambda (el) (funcall walk-data el (cons data genealogy)))
(org-element-contents data))))))))))
(funcall walk-data data nil) selected-trees)) (funcall walk-data data nil) selected-trees))
(defun org-export--skip-p (blob options select-tags) (defun org-export--skip-p (blob options selected)
"Non-nil when element or object BLOB should be skipped during export. "Non-nil when element or object BLOB should be skipped during export.
OPTIONS is the plist holding export options. SELECT-TAGS, when OPTIONS is the plist holding export options. SELECTED, when
non-nil, is a list of tags marking a subtree as exportable." non-nil, is a list of headlines belonging to a tree with a select
tag."
(case (org-element-type blob) (case (org-element-type blob)
;; Check headline. ;; Check headline.
(headline (headline
@ -1571,9 +1571,9 @@ non-nil, is a list of tags marking a subtree as exportable."
;; Ignore subtrees with an exclude tag. ;; Ignore subtrees with an exclude tag.
(loop for k in (plist-get options :exclude-tags) (loop for k in (plist-get options :exclude-tags)
thereis (member k tags)) thereis (member k tags))
;; Ignore subtrees without a select tag, when such tag is ;; When a select tag is present in the buffer, ignore any tree
;; found in the buffer. ;; without it.
(member blob select-tags) (and selected (not (member blob selected)))
;; Ignore commented sub-trees. ;; Ignore commented sub-trees.
(org-element-property :commentedp blob) (org-element-property :commentedp blob)
;; Ignore archived subtrees if `:with-archived-trees' is nil. ;; Ignore archived subtrees if `:with-archived-trees' is nil.

View File

@ -123,14 +123,16 @@ already filled in `info'."
;; Test include tags. ;; Test include tags.
(org-test-with-temp-text " (org-test-with-temp-text "
* Head1 * Head1
** Sub-Head1.1 :export: * Head2
*** Sub-Head1.1.1 ** Sub-Head2.1 :export:
*** Sub-Head2.1.1
* Head2" * Head2"
(org-test-with-backend test (org-test-with-backend test
(should (should
(string-match (equal
"\\* Head1\n\\*\\* Sub-Head1.1[ \t]+:export:\n\\*\\*\\* Sub-Head1.1.1\n" "* Head2\n** Sub-Head2.1 :export:\n*** Sub-Head2.1.1\n"
(org-export-as 'test nil nil nil '(:select-tags ("export"))))))) (let ((org-tags-column 0))
(org-export-as 'test nil nil nil '(:select-tags ("export"))))))))
;; Test mixing include tags and exclude tags. ;; Test mixing include tags and exclude tags.
(org-test-with-temp-text " (org-test-with-temp-text "
* Head1 :export: * Head1 :export: