summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2019-02-25 13:24:37 +0100
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2019-02-25 13:24:37 +0100
commit9d603b1854f658202024807c17ffc1fd47a3cd74 (patch)
tree89f3b9d9a13229bf840fb241f2b7bac7c3c9f9e2
parentc07bf18b502db00ecb2cfc69a54a35c52a78d197 (diff)
downloadorg-mode-9d603b1854f658202024807c17ffc1fd47a3cd74.tar.gz
org-archive: Fix archive location with multiple ARCHIVE keywords
* lisp/org-archive.el (org-get-local-archive-location): (org-extract-archive-file): (org-extract-archive-heading): Remove function. (org-all-archive-files): Fix function. (org-archive--compute-location): New function. * lisp/org-archive.el (org-archive-subtree): Use new function. Do not look for multiple ARCHIVE keywords. This is already taken care of in `org-set-regexps-and-options', through `org-archive-location' buffer-local variable.
-rw-r--r--lisp/org-archive.el93
1 files changed, 35 insertions, 58 deletions
diff --git a/lisp/org-archive.el b/lisp/org-archive.el
index 7ea2490..206a76a 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -29,6 +29,7 @@
;;; Code:
(require 'org)
+(require 'cl-lib)
(declare-function org-element-type "org-element" (element))
(declare-function org-datetree-find-date-create "org-datetree" (date &optional keep-restriction))
@@ -126,22 +127,6 @@ Hook functions are called with point on the subtree in the
original file. At this stage, the subtree has been added to the
archive location, but not yet deleted from the original file.")
-(defun org-get-local-archive-location ()
- "Get the archive location applicable at point."
- (let ((re "^[ \t]*#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
- prop)
- (save-excursion
- (save-restriction
- (widen)
- (setq prop (org-entry-get nil "ARCHIVE" 'inherit))
- (cond
- ((and prop (string-match "\\S-" prop))
- prop)
- ((or (re-search-backward re nil t)
- (re-search-forward re nil t))
- (match-string 1))
- (t org-archive-location))))))
-
;;;###autoload
(defun org-add-archive-files (files)
"Splice the archive files into the list of files.
@@ -159,45 +144,36 @@ archive file is."
files))))
(defun org-all-archive-files ()
- "Get a list of all archive files used in the current buffer."
- (let (files)
+ "List of all archive files used in the current buffer."
+ (let* ((case-fold-search t)
+ (files `(,(car (org-archive--compute-location org-archive-location)))))
(org-with-point-at 1
- (let ((regexp "^[ \t]*\\(#\\+\\|:\\)ARCHIVE:[ \t]+\\(.*\\)")
- (case-fold-search t))
- (while (re-search-forward regexp nil t)
- (when (save-match-data
- (if (equal ":" (match-string 1)) (org-at-property-p)
- (eq 'keyword (org-element-type (org-element-at-point)))))
- (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))
- (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)
- "Extract and expand the file name from archive LOCATION.
-if LOCATION is not given, the value of `org-archive-location' is used."
- (setq location (or location org-archive-location))
- (if (string-match "\\(.*\\)::\\(.*\\)" location)
- (if (= (match-beginning 1) (match-end 1))
- (buffer-file-name (buffer-base-buffer))
- (expand-file-name
- (format (match-string 1 location)
- (file-name-nondirectory
- (buffer-file-name (buffer-base-buffer))))))))
-
-(defun org-extract-archive-heading (&optional location)
- "Extract the heading from archive LOCATION.
-if LOCATION is not given, the value of `org-archive-location' is used."
- (setq location (or location org-archive-location))
- (if (string-match "\\(.*\\)::\\(.*\\)" location)
- (format (match-string 2 location)
- (file-name-nondirectory
- (buffer-file-name (buffer-base-buffer))))))
+ (while (re-search-forward "^[ \t]*:ARCHIVE:" nil t)
+ (when (org-at-property-p)
+ (pcase (org-archive--compute-location (match-string 3))
+ (`(,file . ,_)
+ (when (org-string-nw-p file)
+ (cl-pushnew file files :test #'file-equal-p))))))
+ (cl-remove-if-not #'file-exists-p (nreverse files)))))
+
+(defun org-archive--compute-location (location)
+ "Extract and expand the location from archive LOCATION.
+Return a pair (FILE . HEADING) where FILE is the file name and
+HEADING the heading of the archive location, as strings. Raise
+an error if LOCATION is not a valid archive location."
+ (unless (string-match "::" location)
+ (error "Invalid archive location: %S" location))
+ (let ((current-file (buffer-file-name (buffer-base-buffer)))
+ (file-fmt (substring location nil (match-beginning 0)))
+ (heading-fmt (substring location (match-end 0))))
+ (cons
+ ;; File part.
+ (if (org-string-nw-p file-fmt)
+ (expand-file-name
+ (format file-fmt (file-name-nondirectory current-file)))
+ current-file)
+ ;; Heading part.
+ (format heading-fmt (file-name-nondirectory current-file)))))
;;;###autoload
(defun org-archive-subtree (&optional find-done)
@@ -242,10 +218,11 @@ direct children of this heading."
(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))
+ (location (org-archive--compute-location
+ (or (org-entry-get nil "ARCHIVE" 'inherit)
+ org-archive-location)))
+ (afile (car location))
+ (heading (cdr location))
(infile-p (equal file (abbreviate-file-name (or afile ""))))
(newfile-p (and (org-string-nw-p afile)
(not (file-exists-p afile))))