org-archive-location: Add 'match-outline' option

- add org-find-or-create-olp

lisp/org-archive.el

@@ -259,7 +259,7 @@ direct children of this heading."
 	      (if (local-variable-p 'org-odd-levels-only (current-buffer))
 		  org-odd-levels-only
 		tr-org-odd-levels-only))
-	     level datetree-date datetree-subheading-p
+	     level datetree-date datetree-subheading-p match-outline-path
              ;; Suppress on-the-fly headline updates.
              (org-element--cache-avoid-synchronous-headline-re-parsing t))
 	(when (string-match "\\`datetree/\\(\\**\\)" heading)
@@ -273,10 +273,14 @@ direct children of this heading."
 	    (setq datetree-subheading-p (> nsub 0)))
 	  (setq datetree-date (org-date-to-gregorian
 			       (or (org-entry-get nil "CLOSED" t) time))))
-	(if (and (> (length heading) 0)
-		 (string-match "^\\*+" heading))
-	    (setq level (match-end 0))
-	  (setq heading nil level 0))
+        (if (string-match "\\match-outline" heading)
+            (setq match-outline-path (org-get-outline-path)
+                  level (1+ (length match-outline-path))
+                  heading nil)
+	  (if (and (> (length heading) 0)
+		   (string-match "^\\*+" heading))
+	      (setq level (match-end 0))
+	    (setq heading nil level 0)))
 	(save-excursion
 	  (org-back-to-heading t)
 	  ;; Get context information that will be lost by moving the
@@ -319,6 +323,9 @@ direct children of this heading."
 	      (require 'org-datetree)
 	      (org-datetree-find-date-create datetree-date)
 	      (org-narrow-to-subtree))
+            (when match-outline-path
+              (goto-char (org-find-or-create-olp match-outline-path t))
+              (org-narrow-to-subtree))
 	    ;; Force the TODO keywords of the original buffer
 	    (let ((org-todo-line-regexp tr-org-todo-line-regexp)
 		  (org-todo-keywords-1 tr-org-todo-keywords-1)
@@ -339,7 +346,8 @@ direct children of this heading."
 		      (goto-char (point-max))
 		      (or (bolp) (insert "\n"))
 		      ;; datetrees don't need too much spacing
-		      (insert (if datetree-date "" "\n") heading "\n")
+                      (unless match-outline-path
+		        (insert (if datetree-date "" "\n") heading "\n"))
 		      (end-of-line 0))
 		    ;; Make the subtree visible
 		    (org-fold-show-subtree)
@@ -364,7 +372,7 @@ direct children of this heading."
 		  ;; To prevent this, make sure visible part of buffer
 		  ;; always terminates on a new line, while limiting
 		  ;; number of blank lines in a date tree.
-		  (unless (and datetree-date (bolp)) (insert "\n"))))
+		  (unless (and (or datetree-date match-outline-path) (bolp)) (insert "\n"))))
 	      ;; Paste
 	      (org-paste-subtree (org-get-valid-level level (and heading 1)))
 	      ;; Shall we append inherited tags?

lisp/org.el

@@ -13483,6 +13483,27 @@ only headings."
        (when (org-at-heading-p)
 	 (point-marker))))))
 
+(defun org-find-or-create-olp (path &optional this-buffer)
+  "Call `org-find-olp`. On 'not found' error, create PATH."
+  (condition-case err (org-find-olp path this-buffer)
+    (error
+     (setq err (cadr err))
+     (if (not (string-match "not found on level \\([0-9]*\\)" err))
+         (error err)
+       (let* ((level (1- (read (match-string 1 err))))
+              (found-path (seq-take path level))
+              (unfound-path (nthcdr level path)))
+         (save-excursion
+           (if (not found-path)
+               (goto-char (max-char))
+             (goto-char (org-find-olp found-path this-buffer))
+             (end-of-line)
+             (insert "\n"))
+           (while unfound-path
+	     (setq level (1+ level))
+	     (insert (make-string level ?*) " " (pop unfound-path) "\n"))))
+       (org-find-olp path this-buffer)))))
+
 (defun org-find-exact-headline-in-buffer (heading &optional buffer pos-only)
   "Find node HEADING in BUFFER.
 Return a marker to the heading if it was found, or nil if not.