diff options
author | Bastien <bzg@gnu.org> | 2020-02-05 15:34:06 +0100 |
---|---|---|
committer | Bastien <bzg@gnu.org> | 2020-02-05 15:34:06 +0100 |
commit | f636cf91b6cbe322eca56e23283f4614548c9d65 (patch) | |
tree | bb84126464337b6f21c2270b4942a046ddfdbc67 | |
parent | b14a14c9eedd9e2164c769f0f9425b160b31f33c (diff) | |
download | org-mode-f636cf91b6cbe322eca56e23283f4614548c9d65.tar.gz |
New org-refile.el file with refile definitions
* lisp/org-refile.el: New file.
* lisp/org.el (org-refile, org-directory)
(org-default-notes-file, org-reverse-note-order)
(org-log-refile, org-refile-targets)
(org-refile-target-verify-function, org-refile-use-cache)
(org-refile-use-outline-path)
(org-outline-path-complete-in-steps)
(org-refile-allow-creating-parent-nodes)
(org-refile-active-region-within-subtree)
(org-refile-target-table, org-refile-cache)
(org-refile-markers, org-refile-marker)
(org-refile-cache-clear, org-refile-cache-check-set)
(org-refile-cache-put, org-refile-cache-get)
(org-outline-path-cache, org-refile-get-targets)
(org--get-outline-path-1, org-get-outline-path)
(org-format-outline-path, org-display-outline-path)
(org-refile-history, org-after-refile-insert-hook)
(org-capture-last-stored-marker, org-refile-keep, org-copy)
(org-refile, org-refile-goto-last-stored)
(org-refile--get-location, org-refile-get-location)
(org-refile-check-position, org-refile-new-child)
(org-olpath-completing-read): Move to org-refile.el.
(org-menu-define): Display Org refile comands only when
'org-refile is featured.
* lisp/org-keys.el (org-refile-copy, org-mode-map): Declare
functions.
* lisp/org-capture.el: Require 'org-refile.
* lisp/org-agenda.el: Require 'org-refile.
-rw-r--r-- | lisp/org-agenda.el | 1 | ||||
-rw-r--r-- | lisp/org-capture.el | 1 | ||||
-rw-r--r-- | lisp/org-keys.el | 4 | ||||
-rw-r--r-- | lisp/org-refile.el | 872 | ||||
-rw-r--r-- | lisp/org.el | 842 |
5 files changed, 880 insertions, 840 deletions
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index 46eaa26..3d7d2da 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -49,6 +49,7 @@ (require 'ol) (require 'org) (require 'org-macs) +(require 'org-refile) (declare-function diary-add-to-list "diary-lib" (date string specifier &optional marker globcolor literal)) diff --git a/lisp/org-capture.el b/lisp/org-capture.el index a8317dc..699ca3d 100644 --- a/lisp/org-capture.el +++ b/lisp/org-capture.el @@ -49,6 +49,7 @@ (require 'cl-lib) (require 'org) +(require 'org-refile) (declare-function org-at-encrypted-entry-p "org-crypt" ()) (declare-function org-at-table-p "org-table" (&optional table-type)) diff --git a/lisp/org-keys.el b/lisp/org-keys.el index 4d4e124..7f86831 100644 --- a/lisp/org-keys.el +++ b/lisp/org-keys.el @@ -56,7 +56,7 @@ (declare-function org-clone-subtree-with-time-shift "org" (n &optional shift)) (declare-function org-columns "org" (&optional global columns-fmt-string)) (declare-function org-comment-dwim "org" (arg)) -(declare-function org-copy "org" ()) +(declare-function org-refile-copy "org" ()) (declare-function org-copy-special "org" ()) (declare-function org-copy-visible "org" (beg end)) (declare-function org-ctrl-c-ctrl-c "org" (&optional arg)) @@ -580,7 +580,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names." (org-defkey org-mode-map (kbd "C-c C-d") #'org-deadline) (org-defkey org-mode-map (kbd "C-c ;") #'org-toggle-comment) (org-defkey org-mode-map (kbd "C-c C-w") #'org-refile) -(org-defkey org-mode-map (kbd "C-c M-w") #'org-copy) +(org-defkey org-mode-map (kbd "C-c M-w") #'org-refile-copy) (org-defkey org-mode-map (kbd "C-c /") #'org-sparse-tree) ;minor-mode reserved (org-defkey org-mode-map (kbd "C-c \\") #'org-match-sparse-tree) ;minor-mode r. (org-defkey org-mode-map (kbd "C-c RET") #'org-ctrl-c-ret) diff --git a/lisp/org-refile.el b/lisp/org-refile.el new file mode 100644 index 0000000..e1be329 --- /dev/null +++ b/lisp/org-refile.el @@ -0,0 +1,872 @@ +;;; org-refile.el --- Refile Org Subtrees -*- lexical-binding: t; -*- + +;; Copyright (C) 2010-2020 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org Refile allows you to refile subtrees to various locations. + +;;; Code: + +(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) + +(defgroup org-refile nil + "Options concerning refiling entries in Org mode." + :tag "Org Refile" + :group 'org) + +(defcustom org-directory "~/org" + "Directory with Org files. +This is just a default location to look for Org files. There is no need +at all to put your files into this directory. It is used in the +following situations: + +1. When a capture template specifies a target file that is not an + absolute path. The path will then be interpreted relative to + `org-directory' +2. When the value of variable `org-agenda-files' is a single file, any + relative paths in this file will be taken as relative to + `org-directory'." + :group 'org-refile + :group 'org-capture + :type 'directory) + +(defcustom org-default-notes-file (convert-standard-filename "~/.notes") + "Default target for storing notes. +Used as a fall back file for org-capture.el, for templates that +do not specify a target file." + :group 'org-refile + :group 'org-capture + :type 'file) + +(defcustom org-reverse-note-order nil + "Non-nil means store new notes at the beginning of a file or entry. +When nil, new notes will be filed to the end of a file or entry. +This can also be a list with cons cells of regular expressions that +are matched against file names, and values." + :group 'org-capture + :group 'org-refile + :type '(choice + (const :tag "Reverse always" t) + (const :tag "Reverse never" nil) + (repeat :tag "By file name regexp" + (cons regexp boolean)))) + +(defcustom org-log-refile nil + "Information to record when a task is refiled. + +Possible values are: + +nil Don't add anything +time Add a time stamp to the task +note Prompt for a note and add it with template `org-log-note-headings' + +This option can also be set with on a per-file-basis with + + #+STARTUP: nologrefile + #+STARTUP: logrefile + #+STARTUP: lognoterefile + +You can have local logging settings for a subtree by setting the LOGGING +property to one or more of these keywords. + +When bulk-refiling, e.g., from the agenda, the value `note' is +forbidden and will temporarily be changed to `time'." + :group 'org-refile + :group 'org-progress + :version "24.1" + :type '(choice + (const :tag "No logging" nil) + (const :tag "Record timestamp" time) + (const :tag "Record timestamp with note." note))) + +(defcustom org-refile-targets nil + "Targets for refiling entries with `\\[org-refile]'. +This is a list of cons cells. Each cell contains: +- a specification of the files to be considered, either a list of files, + or a symbol whose function or variable value will be used to retrieve + a file name or a list of file names. If you use `org-agenda-files' for + that, all agenda files will be scanned for targets. Nil means consider + headings in the current buffer. +- A specification of how to find candidate refile targets. This may be + any of: + - a cons cell (:tag . \"TAG\") to identify refile targets by a tag. + This tag has to be present in all target headlines, inheritance will + not be considered. + - a cons cell (:todo . \"KEYWORD\") to identify refile targets by + todo keyword. + - a cons cell (:regexp . \"REGEXP\") with a regular expression matching + headlines that are refiling targets. + - a cons cell (:level . N). Any headline of level N is considered a target. + Note that, when `org-odd-levels-only' is set, level corresponds to + order in hierarchy, not to the number of stars. + - a cons cell (:maxlevel . N). Any headline with level <= N is a target. + Note that, when `org-odd-levels-only' is set, level corresponds to + order in hierarchy, not to the number of stars. + +Each element of this list generates a set of possible targets. +The union of these sets is presented (with completion) to +the user by `org-refile'. + +You can set the variable `org-refile-target-verify-function' to a function +to verify each headline found by the simple criteria above. + +When this variable is nil, all top-level headlines in the current buffer +are used, equivalent to the value `((nil . (:level . 1))'." + :group 'org-refile + :type '(repeat + (cons + (choice :value org-agenda-files + (const :tag "All agenda files" org-agenda-files) + (const :tag "Current buffer" nil) + (function) (variable) (file)) + (choice :tag "Identify target headline by" + (cons :tag "Specific tag" (const :value :tag) (string)) + (cons :tag "TODO keyword" (const :value :todo) (string)) + (cons :tag "Regular expression" (const :value :regexp) (regexp)) + (cons :tag "Level number" (const :value :level) (integer)) + (cons :tag "Max Level number" (const :value :maxlevel) (integer)))))) + +(defcustom org-refile-target-verify-function nil + "Function to verify if the headline at point should be a refile target. +The function will be called without arguments, with point at the +beginning of the headline. It should return t and leave point +where it is if the headline is a valid target for refiling. + +If the target should not be selected, the function must return nil. +In addition to this, it may move point to a place from where the search +should be continued. For example, the function may decide that the entire +subtree of the current entry should be excluded and move point to the end +of the subtree." + :group 'org-refile + :type '(choice + (const nil) + (function))) + +(defcustom org-refile-use-cache nil + "Non-nil means cache refile targets to speed up the process. +\\<org-mode-map>\ +The cache for a particular file will be updated automatically when +the buffer has been killed, or when any of the marker used for flagging +refile targets no longer points at a live buffer. +If you have added new entries to a buffer that might themselves be targets, +you need to clear the cache manually by pressing `C-0 \\[org-refile]' or, +if you find that easier, \ +`\\[universal-argument] \\[universal-argument] \\[universal-argument] \ +\\[org-refile]'." + :group 'org-refile + :version "24.1" + :type 'boolean) + +(defcustom org-refile-use-outline-path nil + "Non-nil means provide refile targets as paths. +So a level 3 headline will be available as level1/level2/level3. + +When the value is `file', also include the file name (without directory) +into the path. In this case, you can also stop the completion after +the file name, to get entries inserted as top level in the file. + +When `full-file-path', include the full file path. + +When `buffer-name', use the buffer name." + :group 'org-refile + :type '(choice + (const :tag "Not" nil) + (const :tag "Yes" t) + (const :tag "Start with file name" file) + (const :tag "Start with full file path" full-file-path) + (const :tag "Start with buffer name" buffer-name))) + +(defcustom org-outline-path-complete-in-steps t + "Non-nil means complete the outline path in hierarchical steps. +When Org uses the refile interface to select an outline path (see +`org-refile-use-outline-path'), the completion of the path can be +done in a single go, or it can be done in steps down the headline +hierarchy. Going in steps is probably the best if you do not use +a special completion package like `ido' or `icicles'. However, +when using these packages, going in one step can be very fast, +while still showing the whole path to the entry." + :group 'org-refile + :type 'boolean) + +(defcustom org-refile-allow-creating-parent-nodes nil + "Non-nil means allow the creation of new nodes as refile targets. +New nodes are then created by adding \"/new node name\" to the completion +of an existing node. When the value of this variable is `confirm', +new node creation must be confirmed by the user (recommended). +When nil, the completion must match an existing entry. + +Note that, if the new heading is not seen by the criteria +listed in `org-refile-targets', multiple instances of the same +heading would be created by trying again to file under the new +heading." + :group 'org-refile + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Prompt for confirmation" confirm))) + +(defcustom org-refile-active-region-within-subtree nil + "Non-nil means also refile active region within a subtree. + +By default `org-refile' doesn't allow refiling regions if they +don't contain a set of subtrees, but it might be convenient to +do so sometimes: in that case, the first line of the region is +converted to a headline before refiling." + :group 'org-refile + :version "24.1" + :type 'boolean) + +(defvar org-refile-target-table nil + "The list of refile targets, created by `org-refile'.") + +(defvar org-refile-cache nil + "Cache for refile targets.") + +(defvar org-refile-markers nil + "All the markers used for caching refile locations.") + +(defun org-refile-marker (pos) + "Get a new refile marker, but only if caching is in use." + (if (not org-refile-use-cache) + pos + (let ((m (make-marker))) + (move-marker m pos) + (push m org-refile-markers) + m))) + +(defun org-refile-cache-clear () + "Clear the refile cache and disable all the markers." + (dolist (m org-refile-markers) (move-marker m nil)) + (setq org-refile-markers nil) + (setq org-refile-cache nil) + (message "Refile cache has been cleared")) + +(defun org-refile-cache-check-set (set) + "Check if all the markers in the cache still have live buffers." + (let (marker) + (catch 'exit + (while (and set (setq marker (nth 3 (pop set)))) + ;; If `org-refile-use-outline-path' is 'file, marker may be nil + (when (and marker (null (marker-buffer marker))) + (message "Please regenerate the refile cache with `C-0 C-c C-w'") + (sit-for 3) + (throw 'exit nil))) + t))) + +(defun org-refile-cache-put (set &rest identifiers) + "Push the refile targets SET into the cache, under IDENTIFIERS." + (let* ((key (sha1 (prin1-to-string identifiers))) + (entry (assoc key org-refile-cache))) + (if entry + (setcdr entry set) + (push (cons key set) org-refile-cache)))) + +(defun org-refile-cache-get (&rest identifiers) + "Retrieve the cached value for refile targets given by IDENTIFIERS." + (cond + ((not org-refile-cache) nil) + ((not org-refile-use-cache) (org-refile-cache-clear) nil) + (t + (let ((set (cdr (assoc (sha1 (prin1-to-string identifiers)) + org-refile-cache)))) + (and set (org-refile-cache-check-set set) set))))) + +(defvar org-outline-path-cache nil + "Alist between buffer positions and outline paths. +It value is an alist (POSITION . PATH) where POSITION is the +buffer position at the beginning of an entry and PATH is a list +of strings describing the outline path for that entry, in reverse +order.") + +(defun org-refile-get-targets (&optional default-buffer) + "Produce a table with refile targets." + (let ((case-fold-search nil) + ;; otherwise org confuses "TODO" as a kw and "Todo" as a word + (entries (or org-refile-targets '((nil . (:level . 1))))) + targets tgs files desc descre) + (message "Getting targets...") + (with-current-buffer (or default-buffer (current-buffer)) + (dolist (entry entries) + (setq files (car entry) desc (cdr entry)) + (cond + ((null files) (setq files (list (current-buffer)))) + ((eq files 'org-agenda-files) + (setq files (org-agenda-files 'unrestricted))) + ((and (symbolp files) (fboundp files)) + (setq files (funcall files))) + ((and (symbolp files) (boundp files)) + (setq files (symbol-value files)))) + (when (stringp files) (setq files (list files))) + (cond + ((eq (car desc) :tag) + (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":"))) + ((eq (car desc) :todo) + (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]"))) + ((eq (car desc) :regexp) + (setq descre (cdr desc))) + ((eq (car desc) :level) + (setq descre (concat "^\\*\\{" (number-to-string + (if org-odd-levels-only + (1- (* 2 (cdr desc))) + (cdr desc))) + "\\}[ \t]"))) + ((eq (car desc) :maxlevel) + (setq descre (concat "^\\*\\{1," (number-to-string + (if org-odd-levels-only + (1- (* 2 (cdr desc))) + (cdr desc))) + "\\}[ \t]"))) + (t (error "Bad refiling target description %s" desc))) + (dolist (f files) + (with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f)) + (or + (setq tgs (org-refile-cache-get (buffer-file-name) descre)) + (progn + (when (bufferp f) + (setq f (buffer-file-name (buffer-base-buffer f)))) + (setq f (and f (expand-file-name f))) + (when (eq org-refile-use-outline-path 'file) + (push (list (file-name-nondirectory f) f nil nil) tgs)) + (when (eq org-refile-use-outline-path 'buffer-name) + (push (list (buffer-name (buffer-base-buffer)) f nil nil) tgs)) + (when (eq org-refile-use-outline-path 'full-file-path) + (push (list (file-truename (buffer-file-name (buffer-base-buffer))) f nil nil) tgs)) + (org-with-wide-buffer + (goto-char (point-min)) + (setq org-outline-path-cache nil) + (while (re-search-forward descre nil t) + (beginning-of-line) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp)) + (let ((begin (point)) + (heading (match-string-no-properties 4))) + (unless (or (and + org-refile-target-verify-function + (not + (funcall org-refile-target-verify-function))) + (not heading)) + (let ((re (format org-complex-heading-regexp-format + (regexp-quote heading))) + (target + (if (not org-refile-use-outline-path) heading + (mapconcat + #'identity + (append + (pcase org-refile-use-outline-path + (`file (list (file-name-nondirectory + (buffer-file-name + (buffer-base-buffer))))) + (`full-file-path + (list (buffer-file-name + (buffer-base-buffer)))) + (`buffer-name + (list (buffer-name + (buffer-base-buffer)))) + (_ nil)) + (mapcar (lambda (s) (replace-regexp-in-string + "/" "\\/" s nil t)) + (org-get-outline-path t t))) + "/")))) + (push (list target f re (org-refile-marker (point))) + tgs))) + (when (= (point) begin) + ;; Verification function has not moved point. + (end-of-line))))))) + (when org-refile-use-cache + (org-refile-cache-put tgs (buffer-file-name) descre)) + (setq targets (append tgs targets)))))) + (message "Getting targets...done") + (delete-dups (nreverse targets)))) + +(defun org--get-outline-path-1 (&optional use-cache) + "Return outline path to current headline. + +Outline path is a list of strings, in reverse order. When +optional argument USE-CACHE is non-nil, make use of a cache. See +`org-get-outline-path' for details. + +Assume buffer is widened and point is on a headline." + (or (and use-cache (cdr (assq (point) org-outline-path-cache))) + (let ((p (point)) + (heading (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp) + (if (not (match-end 4)) "" + ;; Remove statistics cookies. + (org-trim + (org-link-display-format + (replace-regexp-in-string + "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" + (match-string-no-properties 4)))))))) + (if (org-up-heading-safe) + (let ((path (cons heading (org--get-outline-path-1 use-cache)))) + (when use-cache + (push (cons p path) org-outline-path-cache)) + path) + ;; This is a new root node. Since we assume we are moving + ;; forward, we can drop previous cache so as to limit number + ;; of associations there. + (let ((path (list heading))) + (when use-cache (setq org-outline-path-cache (list (cons p path)))) + path))))) + +(defun org-get-outline-path (&optional with-self use-cache) + "Return the outline path to the current entry. + +An outline path is a list of ancestors for current headline, as +a list of strings. Statistics cookies are removed and links are +replaced with their description, if any, or their path otherwise. + +When optional argument WITH-SELF is non-nil, the path also +includes the current headline. + +When optional argument USE-CACHE is non-nil, cache outline paths +between calls to this function so as to avoid backtracking. This +argument is useful when planning to find more than one outline +path in the same document. In that case, there are two +conditions to satisfy: + - `org-outline-path-cache' is set to nil before starting the + process; + - outline paths are computed by increasing buffer positions." + (org-with-wide-buffer + (and (or (and with-self (org-back-to-heading t)) + (org-up-heading-safe)) + (reverse (org--get-outline-path-1 use-cache))))) + +(defun org-format-outline-path (path &optional width prefix separator) + "Format the outline path PATH for display. +WIDTH is the maximum number of characters that is available. +PREFIX is a prefix to be included in the returned string, +such as the file name. +SEPARATOR is inserted between the different parts of the path, +the default is \"/\"." + (setq width (or width 79)) + (setq path (delq nil path)) + (unless (> width 0) + (user-error "Argument `width' must be positive")) + (setq separator (or separator "/")) + (let* ((org-odd-levels-only nil) + (fpath (concat + prefix (and prefix path separator) + (mapconcat + (lambda (s) (replace-regexp-in-string "[ \t]+\\'" "" s)) + (cl-loop for head in path + for n from 0 + collect (org-add-props + head nil 'face + (nth (% n org-n-level-faces) org-level-faces))) + separator)))) + (when (> (length fpath) width) + (if (< width 7) + ;; It's unlikely that `width' will be this small, but don't + ;; waste characters by adding ".." if it is. + (setq fpath (substring fpath 0 width)) + (setf (substring fpath (- width 2)) ".."))) + fpath)) + +(defun org-display-outline-path (&optional file current separator just-return-string) + "Display the current outline path in the echo area. + +If FILE is non-nil, prepend the output with the file name. +If CURRENT is non-nil, append the current heading to the output. +SEPARATOR is passed through to `org-format-outline-path'. It separates +the different parts of the path and defaults to \"/\". +If JUST-RETURN-STRING is non-nil, return a string, don't display a message." + (interactive "P") + (let* (case-fold-search + (bfn (buffer-file-name (buffer-base-buffer))) + (path (and (derived-mode-p 'org-mode) (org-get-outline-path))) + res) + (when current (setq path (append path + (save-excursion + (org-back-to-heading t) + (when (looking-at org-complex-heading-regexp) + (list (match-string 4))))))) + (setq res + (org-format-outline-path + path + (1- (frame-width)) + (and file bfn (concat (file-name-nondirectory bfn) separator)) + separator)) + (if just-return-string + (org-no-properties res) + (org-unlogged-message "%s" res)))) + +(defvar org-refile-history nil + "History for refiling operations.") + +(defvar org-after-refile-insert-hook nil + "Hook run after `org-refile' has inserted its stuff at the new location. +Note that this is still *before* the stuff will be removed from +the *old* location.") + +(defvar org-refile-keep nil + "Non-nil means `org-refile' will copy instead of refile.") + +;;;###autoload +(define-obsolete-function-alias 'org-copy 'org-refile-copy) +(defun org-refile-copy () + "Like `org-refile', but preserve the refiled subtree." + (interactive) + (let ((org-refile-keep t)) + (org-refile nil nil nil "Copy"))) + +(defvar org-capture-last-stored-marker) + +;;;###autoload +(defun org-refile (&optional arg default-buffer rfloc msg) + "Move the entry or entries at point to another heading. + +The list of target headings is compiled using the information in +`org-refile-targets', which see. + +At the target location, the entry is filed as a subitem of the +target heading. Depending on `org-reverse-note-order', the new +subitem will either be the first or the last subitem. + +If there is an active region, all entries in that region will be +refiled. However, the region must fulfill the requirement that +the first heading sets the top-level of the moved text. + +With a `\\[universal-argument]' ARG, the command will only visit the target \ +location +and not actually move anything. + +With a prefix `\\[universal-argument] \\[universal-argument]', go to the \ +location where the last +refiling operation has put the subtree. + +With a numeric prefix argument of `2', refile to the running clock. + +With a numeric prefix argument of `3', emulate `org-refile-keep' +being set to t and copy to the target location, don't move it. +Beware that keeping refiled entries may result in duplicated ID +properties. + +RFLOC can be a refile location obtained in a different way. + +MSG is a string to replace \"Refile\" in the default prompt with +another verb. E.g. `org-copy' sets this parameter to \"Copy\". + +See also `org-refile-use-outline-path'. + +If you are using target caching (see `org-refile-use-cache'), you +have to clear the target cache in order to find new targets. +This can be done with a `0' prefix (`C-0 C-c C-w') or a triple +prefix argument (`C-u C-u C-u C-c C-w')." + (interactive "P") + (if (member arg '(0 (64))) + (org-refile-cache-clear) + (let* ((actionmsg (cond (msg msg) + ((equal arg 3) "Refile (and keep)") + (t "Refile"))) + (regionp (org-region-active-p)) + (region-start (and regionp (region-beginning))) + (region-end (and regionp (region-end))) + (org-refile-keep (if (equal arg 3) t org-refile-keep)) + pos it nbuf file level reversed) + (setq last-command nil) + (when regionp + (goto-char region-start) + (beginning-of-line) + (setq region-start (point)) + (unless (or (org-kill-is-subtree-p + (buffer-substring region-start region-end)) + (prog1 org-refile-active-region-within-subtree + (let ((s (point-at-eol))) + (org-toggle-heading) + (setq region-end (+ (- (point-at-eol) s) region-end))))) + (user-error "The region is not a (sequence of) subtree(s)"))) + (if (equal arg '(16)) + (org-refile-goto-last-stored) + (when (or + (and (equal arg 2) + org-clock-hd-marker (marker-buffer org-clock-hd-marker) + (prog1 + (setq it (list (or org-clock-heading "running clock") + (buffer-file-name + (marker-buffer org-clock-hd-marker)) + "" + (marker-position org-clock-hd-marker))) + (setq arg nil))) + (setq it + (or rfloc + (let (heading-text) + (save-excursion + (unless (and arg (listp arg)) + (org-back-to-heading t) + (setq heading-text + (replace-regexp-in-string + org-link-bracket-re + "\\2" + (or (nth 4 (org-heading-components)) + "")))) + (org-refile-get-location + (cond ((and arg (listp arg)) "Goto") + (regionp (concat actionmsg " region to")) + (t (concat actionmsg " subtree \"" + heading-text "\" to"))) + default-buffer + (and (not (equal '(4) arg)) + org-refile-allow-creating-parent-nodes))))))) + (setq file (nth 1 it) + pos (nth 3 it)) + (when (and (not arg) + pos + (equal (buffer-file-name) file) + (if regionp + (and (>= pos region-start) + (<= pos region-end)) + (and (>= pos (point)) + (< pos (save-excursion + (org-end-of-subtree t t)))))) + (error "Cannot refile to position inside the tree or region")) + (setq nbuf (or (find-buffer-visiting file) + (find-file-noselect file))) + (if (and arg (not (equal arg 3))) + (progn + (pop-to-buffer-same-window nbuf) + (goto-char (cond (pos) + ((org-notes-order-reversed-p) (point-min)) + (t (point-max)))) + (org-show-context 'org-goto)) + (if regionp + (progn + (org-kill-new (buffer-substring region-start region-end)) + (org-save-markers-in-region region-start region-end)) + (org-copy-subtree 1 nil t)) + (with-current-buffer (setq nbuf (or (find-buffer-visiting file) + (find-file-noselect file))) + (setq reversed (org-notes-order-reversed-p)) + (org-with-wide-buffer + (if pos + (progn + (goto-char pos) + (setq level (org-get-valid-level (funcall outline-level) 1)) + (goto-char + (if reversed + (or (outline-next-heading) (point-max)) + (or (save-excursion (org-get-next-sibling)) + (org-end-of-subtree t t) + (point-max))))) + (setq level 1) + (if (not reversed) + (goto-char (point-max)) + (goto-char (point-min)) + (or (outline-next-heading) (goto-char (point-max))))) + (unless (bolp) (newline)) + (org-paste-subtree level nil nil t) + ;; Record information, according to `org-log-refile'. + ;; Do not prompt for a note when refiling multiple + ;; headlines, however. Simply add a time stamp. + (cond + ((not org-log-refile)) + (regionp + (org-map-region + (lambda () (org-add-log-setup 'refile nil nil 'time)) + (point) + (+ (point) (- region-end region-start)))) + (t + (org-add-log-setup 'refile nil nil org-log-refile))) + (and org-auto-align-tags + (let ((org-loop-over-headlines-in-active-region nil)) + (org-align-tags))) + (let ((bookmark-name (plist-get org-bookmark-names-plist + :last-refile))) + (when bookmark-name + (with-demoted-errors + (bookmark-set bookmark-name)))) + ;; If we are refiling for capture, make sure that the + ;; last-capture pointers point here + (when (bound-and-true-p org-capture-is-refiling) + (let ((bookmark-name (plist-get org-bookmark-names-plist + :last-capture-marker))) + (when bookmark-name + (with-demoted-errors + (bookmark-set bookmark-name)))) + (move-marker org-capture-last-stored-marker (point))) + (when (fboundp 'deactivate-mark) (deactivate-mark)) + (run-hooks 'org-after-refile-insert-hook))) + (unless org-refile-keep + (if regionp + (delete-region (point) (+ (point) (- region-end region-start))) + (org-preserve-local-variables + (delete-region + (and (org-back-to-heading t) (point)) + (min (1+ (buffer-size)) (org-end-of-subtree t t) (point)))))) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe)) + (setq org-markers-to-move nil) + (message "%s to \"%s\" in file %s: done" actionmsg + (car it) file))))))) + +(defun org-refile-goto-last-stored () + "Go to the location where the last refile was stored." + (interactive) + (bookmark-jump (plist-get org-bookmark-names-plist :last-refile)) + (message "This is the location of the last refile")) + +(defun org-refile--get-location (refloc tbl) + "When user refile to REFLOC, find the associated target in TBL. +Also check `org-refile-target-table'." + (car (delq + nil + (mapcar + (lambda (r) (or (assoc r tbl) + (assoc r org-refile-target-table))) + (list (replace-regexp-in-string "/$" "" refloc) + (replace-regexp-in-string "\\([^/]\\)$" "\\1/" refloc)))))) + +(defun org-refile-get-location (&optional prompt default-buffer new-nodes) + "Prompt the user for a refile location, using PROMPT. +PROMPT should not be suffixed with a colon and a space, because +this function appends the default value from +`org-refile-history' automatically, if that is not empty." + (let ((org-refile-targets org-refile-targets) + (org-refile-use-outline-path org-refile-use-outline-path)) + (setq org-refile-target-table (org-refile-get-targets default-buffer))) + (unless org-refile-target-table + (user-error "No refile targets")) + (let* ((cbuf (current-buffer)) + (cfn (buffer-file-name (buffer-base-buffer cbuf))) + (cfunc (if (and org-refile-use-outline-path + org-outline-path-complete-in-steps) + #'org-olpath-completing-read + #'completing-read)) + (extra (if org-refile-use-outline-path "/" "")) + (cbnex (concat (buffer-name) extra)) + (filename (and cfn (expand-file-name cfn))) + (tbl (mapcar + (lambda (x) + (if (and (not (member org-refile-use-outline-path + '(file full-file-path))) + (not (equal filename (nth 1 x)))) + (cons (concat (car x) extra " (" + (file-name-nondirectory (nth 1 x)) ")") + (cdr x)) + (cons (concat (car x) extra) (cdr x)))) + org-refile-target-table)) + (completion-ignore-case t) + cdef + (prompt (concat prompt + (or (and (car org-refile-history) + (concat " (default " (car org-refile-history) ")")) + (and (assoc cbnex tbl) (setq cdef cbnex) + (concat " (default " cbnex ")"))) ": ")) + pa answ parent-target child parent old-hist) + (setq old-hist org-refile-history) + (setq answ (funcall cfunc prompt tbl nil (not new-nodes) + nil 'org-refile-history (or cdef (car org-refile-history)))) + (if (setq pa (org-refile--get-location answ tbl)) + (progn + (org-refile-check-position pa) + (when (or (not org-refile-history) + (not (eq old-hist org-refile-history)) + (not (equal (car pa) (car org-refile-history)))) + (setq org-refile-history + (cons (car pa) (if (assoc (car org-refile-history) tbl) + org-refile-history + (cdr org-refile-history)))) + (when (equal (car org-refile-history) (nth 1 org-refile-history)) + (pop org-refile-history))) + pa) + (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ) + (progn + (setq parent (match-string 1 answ) + child (match-string 2 answ)) + (setq parent-target (org-refile--get-location parent tbl)) + (when (and parent-target + (or (eq new-nodes t) + (and (eq new-nodes 'confirm) + (y-or-n-p (format "Create new node \"%s\"? " + child))))) + (org-refile-new-child parent-target child))) + (user-error "Invalid target location"))))) + +(defun org-refile-check-position (refile-pointer) + "Check if the refile pointer matches the headline to which it points." + (let* ((file (nth 1 refile-pointer)) + (re (nth 2 refile-pointer)) + (pos (nth 3 refile-pointer)) + buffer) + (if (and (not (markerp pos)) (not file)) + (user-error "Please indicate a target file in the refile path") + (when (org-string-nw-p re) + (setq buffer (if (markerp pos) + (marker-buffer pos) + (or (find-buffer-visiting file) + (find-file-noselect file)))) + (with-current-buffer buffer + (org-with-wide-buffer + (goto-char pos) + (beginning-of-line 1) + (unless (looking-at-p re) + (user-error "Invalid refile position, please clear the cache with `C-0 C-c C-w' before refiling")))))))) + +(defun org-refile-new-child (parent-target child) + "Use refile target PARENT-TARGET to add new CHILD below it." + (unless parent-target + (error "Cannot find parent for new node")) + (let ((file (nth 1 parent-target)) + (pos (nth 3 parent-target)) + level) + (with-current-buffer (or (find-buffer-visiting file) + (find-file-noselect file)) + (org-with-wide-buffer + (if pos + (goto-char pos) + (goto-char (point-max)) + (unless (bolp) (newline))) + (when (looking-at org-outline-regexp) + (setq level (funcall outline-level)) + (org-end-of-subtree t t)) + (org-back-over-empty-lines) + (insert "\n" (make-string + (if pos (org-get-valid-level level 1) 1) ?*) + " " child "\n") + (beginning-of-line 0) + (list (concat (car parent-target) "/" child) file "" (point)))))) + +(defun org-olpath-completing-read (prompt collection &rest args) + "Read an outline path like a file name." + (let ((thetable collection)) + (apply #'completing-read + prompt + (lambda (string predicate &optional flag) + (cond + ((eq flag nil) (try-completion string thetable)) + ((eq flag t) + (let ((l (length string))) + (mapcar (lambda (x) + (let ((r (substring x l)) + (f (if (string-match " ([^)]*)$" x) + (match-string 0 x) + ""))) + (if (string-match "/" r) + (concat string (substring r 0 (match-end 0)) f) + x))) + (all-completions string thetable predicate)))) + ;; Exact match? + ((eq flag 'lambda) (assoc string thetable)))) + args))) + +(provide 'org-refile) +;;; org-refile.el ends here diff --git a/lisp/org.el b/lisp/org.el index 3ce5973..e38f743 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -1794,213 +1794,6 @@ Changing this requires a restart of Emacs to work correctly." :group 'org-link-follow :type 'integer) -(defgroup org-refile nil - "Options concerning refiling entries in Org mode." - :tag "Org Refile" - :group 'org) - -(defcustom org-directory "~/org" - "Directory with Org files. -This is just a default location to look for Org files. There is no need -at all to put your files into this directory. It is used in the -following situations: - -1. When a capture template specifies a target file that is not an - absolute path. The path will then be interpreted relative to - `org-directory' -2. When the value of variable `org-agenda-files' is a single file, any - relative paths in this file will be taken as relative to - `org-directory'." - :group 'org-refile - :group 'org-capture - :type 'directory) - -(defcustom org-default-notes-file (convert-standard-filename "~/.notes") - "Default target for storing notes. -Used as a fall back file for org-capture.el, for templates that -do not specify a target file." - :group 'org-refile - :group 'org-capture - :type 'file) - -(defcustom org-reverse-note-order nil - "Non-nil means store new notes at the beginning of a file or entry. -When nil, new notes will be filed to the end of a file or entry. -This can also be a list with cons cells of regular expressions that -are matched against file names, and values." - :group 'org-capture - :group 'org-refile - :type '(choice - (const :tag "Reverse always" t) - (const :tag "Reverse never" nil) - (repeat :tag "By file name regexp" - (cons regexp boolean)))) - -(defcustom org-log-refile nil - "Information to record when a task is refiled. - -Possible values are: - -nil Don't add anything -time Add a time stamp to the task -note Prompt for a note and add it with template `org-log-note-headings' - -This option can also be set with on a per-file-basis with - - #+STARTUP: nologrefile - #+STARTUP: logrefile - #+STARTUP: lognoterefile - -You can have local logging settings for a subtree by setting the LOGGING -property to one or more of these keywords. - -When bulk-refiling, e.g., from the agenda, the value `note' is -forbidden and will temporarily be changed to `time'." - :group 'org-refile - :group 'org-progress - :version "24.1" - :type '(choice - (const :tag "No logging" nil) - (const :tag "Record timestamp" time) - (const :tag "Record timestamp with note." note))) - -(defcustom org-refile-targets nil - "Targets for refiling entries with `\\[org-refile]'. -This is a list of cons cells. Each cell contains: -- a specification of the files to be considered, either a list of files, - or a symbol whose function or variable value will be used to retrieve - a file name or a list of file names. If you use `org-agenda-files' for - that, all agenda files will be scanned for targets. Nil means consider - headings in the current buffer. -- A specification of how to find candidate refile targets. This may be - any of: - - a cons cell (:tag . \"TAG\") to identify refile targets by a tag. - This tag has to be present in all target headlines, inheritance will - not be considered. - - a cons cell (:todo . \"KEYWORD\") to identify refile targets by - todo keyword. - - a cons cell (:regexp . \"REGEXP\") with a regular expression matching - headlines that are refiling targets. - - a cons cell (:level . N). Any headline of level N is considered a target. - Note that, when `org-odd-levels-only' is set, level corresponds to - order in hierarchy, not to the number of stars. - - a cons cell (:maxlevel . N). Any headline with level <= N is a target. - Note that, when `org-odd-levels-only' is set, level corresponds to - order in hierarchy, not to the number of stars. - -Each element of this list generates a set of possible targets. -The union of these sets is presented (with completion) to -the user by `org-refile'. - -You can set the variable `org-refile-target-verify-function' to a function -to verify each headline found by the simple criteria above. - -When this variable is nil, all top-level headlines in the current buffer -are used, equivalent to the value `((nil . (:level . 1))'." - :group 'org-refile - :type '(repeat - (cons - (choice :value org-agenda-files - (const :tag "All agenda files" org-agenda-files) - (const :tag "Current buffer" nil) - (function) (variable) (file)) - (choice :tag "Identify target headline by" - (cons :tag "Specific tag" (const :value :tag) (string)) - (cons :tag "TODO keyword" (const :value :todo) (string)) - (cons :tag "Regular expression" (const :value :regexp) (regexp)) - (cons :tag "Level number" (const :value :level) (integer)) - (cons :tag "Max Level number" (const :value :maxlevel) (integer)))))) - -(defcustom org-refile-target-verify-function nil - "Function to verify if the headline at point should be a refile target. -The function will be called without arguments, with point at the -beginning of the headline. It should return t and leave point -where it is if the headline is a valid target for refiling. - -If the target should not be selected, the function must return nil. -In addition to this, it may move point to a place from where the search -should be continued. For example, the function may decide that the entire -subtree of the current entry should be excluded and move point to the end -of the subtree." - :group 'org-refile - :type '(choice - (const nil) - (function))) - -(defcustom org-refile-use-cache nil - "Non-nil means cache refile targets to speed up the process. -\\<org-mode-map>\ -The cache for a particular file will be updated automatically when -the buffer has been killed, or when any of the marker used for flagging -refile targets no longer points at a live buffer. -If you have added new entries to a buffer that might themselves be targets, -you need to clear the cache manually by pressing `C-0 \\[org-refile]' or, -if you find that easier, \ -`\\[universal-argument] \\[universal-argument] \\[universal-argument] \ -\\[org-refile]'." - :group 'org-refile - :version "24.1" - :type 'boolean) - -(defcustom org-refile-use-outline-path nil - "Non-nil means provide refile targets as paths. -So a level 3 headline will be available as level1/level2/level3. - -When the value is `file', also include the file name (without directory) -into the path. In this case, you can also stop the completion after -the file name, to get entries inserted as top level in the file. - -When `full-file-path', include the full file path. - -When `buffer-name', use the buffer name." - :group 'org-refile - :type '(choice - (const :tag "Not" nil) - (const :tag "Yes" t) - (const :tag "Start with file name" file) - (const :tag "Start with full file path" full-file-path) - (const :tag "Start with buffer name" buffer-name))) - -(defcustom org-outline-path-complete-in-steps t - "Non-nil means complete the outline path in hierarchical steps. -When Org uses the refile interface to select an outline path (see -`org-refile-use-outline-path'), the completion of the path can be -done in a single go, or it can be done in steps down the headline -hierarchy. Going in steps is probably the best if you do not use -a special completion package like `ido' or `icicles'. However, -when using these packages, going in one step can be very fast, -while still showing the whole path to the entry." - :group 'org-refile - :type 'boolean) - -(defcustom org-refile-allow-creating-parent-nodes nil - "Non-nil means allow the creation of new nodes as refile targets. -New nodes are then created by adding \"/new node name\" to the completion -of an existing node. When the value of this variable is `confirm', -new node creation must be confirmed by the user (recommended). -When nil, the completion must match an existing entry. - -Note that, if the new heading is not seen by the criteria -listed in `org-refile-targets', multiple instances of the same -heading would be created by trying again to file under the new -heading." - :group 'org-refile - :type '(choice - (const :tag "Never" nil) - (const :tag "Always" t) - (const :tag "Prompt for confirmation" confirm))) - -(defcustom org-refile-active-region-within-subtree nil - "Non-nil means also refile active region within a subtree. - -By default `org-refile' doesn't allow refiling regions if they -don't contain a set of subtrees, but it might be convenient to -do so sometimes: in that case, the first line of the region is -converted to a headline before refiling." - :group 'org-refile - :version "24.1" - :type 'boolean) - (defgroup org-todo nil "Options concerning TODO items in Org mode." :tag "Org TODO" @@ -9007,639 +8800,10 @@ or to another Org file, automatically push the old position onto the ring." (when (string-match (car entry) buffer-file-name) (throw 'exit (cdr entry)))))))) -(defvar org-refile-target-table nil - "The list of refile targets, created by `org-refile'.") - (defvar org-agenda-new-buffers nil "Buffers created to visit agenda files.") -(defvar org-refile-cache nil - "Cache for refile targets.") - -(defvar org-refile-markers nil - "All the markers used for caching refile locations.") - -(defun org-refile-marker (pos) - "Get a new refile marker, but only if caching is in use." - (if (not org-refile-use-cache) - pos - (let ((m (make-marker))) - (move-marker m pos) - (push m org-refile-markers) - m))) - -(defun org-refile-cache-clear () - "Clear the refile cache and disable all the markers." - (dolist (m org-refile-markers) (move-marker m nil)) - (setq org-refile-markers nil) - (setq org-refile-cache nil) - (message "Refile cache has been cleared")) - -(defun org-refile-cache-check-set (set) - "Check if all the markers in the cache still have live buffers." - (let (marker) - (catch 'exit - (while (and set (setq marker (nth 3 (pop set)))) - ;; If `org-refile-use-outline-path' is 'file, marker may be nil - (when (and marker (null (marker-buffer marker))) - (message "Please regenerate the refile cache with `C-0 C-c C-w'") - (sit-for 3) - (throw 'exit nil))) - t))) - -(defun org-refile-cache-put (set &rest identifiers) - "Push the refile targets SET into the cache, under IDENTIFIERS." - (let* ((key (sha1 (prin1-to-string identifiers))) - (entry (assoc key org-refile-cache))) - (if entry - (setcdr entry set) - (push (cons key set) org-refile-cache)))) - -(defun org-refile-cache-get (&rest identifiers) - "Retrieve the cached value for refile targets given by IDENTIFIERS." - (cond - ((not org-refile-cache) nil) - ((not org-refile-use-cache) (org-refile-cache-clear) nil) - (t - (let ((set (cdr (assoc (sha1 (prin1-to-string identifiers)) - org-refile-cache)))) - (and set (org-refile-cache-check-set set) set))))) - -(defvar org-outline-path-cache nil - "Alist between buffer positions and outline paths. -It value is an alist (POSITION . PATH) where POSITION is the -buffer position at the beginning of an entry and PATH is a list -of strings describing the outline path for that entry, in reverse -order.") - -(defun org-refile-get-targets (&optional default-buffer) - "Produce a table with refile targets." - (let ((case-fold-search nil) - ;; otherwise org confuses "TODO" as a kw and "Todo" as a word - (entries (or org-refile-targets '((nil . (:level . 1))))) - targets tgs files desc descre) - (message "Getting targets...") - (with-current-buffer (or default-buffer (current-buffer)) - (dolist (entry entries) - (setq files (car entry) desc (cdr entry)) - (cond - ((null files) (setq files (list (current-buffer)))) - ((eq files 'org-agenda-files) - (setq files (org-agenda-files 'unrestricted))) - ((and (symbolp files) (fboundp files)) - (setq files (funcall files))) - ((and (symbolp files) (boundp files)) - (setq files (symbol-value files)))) - (when (stringp files) (setq files (list files))) - (cond - ((eq (car desc) :tag) - (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":"))) - ((eq (car desc) :todo) - (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]"))) - ((eq (car desc) :regexp) - (setq descre (cdr desc))) - ((eq (car desc) :level) - (setq descre (concat "^\\*\\{" (number-to-string - (if org-odd-levels-only - (1- (* 2 (cdr desc))) - (cdr desc))) - "\\}[ \t]"))) - ((eq (car desc) :maxlevel) - (setq descre (concat "^\\*\\{1," (number-to-string - (if org-odd-levels-only - (1- (* 2 (cdr desc))) - (cdr desc))) - "\\}[ \t]"))) - (t (error "Bad refiling target description %s" desc))) - (dolist (f files) - (with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f)) - (or - (setq tgs (org-refile-cache-get (buffer-file-name) descre)) - (progn - (when (bufferp f) - (setq f (buffer-file-name (buffer-base-buffer f)))) - (setq f (and f (expand-file-name f))) - (when (eq org-refile-use-outline-path 'file) - (push (list (file-name-nondirectory f) f nil nil) tgs)) - (when (eq org-refile-use-outline-path 'buffer-name) - (push (list (buffer-name (buffer-base-buffer)) f nil nil) tgs)) - (when (eq org-refile-use-outline-path 'full-file-path) - (push (list (file-truename (buffer-file-name (buffer-base-buffer))) f nil nil) tgs)) - (org-with-wide-buffer - (goto-char (point-min)) - (setq org-outline-path-cache nil) - (while (re-search-forward descre nil t) - (beginning-of-line) - (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp)) - (let ((begin (point)) - (heading (match-string-no-properties 4))) - (unless (or (and - org-refile-target-verify-function - (not - (funcall org-refile-target-verify-function))) - (not heading)) - (let ((re (format org-complex-heading-regexp-format - (regexp-quote heading))) - (target - (if (not org-refile-use-outline-path) heading - (mapconcat - #'identity - (append - (pcase org-refile-use-outline-path - (`file (list (file-name-nondirectory - (buffer-file-name - (buffer-base-buffer))))) - (`full-file-path - (list (buffer-file-name - (buffer-base-buffer)))) - (`buffer-name - (list (buffer-name - (buffer-base-buffer)))) - (_ nil)) - (mapcar (lambda (s) (replace-regexp-in-string - "/" "\\/" s nil t)) - (org-get-outline-path t t))) - "/")))) - (push (list target f re (org-refile-marker (point))) - tgs))) - (when (= (point) begin) - ;; Verification function has not moved point. - (end-of-line))))))) - (when org-refile-use-cache - (org-refile-cache-put tgs (buffer-file-name) descre)) - (setq targets (append tgs targets)))))) - (message "Getting targets...done") - (delete-dups (nreverse targets)))) - -(defun org--get-outline-path-1 (&optional use-cache) - "Return outline path to current headline. - -Outline path is a list of strings, in reverse order. When -optional argument USE-CACHE is non-nil, make use of a cache. See -`org-get-outline-path' for details. - -Assume buffer is widened and point is on a headline." - (or (and use-cache (cdr (assq (point) org-outline-path-cache))) - (let ((p (point)) - (heading (let ((case-fold-search nil)) - (looking-at org-complex-heading-regexp) - (if (not (match-end 4)) "" - ;; Remove statistics cookies. - (org-trim - (org-link-display-format - (replace-regexp-in-string - "\\[[0-9]+%\\]\\|\\[[0-9]+/[0-9]+\\]" "" - (match-string-no-properties 4)))))))) - (if (org-up-heading-safe) - (let ((path (cons heading (org--get-outline-path-1 use-cache)))) - (when use-cache - (push (cons p path) org-outline-path-cache)) - path) - ;; This is a new root node. Since we assume we are moving - ;; forward, we can drop previous cache so as to limit number - ;; of associations there. - (let ((path (list heading))) - (when use-cache (setq org-outline-path-cache (list (cons p path)))) - path))))) - -(defun org-get-outline-path (&optional with-self use-cache) - "Return the outline path to the current entry. - -An outline path is a list of ancestors for current headline, as -a list of strings. Statistics cookies are removed and links are -replaced with their description, if any, or their path otherwise. - -When optional argument WITH-SELF is non-nil, the path also -includes the current headline. - -When optional argument USE-CACHE is non-nil, cache outline paths -between calls to this function so as to avoid backtracking. This -argument is useful when planning to find more than one outline -path in the same document. In that case, there are two -conditions to satisfy: - - `org-outline-path-cache' is set to nil before starting the - process; - - outline paths are computed by increasing buffer positions." - (org-with-wide-buffer - (and (or (and with-self (org-back-to-heading t)) - (org-up-heading-safe)) - (reverse (org--get-outline-path-1 use-cache))))) - -(defun org-format-outline-path (path &optional width prefix separator) - "Format the outline path PATH for display. -WIDTH is the maximum number of characters that is available. -PREFIX is a prefix to be included in the returned string, -such as the file name. -SEPARATOR is inserted between the different parts of the path, -the default is \"/\"." - (setq width (or width 79)) - (setq path (delq nil path)) - (unless (> width 0) - (user-error "Argument `width' must be positive")) - (setq separator (or separator "/")) - (let* ((org-odd-levels-only nil) - (fpath (concat - prefix (and prefix path separator) - (mapconcat - (lambda (s) (replace-regexp-in-string "[ \t]+\\'" "" s)) - (cl-loop for head in path - for n from 0 - collect (org-add-props - head nil 'face - (nth (% n org-n-level-faces) org-level-faces))) - separator)))) - (when (> (length fpath) width) - (if (< width 7) - ;; It's unlikely that `width' will be this small, but don't - ;; waste characters by adding ".." if it is. - (setq fpath (substring fpath 0 width)) - (setf (substring fpath (- width 2)) ".."))) - fpath)) - -(defun org-display-outline-path (&optional file current separator just-return-string) - "Display the current outline path in the echo area. - -If FILE is non-nil, prepend the output with the file name. -If CURRENT is non-nil, append the current heading to the output. -SEPARATOR is passed through to `org-format-outline-path'. It separates -the different parts of the path and defaults to \"/\". -If JUST-RETURN-STRING is non-nil, return a string, don't display a message." - (interactive "P") - (let* (case-fold-search - (bfn (buffer-file-name (buffer-base-buffer))) - (path (and (derived-mode-p 'org-mode) (org-get-outline-path))) - res) - (when current (setq path (append path - (save-excursion - (org-back-to-heading t) - (when (looking-at org-complex-heading-regexp) - (list (match-string 4))))))) - (setq res - (org-format-outline-path - path - (1- (frame-width)) - (and file bfn (concat (file-name-nondirectory bfn) separator)) - separator)) - (if just-return-string - (org-no-properties res) - (org-unlogged-message "%s" res)))) - -(defvar org-refile-history nil - "History for refiling operations.") - -(defvar org-after-refile-insert-hook nil - "Hook run after `org-refile' has inserted its stuff at the new location. -Note that this is still *before* the stuff will be removed from -the *old* location.") - -(defvar org-capture-last-stored-marker) -(defvar org-refile-keep nil - "Non-nil means `org-refile' will copy instead of refile.") - -(defun org-copy () - "Like `org-refile', but copy." - (interactive) - (let ((org-refile-keep t)) - (org-refile nil nil nil "Copy"))) - -(defun org-refile (&optional arg default-buffer rfloc msg) - "Move the entry or entries at point to another heading. - -The list of target headings is compiled using the information in -`org-refile-targets', which see. - -At the target location, the entry is filed as a subitem of the -target heading. Depending on `org-reverse-note-order', the new -subitem will either be the first or the last subitem. - -If there is an active region, all entries in that region will be -refiled. However, the region must fulfill the requirement that -the first heading sets the top-level of the moved text. - -With a `\\[universal-argument]' ARG, the command will only visit the target \ -location -and not actually move anything. - -With a prefix `\\[universal-argument] \\[universal-argument]', go to the \ -location where the last -refiling operation has put the subtree. - -With a numeric prefix argument of `2', refile to the running clock. - -With a numeric prefix argument of `3', emulate `org-refile-keep' -being set to t and copy to the target location, don't move it. -Beware that keeping refiled entries may result in duplicated ID -properties. - -RFLOC can be a refile location obtained in a different way. - -MSG is a string to replace \"Refile\" in the default prompt with -another verb. E.g. `org-copy' sets this parameter to \"Copy\". - -See also `org-refile-use-outline-path'. - -If you are using target caching (see `org-refile-use-cache'), you -have to clear the target cache in order to find new targets. -This can be done with a `0' prefix (`C-0 C-c C-w') or a triple -prefix argument (`C-u C-u C-u C-c C-w')." - (interactive "P") - (if (member arg '(0 (64))) - (org-refile-cache-clear) - (let* ((actionmsg (cond (msg msg) - ((equal arg 3) "Refile (and keep)") - (t "Refile"))) - (regionp (org-region-active-p)) - (region-start (and regionp (region-beginning))) - (region-end (and regionp (region-end))) - (org-refile-keep (if (equal arg 3) t org-refile-keep)) - pos it nbuf file level reversed) - (setq last-command nil) - (when regionp - (goto-char region-start) - (beginning-of-line) - (setq region-start (point)) - (unless (or (org-kill-is-subtree-p - (buffer-substring region-start region-end)) - (prog1 org-refile-active-region-within-subtree - (let ((s (point-at-eol))) - (org-toggle-heading) - (setq region-end (+ (- (point-at-eol) s) region-end))))) - (user-error "The region is not a (sequence of) subtree(s)"))) - (if (equal arg '(16)) - (org-refile-goto-last-stored) - (when (or - (and (equal arg 2) - org-clock-hd-marker (marker-buffer org-clock-hd-marker) - (prog1 - (setq it (list (or org-clock-heading "running clock") - (buffer-file-name - (marker-buffer org-clock-hd-marker)) - "" - (marker-position org-clock-hd-marker))) - (setq arg nil))) - (setq it - (or rfloc - (let (heading-text) - (save-excursion - (unless (and arg (listp arg)) - (org-back-to-heading t) - (setq heading-text - (replace-regexp-in-string - org-link-bracket-re - "\\2" - (or (nth 4 (org-heading-components)) - "")))) - (org-refile-get-location - (cond ((and arg (listp arg)) "Goto") - (regionp (concat actionmsg " region to")) - (t (concat actionmsg " subtree \"" - heading-text "\" to"))) - default-buffer - (and (not (equal '(4) arg)) - org-refile-allow-creating-parent-nodes))))))) - (setq file (nth 1 it) - pos (nth 3 it)) - (when (and (not arg) - pos - (equal (buffer-file-name) file) - (if regionp - (and (>= pos region-start) - (<= pos region-end)) - (and (>= pos (point)) - (< pos (save-excursion - (org-end-of-subtree t t)))))) - (error "Cannot refile to position inside the tree or region")) - (setq nbuf (or (find-buffer-visiting file) - (find-file-noselect file))) - (if (and arg (not (equal arg 3))) - (progn - (pop-to-buffer-same-window nbuf) - (goto-char (cond (pos) - ((org-notes-order-reversed-p) (point-min)) - (t (point-max)))) - (org-show-context 'org-goto)) - (if regionp - (progn - (org-kill-new (buffer-substring region-start region-end)) - (org-save-markers-in-region region-start region-end)) - (org-copy-subtree 1 nil t)) - (with-current-buffer (setq nbuf (or (find-buffer-visiting file) - (find-file-noselect file))) - (setq reversed (org-notes-order-reversed-p)) - (org-with-wide-buffer - (if pos - (progn - (goto-char pos) - (setq level (org-get-valid-level (funcall outline-level) 1)) - (goto-char - (if reversed - (or (outline-next-heading) (point-max)) - (or (save-excursion (org-get-next-sibling)) - (org-end-of-subtree t t) - (point-max))))) - (setq level 1) - (if (not reversed) - (goto-char (point-max)) - (goto-char (point-min)) - (or (outline-next-heading) (goto-char (point-max))))) - (unless (bolp) (newline)) - (org-paste-subtree level nil nil t) - ;; Record information, according to `org-log-refile'. - ;; Do not prompt for a note when refiling multiple - ;; headlines, however. Simply add a time stamp. - (cond - ((not org-log-refile)) - (regionp - (org-map-region - (lambda () (org-add-log-setup 'refile nil nil 'time)) - (point) - (+ (point) (- region-end region-start)))) - (t - (org-add-log-setup 'refile nil nil org-log-refile))) - (and org-auto-align-tags - (let ((org-loop-over-headlines-in-active-region nil)) - (org-align-tags))) - (let ((bookmark-name (plist-get org-bookmark-names-plist - :last-refile))) - (when bookmark-name - (with-demoted-errors - (bookmark-set bookmark-name)))) - ;; If we are refiling for capture, make sure that the - ;; last-capture pointers point here - (when (bound-and-true-p org-capture-is-refiling) - (let ((bookmark-name (plist-get org-bookmark-names-plist - :last-capture-marker))) - (when bookmark-name - (with-demoted-errors - (bookmark-set bookmark-name)))) - (move-marker org-capture-last-stored-marker (point))) - (when (fboundp 'deactivate-mark) (deactivate-mark)) - (run-hooks 'org-after-refile-insert-hook))) - (unless org-refile-keep - (if regionp - (delete-region (point) (+ (point) (- region-end region-start))) - (org-preserve-local-variables - (delete-region - (and (org-back-to-heading t) (point)) - (min (1+ (buffer-size)) (org-end-of-subtree t t) (point)))))) - (when (featurep 'org-inlinetask) - (org-inlinetask-remove-END-maybe)) - (setq org-markers-to-move nil) - (message "%s to \"%s\" in file %s: done" actionmsg - (car it) file))))))) - -(defun org-refile-goto-last-stored () - "Go to the location where the last refile was stored." - (interactive) - (bookmark-jump (plist-get org-bookmark-names-plist :last-refile)) - (message "This is the location of the last refile")) - -(defun org-refile--get-location (refloc tbl) - "When user refile to REFLOC, find the associated target in TBL. -Also check `org-refile-target-table'." - (car (delq - nil - (mapcar - (lambda (r) (or (assoc r tbl) - (assoc r org-refile-target-table))) - (list (replace-regexp-in-string "/$" "" refloc) - (replace-regexp-in-string "\\([^/]\\)$" "\\1/" refloc)))))) - -(defun org-refile-get-location (&optional prompt default-buffer new-nodes) - "Prompt the user for a refile location, using PROMPT. -PROMPT should not be suffixed with a colon and a space, because -this function appends the default value from -`org-refile-history' automatically, if that is not empty." - (let ((org-refile-targets org-refile-targets) - (org-refile-use-outline-path org-refile-use-outline-path)) - (setq org-refile-target-table (org-refile-get-targets default-buffer))) - (unless org-refile-target-table - (user-error "No refile targets")) - (let* ((cbuf (current-buffer)) - (cfn (buffer-file-name (buffer-base-buffer cbuf))) - (cfunc (if (and org-refile-use-outline-path - org-outline-path-complete-in-steps) - #'org-olpath-completing-read - #'completing-read)) - (extra (if org-refile-use-outline-path "/" "")) - (cbnex (concat (buffer-name) extra)) - (filename (and cfn (expand-file-name cfn))) - (tbl (mapcar - (lambda (x) - (if (and (not (member org-refile-use-outline-path - '(file full-file-path))) - (not (equal filename (nth 1 x)))) - (cons (concat (car x) extra " (" - (file-name-nondirectory (nth 1 x)) ")") - (cdr x)) - (cons (concat (car x) extra) (cdr x)))) - org-refile-target-table)) - (completion-ignore-case t) - cdef - (prompt (concat prompt - (or (and (car org-refile-history) - (concat " (default " (car org-refile-history) ")")) - (and (assoc cbnex tbl) (setq cdef cbnex) - (concat " (default " cbnex ")"))) ": ")) - pa answ parent-target child parent old-hist) - (setq old-hist org-refile-history) - (setq answ (funcall cfunc prompt tbl nil (not new-nodes) - nil 'org-refile-history (or cdef (car org-refile-history)))) - (if (setq pa (org-refile--get-location answ tbl)) - (progn - (org-refile-check-position pa) - (when (or (not org-refile-history) - (not (eq old-hist org-refile-history)) - (not (equal (car pa) (car org-refile-history)))) - (setq org-refile-history - (cons (car pa) (if (assoc (car org-refile-history) tbl) - org-refile-history - (cdr org-refile-history)))) - (when (equal (car org-refile-history) (nth 1 org-refile-history)) - (pop org-refile-history))) - pa) - (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ) - (progn - (setq parent (match-string 1 answ) - child (match-string 2 answ)) - (setq parent-target (org-refile--get-location parent tbl)) - (when (and parent-target - (or (eq new-nodes t) - (and (eq new-nodes 'confirm) - (y-or-n-p (format "Create new node \"%s\"? " - child))))) - (org-refile-new-child parent-target child))) - (user-error "Invalid target location"))))) - (declare-function org-string-nw-p "org-macs" (s)) -(defun org-refile-check-position (refile-pointer) - "Check if the refile pointer matches the headline to which it points." - (let* ((file (nth 1 refile-pointer)) - (re (nth 2 refile-pointer)) - (pos (nth 3 refile-pointer)) - buffer) - (if (and (not (markerp pos)) (not file)) - (user-error "Please indicate a target file in the refile path") - (when (org-string-nw-p re) - (setq buffer (if (markerp pos) - (marker-buffer pos) - (or (find-buffer-visiting file) - (find-file-noselect file)))) - (with-current-buffer buffer - (org-with-wide-buffer - (goto-char pos) - (beginning-of-line 1) - (unless (looking-at-p re) - (user-error "Invalid refile position, please clear the cache with `C-0 C-c C-w' before refiling")))))))) - -(defun org-refile-new-child (parent-target child) - "Use refile target PARENT-TARGET to add new CHILD below it." - (unless parent-target - (error "Cannot find parent for new node")) - (let ((file (nth 1 parent-target)) - (pos (nth 3 parent-target)) - level) - (with-current-buffer (or (find-buffer-visiting file) - (find-file-noselect file)) - (org-with-wide-buffer - (if pos - (goto-char pos) - (goto-char (point-max)) - (unless (bolp) (newline))) - (when (looking-at org-outline-regexp) - (setq level (funcall outline-level)) - (org-end-of-subtree t t)) - (org-back-over-empty-lines) - (insert "\n" (make-string - (if pos (org-get-valid-level level 1) 1) ?*) - " " child "\n") - (beginning-of-line 0) - (list (concat (car parent-target) "/" child) file "" (point)))))) - -(defun org-olpath-completing-read (prompt collection &rest args) - "Read an outline path like a file name." - (let ((thetable collection)) - (apply #'completing-read - prompt - (lambda (string predicate &optional flag) - (cond - ((eq flag nil) (try-completion string thetable)) - ((eq flag t) - (let ((l (length string))) - (mapcar (lambda (x) - (let ((r (substring x l)) - (f (if (string-match " ([^)]*)$" x) - (match-string 0 x) - ""))) - (if (string-match "/" r) - (concat string (substring r 0 (match-end 0)) f) - x))) - (all-completions string thetable predicate)))) - ;; Exact match? - ((eq flag 'lambda) (assoc string thetable)))) - args))) - ;;;; Dynamic blocks (defun org-find-dblock (name) @@ -18496,8 +17660,10 @@ an argument, unconditionally call `org-insert-heading'." "--" ["Jump" org-goto t]) ("Edit Structure" - ["Refile Subtree" org-refile (org-in-subtree-not-table-p)] - "--" + ,@(when (featurep 'org-refile) + '(["Refile Subtree" org-refile (org-in-subtree-not-table-p)] + ["Refile and copy Subtree" org-copy (org-in-subtree-not-table-p)] + "--")) ["Move Subtree Up" org-metaup (org-at-heading-p)] ["Move Subtree Down" org-metadown (org-at-heading-p)] "--" |