Browse Source

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/
Bastien 7 months ago
parent
commit
9f0af69dd2
4 changed files with 38 additions and 2 deletions
  1. 3 1
      lisp/ob-exp.el
  2. 3 1
      lisp/ob-tangle.el
  3. 14 0
      lisp/org.el
  4. 18 0
      testing/lisp/test-org.el

+ 3 - 1
lisp/ob-exp.el

@@ -33,6 +33,7 @@
 (declare-function org-escape-code-in-string "org-src" (s))
 (declare-function org-export-copy-buffer "ox" ())
 (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)
 
@@ -157,7 +158,8 @@ this template."
 	      ;; encountered.
 	      (goto-char (point-min))
 	      (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))
 			 (element (save-match-data
 				    (if object? (org-element-context)

+ 3 - 1
lisp/ob-tangle.el

@@ -41,6 +41,7 @@
 (declare-function org-element-type "org-element" (element))
 (declare-function org-heading-components "org" ())
 (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" ())
 
 (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)
 	  (setq counter 1)
 	  (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))
 	       (src-lang (nth 0 info))
 	       (src-tfile (cdr (assq :tangle (nth 2 info)))))

+ 14 - 0
lisp/org.el

@@ -20265,6 +20265,20 @@ unless optional argument NO-INHERITANCE is non-nil."
    (t
     (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
   "Return t if cursor is in a commented line."
   (save-excursion

+ 18 - 0
testing/lisp/test-org.el

@@ -2087,6 +2087,24 @@
      (goto-char (point-max))
      (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 ()
   ;; Check other dependencies.
   (should