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-locations-file "~/.org-id-locations"
  90   "The file for remembering the last ID number generated."
  91   :group 'org-id
  92   :type 'file)
  93
  94 (defvar org-id-locations nil
  95   "List of files with ID's in those files.")
  96
  97 (defcustom org-id-extra-files 'org-agenda-text-search-extra-files
  98   "Files to be searched for ID's, besides the agenda files."
  99   :group 'org-id
 100   :type
 101   '(choice
 102     (symbol :tag "Variable")
 103     (repeat :tag "List of files"
 104             (file))))
 105
 106 ;;; The API functions
 107
 108 (defun org-id-create (&optional force)
 109   "Create an ID for the current entry and return it.
 110 If the entry already has an ID, just return it.
 111 With optional argument FORCE, force the creation of a new ID."
 112   (interactive "P")
 113   (when force
 114     (org-entry-put (point) "ID" nil))
 115   (org-id-get (point) 'create))
 116
 117 (defun org-id-copy ()
 118   "Copy the ID of the entry at point to the kill ring.
 119 Create an ID if necessary."
 120   (interactive)
 121   (kill-new (org-id-get nil 'create)))
 122
 123 (defun org-id-get (&optional pom create prefix)
 124   "Get the ID property of the entry at point-or-marker POM.
 125 If POM is nil, refer to the entry at point.
 126 If the entry does not have an ID, the function returns nil.
 127 However, when CREATE is non nil, create an ID if none is present already.
 128 PREFIX will be passed through to `org-id-new'.
 129 In any case, the ID of the entry is returned."
 130   (let ((id (org-entry-get pom "ID")))
 131     (cond
 132      ((and id (stringp id) (string-match "\\S-" id))
 133       id)
 134      (create
 135       (setq id (org-id-new prefix))
 136       (org-entry-put pom "ID" id)
 137       (org-id-add-location id (buffer-file-name (buffer-base-buffer)))
 138       id)
 139      (t nil))))
 140
 141 (defun org-id-get-with-outline-path-completion (&optional targets)
 142   "Use outline-path-completion to retrieve the ID of an entry.
 143 TARGETS may be a setting for `org-refile-targets' to define the eligible
 144 headlines.  When omitted, all headlines in all agenda files are
 145 eligible.
 146 It returns the ID of the entry.  If necessary, the ID is created."
 147   (let* ((org-refile-targets (or targets '((nil . (:maxlevel . 10)))))
 148          (org-refile-use-outline-path
 149           (if (caar org-refile-targets) 'file t))
 150          (spos (org-refile-get-location "Entry: "))
 151          (pom (and spos (move-marker (make-marker) (nth 3 spos)
 152                                      (get-file-buffer (nth 1 spos))))))
 153     (prog1 (org-id-get pom 'create)
 154       (move-marker pom nil))))
 155
 156 (defun org-id-get-with-outline-drilling (&optional targets)
 157   "Use an outline-cycling interface to retrieve the ID of an entry.
 158 This only finds entries in the current buffer, using `org-get-location'.
 159 It returns the ID of the entry.  If necessary, the ID is created."
 160   (let* ((spos (org-get-location (current-buffer) org-goto-help))
 161          (pom (and spos (move-marker (make-marker) (car spos)))))
 162     (prog1 (org-id-get pom 'create)
 163       (move-marker pom nil))))
 164
 165 (defun org-id-goto (id)
 166   "Switch to the buffer containing the entry with id ID.
 167 Move the cursor to that entry in that buffer."
 168   (interactive)
 169   (let ((m (org-id-find id 'marker)))
 170     (unless m
 171       (error "Cannot find entry with ID \"%s\"" id))
 172     (switch-to-buffer (marker-buffer m))
 173     (goto-char m)
 174     (move-marker m nil)
 175     (org-show-context)))
 176
 177 (defun org-id-find (id &optional markerp)
 178   "Return the location of the entry with the id ID.
 179 The return value is a cons cell (file-name . position), or nil
 180 if there is no entry with that ID.
 181 With optional argument MARKERP, return the position as a new marker."
 182   (let ((file (org-id-find-id-file id))
 183         org-agenda-new-buffers where)
 184     (when file
 185       (setq where (org-id-find-id-in-file id file markerp)))
 186     (unless where
 187       (org-id-update-id-locations)
 188       (setq file (org-id-find-id-file id))
 189       (when file
 190         (setq where (org-id-find-id-in-file id file markerp))))
 191     where))
 192
 193 ;;; Internal functions
 194
 195 ;; Creating new IDs
 196
 197 (defun org-id-new (&optional prefix)
 198   "Create a new globally unique ID.
 199
 200 An ID consists of two parts separated by a colon:
 201 - a prefix
 202 - an encoding of the current time to micro-second accuracy
 203
 204 PREFIX can specify the prefix, the default is given by the variable
 205 `org-id-prefix'.  However, if PREFIX is the symbol `none', don't use any
 206 prefix even if `org-id-prefix' specifies one.
 207
 208 So a typical ID could look like \"Org:4nd91V40HI\"."
 209   (let* ((prefix (if (eq prefix 'none)
 210                      nil
 211                    (or prefix org-id-prefix)))
 212          (etime (org-id-time-to-b62)))
 213     (if prefix
 214         (concat prefix ":" etime)
 215       etime)))
 216
 217 (defun org-id-int-to-b62-one-digit (i)
 218   "Turn an integer between 0 and 61 into a single character 0..9, A..Z, a..z."
 219   (cond
 220    ((< i 10) (+ ?0 i))
 221    ((< i 36) (+ ?A i -10))
 222    ((< i 62) (+ ?a i -36))
 223    (t (error "Larger that 61"))))
 224
 225 (defun org-id-b62-to-int-one-digit (i)
 226   "Turn a character 0..9, A..Z, a..z into a number 0..61.
 227 The input I may be a character, or a single-letter string."
 228   (and (stringp i) (setq i (string-to-char i)))
 229   (cond
 230    ((and (>= i ?0) (<= i ?9)) (- i ?0))
 231    ((and (>= i ?A) (<= i ?Z)) (+ (- i ?A) 10))
 232    ((and (>= i ?a) (<= i ?z)) (+ (- i ?a) 36))
 233    (t (error "Invalid b62 letter"))))
 234
 235 (defun org-id-int-to-b62 (i &optional length)
 236   "Convert an integer to a base-62 number represented as a string."
 237   (let ((s ""))
 238     (while (> i 0)
 239       (setq s (concat (char-to-string
 240                        (org-id-int-to-b62-one-digit (mod i 62))) s)
 241             i (/ i 62)))
 242     (setq length (max 1 (or length 1)))
 243     (if (< (length s) length)
 244         (setq s (concat (make-string (- length (length s)) ?0) s)))
 245     s))
 246
 247 (defun org-id-b62-to-int (s)
 248   "Convert a base-62 string into the corresponding integer."
 249   (let ((r 0))
 250     (mapc (lambda (i) (setq r (+ (* r 62) (org-id-b62-to-int-one-digit i))))
 251           s)
 252     r))
 253
 254 (defun org-id-time-to-b62 (&optional time)
 255   "Encode TIME as a 10-digit string.
 256 This string holds the time to micro-second accuracy, and can be decoded
 257 using `org-id-decode'."
 258   (setq time (or time (current-time)))
 259   (concat (org-id-int-to-b62 (nth 0 time) 3)
 260           (org-id-int-to-b62 (nth 1 time) 3)
 261           (org-id-int-to-b62 (or (nth 2 time) 0) 4)))
 262
 263 (defun org-id-decode (id)
 264   "Split ID into the prefix and the time value that was used to create it.
 265 The return value is (prefix . time) where PREFIX is nil or a string,
 266 and time is the usual three-integer representation of time."
 267   (let (prefix time parts)
 268     (setq parts (org-split-string id ":"))
 269     (if (= 2 (length parts))
 270         (setq prefix (car parts) time (nth 1 parts))
 271       (setq prefix nil time (nth 0 parts)))
 272     (setq time (list (org-id-b62-to-int (substring time 0 3))
 273                      (org-id-b62-to-int (substring time 3 6))
 274                      (org-id-b62-to-int (substring time 6 10))))
 275     (cons prefix time)))
 276
 277 ;; Storing ID locations (files)
 278
 279 (defun org-id-update-id-locations ()
 280   "Scan relevant files for ID's.
 281 Store the relation between files and corresponding ID's."
 282   (interactive)
 283   (let ((files (append (org-agenda-files)
 284                        (if (symbolp org-id-extra-files)
 285                            (symbol-value org-id-extra-files)
 286                          org-id-extra-files)))
 287         org-agenda-new-buffers
 288         file ids reg found id)
 289     (while (setq file (pop files))
 290       (setq ids nil)
 291       (with-current-buffer (org-get-agenda-file-buffer file)
 292         (save-excursion
 293           (save-restriction
 294             (widen)
 295             (goto-char (point-min))
 296             (while (re-search-forward "^[ \t]*:ID:[ \t]+\\(\\S-+\\)[ \t]*$"
 297                                       nil t)
 298               (setq id (org-match-string-no-properties 1))
 299               (if (member id found)
 300                   (error "Duplicate ID \"%s\"" id))
 301               (push id found)
 302               (push id ids))
 303             (push (cons file ids) reg)))))
 304     (org-release-buffers org-agenda-new-buffers)
 305     (setq org-agenda-new-buffers nil)
 306     (setq org-id-locations reg)
 307     (org-id-locations-save)))
 308
 309 (defun org-id-locations-save ()
 310   "Save `org-id-locations' in `org-id-locations-file'."
 311   (with-temp-file org-id-locations-file
 312     (print org-id-locations (current-buffer))))
 313
 314 (defun org-id-locations-load ()
 315   "Read the data from `org-id-locations-file'."
 316   (setq org-id-locations nil)
 317   (with-temp-buffer
 318     (condition-case nil
 319         (progn
 320           (insert-file-contents-literally org-id-locations-file)
 321           (goto-char (point-min))
 322           (setq org-id-locations (read (current-buffer))))
 323       (error
 324        (message "Could not read org-id-values from %s. Setting it to nil."
 325                 org-id-locations-file)))))
 326
 327 (defun org-id-add-location (id file)
 328   "Add the ID with location FILE to the database of ID loations."
 329   (unless org-id-locations (org-id-locations-load))
 330   (catch 'exit
 331     (let ((locs org-id-locations) list)
 332       (while (setq list (pop locs))
 333         (when (equal (file-truename file) (file-truename (car list)))
 334           (setcdr list (cons id (cdr list)))
 335           (throw 'exit t))))
 336     (push (list file id) org-id-locations))
 337   (org-id-locations-save))
 338
 339 ;; Finding entries with specified id
 340
 341 (defun org-id-find-id-file (id)
 342   "Query the id database for the file in which this ID is located."
 343   (unless org-id-locations (org-id-locations-load))
 344   (catch 'found
 345     (mapc (lambda (x) (if (member id (cdr x))
 346                           (throw 'found (car x))))
 347           org-id-locations)
 348     nil))
 349
 350 (defun org-id-find-id-in-file (id file &optional markerp)
 351   "Return the position of the entry ID in FILE.
 352 If that files does not exist, or if it does not contain this ID,
 353 return nil.
 354 The position is returned as a cons cell (file-name . position).  With
 355 optional argument MARKERP, return the position as a new marker."
 356   (let (org-agenda-new-buffers m buf pos)
 357     (cond
 358      ((not file) nil)
 359      ((not (file-exists-p file)) nil)
 360      (t (with-current-buffer (setq buf (org-get-agenda-file-buffer file))
 361           (setq pos (org-find-entry-with-id id))
 362           (when pos
 363             (if markerp
 364                 (move-marker (make-marker) pos buf)
 365               (cons file pos))))))))
 366
 367 (provide 'org-id)
 368
 369 ;;; org-id.el ends here
 370