Imported Upstream version 9.0

1 files changed, 156 insertions, 155 deletions

diff --git a/lisp/org-archive.el b/lisp/org-archive.el
index 4c6a8c3..6daed74 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -1,4 +1,4 @@
-;;; org-archive.el --- Archiving for Org-mode
+;;; org-archive.el --- Archiving for Org             -*- lexical-binding: t; -*-
 
 ;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
 
@@ -30,8 +30,9 @@
 
 (require 'org)
 
-(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
+(declare-function org-element-type "org-element" (element))
 (declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction))
+(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
 
 (defcustom org-archive-default-command 'org-archive-subtree
   "The default archiving command."
@@ -56,7 +57,7 @@ See `org-archive-to-archive-sibling' for more information."
 
 (defcustom org-archive-mark-done nil
   "Non-nil means mark entries as DONE when they are moved to the archive file.
-This can be a string to set the keyword to use.  When t, Org-mode will
+This can be a string to set the keyword to use.  When non-nil, Org will
 use the first keyword in its list that means done."
   :group 'org-archive
   :type '(choice
@@ -159,21 +160,24 @@ archive file is."
 
 (defun org-all-archive-files ()
   "Get a list of all archive files used in the current buffer."
-  (let (file files)
-    (save-excursion
-      (save-restriction
-	(goto-char (point-min))
-	(while (re-search-forward
-		"^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)"
-		nil t)
-	  (setq file (org-extract-archive-file
-		      (org-match-string-no-properties 2)))
-	  (and file (> (length file) 0) (file-exists-p file)
-	       (add-to-list 'files file)))))
+  (let ((case-fold-search t)
+	files)
+    (org-with-wide-buffer
+     (goto-char (point-min))
+     (while (re-search-forward
+	     "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)"
+	     nil t)
+       (when (save-match-data
+	       (if (eq (match-string 1) ":") (org-at-property-p)
+		 (eq (org-element-type (org-element-at-point)) 'keyword)))
+	 (let ((file (org-extract-archive-file
+		      (match-string-no-properties 2))))
+	   (when (and (org-string-nw-p file) (file-exists-p file))
+	     (push file files))))))
     (setq files (nreverse files))
-    (setq file (org-extract-archive-file))
-    (and file (> (length file) 0) (file-exists-p file)
-	 (add-to-list 'files file))
+    (let ((file (org-extract-archive-file)))
+      (when (and (org-string-nw-p file) (file-exists-p file))
+	(push file files)))
     files))
 
 (defun org-extract-archive-file (&optional location)
@@ -226,42 +230,30 @@ this heading."
      ((equal find-done '(16)) (org-archive-all-old))
      (t
       ;; Save all relevant TODO keyword-relatex variables
-      (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
-	    (tr-org-todo-keywords-1 org-todo-keywords-1)
-	    (tr-org-todo-kwd-alist org-todo-kwd-alist)
-	    (tr-org-done-keywords org-done-keywords)
-	    (tr-org-todo-regexp org-todo-regexp)
-	    (tr-org-todo-line-regexp org-todo-line-regexp)
-	    (tr-org-odd-levels-only org-odd-levels-only)
-	    (this-buffer (current-buffer))
-	    ;; start of variables that will be used for saving context
-	    ;; The compiler complains about them - keep them anyway!
-	    (file (abbreviate-file-name
-		   (or (buffer-file-name (buffer-base-buffer))
-		       (error "No file associated to buffer"))))
-	    (olpath (mapconcat 'identity (org-get-outline-path) "/"))
-	    (time (format-time-string
-		   (substring (cdr org-time-stamp-formats) 1 -1)))
-	    category todo priority ltags itags atags
-	    ;; end of variables that will be used for saving context
-	    location afile heading buffer level newfile-p infile-p visiting
-	    datetree-date datetree-subheading-p)
-
-	;; Find the local archive location
-	(setq location (org-get-local-archive-location)
-	      afile (org-extract-archive-file location)
-	      heading (org-extract-archive-heading location)
-	      infile-p (equal file (abbreviate-file-name (or afile ""))))
-	(unless afile
-	  (error "Invalid `org-archive-location'"))
-
-	(if (> (length afile) 0)
-	    (setq newfile-p (not (file-exists-p afile))
-		  visiting (find-buffer-visiting afile)
-		  buffer (or visiting (find-file-noselect afile)))
-	  (setq buffer (current-buffer)))
-	(unless buffer
-	  (error "Cannot access file \"%s\"" afile))
+      (let* ((tr-org-todo-keywords-1 org-todo-keywords-1)
+	     (tr-org-todo-kwd-alist org-todo-kwd-alist)
+	     (tr-org-done-keywords org-done-keywords)
+	     (tr-org-todo-regexp org-todo-regexp)
+	     (tr-org-todo-line-regexp org-todo-line-regexp)
+	     (tr-org-odd-levels-only org-odd-levels-only)
+	     (this-buffer (current-buffer))
+	     (time (format-time-string
+		    (substring (cdr org-time-stamp-formats) 1 -1)))
+	     (file (abbreviate-file-name
+		    (or (buffer-file-name (buffer-base-buffer))
+			(error "No file associated to buffer"))))
+	     (location (org-get-local-archive-location))
+	     (afile (or (org-extract-archive-file location)
+			(error "Invalid `org-archive-location'")))
+	     (heading (org-extract-archive-heading location))
+	     (infile-p (equal file (abbreviate-file-name (or afile ""))))
+	     (newfile-p (and (org-string-nw-p afile)
+			     (not (file-exists-p afile))))
+	     (buffer (cond ((not (org-string-nw-p afile)) this-buffer)
+			   ((find-buffer-visiting afile))
+			   ((find-file-noselect afile))
+			   (t (error "Cannot access file \"%s\"" afile))))
+	     level datetree-date datetree-subheading-p)
 	(when (string-match "\\`datetree/" heading)
 	  ;; Replace with ***, to represent the 3 levels of headings the
 	  ;; datetree has.
@@ -275,106 +267,115 @@ this heading."
 	  (setq heading nil level 0))
 	(save-excursion
 	  (org-back-to-heading t)
-	  ;; Get context information that will be lost by moving the tree
-	  (setq category (org-get-category nil 'force-refresh)
-		todo (and (looking-at org-todo-line-regexp)
-			  (match-string 2))
-		priority (org-get-priority
-			  (if (match-end 3) (match-string 3) ""))
-		ltags (org-get-tags)
-		itags (org-delete-all ltags (org-get-tags-at))
-		atags (org-get-tags-at))
-	  (setq ltags (mapconcat 'identity ltags " ")
-		itags (mapconcat 'identity itags " "))
-	  ;; We first only copy, in case something goes wrong
-	  ;; we need to protect `this-command', to avoid kill-region sets it,
-	  ;; which would lead to duplication of subtrees
-	  (let (this-command) (org-copy-subtree 1 nil t))
-	  (set-buffer buffer)
-	  ;; Enforce org-mode for the archive buffer
-	  (if (not (derived-mode-p 'org-mode))
-	      ;; Force the mode for future visits.
-	      (let ((org-insert-mode-line-in-empty-file t)
-		    (org-inhibit-startup t))
-		(call-interactively 'org-mode)))
-	  (when (and newfile-p org-archive-file-header-format)
-	    (goto-char (point-max))
-	    (insert (format org-archive-file-header-format
-			    (buffer-file-name this-buffer))))
-	  (when datetree-date
-	    (require 'org-datetree)
-	    (org-datetree-find-date-create datetree-date)
-	    (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)
-		(org-todo-kwd-alist tr-org-todo-kwd-alist)
-		(org-done-keywords tr-org-done-keywords)
-		(org-todo-regexp tr-org-todo-regexp)
-		(org-todo-line-regexp tr-org-todo-line-regexp)
-		(org-odd-levels-only
-		 (if (local-variable-p 'org-odd-levels-only (current-buffer))
-		     org-odd-levels-only
-		   tr-org-odd-levels-only)))
-	    (goto-char (point-min))
-	    (outline-show-all)
-	    (if (and heading (not (and datetree-date (not datetree-subheading-p))))
-		(progn
-		  (if (re-search-forward
-		       (concat "^" (regexp-quote heading)
-			       (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
-		       nil t)
-		      (goto-char (match-end 0))
-		    ;; Heading not found, just insert it at the end
-		    (goto-char (point-max))
-		    (or (bolp) (insert "\n"))
-		    ;; datetrees don't need too much spacing
-		    (insert (if datetree-date "" "\n") heading "\n")
-		    (end-of-line 0))
-		  ;; Make the subtree visible
-		  (outline-show-subtree)
-		  (if org-archive-reversed-order
-		      (progn
-			(org-back-to-heading t)
-			(outline-next-heading))
-		    (org-end-of-subtree t))
-		  (skip-chars-backward " \t\r\n")
-		  (and (looking-at "[ \t\r\n]*")
-		       ;; datetree archives don't need so much spacing.
-		       (replace-match (if datetree-date "\n" "\n\n"))))
-	      ;; No specific heading, just go to end of file.
-	      (goto-char (point-max)) (unless datetree-date (insert "\n")))
-	    ;; Paste
-	    (org-paste-subtree (org-get-valid-level level (and heading 1)))
-	    ;; Shall we append inherited tags?
-	    (and itags
-		 (or (and (eq org-archive-subtree-add-inherited-tags 'infile)
-			  infile-p)
-		     (eq org-archive-subtree-add-inherited-tags t))
-		 (org-set-tags-to atags))
-	    ;; Mark the entry as done
-	    (when (and org-archive-mark-done
-		       (looking-at org-todo-line-regexp)
-		       (or (not (match-end 2))
-			   (not (member (match-string 2) org-done-keywords))))
-	      (let (org-log-done org-todo-log-states)
-		(org-todo
-		 (car (or (member org-archive-mark-done org-done-keywords)
-			  org-done-keywords)))))
-
-	    ;; Add the context info
-	    (when org-archive-save-context-info
-	      (let ((l org-archive-save-context-info) e n v)
-		(while (setq e (pop l))
-		  (when (and (setq v (symbol-value e))
-			     (stringp v) (string-match "\\S-" v))
-		    (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
-		    (org-entry-put (point) n v)))))
-
-	    (widen)
-	    ;; Save and kill the buffer, if it is not the same buffer.
-	    (when (not (eq this-buffer buffer))
-	      (save-buffer))))
+	  ;; Get context information that will be lost by moving the
+	  ;; tree.  See `org-archive-save-context-info'.
+	  (let* ((all-tags (org-get-tags-at))
+		 (local-tags (org-get-tags))
+		 (inherited-tags (org-delete-all local-tags all-tags))
+		 (context
+		  `((category . ,(org-get-category nil 'force-refresh))
+		    (file . ,file)
+		    (itags . ,(mapconcat #'identity inherited-tags " "))
+		    (ltags . ,(mapconcat #'identity local-tags " "))
+		    (olpath . ,(mapconcat #'identity
+					  (org-get-outline-path)
+					  "/"))
+		    (time . ,time)
+		    (todo . ,(org-entry-get (point) "TODO")))))
+	    ;; We first only copy, in case something goes wrong
+	    ;; we need to protect `this-command', to avoid kill-region sets it,
+	    ;; which would lead to duplication of subtrees
+	    (let (this-command) (org-copy-subtree 1 nil t))
+	    (set-buffer buffer)
+	    ;; Enforce Org mode for the archive buffer
+	    (if (not (derived-mode-p 'org-mode))
+		;; Force the mode for future visits.
+		(let ((org-insert-mode-line-in-empty-file t)
+		      (org-inhibit-startup t))
+		  (call-interactively 'org-mode)))
+	    (when (and newfile-p org-archive-file-header-format)
+	      (goto-char (point-max))
+	      (insert (format org-archive-file-header-format
+			      (buffer-file-name this-buffer))))
+	    (when datetree-date
+	      (require 'org-datetree)
+	      (org-datetree-find-date-create datetree-date)
+	      (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)
+		  (org-todo-kwd-alist tr-org-todo-kwd-alist)
+		  (org-done-keywords tr-org-done-keywords)
+		  (org-todo-regexp tr-org-todo-regexp)
+		  (org-todo-line-regexp tr-org-todo-line-regexp)
+		  (org-odd-levels-only
+		   (if (local-variable-p 'org-odd-levels-only (current-buffer))
+		       org-odd-levels-only
+		     tr-org-odd-levels-only)))
+	      (goto-char (point-min))
+	      (outline-show-all)
+	      (if (and heading (not (and datetree-date (not datetree-subheading-p))))
+		  (progn
+		    (if (re-search-forward
+			 (concat "^" (regexp-quote heading)
+				 "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)")
+			 nil t)
+			(goto-char (match-end 0))
+		      ;; Heading not found, just insert it at the end
+		      (goto-char (point-max))
+		      (or (bolp) (insert "\n"))
+		      ;; datetrees don't need too much spacing
+		      (insert (if datetree-date "" "\n") heading "\n")
+		      (end-of-line 0))
+		    ;; Make the subtree visible
+		    (outline-show-subtree)
+		    (if org-archive-reversed-order
+			(progn
+			  (org-back-to-heading t)
+			  (outline-next-heading))
+		      (org-end-of-subtree t))
+		    (skip-chars-backward " \t\r\n")
+		    (and (looking-at "[ \t\r\n]*")
+			 ;; datetree archives don't need so much spacing.
+			 (replace-match (if datetree-date "\n" "\n\n"))))
+		;; No specific heading, just go to end of file.
+		(goto-char (point-max))
+		;; Subtree narrowing can let the buffer end on
+		;; a headline.  `org-paste-subtree' then deletes it.
+		;; 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")))
+	      ;; Paste
+	      (org-paste-subtree (org-get-valid-level level (and heading 1)))
+	      ;; Shall we append inherited tags?
+	      (and inherited-tags
+		   (or (and (eq org-archive-subtree-add-inherited-tags 'infile)
+			    infile-p)
+		       (eq org-archive-subtree-add-inherited-tags t))
+		   (org-set-tags-to all-tags))
+	      ;; Mark the entry as done
+	      (when (and org-archive-mark-done
+			 (looking-at org-todo-line-regexp)
+			 (or (not (match-end 2))
+			     (not (member (match-string 2) org-done-keywords))))
+		(let (org-log-done org-todo-log-states)
+		  (org-todo
+		   (car (or (member org-archive-mark-done org-done-keywords)
+			    org-done-keywords)))))
+
+	      ;; Add the context info.
+	      (dolist (item org-archive-save-context-info)
+		(let ((value (cdr (assq item context))))
+		  (when (org-string-nw-p value)
+		    (org-entry-put
+		     (point)
+		     (concat "ARCHIVE_" (upcase (symbol-name item)))
+		     value))))
+	      (widen)
+	      ;; Save and kill the buffer, if it is not the same
+	      ;; buffer.
+	      (unless (eq this-buffer buffer) (save-buffer)))))
 	;; Here we are back in the original buffer.  Everything seems
 	;; to have worked.  So now run hooks, cut the tree and finish
 	;; up.
@@ -467,7 +468,7 @@ If the cursor is not on a headline, try all level 1 trees.  If
 it is on a headline, try all direct children.
 When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
   (org-archive-all-matches
-   (lambda (beg end)
+   (lambda (_beg end)
      (unless (re-search-forward org-not-done-heading-regexp end t)
        "no open TODO items"))
    tag))
@@ -478,7 +479,7 @@ If the cursor is not on a headline, try all level 1 trees.  If
 it is on a headline, try all direct children.
 When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
   (org-archive-all-matches
-   (lambda (beg end)
+   (lambda (_beg end)
      (let (ts)
        (and (re-search-forward org-ts-regexp end t)
 	    (setq ts (match-string 0))