org-mode/contrib/lisp/org-registry.el

272 lines
9.0 KiB
EmacsLisp

;;; org-registry.el --- a registry for Org links
;;
;; Copyright 2007-2012 Bastien Guerry
;;
;; Emacs Lisp Archive Entry
;; Filename: org-registry.el
;; Version: 0.1a
;; Author: Bastien Guerry <bzg AT gnu DOT org>
;; Maintainer: Bastien Guerry <bzg AT gnu DOT org>
;; Keywords: org, wp, registry
;; Description: Shows Org files where the current buffer is linked
;; URL: http://www.cognition.ens.fr/~guerry/u/org-registry.el
;;
;; 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, 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, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;;
;; This library add a registry to your Org setup.
;;
;; Org files are full of links inserted with `org-store-link'. This links
;; point to e-mail, webpages, files, dirs, info pages, man pages, etc.
;; Actually, they come from potentially *everywhere* since Org lets you
;; define your own storing/following functions.
;;
;; So, what if you are on a e-mail, webpage or whatever and want to know if
;; this buffer has already been linked to somewhere in your agenda files?
;;
;; This is were org-registry comes in handy.
;;
;; M-x org-registry-show will tell you the name of the file
;; C-u M-x org-registry-show will directly jump to the file
;;
;; In case there are several files where the link lives in:
;;
;; M-x org-registry-show will display them in a new window
;; C-u M-x org-registry-show will prompt for a file to visit
;;
;; Add this to your Org configuration:
;;
;; (require 'org-registry)
;; (org-registry-initialize)
;;
;; If you want to update the registry with newly inserted links in the
;; current buffer: M-x org-registry-update
;;
;; If you want this job to be done each time you save an Org buffer,
;; hook 'org-registry-update to the local 'after-save-hook in org-mode:
;;
;; (org-registry-insinuate)
;;; Code:
(eval-when-compile
(require 'cl))
(defgroup org-registry nil
"A registry for Org."
:group 'org)
(defcustom org-registry-file
(concat (getenv "HOME") "/.org-registry.el")
"The Org registry file."
:group 'org-registry
:type 'file)
(defcustom org-registry-find-file 'find-file-other-window
"How to find visit files."
:type 'function
:group 'org-registry)
(defvar org-registry-alist nil
"An alist containing the Org registry.")
;;;###autoload
(defun org-registry-show (&optional visit)
"Show Org files where there are links pointing to the current
buffer."
(interactive "P")
(org-registry-initialize)
(let* ((blink (or (org-remember-annotation) ""))
(link (when (string-match org-bracket-link-regexp blink)
(match-string-no-properties 1 blink)))
(desc (or (and (string-match org-bracket-link-regexp blink)
(match-string-no-properties 3 blink)) "No description"))
(files (org-registry-assoc-all link))
file point selection tmphist)
(cond ((and files visit)
;; result(s) to visit
(cond ((< 1 (length files))
;; more than one result
(setq tmphist (mapcar (lambda(entry)
(format "%s (%d) [%s]"
(nth 3 entry) ; file
(nth 2 entry) ; point
(nth 1 entry))) files))
(setq selection (completing-read "File: " tmphist
nil t nil 'tmphist))
(string-match "\\(.+\\) (\\([0-9]+\\))" selection)
(setq file (match-string 1 selection))
(setq point (string-to-number (match-string 2 selection))))
((eq 1 (length files))
;; just one result
(setq file (nth 3 (car files)))
(setq point (nth 2 (car files)))))
;; visit the (selected) file
(funcall org-registry-find-file file)
(goto-char point)
(unless (org-before-first-heading-p)
(org-show-context)))
((and files (not visit))
;; result(s) to display
(cond ((eq 1 (length files))
;; show one file
(message "Link in file %s (%d) [%s]"
(nth 3 (car files))
(nth 2 (car files))
(nth 1 (car files))))
(t (org-registry-display-files files link))))
(t (message "No link to this in org-agenda-files")))))
(defun org-registry-display-files (files link)
"Display files in a separate window."
(switch-to-buffer-other-window
(get-buffer-create " *Org registry info*"))
(erase-buffer)
(insert (format "Files pointing to %s:\n\n" link))
(let (file)
(while (setq file (pop files))
(insert (format "%s (%d) [%s]\n" (nth 3 file)
(nth 2 file) (nth 1 file)))))
(shrink-window-if-larger-than-buffer)
(other-window 1))
(defun org-registry-assoc-all (link &optional registry)
"Return all associated entries of LINK in the registry."
(org-registry-find-all
(lambda (entry) (string= link (car entry)))
registry))
(defun org-registry-find-all (test &optional registry)
"Return all entries satisfying `test' in the registry."
(delq nil
(mapcar
(lambda (x) (and (funcall test x) x))
(or registry org-registry-alist))))
;;;###autoload
(defun org-registry-visit ()
"If an Org file contains a link to the current location, visit
this file."
(interactive)
(org-registry-show t))
;;;###autoload
(defun org-registry-initialize (&optional from-scratch)
"Initialize `org-registry-alist'.
If FROM-SCRATCH is non-nil or the registry does not exist yet,
create a new registry from scratch and eval it. If the registry
exists, eval `org-registry-file' and make it the new value for
`org-registry-alist'."
(interactive "P")
(if (or from-scratch (not (file-exists-p org-registry-file)))
;; create a new registry
(let ((files org-agenda-files) file)
(while (setq file (pop files))
(setq file (expand-file-name file))
(mapc (lambda (entry)
(add-to-list 'org-registry-alist entry))
(org-registry-get-entries file)))
(when from-scratch
(org-registry-create org-registry-alist)))
;; eval the registry file
(with-temp-buffer
(insert-file-contents org-registry-file)
(eval-buffer))))
;;;###autoload
(defun org-registry-insinuate ()
"Call `org-registry-update' after saving in Org-mode.
Use with caution. This could slow down things a bit."
(interactive)
(add-hook 'org-mode-hook
(lambda() (add-hook 'after-save-hook
'org-registry-update t t))))
(defun org-registry-get-entries (file)
"List Org links in FILE that will be put in the registry."
(let (bufstr result)
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(while (re-search-forward org-angle-link-re nil t)
(let* ((point (match-beginning 0))
(link (match-string-no-properties 0))
(desc (match-string-no-properties 0)))
(add-to-list 'result (list link desc point file))))
(goto-char (point-min))
(while (re-search-forward org-bracket-link-regexp nil t)
(let* ((point (match-beginning 0))
(link (match-string-no-properties 1))
(desc (or (match-string-no-properties 3) "No description")))
(add-to-list 'result (list link desc point file)))))
;; return the list of new entries
result))
;;;###autoload
(defun org-registry-update ()
"Update the registry for the current Org file."
(interactive)
(unless (eq major-mode 'org-mode) (error "Not in org-mode"))
(let* ((from-file (expand-file-name (buffer-file-name)))
(new-entries (org-registry-get-entries from-file)))
(with-temp-buffer
(unless (file-exists-p org-registry-file)
(org-registry-initialize t))
(find-file org-registry-file)
(goto-char (point-min))
(while (re-search-forward (concat from-file "\")$") nil t)
(let ((end (1+ (match-end 0)))
(beg (progn (re-search-backward "^(\"" nil t)
(match-beginning 0))))
(delete-region beg end)))
(goto-char (point-min))
(re-search-forward "^(\"" nil t)
(goto-char (match-beginning 0))
(mapc (lambda (elem)
(insert (with-output-to-string (prin1 elem)) "\n"))
new-entries)
(save-buffer)
(kill-buffer (current-buffer)))
(message (format "Org registry updated for %s"
(file-name-nondirectory from-file)))))
(defun org-registry-create (entries)
"Create `org-registry-file' with ENTRIES."
(let (entry)
(with-temp-buffer
(find-file org-registry-file)
(erase-buffer)
(insert
(with-output-to-string
(princ ";; -*- emacs-lisp -*-\n")
(princ ";; Org registry\n")
(princ ";; You shouldn't try to modify this buffer manually\n\n")
(princ "(setq org-registry-alist\n'(\n")
(while entries
(when (setq entry (pop entries))
(prin1 entry)
(princ "\n")))
(princ "))\n")))
(save-buffer)
(kill-buffer (current-buffer))))
(message "Org registry created"))
(provide 'org-registry)
;;; User Options, Variables
;;; org-registry.el ends here