contrib/lisp/org-registry.el

   1 ;;; org-registry.el --- a registry for Org links
   2 ;;
   3 ;; Copyright 2007-2012 Bastien Guerry
   4 ;;
   5 ;; Emacs Lisp Archive Entry
   6 ;; Filename: org-registry.el
   7 ;; Version: 0.1a
   8 ;; Author: Bastien Guerry <bzg AT gnu DOT org>
   9 ;; Maintainer: Bastien Guerry <bzg AT gnu DOT org>
  10 ;; Keywords: org, wp, registry
  11 ;; Description: Shows Org files where the current buffer is linked
  12 ;; URL: http://www.cognition.ens.fr/~guerry/u/org-registry.el
  13 ;;
  14 ;; This program is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 3, or (at your option)
  17 ;; any later version.
  18 ;;
  19 ;; This program is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23 ;;
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program; if not, write to the Free Software
  26 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; This library add a registry to your Org setup.
  31 ;;
  32 ;; Org files are full of links inserted with `org-store-link'. This links
  33 ;; point to e-mail, webpages, files, dirs, info pages, man pages, etc.
  34 ;; Actually, they come from potentially *everywhere* since Org lets you
  35 ;; define your own storing/following functions.
  36 ;;
  37 ;; So, what if you are on a e-mail, webpage or whatever and want to know if
  38 ;; this buffer has already been linked to somewhere in your agenda files?
  39 ;;
  40 ;; This is were org-registry comes in handy.
  41 ;;
  42 ;;     M-x org-registry-show will tell you the name of the file
  43 ;; C-u M-x org-registry-show will directly jump to the file
  44 ;;
  45 ;; In case there are several files where the link lives in:
  46 ;;
  47 ;;     M-x org-registry-show will display them in a new window
  48 ;; C-u M-x org-registry-show will prompt for a file to visit
  49 ;;
  50 ;; Add this to your Org configuration:
  51 ;;
  52 ;; (require 'org-registry)
  53 ;; (org-registry-initialize)
  54 ;;
  55 ;; If you want to update the registry with newly inserted links in the
  56 ;; current buffer: M-x org-registry-update
  57 ;;
  58 ;; If you want this job to be done each time you save an Org buffer,
  59 ;; hook 'org-registry-update to the local 'after-save-hook in org-mode:
  60 ;;
  61 ;; (org-registry-insinuate)
  62
  63 ;;; Code:
  64
  65 (eval-when-compile
  66   (require 'cl))
  67
  68 (defgroup org-registry nil
  69   "A registry for Org."
  70   :group 'org)
  71
  72 (defcustom org-registry-file
  73   (concat (getenv "HOME") "/.org-registry.el")
  74   "The Org registry file."
  75   :group 'org-registry
  76   :type 'file)
  77
  78 (defcustom org-registry-find-file 'find-file-other-window
  79   "How to find visit files."
  80   :type 'function
  81   :group 'org-registry)
  82
  83 (defvar org-registry-alist nil
  84   "An alist containing the Org registry.")
  85
  86 ;;;###autoload
  87 (defun org-registry-show (&optional visit)
  88   "Show Org files where there are links pointing to the current
  89 buffer."
  90   (interactive "P")
  91   (org-registry-initialize)
  92   (let* ((blink (or (org-remember-annotation) ""))
  93          (link (when (string-match org-bracket-link-regexp blink)
  94                  (match-string-no-properties 1 blink)))
  95          (desc (or (and (string-match org-bracket-link-regexp blink)
  96                         (match-string-no-properties 3 blink)) "No description"))
  97          (files (org-registry-assoc-all link))
  98          file point selection tmphist)
  99     (cond ((and files visit)
 100            ;; result(s) to visit
 101            (cond ((< 1 (length files))
 102                   ;; more than one result
 103                   (setq tmphist (mapcar (lambda(entry)
 104                                           (format "%s (%d) [%s]"
 105                                                   (nth 3 entry) ; file
 106                                                   (nth 2 entry) ; point
 107                                                   (nth 1 entry))) files))
 108                   (setq selection (completing-read "File: " tmphist
 109                                                    nil t nil 'tmphist))
 110                   (string-match "\\(.+\\) (\\([0-9]+\\))" selection)
 111                   (setq file (match-string 1 selection))
 112                   (setq point (string-to-number (match-string 2 selection))))
 113                  ((eq 1 (length files))
 114                   ;; just one result
 115                   (setq file (nth 3 (car files)))
 116                   (setq point (nth 2 (car files)))))
 117            ;; visit the (selected) file
 118            (funcall org-registry-find-file file)
 119            (goto-char point)
 120            (unless (org-before-first-heading-p)
 121              (org-show-context)))
 122           ((and files (not visit))
 123            ;; result(s) to display
 124            (cond  ((eq 1 (length files))
 125                    ;; show one file
 126                    (message "Link in file %s (%d) [%s]"
 127                             (nth 3 (car files))
 128                             (nth 2 (car files))
 129                             (nth 1 (car files))))
 130                   (t (org-registry-display-files files link))))
 131           (t (message "No link to this in org-agenda-files")))))
 132
 133 (defun org-registry-display-files (files link)
 134   "Display files in a separate window."
 135   (switch-to-buffer-other-window
 136    (get-buffer-create " *Org registry info*"))
 137   (erase-buffer)
 138   (insert (format "Files pointing to %s:\n\n" link))
 139   (let (file)
 140     (while (setq file (pop files))
 141       (insert (format "%s (%d) [%s]\n" (nth 3 file)
 142                       (nth 2 file) (nth 1 file)))))
 143   (shrink-window-if-larger-than-buffer)
 144   (other-window 1))
 145
 146 (defun org-registry-assoc-all (link &optional registry)
 147   "Return all associated entries of LINK in the registry."
 148   (org-registry-find-all
 149    (lambda (entry) (string= link (car entry)))
 150    registry))
 151
 152 (defun org-registry-find-all (test &optional registry)
 153   "Return all entries satisfying `test' in the registry."
 154   (delq nil
 155         (mapcar
 156          (lambda (x) (and (funcall test x) x))
 157          (or registry org-registry-alist))))
 158
 159 ;;;###autoload
 160 (defun org-registry-visit ()
 161   "If an Org file contains a link to the current location, visit
 162 this file."
 163   (interactive)
 164   (org-registry-show t))
 165
 166 ;;;###autoload
 167 (defun org-registry-initialize (&optional from-scratch)
 168   "Initialize `org-registry-alist'.
 169 If FROM-SCRATCH is non-nil or the registry does not exist yet,
 170 create a new registry from scratch and eval it. If the registry
 171 exists, eval `org-registry-file' and make it the new value for
 172 `org-registry-alist'."
 173   (interactive "P")
 174   (if (or from-scratch (not (file-exists-p org-registry-file)))
 175       ;; create a new registry
 176       (let ((files org-agenda-files) file)
 177         (while (setq file (pop files))
 178           (setq file (expand-file-name file))
 179           (mapc (lambda (entry)
 180                   (add-to-list 'org-registry-alist entry))
 181                 (org-registry-get-entries file)))
 182         (when from-scratch
 183           (org-registry-create org-registry-alist)))
 184     ;; eval the registry file
 185     (with-temp-buffer
 186       (insert-file-contents org-registry-file)
 187       (eval-buffer))))
 188
 189 ;;;###autoload
 190 (defun org-registry-insinuate ()
 191   "Call `org-registry-update' after saving in Org-mode.
 192 Use with caution.  This could slow down things a bit."
 193   (interactive)
 194   (add-hook 'org-mode-hook
 195             (lambda() (add-hook 'after-save-hook
 196                                 'org-registry-update t t))))
 197
 198 (defun org-registry-get-entries (file)
 199   "List Org links in FILE that will be put in the registry."
 200   (let (bufstr result)
 201     (with-temp-buffer
 202       (insert-file-contents file)
 203       (goto-char (point-min))
 204       (while (re-search-forward org-angle-link-re nil t)
 205         (let* ((point (match-beginning 0))
 206                (link (match-string-no-properties 0))
 207                (desc (match-string-no-properties 0)))
 208             (add-to-list 'result (list link desc point file))))
 209       (goto-char (point-min))
 210       (while (re-search-forward org-bracket-link-regexp nil t)
 211         (let* ((point (match-beginning 0))
 212                (link (match-string-no-properties 1))
 213                (desc (or (match-string-no-properties 3) "No description")))
 214             (add-to-list 'result (list link desc point file)))))
 215     ;; return the list of new entries
 216     result))
 217
 218 ;;;###autoload
 219 (defun org-registry-update ()
 220   "Update the registry for the current Org file."
 221   (interactive)
 222   (unless (eq major-mode 'org-mode) (error "Not in org-mode"))
 223   (let* ((from-file (expand-file-name (buffer-file-name)))
 224          (new-entries (org-registry-get-entries from-file)))
 225     (with-temp-buffer
 226       (unless (file-exists-p org-registry-file)
 227         (org-registry-initialize t))
 228       (find-file org-registry-file)
 229       (goto-char (point-min))
 230       (while (re-search-forward (concat from-file "\")$") nil t)
 231         (let ((end (1+ (match-end 0)))
 232               (beg (progn (re-search-backward "^(\"" nil t)
 233                           (match-beginning 0))))
 234         (delete-region beg end)))
 235       (goto-char (point-min))
 236       (re-search-forward "^(\"" nil t)
 237       (goto-char (match-beginning 0))
 238       (mapc (lambda (elem)
 239               (insert (with-output-to-string (prin1 elem)) "\n"))
 240             new-entries)
 241       (save-buffer)
 242       (kill-buffer (current-buffer)))
 243     (message (format "Org registry updated for %s"
 244                      (file-name-nondirectory from-file)))))
 245
 246 (defun org-registry-create (entries)
 247   "Create `org-registry-file' with ENTRIES."
 248   (let (entry)
 249     (with-temp-buffer
 250       (find-file org-registry-file)
 251       (erase-buffer)
 252       (insert
 253        (with-output-to-string
 254          (princ ";; -*- emacs-lisp -*-\n")
 255          (princ ";; Org registry\n")
 256          (princ ";; You shouldn't try to modify this buffer manually\n\n")
 257          (princ "(setq org-registry-alist\n'(\n")
 258          (while entries
 259            (when (setq entry (pop entries))
 260              (prin1 entry)
 261              (princ "\n")))
 262          (princ "))\n")))
 263       (save-buffer)
 264       (kill-buffer (current-buffer))))
 265   (message "Org registry created"))
 266
 267 (provide 'org-registry)
 268
 269 ;;;  User Options, Variables
 270
 271 ;;; org-registry.el ends here