lisp/muse-backlink.el

   1 ;;; muse-backlink.el --- backlinks for Muse
   2
   3 ;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: Jim Ottaway <j.ottaway@lse.ac.uk>
   6 ;; Keywords:
   7
   8 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   9
  10 ;; Emacs Muse is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published
  12 ;; by the Free Software Foundation; either version 2, or (at your
  13 ;; option) any later version.
  14
  15 ;; Emacs Muse is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Hierarchical backlink insertion into new muse pages.
  28 ;;
  29 ;; To add:
  30 ;;
  31 ;; (require 'muse-backlink)
  32 ;; (muse-backlink-install)
  33 ;;
  34 ;; To control what gets backlinked, modify
  35 ;; `muse-backlink-exclude-backlink-regexp' and
  36 ;; `muse-backlink-exclude-backlink-parent-regexp'.
  37 ;;
  38 ;; To stop backlinking temporarily:
  39 ;; (setq muse-backlink-create-backlinks nil)
  40 ;;
  41 ;; To remove the backlink functionality completely:
  42 ;;
  43 ;; (muse-backlink-remove)
  44
  45 ;;; Contributors:
  46
  47 ;;; Code:
  48
  49 (require 'muse)
  50 (require 'muse-project)
  51
  52 (eval-when-compile (require 'muse-mode))
  53
  54 (defgroup muse-backlink nil
  55   "Hierarchical backlinking for Muse."
  56   :group 'muse)
  57
  58 (defcustom muse-backlink-create-backlinks t
  59   "When non-nil, create hierarchical backlinks in new Muse pages.
  60 For control over which pages will receive backlinks, see
  61 `muse-backlink-exclude-backlink-parent-regexp' and
  62 `muse-backlink-exclude-backlink-regexp'."
  63   :type 'boolean
  64   :group 'muse-backlink)
  65
  66 (defcustom muse-backlink-avoid-bad-links t
  67   "When non-nil, avoid bad links when backlinking."
  68   :type 'boolean
  69   :group 'muse-backlink)
  70
  71 ;; The default for exclusion stops backlinks from being added to and
  72 ;; from planner day pages.
  73 (defcustom muse-backlink-exclude-backlink-parent-regexp
  74   "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
  75   "Regular expression matching pages whose children should not have backlinks."
  76   :type 'regexp
  77   :group 'muse-backlink)
  78
  79 (defcustom muse-backlink-exclude-backlink-regexp
  80   "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
  81   "Regular expression matching pages that should not have backlinks."
  82   :type 'regexp
  83   :group 'muse-backlink)
  84
  85 (defcustom muse-backlink-separator "/"
  86   "String that separates backlinks.
  87 Should be something that will not appear as a substring in an explicit
  88 link that has no description."
  89   :type 'string
  90   :group 'muse-backlink)
  91
  92 (defcustom muse-backlink-before-string "backlinks: "
  93   "String to come before the backlink list."
  94   :type 'string
  95   :group 'muse-backlink)
  96
  97 (defcustom muse-backlink-after-string ""
  98   "String to come after the backlink list."
  99   :type 'string
 100   :group 'muse-backlink)
 101
 102 (defcustom muse-backlink-separator "/"
 103   "String that separates backlinks.
 104 Should be something that will not appear as a substring in an explicit
 105 link that has no description."
 106   :type 'string
 107   :group 'muse-backlink)
 108
 109 (defcustom muse-backlink-regexp
 110   (concat "^"
 111           (regexp-quote muse-backlink-before-string)
 112           "\\("
 113           (regexp-quote muse-backlink-separator)
 114           ".+\\)"
 115           (regexp-quote muse-backlink-after-string))
 116   ;; Really, I want something like this, but I can't make it work:
 117   ;;   (concat "^\\("
 118   ;;           (regexp-quote muse-backlink-separator)
 119   ;;           "\\(?:"
 120   ;;           muse-explicit-link-regexp
 121   ;;           "\\)\\)+")
 122   "Regular expression to match backlinks in a buffer.
 123 Match 1 is the list of backlinks without `muse-backlink-before-string'
 124 and `muse-backlink-after-string'."
 125   :type 'regexp
 126   :group 'muse-backlink)
 127
 128 (defun muse-backlink-goto-insertion-point ()
 129   "Find the right place to add backlinks."
 130   (goto-char (point-min))
 131   (when (looking-at "\\(?:^#.+[ \t]*\n\\)+")
 132     (goto-char (match-end 0))))
 133
 134 (defun muse-backlink-get-current ()
 135   "Return a list of backlinks in the current buffer."
 136   (save-excursion
 137     (goto-char (point-min))
 138     (when (re-search-forward muse-backlink-regexp nil t)
 139       (split-string (match-string 1)
 140                     (regexp-quote muse-backlink-separator) t))))
 141
 142 (defun muse-backlink-format-link-list (links)
 143   "Format the list of LINKS as backlinks."
 144   (concat muse-backlink-separator
 145           (mapconcat #'identity links muse-backlink-separator)))
 146
 147 (defun muse-backlink-insert-links (links)
 148   "Insert backlinks to LINKS into the current page.
 149 LINKS is a list of links ordered by ancestry, with the parent as the
 150 last element."
 151   (muse-backlink-goto-insertion-point)
 152   (insert muse-backlink-before-string
 153           (muse-backlink-format-link-list links)
 154           muse-backlink-after-string
 155           ;; Could have this in the after string, but they might get
 156           ;; deleted.
 157           "\n\n"))
 158
 159 (defun muse-backlink-unsaved-page-p (page project)
 160   "Return non-nil if PAGE is in PROJECT but has not been saved."
 161   (member
 162    page
 163    (mapcar
 164     #'(lambda (b)
 165         (with-current-buffer b
 166           (and (derived-mode-p 'muse-mode)
 167                (equal muse-current-project project)
 168                (not (muse-project-page-file
 169                      (muse-page-name)
 170                      muse-current-project))
 171                (muse-page-name))))
 172     (buffer-list))))
 173
 174 (defvar muse-backlink-links nil
 175   "Internal variable.
 176 The links to insert in the forthcomingly visited muse page.")
 177
 178 (defvar muse-backlink-parent-buffer nil
 179   "Internal variable.
 180 The parent buffer of the forthcomingly visited muse page.")
 181
 182 (defun muse-backlink-insert-hook-func ()
 183   "Insert backlinks into the current buffer and clean up."
 184   (unwind-protect
 185       (when muse-backlink-links
 186         (muse-backlink-insert-links muse-backlink-links)
 187         (when muse-backlink-avoid-bad-links
 188           (save-buffer)
 189           (when muse-backlink-parent-buffer
 190             (with-current-buffer muse-backlink-parent-buffer
 191               (font-lock-fontify-buffer)))))
 192     (setq muse-backlink-links nil
 193           muse-backlink-parent-buffer nil)
 194     (remove-hook 'muse-mode-hook #'muse-backlink-insert-hook-func)))
 195
 196 (defun muse-backlink-handle-link (link)
 197   "When appropriate, arrange for backlinks on visiting LINK."
 198   (when (and muse-backlink-create-backlinks
 199              (memq this-command
 200                    '(muse-follow-name-at-point muse-follow-name-at-mouse))
 201              (not muse-publishing-p)
 202              (not (and (boundp 'muse-colors-fontifying-p)
 203                        muse-colors-fontifying-p)))
 204     (require 'muse-mode)
 205     (setq
 206      muse-backlink-links
 207      (save-match-data
 208        (let* ((orig-link (or link (match-string 1)))
 209               (link (if (string-match "#" orig-link)
 210                         (substring orig-link 0 (match-beginning 0))
 211                       orig-link)))
 212          (unless
 213              (or (not muse-current-project)
 214                  (string-match muse-url-regexp orig-link)
 215                  (string-match muse-image-regexp orig-link)
 216                  (and (boundp 'muse-wiki-interwiki-regexp)
 217                       (string-match muse-wiki-interwiki-regexp
 218                                     orig-link))
 219                  ;; Don't add a backlink if the page already
 220                  ;; exists, whether it has been saved or not.
 221                  (or (muse-project-page-file link muse-current-project)
 222                      (muse-backlink-unsaved-page-p link muse-current-project))
 223                  (string-match muse-backlink-exclude-backlink-parent-regexp
 224                                (muse-page-name))
 225                  (string-match muse-backlink-exclude-backlink-regexp link))
 226            (add-hook 'muse-mode-hook #'muse-backlink-insert-hook-func)
 227            (when muse-backlink-avoid-bad-links
 228              (setq muse-backlink-parent-buffer (current-buffer))
 229              (unless (muse-project-page-file
 230                       (muse-page-name) muse-current-project)
 231                ;; It must be modified...
 232                (save-buffer)))
 233            (append (muse-backlink-get-current)
 234                    (list (muse-make-link (muse-page-name)))))))))
 235   ;; Make sure we always return nil
 236   nil)
 237
 238 (defun muse-backlink-install ()
 239   "Add backlinking functionality to muse-mode."
 240   (add-to-list 'muse-explicit-link-functions #'muse-backlink-handle-link))
 241
 242 (defun muse-backlink-remove ()
 243   "Remove backlinking functionality from muse-mode."
 244   (setq muse-explicit-link-functions
 245         (delq #'muse-backlink-handle-link muse-explicit-link-functions)))
 246
 247 (provide 'muse-backlink)
 248 ;;; muse-backlink.el ends here