lisp/muse-backlink.el

   1 ;;; muse-backlink.el --- backlinks for Muse
   2
   3 ;; Copyright (C) 2005, 2006, 2007, 2008  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 3, 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 (eval-and-compile
  55   (if (< emacs-major-version 22)
  56       (progn
  57         ;; Swiped from Emacs 22.0.50.4
  58         (defvar muse-backlink-split-string-default-separators "[ \f\t\n\r\v]+"
  59         "The default value of separators for `split-string'.
  60
  61 A regexp matching strings of whitespace.  May be locale-dependent
  62 \(as yet unimplemented).  Should not match non-breaking spaces.
  63
  64 Warning: binding this to a different value and using it as default is
  65 likely to have undesired semantics.")
  66
  67         (defun muse-backlink-split-string (string &optional separators omit-nulls)
  68         "Split STRING into substrings bounded by matches for SEPARATORS.
  69
  70 The beginning and end of STRING, and each match for SEPARATORS, are
  71 splitting points.  The substrings matching SEPARATORS are removed, and
  72 the substrings between the splitting points are collected as a list,
  73 which is returned.
  74
  75 If SEPARATORS is non-nil, it should be a regular expression matching text
  76 which separates, but is not part of, the substrings.  If nil it defaults to
  77 `split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
  78 OMIT-NULLS is forced to t.
  79
  80 If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
  81 that for the default value of SEPARATORS leading and trailing whitespace
  82 are effectively trimmed).  If nil, all zero-length substrings are retained,
  83 which correctly parses CSV format, for example.
  84
  85 Note that the effect of `(split-string STRING)' is the same as
  86 `(split-string STRING split-string-default-separators t)').  In the rare
  87 case that you wish to retain zero-length substrings when splitting on
  88 whitespace, use `(split-string STRING split-string-default-separators)'.
  89
  90 Modifies the match data; use `save-match-data' if necessary."
  91         (let ((keep-nulls (not (if separators omit-nulls t)))
  92               (rexp (or separators muse-backlink-split-string-default-separators))
  93               (start 0)
  94               notfirst
  95               (list nil))
  96           (while (and (string-match rexp string
  97                                     (if (and notfirst
  98                                              (= start (match-beginning 0))
  99                                              (< start (length string)))
 100                                         (1+ start) start))
 101                       (< start (length string)))
 102             (setq notfirst t)
 103             (if (or keep-nulls (< start (match-beginning 0)))
 104                 (setq list
 105                       (cons (substring string start (match-beginning 0))
 106                             list)))
 107             (setq start (match-end 0)))
 108           (if (or keep-nulls (< start (length string)))
 109               (setq list
 110                     (cons (substring string start)
 111                           list)))
 112           (nreverse list))))
 113     (defalias 'muse-backlink-split-string 'split-string)))
 114
 115 (defgroup muse-backlink nil
 116   "Hierarchical backlinking for Muse."
 117   :group 'muse)
 118
 119 (defcustom muse-backlink-create-backlinks t
 120   "When non-nil, create hierarchical backlinks in new Muse pages.
 121 For control over which pages will receive backlinks, see
 122 `muse-backlink-exclude-backlink-parent-regexp' and
 123 `muse-backlink-exclude-backlink-regexp'."
 124   :type 'boolean
 125   :group 'muse-backlink)
 126
 127 (defcustom muse-backlink-avoid-bad-links t
 128   "When non-nil, avoid bad links when backlinking."
 129   :type 'boolean
 130   :group 'muse-backlink)
 131
 132 ;; The default for exclusion stops backlinks from being added to and
 133 ;; from planner day pages.
 134 (defcustom muse-backlink-exclude-backlink-parent-regexp
 135   "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
 136   "Regular expression matching pages whose children should not have backlinks."
 137   :type 'regexp
 138   :group 'muse-backlink)
 139
 140 (defcustom muse-backlink-exclude-backlink-regexp
 141   "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
 142   "Regular expression matching pages that should not have backlinks."
 143   :type 'regexp
 144   :group 'muse-backlink)
 145
 146 (defcustom muse-backlink-separator "/"
 147   "String that separates backlinks.
 148 Should be something that will not appear as a substring in an explicit
 149 link that has no description."
 150   :type 'string
 151   :group 'muse-backlink)
 152
 153 (defcustom muse-backlink-before-string "backlinks: "
 154   "String to come before the backlink list."
 155   :type 'string
 156   :group 'muse-backlink)
 157
 158 (defcustom muse-backlink-after-string ""
 159   "String to come after the backlink list."
 160   :type 'string
 161   :group 'muse-backlink)
 162
 163 (defcustom muse-backlink-separator "/"
 164   "String that separates backlinks.
 165 Should be something that will not appear as a substring in an explicit
 166 link that has no description."
 167   :type 'string
 168   :group 'muse-backlink)
 169
 170 (defcustom muse-backlink-regexp
 171   (concat "^"
 172           (regexp-quote muse-backlink-before-string)
 173           "\\("
 174           (regexp-quote muse-backlink-separator)
 175           ".+\\)"
 176           (regexp-quote muse-backlink-after-string))
 177   ;; Really, I want something like this, but I can't make it work:
 178   ;;   (concat "^\\("
 179   ;;           (regexp-quote muse-backlink-separator)
 180   ;;           "\\(?:"
 181   ;;           muse-explicit-link-regexp
 182   ;;           "\\)\\)+")
 183   "Regular expression to match backlinks in a buffer.
 184 Match 1 is the list of backlinks without `muse-backlink-before-string'
 185 and `muse-backlink-after-string'."
 186   :type 'regexp
 187   :group 'muse-backlink)
 188
 189 (defun muse-backlink-goto-insertion-point ()
 190   "Find the right place to add backlinks."
 191   (goto-char (point-min))
 192   (when (looking-at "\\(?:^#.+[ \t]*\n\\)+")
 193     (goto-char (match-end 0))))
 194
 195 (defun muse-backlink-get-current ()
 196   "Return a list of backlinks in the current buffer."
 197   (save-excursion
 198     (goto-char (point-min))
 199     (when (re-search-forward muse-backlink-regexp nil t)
 200       (muse-backlink-split-string
 201        (match-string 1)
 202        (regexp-quote muse-backlink-separator) t))))
 203
 204 (defun muse-backlink-format-link-list (links)
 205   "Format the list of LINKS as backlinks."
 206   (concat muse-backlink-separator
 207           (mapconcat #'identity links muse-backlink-separator)))
 208
 209 (defun muse-backlink-insert-links (links)
 210   "Insert backlinks to LINKS into the current page.
 211 LINKS is a list of links ordered by ancestry, with the parent as the
 212 last element."
 213   (muse-backlink-goto-insertion-point)
 214   (insert muse-backlink-before-string
 215           (muse-backlink-format-link-list links)
 216           muse-backlink-after-string
 217           ;; Could have this in the after string, but they might get
 218           ;; deleted.
 219           "\n\n"))
 220
 221 (defun muse-backlink-unsaved-page-p (page project)
 222   "Return non-nil if PAGE is in PROJECT but has not been saved."
 223   (member
 224    page
 225    (mapcar
 226     #'(lambda (b)
 227         (with-current-buffer b
 228           (and (derived-mode-p 'muse-mode)
 229                (equal muse-current-project project)
 230                (not (muse-project-page-file
 231                      (muse-page-name)
 232                      muse-current-project))
 233                (muse-page-name))))
 234     (buffer-list))))
 235
 236 (defvar muse-backlink-links nil
 237   "Internal variable.
 238 The links to insert in the forthcomingly visited muse page.")
 239
 240 (defvar muse-backlink-pending nil
 241   "Internal variable.")
 242
 243 (defvar muse-backlink-parent-buffer nil
 244   "Internal variable.
 245 The parent buffer of the forthcomingly visited muse page.")
 246
 247
 248 ;;; Attach hook to the derived mode hook, to avoid problems such as
 249 ;;; planner-prepare-file thinking that the buffer needs no template.
 250 (defun muse-backlink-get-mode-hook ()
 251   (derived-mode-hook-name major-mode))
 252
 253 (defun muse-backlink-insert-hook-func ()
 254   "Insert backlinks into the current buffer and clean up."
 255   (when (and muse-backlink-links
 256              muse-backlink-pending
 257              (string= (car muse-backlink-links) (muse-page-name)))
 258     (muse-backlink-insert-links (cdr muse-backlink-links))
 259     (when muse-backlink-avoid-bad-links
 260       (save-buffer)
 261       (when muse-backlink-parent-buffer
 262         (with-current-buffer muse-backlink-parent-buffer
 263           (font-lock-fontify-buffer))))
 264     (setq muse-backlink-links nil
 265           muse-backlink-parent-buffer nil
 266           muse-backlink-pending nil)
 267     (remove-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func)))
 268
 269 (defun muse-backlink-handle-link (link)
 270   "When appropriate, arrange for backlinks on visiting LINK."
 271   (when (and muse-backlink-create-backlinks
 272              (not muse-backlink-pending)
 273              (memq this-command
 274                    '(muse-follow-name-at-point muse-follow-name-at-mouse))
 275              (not muse-publishing-p)
 276              (not (and (boundp 'muse-colors-fontifying-p)
 277                        muse-colors-fontifying-p)))
 278     (require 'muse-mode)
 279     (setq
 280      muse-backlink-links
 281      (save-match-data
 282        (let* ((orig-link (or link (match-string 1)))
 283               (link (if (string-match "#" orig-link)
 284                         (substring orig-link 0 (match-beginning 0))
 285                       orig-link)))
 286          (unless
 287              (or (not muse-current-project)
 288                  (string-match muse-url-regexp orig-link)
 289                  (string-match muse-image-regexp orig-link)
 290                  (and (boundp 'muse-wiki-interwiki-regexp)
 291                       (string-match muse-wiki-interwiki-regexp
 292                                     orig-link))
 293                  ;; Don't add a backlink if the page already
 294                  ;; exists, whether it has been saved or not.
 295                  (or (muse-project-page-file link muse-current-project)
 296                      (muse-backlink-unsaved-page-p link muse-current-project))
 297                  (string-match muse-backlink-exclude-backlink-parent-regexp
 298                                (muse-page-name))
 299                  (string-match muse-backlink-exclude-backlink-regexp link))
 300            ;; todo: Hmm. This will only work if the child page is the
 301            ;; same mode as the parent page.
 302            (add-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func)
 303            (setq muse-backlink-pending t)
 304            (when muse-backlink-avoid-bad-links
 305              (setq muse-backlink-parent-buffer (current-buffer))
 306              (unless (muse-project-page-file
 307                       (muse-page-name) muse-current-project)
 308                ;; It must be modified...
 309                (save-buffer)))
 310            (cons link
 311                  (append (muse-backlink-get-current)
 312                          (list (muse-make-link (muse-page-name))))))))))
 313   ;; Make sure we always return nil
 314   nil)
 315
 316 (defun muse-backlink-install ()
 317   "Add backlinking functionality to muse-mode."
 318   (add-to-list 'muse-explicit-link-functions #'muse-backlink-handle-link))
 319
 320 (defun muse-backlink-remove ()
 321   "Remove backlinking functionality from muse-mode."
 322   (setq muse-explicit-link-functions
 323         (delq #'muse-backlink-handle-link muse-explicit-link-functions)))
 324
 325 (provide 'muse-backlink)
 326 ;;; muse-backlink.el ends here