Skip archived headings when tangling and exporting

* lisp/org.el (org-in-archived-heading-p): New function.

* lisp/ob-exp.el (org-babel-exp-process-buffer):
* lisp/ob-tangle.el (org-babel-tangle-collect-blocks): Use
`org-in-archived-heading-p' to skip archived headings when tangling
and exporting.

* testing/lisp/test-org.el (test-org/in-archived-heading-p): Add
test for `org-in-archived-heading-p'.

Reported-by: flare <gabrielxaviersmith@gmail.com>
See https://orgmode.org/list/877dt9ey2c.fsf@gmail.com/
This commit is contained in:
Bastien 2020-09-07 06:49:12 +02:00
parent 4df12ea391
commit 9f0af69dd2
4 changed files with 38 additions and 2 deletions

View File

@ -33,6 +33,7 @@
(declare-function org-escape-code-in-string "org-src" (s)) (declare-function org-escape-code-in-string "org-src" (s))
(declare-function org-export-copy-buffer "ox" ()) (declare-function org-export-copy-buffer "ox" ())
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(declare-function org-in-archived-heading-p "org" (&optional no-inheritance))
(defvar org-src-preserve-indentation) (defvar org-src-preserve-indentation)
@ -157,7 +158,8 @@ this template."
;; encountered. ;; encountered.
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward regexp nil t) (while (re-search-forward regexp nil t)
(unless (save-match-data (org-in-commented-heading-p)) (unless (save-match-data (or (org-in-commented-heading-p)
(org-in-archived-heading-p)))
(let* ((object? (match-end 1)) (let* ((object? (match-end 1))
(element (save-match-data (element (save-match-data
(if object? (org-element-context) (if object? (org-element-context)

View File

@ -41,6 +41,7 @@
(declare-function org-element-type "org-element" (element)) (declare-function org-element-type "org-element" (element))
(declare-function org-heading-components "org" ()) (declare-function org-heading-components "org" ())
(declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) (declare-function org-in-commented-heading-p "org" (&optional no-inheritance))
(declare-function org-in-archived-heading-p "org" (&optional no-inheritance))
(declare-function outline-previous-heading "outline" ()) (declare-function outline-previous-heading "outline" ())
(defcustom org-babel-tangle-lang-exts (defcustom org-babel-tangle-lang-exts
@ -382,7 +383,8 @@ code blocks by target file."
(if (eq last-heading-pos current-heading-pos) (cl-incf counter) (if (eq last-heading-pos current-heading-pos) (cl-incf counter)
(setq counter 1) (setq counter 1)
(setq last-heading-pos current-heading-pos))) (setq last-heading-pos current-heading-pos)))
(unless (org-in-commented-heading-p) (unless (or (org-in-commented-heading-p)
(org-in-archived-heading-p))
(let* ((info (org-babel-get-src-block-info 'light)) (let* ((info (org-babel-get-src-block-info 'light))
(src-lang (nth 0 info)) (src-lang (nth 0 info))
(src-tfile (cdr (assq :tangle (nth 2 info))))) (src-tfile (cdr (assq :tangle (nth 2 info)))))

View File

@ -20265,6 +20265,20 @@ unless optional argument NO-INHERITANCE is non-nil."
(t (t
(save-excursion (and (org-up-heading-safe) (org-in-commented-heading-p)))))) (save-excursion (and (org-up-heading-safe) (org-in-commented-heading-p))))))
(defun org-in-archived-heading-p (&optional no-inheritance)
"Non-nil if point is under an archived heading.
This function also checks ancestors of the current headline,
unless optional argument NO-INHERITANCE is non-nil."
(cond
((org-before-first-heading-p) nil)
((let ((tags (nth 5 (org-heading-components))))
(and tags
(let ((case-fold-search nil))
(string-match-p org-archive-tag tags)))))
(no-inheritance nil)
(t
(save-excursion (and (org-up-heading-safe) (org-in-archived-heading-p))))))
(defun org-at-comment-p nil (defun org-at-comment-p nil
"Return t if cursor is in a commented line." "Return t if cursor is in a commented line."
(save-excursion (save-excursion

View File

@ -2087,6 +2087,24 @@
(goto-char (point-max)) (goto-char (point-max))
(org-in-commented-heading-p t)))) (org-in-commented-heading-p t))))
(ert-deftest test-org/in-archived-heading-p ()
"Test `org-in-archived-heading-p' specifications."
;; Archived headline.
(should
(org-test-with-temp-text "* Headline :ARCHIVE:\nBody"
(goto-char (point-max))
(org-in-archived-heading-p)))
;; Archived ancestor.
(should
(org-test-with-temp-text "* Headline :ARCHIVE:\n** Level 2\nBody"
(goto-char (point-max))
(org-in-archived-heading-p)))
;; Optional argument.
(should-not
(org-test-with-temp-text "* Headline :ARCHIVE:\n** Level 2\nBody"
(goto-char (point-max))
(org-in-archived-heading-p t))))
(ert-deftest test-org/entry-blocked-p () (ert-deftest test-org/entry-blocked-p ()
;; Check other dependencies. ;; Check other dependencies.
(should (should