contrib/lisp/org-id.el

   1 ;;; org-id.el --- Global identifier for Org-mode entries
   2 ;; Copyright (C) 2008 Free Software Foundation, Inc.
   3 ;;
   4 ;; Author: Carsten Dominik <carsten at orgmode dot org>
   5 ;; Keywords: outlines, hypermedia, calendar, wp
   6 ;; Homepage: http://orgmode.org
   7 ;; Version: 0.02
   8 ;;
   9 ;; This file is not yet part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;;; Commentary:
  28
  29 ;; This file implements globally unique identifiers for Org-mode entries.
  30 ;; Identifiers are stored in the entry as an :ID: property.  Functions
  31 ;; are provided that create and retrieve such identifiers, and that find
  32 ;; entries based on the identifier.
  33
  34 ;; Identifiers consist of a prefix (default "Org") and a compact encoding
  35 ;; of the creation time of the ID, with microsecond accuracy.  This virtually
  36 ;; guarantees globally unique identifiers, even if several people are
  37 ;; creating ID's at the same time in files that will eventually be used
  38 ;; together.  Even higher security can be achieved by using different
  39 ;; values for each collaborator or file.
  40 ;;
  41 ;; This file defines the following API:
  42 ;;
  43 ;; org-id-create
  44 ;;        Create an ID for the entry at point if it does not yet have one.
  45 ;;        Returns the ID (old or new).  This function can be used
  46 ;;        interactively, with prefix argument the creation of a new ID is
  47 ;;        forced, even if there was an old one.
  48 ;;
  49 ;; org-id-get
  50 ;;        Get the ID property of an entry.  Using appropriate arguments
  51 ;;        to the function, it can also create the ID for this entry.
  52 ;;
  53 ;; org-id-goto
  54 ;;        Command to go to a specific ID, this command can be used
  55 ;;        interactively.
  56 ;;
  57 ;; org-id-get-with-outline-path-completion
  58 ;;        Retrieve the ID of an entry, using outline path completion.
  59 ;;        This function can work for multiple files.
  60 ;;
  61 ;; org-id-get-with-outline-drilling
  62 ;;        Retrieve the ID of an entry, using outline path completion.
  63 ;;        This function only works for the current file.
  64 ;;
  65 ;; org-id-find
  66 ;;        Find the location of an entry with specific id.
  67 ;;
  68
  69 (require 'org)
  70
  71 ;;; Customization
  72
  73 (defgroup org-id nil
  74   "Options concerning global entry identifiers in Org-mode."
  75   :tag "Org ID"
  76   :group 'org)
  77
  78 (defcustom org-id-prefix "Org"
  79   "The prefix for IDs.
  80
  81 This may be a string, or it can be nil to indicate that no prefix is required.
  82 When a string, the string should have no space characters as IDs are expected
  83 to have no space characters in them."
  84   :group 'org-id
  85   :type '(choice
  86           (const :tag "No prefix")
  87           (string :tag "Prefix")))
  88
  89 (defcustom org-id-include-domain t
  90   "Non-nil means, add the domain name to new IDs.
  91 This ensures global uniqueness of ID's, and is also suggested by
  92 RFC 2445 in combination with RFC 822."
  93   :group 'org-id
  94   :type 'boolean)
  95
  96 (defcustom org-id-locations-file "~/.org-id-locations"
  97   "The file for remembering the last ID number generated."
  98   :group 'org-id
  99   :type 'file)
 100
 101 (defvar org-id-locations nil
 102   "List of files with ID's in those files.")
 103
 104 (defcustom org-id-extra-files 'org-agenda-text-search-extra-files
 105   "Files to be searched for ID's, besides the agenda files."
 106   :group 'org-id
 107   :type
 108   '(choice
 109     (symbol :tag "Variable")
 110     (repeat :tag "List of files"
 111             (file))))
 112
 113 ;;; The API functions
 114
 115 (defun org-id-create (&optional force)
 116   "Create an ID for the current entry and return it.
 117 If the entry already has an ID, just return it.
 118 With optional argument FORCE, force the creation of a new ID."
 119   (interactive "P")
 120   (when force
 121     (org-entry-put (point) "ID" nil))
 122   (org-id-get (point) 'create))
 123
 124 (defun org-id-copy ()
 125   "Copy the ID of the entry at point to the kill ring.
 126 Create an ID if necessary."
 127   (interactive)
 128   (kill-new (org-id-get nil 'create)))
 129
 130 (defun org-id-get (&optional pom create prefix)
 131   "Get the ID property of the entry at point-or-marker POM.
 132 If POM is nil, refer to the entry at point.
 133 If the entry does not have an ID, the function returns nil.
 134 However, when CREATE is non nil, create an ID if none is present already.
 135 PREFIX will be passed through to `org-id-new'.
 136 In any case, the ID of the entry is returned."
 137   (let ((id (org-entry-get pom "ID")))
 138     (cond
 139      ((and id (stringp id) (string-match "\\S-" id))
 140       id)
 141      (create
 142       (setq id (org-id-new prefix))
 143       (org-entry-put pom "ID" id)
 144       (org-id-add-location id (buffer-file-name (buffer-base-buffer)))
 145       id)
 146      (t nil))))
 147
 148 (defun org-id-get-with-outline-path-completion (&optional targets)
 149   "Use outline-path-completion to retrieve the ID of an entry.
 150 TARGETS may be a setting for `org-refile-targets' to define the eligible
 151 headlines.  When omitted, all headlines in all agenda files are
 152 eligible.
 153 It returns the ID of the entry.  If necessary, the ID is created."
 154   (let* ((org-refile-targets (or targets '((nil . (:maxlevel . 10)))))
 155          (org-refile-use-outline-path
 156           (if (caar org-refile-targets) 'file t))
 157          (spos (org-refile-get-location "Entry: "))
 158          (pom (and spos (move-marker (make-marker) (nth 3 spos)
 159                                      (get-file-buffer (nth 1 spos))))))
 160     (prog1 (org-id-get pom 'create)
 161       (move-marker pom nil))))
 162
 163 (defun org-id-get-with-outline-drilling (&optional targets)
 164   "Use an outline-cycling interface to retrieve the ID of an entry.
 165 This only finds entries in the current buffer, using `org-get-location'.
 166 It returns the ID of the entry.  If necessary, the ID is created."
 167   (let* ((spos (org-get-location (current-buffer) org-goto-help))
 168          (pom (and spos (move-marker (make-marker) (car spos)))))
 169     (prog1 (org-id-get pom 'create)
 170       (move-marker pom nil))))
 171
 172 (defun org-id-goto (id)
 173   "Switch to the buffer containing the entry with id ID.
 174 Move the cursor to that entry in that buffer."
 175   (interactive)
 176   (let ((m (org-id-find id 'marker)))
 177     (unless m
 178       (error "Cannot find entry with ID \"%s\"" id))
 179     (switch-to-buffer (marker-buffer m))
 180     (goto-char m)
 181     (move-marker m nil)
 182     (org-show-context)))
 183
 184 (defun org-id-find (id &optional markerp)
 185   "Return the location of the entry with the id ID.
 186 The return value is a cons cell (file-name . position), or nil
 187 if there is no entry with that ID.
 188 With optional argument MARKERP, return the position as a new marker."
 189   (let ((file (org-id-find-id-file id))
 190         org-agenda-new-buffers where)
 191     (when file
 192       (setq where (org-id-find-id-in-file id file markerp)))
 193     (unless where
 194       (org-id-update-id-locations)
 195       (setq file (org-id-find-id-file id))
 196       (when file
 197         (setq where (org-id-find-id-in-file id file markerp))))
 198     where))
 199
 200 ;;; Internal functions
 201
 202 ;; Creating new IDs
 203
 204 (defun org-id-new (&optional prefix)
 205   "Create a new globally unique ID.
 206
 207 An ID consists of two parts separated by a colon:
 208 - a prefix
 209 - an encoding of the current time to micro-second accuracy
 210
 211 PREFIX can specify the prefix, the default is given by the variable
 212 `org-id-prefix'.  However, if PREFIX is the symbol `none', don't use any
 213 prefix even if `org-id-prefix' specifies one.
 214
 215 So a typical ID could look like \"Org:4nd91V40HI\"."
 216   (let* ((prefix (if (eq prefix 'none)
 217                      nil
 218                    (or prefix org-id-prefix)))
 219          (etime (org-id-time-to-b62))
 220          (postfix (if org-id-include-domain
 221                       (progn
 222                         (require 'message)
 223                         (concat "@" (message-make-fqdn))))))
 224     (if prefix
 225         (concat prefix ":" etime postfix)
 226       (concat etime postfix))))
 227
 228 (defun org-id-int-to-b62-one-digit (i)
 229   "Turn an integer between 0 and 61 into a single character 0..9, A..Z, a..z."
 230   (cond
 231    ((< i 10) (+ ?0 i))
 232    ((< i 36) (+ ?A i -10))
 233    ((< i 62) (+ ?a i -36))
 234    (t (error "Larger that 61"))))
 235
 236 (defun org-id-b62-to-int-one-digit (i)
 237   "Turn a character 0..9, A..Z, a..z into a number 0..61.
 238 The input I may be a character, or a single-letter string."
 239   (and (stringp i) (setq i (string-to-char i)))
 240   (cond
 241    ((and (>= i ?0) (<= i ?9)) (- i ?0))
 242    ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
 243    ((and (>= i ?a) (<= i ?z)) (+ (- i ?a) 36))
 244    (t (error "Invalid b62 letter"))))
 245
 246 (defun org-id-int-to-b62 (i &optional length)
 247   "Convert an integer to a base-62 number represented as a string."
 248   (let ((s ""))
 249     (while (> i 0)
 250       (setq s (concat (char-to-string
 251                        (org-id-int-to-b62-one-digit (mod i 62))) s)
 252             i (/ i 62)))
 253     (setq length (max 1 (or length 1)))
 254     (if (< (length s) length)
 255         (setq s (concat (make-string (- length (length s)) ?0) s)))
 256     s))
 257
 258 (defun org-id-b62-to-int (s)
 259   "Convert a base-62 string into the corresponding integer."
 260   (let ((r 0))
 261     (mapc (lambda (i) (setq r (+ (* r 62) (org-id-b62-to-int-one-digit i))))
 262           s)
 263     r))
 264
 265 (defun org-id-time-to-b62 (&optional time)
 266   "Encode TIME as a 10-digit string.
 267 This string holds the time to micro-second accuracy, and can be decoded
 268 using `org-id-decode'."
 269   (setq time (or time (current-time)))
 270   (concat (org-id-int-to-b62 (nth 0 time) 3)
 271           (org-id-int-to-b62 (nth 1 time) 3)
 272           (org-id-int-to-b62 (or (nth 2 time) 0) 4)))
 273
 274 (defun org-id-decode (id)
 275   "Split ID into the prefix and the time value that was used to create it.
 276 The return value is (prefix . time) where PREFIX is nil or a string,
 277 and time is the usual three-integer representation of time."
 278   (let (prefix time parts)
 279     (setq parts (org-split-string id ":"))
 280     (if (= 2 (length parts))
 281         (setq prefix (car parts) time (nth 1 parts))
 282       (setq prefix nil time (nth 0 parts)))
 283     (setq time (list (org-id-b62-to-int (substring time 0 3))
 284                      (org-id-b62-to-int (substring time 3 6))
 285                      (org-id-b62-to-int (substring time 6 10))))
 286     (cons prefix time)))
 287
 288 ;; Storing ID locations (files)
 289
 290 (defun org-id-update-id-locations ()
 291   "Scan relevant files for ID's.
 292 Store the relation between files and corresponding ID's."
 293   (interactive)
 294   (let ((files (append (org-agenda-files)
 295                        (if (symbolp org-id-extra-files)
 296                            (symbol-value org-id-extra-files)
 297                          org-id-extra-files)))
 298         org-agenda-new-buffers
 299         file ids reg found id)
 300     (while (setq file (pop files))
 301       (setq ids nil)
 302       (with-current-buffer (org-get-agenda-file-buffer file)
 303         (save-excursion
 304           (save-restriction
 305             (widen)
 306             (goto-char (point-min))
 307             (while (re-search-forward "^[ \t]*:ID:[ \t]+\\(\\S-+\\)[ \t]*$"
 308                                       nil t)
 309               (setq id (org-match-string-no-properties 1))
 310               (if (member id found)
 311                   (error "Duplicate ID \"%s\"" id))
 312               (push id found)
 313               (push id ids))
 314             (push (cons file ids) reg)))))
 315     (org-release-buffers org-agenda-new-buffers)
 316     (setq org-agenda-new-buffers nil)
 317     (setq org-id-locations reg)
 318     (org-id-locations-save)))
 319
 320 (defun org-id-locations-save ()
 321   "Save `org-id-locations' in `org-id-locations-file'."
 322   (with-temp-file org-id-locations-file
 323     (print org-id-locations (current-buffer))))
 324
 325 (defun org-id-locations-load ()
 326   "Read the data from `org-id-locations-file'."
 327   (setq org-id-locations nil)
 328   (with-temp-buffer
 329     (condition-case nil
 330         (progn
 331           (insert-file-contents-literally org-id-locations-file)
 332           (goto-char (point-min))
 333           (setq org-id-locations (read (current-buffer))))
 334       (error
 335        (message "Could not read org-id-values from %s. Setting it to nil."
 336                 org-id-locations-file)))))
 337
 338 (defun org-id-add-location (id file)
 339   "Add the ID with location FILE to the database of ID loations."
 340   (unless org-id-locations (org-id-locations-load))
 341   (catch 'exit
 342     (let ((locs org-id-locations) list)
 343       (while (setq list (pop locs))
 344         (when (equal (file-truename file) (file-truename (car list)))
 345           (setcdr list (cons id (cdr list)))
 346           (throw 'exit t))))
 347     (push (list file id) org-id-locations))
 348   (org-id-locations-save))
 349
 350 ;; Finding entries with specified id
 351
 352 (defun org-id-find-id-file (id)
 353   "Query the id database for the file in which this ID is located."
 354   (unless org-id-locations (org-id-locations-load))
 355   (catch 'found
 356     (mapc (lambda (x) (if (member id (cdr x))
 357                           (throw 'found (car x))))
 358           org-id-locations)
 359     nil))
 360
 361 (defun org-id-find-id-in-file (id file &optional markerp)
 362   "Return the position of the entry ID in FILE.
 363 If that files does not exist, or if it does not contain this ID,
 364 return nil.
 365 The position is returned as a cons cell (file-name . position).  With
 366 optional argument MARKERP, return the position as a new marker."
 367   (let (org-agenda-new-buffers m buf pos)
 368     (cond
 369      ((not file) nil)
 370      ((not (file-exists-p file)) nil)
 371      (t (with-current-buffer (setq buf (org-get-agenda-file-buffer file))
 372           (setq pos (org-find-entry-with-id id))
 373           (when pos
 374             (if markerp
 375                 (move-marker (make-marker) pos buf)
 376               (cons file pos))))))))
 377
 378 (provide 'org-id)
 379
 380 ;;; org-id.el ends here
 381