dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

org-registry.el (9163B)


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