From 9f0af69dd2b03f01e6ac0c16d4feb711f7852ba0 Mon Sep 17 00:00:00 2001
From: Bastien <bzg@gnu.org>
Date: Mon, 7 Sep 2020 06:49:12 +0200
Subject: [PATCH] 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/
---
 lisp/ob-exp.el           |  4 +++-
 lisp/ob-tangle.el        |  4 +++-
 lisp/org.el              | 14 ++++++++++++++
 testing/lisp/test-org.el | 18 ++++++++++++++++++
 4 files changed, 38 insertions(+), 2 deletions(-)

diff --git a/lisp/ob-exp.el b/lisp/ob-exp.el
index 34caf9546..1830730e4 100644
--- a/lisp/ob-exp.el
+++ b/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)
diff --git a/lisp/ob-tangle.el b/lisp/ob-tangle.el
index b50d42d9b..b74b3fa0c 100644
--- a/lisp/ob-tangle.el
+++ b/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)))))
diff --git a/lisp/org.el b/lisp/org.el
index 280c8b337..a5c7dcf3b 100644
--- a/lisp/org.el
+++ b/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
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index 6144a7af1..1d48bae72 100644
--- a/testing/lisp/test-org.el
+++ b/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