lisp/muse-backlink.el

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