diff options
Diffstat (limited to 'lisp/org/org-id.el')
| -rw-r--r-- | lisp/org/org-id.el | 188 |
1 files changed, 105 insertions, 83 deletions
diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 7f7faaae8e8..653baf9b73d 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -71,8 +71,11 @@ ;;; Code: (require 'org) +(require 'ol) (declare-function message-make-fqdn "message" ()) +(declare-function org-goto-location "org-goto" (&optional _buf help)) +(declare-function org-link-set-parameters "ol" (type &rest rest)) ;;; Customization @@ -139,11 +142,15 @@ org Org's own internal method, using an encoding of the current time to uuid Create random (version 4) UUIDs. If the program defined in `org-id-uuid-program' is available it is used to create the ID. - Otherwise an internal functions is used." + Otherwise an internal functions is used. + +ts Create ID's based on ISO8601 timestamps (without separators + and without timezone, local time). Precision down to seconds." :group 'org-id :type '(choice (const :tag "Org's internal method" org) - (const :tag "external: uuidgen" uuid))) + (const :tag "external: uuidgen" uuid) + (const :tag "ISO8601 timestamp" ts))) (defcustom org-id-prefix nil "The prefix for IDs. @@ -160,7 +167,7 @@ to have no space characters in them." "Non-nil means add the domain name to new IDs. This ensures global uniqueness of IDs, and is also suggested by the relevant RFCs. This is relevant only if `org-id-method' is -`org'. When uuidgen is used, the domain will never be added. +`org' or `ts'. When uuidgen is used, the domain will never be added. The default is to not use this because we have no really good way to get the true domain, and Org entries will normally not be shared with enough @@ -188,6 +195,22 @@ This variable is only relevant when `org-id-track-globally' is set." :group 'org-id :type 'file) +(defcustom org-id-locations-file-relative nil + "Determines if org-id-locations should be stored as relative links. +Non-nil means that links to locations are stored as links +relative to the location of where `org-id-locations-file' is +stored. + +Nil means to store absolute paths to files. + +This customization is useful when folders are shared across +systems but mounted at different roots. Relative path to +`org-id-locations-file' still has to be maintained across +systems." + :group 'org-id + :type 'boolean + :package-version '(Org . "9.3")) + (defvar org-id-locations nil "List of files with IDs in those files.") @@ -275,9 +298,9 @@ If necessary, the ID is created." ;;;###autoload (defun org-id-get-with-outline-drilling () "Use an outline-cycling interface to retrieve the ID of an entry. -This only finds entries in the current buffer, using `org-get-location'. +This only finds entries in the current buffer, using `org-goto-location'. It returns the ID of the entry. If necessary, the ID is created." - (let* ((spos (org-get-location (current-buffer) org-goto-help)) + (let* ((spos (org-goto-location)) (pom (and spos (move-marker (make-marker) (car spos))))) (prog1 (org-id-get pom 'create) (move-marker pom nil)))) @@ -349,6 +372,13 @@ So a typical ID could look like \"Org:4nd91V40HI\"." (require 'message) (concat "@" (message-make-fqdn)))))) (setq unique (concat etime postfix)))) + ((eq org-id-method 'ts) + (let ((ts (format-time-string "%Y%m%dT%H%M%S.%6N")) + (postfix (if org-id-include-domain + (progn + (require 'message) + (concat "@" (message-make-fqdn)))))) + (setq unique (concat ts postfix)))) (t (error "Invalid `org-id-method'"))) (concat prefix unique))) @@ -356,7 +386,7 @@ So a typical ID could look like \"Org:4nd91V40HI\"." "Return string with random (version 4) UUID." (let ((rnd (md5 (format "%s%s%s%s%s%s%s" (random) - (time-convert nil 'list) + (org-time-convert-to-list nil) (user-uid) (emacs-pid) (user-full-name) @@ -418,7 +448,7 @@ using `org-id-decode'." ;; FIXME: If TIME represents N seconds after the epoch, then ;; this encoding assumes 0 <= N < 110075314176 = (* (expt 36 4) 65536), ;; i.e., that TIME is from 1970-01-01 00:00:00 to 5458-02-23 20:09:36 UTC. - (setq time (time-convert time 'list)) + (setq time (org-time-convert-to-list nil)) (concat (org-id-int-to-b36 (nth 0 time) 4) (org-id-int-to-b36 (nth 1 time) 4) (org-id-int-to-b36 (nth 2 time) 4))) @@ -446,81 +476,56 @@ and TIME is a Lisp time value (HI LO USEC)." Store the relation between files and corresponding IDs. This will scan all agenda files, all associated archives, and all files currently mentioned in `org-id-locations'. -When FILES is given, scan these files instead." +When FILES is given, scan also these files." (interactive) (if (not org-id-track-globally) (error "Please turn on `org-id-track-globally' if you want to track IDs") - (let* ((org-id-search-archives - (or org-id-search-archives - (and (symbolp org-id-extra-files) - (symbol-value org-id-extra-files) - (member 'agenda-archives org-id-extra-files)))) - (files - (or files - (append - ;; Agenda files and all associated archives - (org-agenda-files t org-id-search-archives) - ;; Explicit extra files - (if (symbolp org-id-extra-files) - (symbol-value org-id-extra-files) - org-id-extra-files) - ;; Files associated with live Org buffers - (delq nil - (mapcar (lambda (b) - (with-current-buffer b - (and (derived-mode-p 'org-mode) (buffer-file-name)))) - (buffer-list))) - ;; All files known to have IDs - org-id-files))) - org-agenda-new-buffers - file nfiles tfile ids reg found id seen (ndup 0)) - (when (member 'agenda-archives files) - (setq files (delq 'agenda-archives (copy-sequence files)))) - (setq nfiles (length files)) - (while (setq file (pop files)) - (unless silent - (message "Finding ID locations (%d/%d files): %s" - (- nfiles (length files)) nfiles file)) - (setq tfile (file-truename file)) - (when (and (file-exists-p file) (not (member tfile seen))) - (push tfile seen) - (setq ids nil) - (with-current-buffer (org-get-agenda-file-buffer file) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "^[ \t]*:ID:[ \t]+\\(\\S-+\\)[ \t]*$" - nil t) - (setq id (match-string-no-properties 1)) - (if (member id found) - (progn - (message "Duplicate ID \"%s\", also in file %s" - id (or (car (delq - nil - (mapcar - (lambda (x) - (if (member id (cdr x)) - (car x))) - reg))) - (buffer-file-name))) - (when (= ndup 0) - (ding) - (sit-for 2)) - (setq ndup (1+ ndup))) - (push id found) - (push id ids))) - (push (cons (abbreviate-file-name file) ids) reg)))))) - (org-release-buffers org-agenda-new-buffers) - (setq org-agenda-new-buffers nil) - (setq org-id-locations reg) + (let* ((files (delete-dups + (mapcar #'file-truename + (append + ;; Agenda files and all associated archives + (org-agenda-files t org-id-search-archives) + ;; Explicit extra files + (unless (symbolp org-id-extra-files) + org-id-extra-files) + ;; All files known to have IDs + org-id-files + ;; function input + files)))) + (nfiles (length files)) + ids seen-ids (ndup 0) (i 0) file-id-alist) + (with-temp-buffer + (delay-mode-hooks + (org-mode) + (dolist (file files) + (unless silent + (setq i (1+ i)) + (message "Finding ID locations (%d/%d files): %s" + i nfiles file)) + (when (file-exists-p file) + (insert-file-contents file nil nil nil 'replace) + (setq ids (org-map-entries + (lambda () + (org-entry-get (point) "ID")) + "ID<>\"\"")) + (dolist (id ids) + (if (member id seen-ids) + (progn + (message "Duplicate ID \"%s\"" id) + (setq ndup (1+ ndup))) + (push id seen-ids))) + (when ids + (setq file-id-alist (cons (cons (abbreviate-file-name file) ids) + file-id-alist))))))) + (setq org-id-locations file-id-alist) (setq org-id-files (mapcar 'car org-id-locations)) - (org-id-locations-save) ;; this function can also handle the alist form + (org-id-locations-save) ;; now convert to a hash (setq org-id-locations (org-id-alist-to-hash org-id-locations)) - (if (> ndup 0) - (message "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup) - (message "%d unique files scanned for IDs" (length org-id-files))) + (when (> ndup 0) + (warn "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup)) + (message "%d files scanned, %d files contains IDs and in total %d IDs found." + nfiles (length org-id-files) (hash-table-count org-id-locations)) org-id-locations))) (defun org-id-locations-save () @@ -529,6 +534,16 @@ When FILES is given, scan these files instead." (let ((out (if (hash-table-p org-id-locations) (org-id-hash-to-alist org-id-locations) org-id-locations))) + (when (and org-id-locations-file-relative out) + (setq out (mapcar + (lambda (item) + (if (file-name-absolute-p (car item)) + (cons (file-relative-name + (car item) (file-name-directory + org-id-locations-file)) + (cdr item)) + item)) + out))) (with-temp-file org-id-locations-file (let ((print-level nil) (print-length nil)) @@ -542,7 +557,12 @@ When FILES is given, scan these files instead." (condition-case nil (progn (insert-file-contents org-id-locations-file) - (setq org-id-locations (read (current-buffer)))) + (setq org-id-locations (read (current-buffer))) + (let ((loc (file-name-directory org-id-locations-file))) + (mapc (lambda (item) + (unless (file-name-absolute-p (car item)) + (setf (car item) (expand-file-name (car item) loc)))) + org-id-locations))) (error (message "Could not read org-id-values from %s. Setting it to nil." org-id-locations-file)))) @@ -552,10 +572,12 @@ When FILES is given, scan these files instead." (defun org-id-add-location (id file) "Add the ID with location FILE to the database of ID locations." ;; Only if global tracking is on, and when the buffer has a file - (when (and org-id-track-globally id file) - (unless org-id-locations (org-id-locations-load)) - (puthash id (abbreviate-file-name file) org-id-locations) - (add-to-list 'org-id-files (abbreviate-file-name file)))) + (let ((afile (abbreviate-file-name file))) + (when (and org-id-track-globally id file) + (unless org-id-locations (org-id-locations-load)) + (puthash id afile org-id-locations) + (unless (member afile org-id-files) + (add-to-list 'org-id-files afile))))) (unless noninteractive (add-hook 'kill-emacs-hook 'org-id-locations-save)) @@ -565,7 +587,7 @@ When FILES is given, scan these files instead." (let (res x) (maphash (lambda (k v) - (if (setq x (member v res)) + (if (setq x (assoc v res)) (setcdr x (cons k (cdr x))) (push (list v k) res))) hash) @@ -649,7 +671,7 @@ optional argument MARKERP, return the position as a new marker." (match-string 4) (match-string 0))) link)))) - (org-store-link-props :link link :description desc :type "id") + (org-link-store-props :link link :description desc :type "id") link))) (defun org-id-open (id) |