|
|
@@ -230,40 +230,30 @@ this heading."
|
|
|
((equal find-done '(16)) (org-archive-all-old))
|
|
|
(t
|
|
|
;; Save all relevant TODO keyword-relatex variables
|
|
|
- (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))
|
|
|
- ;; 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"))))
|
|
|
- (time (format-time-string
|
|
|
- (substring (cdr org-time-stamp-formats) 1 -1)))
|
|
|
- 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.
|
|
|
@@ -277,101 +267,109 @@ 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 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)
|
|
|
+ (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 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.
|
Nicolas Goaziou