1 files changed, 327 insertions, 0 deletions
diff --git a/emacs.d/elisp/muse/muse-backlink.el b/emacs.d/elisp/muse/muse-backlink.el
new file mode 100644
index 0000000..bc21ddd
--- /dev/null
+++ b/emacs.d/elisp/muse/muse-backlink.el
@@ -0,0 +1,327 @@
+;;; muse-backlink.el --- backlinks for Muse
+
+;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
+;;   Free Software Foundation, Inc.
+
+;; Author: Jim Ottaway <j.ottaway@lse.ac.uk>
+;; Keywords:
+
+;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
+
+;; Emacs Muse 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.
+
+;; Emacs Muse 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 Emacs Muse; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Hierarchical backlink insertion into new muse pages.
+;;
+;; To add:
+;;
+;; (require 'muse-backlink)
+;; (muse-backlink-install)
+;;
+;; To control what gets backlinked, modify
+;; `muse-backlink-exclude-backlink-regexp' and
+;; `muse-backlink-exclude-backlink-parent-regexp'.
+;;
+;; To stop backlinking temporarily:
+;; (setq muse-backlink-create-backlinks nil)
+;;
+;; To remove the backlink functionality completely:
+;;
+;; (muse-backlink-remove)
+
+;;; Contributors:
+
+;;; Code:
+
+(require 'muse)
+(require 'muse-project)
+
+(eval-when-compile (require 'muse-mode))
+
+(eval-and-compile
+  (if (< emacs-major-version 22)
+      (progn
+        ;; Swiped from Emacs 22.0.50.4
+        (defvar muse-backlink-split-string-default-separators "[ \f\t\n\r\v]+"
+        "The default value of separators for `split-string'.
+
+A regexp matching strings of whitespace.  May be locale-dependent
+\(as yet unimplemented).  Should not match non-breaking spaces.
+
+Warning: binding this to a different value and using it as default is
+likely to have undesired semantics.")
+
+        (defun muse-backlink-split-string (string &optional separators omit-nulls)
+        "Split STRING into substrings bounded by matches for SEPARATORS.
+
+The beginning and end of STRING, and each match for SEPARATORS, are
+splitting points.  The substrings matching SEPARATORS are removed, and
+the substrings between the splitting points are collected as a list,
+which is returned.
+
+If SEPARATORS is non-nil, it should be a regular expression matching text
+which separates, but is not part of, the substrings.  If nil it defaults to
+`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
+OMIT-NULLS is forced to t.
+
+If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
+that for the default value of SEPARATORS leading and trailing whitespace
+are effectively trimmed).  If nil, all zero-length substrings are retained,
+which correctly parses CSV format, for example.
+
+Note that the effect of `(split-string STRING)' is the same as
+`(split-string STRING split-string-default-separators t)').  In the rare
+case that you wish to retain zero-length substrings when splitting on
+whitespace, use `(split-string STRING split-string-default-separators)'.
+
+Modifies the match data; use `save-match-data' if necessary."
+        (let ((keep-nulls (not (if separators omit-nulls t)))
+              (rexp (or separators muse-backlink-split-string-default-separators))
+              (start 0)
+              notfirst
+              (list nil))
+          (while (and (string-match rexp string
+                                    (if (and notfirst
+                                             (= start (match-beginning 0))
+                                             (< start (length string)))
+                                        (1+ start) start))
+                      (< start (length string)))
+            (setq notfirst t)
+            (if (or keep-nulls (< start (match-beginning 0)))
+                (setq list
+                      (cons (substring string start (match-beginning 0))
+                            list)))
+            (setq start (match-end 0)))
+          (if (or keep-nulls (< start (length string)))
+              (setq list
+                    (cons (substring string start)
+                          list)))
+          (nreverse list))))
+    (defalias 'muse-backlink-split-string 'split-string)))
+
+(defgroup muse-backlink nil
+  "Hierarchical backlinking for Muse."
+  :group 'muse)
+
+(defcustom muse-backlink-create-backlinks t
+  "When non-nil, create hierarchical backlinks in new Muse pages.
+For control over which pages will receive backlinks, see
+`muse-backlink-exclude-backlink-parent-regexp' and
+`muse-backlink-exclude-backlink-regexp'."
+  :type 'boolean
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-avoid-bad-links t
+  "When non-nil, avoid bad links when backlinking."
+  :type 'boolean
+  :group 'muse-backlink)
+
+;; The default for exclusion stops backlinks from being added to and
+;; from planner day pages.
+(defcustom muse-backlink-exclude-backlink-parent-regexp
+  "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
+  "Regular expression matching pages whose children should not have backlinks."
+  :type 'regexp
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-exclude-backlink-regexp
+  "^[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]$"
+  "Regular expression matching pages that should not have backlinks."
+  :type 'regexp
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-separator "/"
+  "String that separates backlinks.
+Should be something that will not appear as a substring in an explicit
+link that has no description."
+  :type 'string
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-before-string "backlinks: "
+  "String to come before the backlink list."
+  :type 'string
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-after-string ""
+  "String to come after the backlink list."
+  :type 'string
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-separator "/"
+  "String that separates backlinks.
+Should be something that will not appear as a substring in an explicit
+link that has no description."
+  :type 'string
+  :group 'muse-backlink)
+
+(defcustom muse-backlink-regexp
+  (concat "^"
+          (regexp-quote muse-backlink-before-string)
+          "\\("
+          (regexp-quote muse-backlink-separator)
+          ".+\\)"
+          (regexp-quote muse-backlink-after-string))
+  ;; Really, I want something like this, but I can't make it work:
+  ;;   (concat "^\\("
+  ;;           (regexp-quote muse-backlink-separator)
+  ;;           "\\(?:"
+  ;;           muse-explicit-link-regexp
+  ;;           "\\)\\)+")
+  "Regular expression to match backlinks in a buffer.
+Match 1 is the list of backlinks without `muse-backlink-before-string'
+and `muse-backlink-after-string'."
+  :type 'regexp
+  :group 'muse-backlink)
+
+(defun muse-backlink-goto-insertion-point ()
+  "Find the right place to add backlinks."
+  (goto-char (point-min))
+  (when (looking-at "\\(?:^#.+[ \t]*\n\\)+")
+    (goto-char (match-end 0))))
+
+(defun muse-backlink-get-current ()
+  "Return a list of backlinks in the current buffer."
+  (save-excursion
+    (goto-char (point-min))
+    (when (re-search-forward muse-backlink-regexp nil t)
+      (muse-backlink-split-string
+       (match-string 1)
+       (regexp-quote muse-backlink-separator) t))))
+
+(defun muse-backlink-format-link-list (links)
+  "Format the list of LINKS as backlinks."
+  (concat muse-backlink-separator
+          (mapconcat #'identity links muse-backlink-separator)))
+
+(defun muse-backlink-insert-links (links)
+  "Insert backlinks to LINKS into the current page.
+LINKS is a list of links ordered by ancestry, with the parent as the
+last element."
+  (muse-backlink-goto-insertion-point)
+  (insert muse-backlink-before-string
+          (muse-backlink-format-link-list links)
+          muse-backlink-after-string
+          ;; Could have this in the after string, but they might get
+          ;; deleted.
+          "\n\n"))
+
+(defun muse-backlink-unsaved-page-p (page project)
+  "Return non-nil if PAGE is in PROJECT but has not been saved."
+  (member
+   page
+   (mapcar
+    #'(lambda (b)
+        (with-current-buffer b
+          (and (derived-mode-p 'muse-mode)
+               (equal muse-current-project project)
+               (not (muse-project-page-file
+                     (muse-page-name)
+                     muse-current-project))
+               (muse-page-name))))
+    (buffer-list))))
+
+(defvar muse-backlink-links nil
+  "Internal variable.
+The links to insert in the forthcomingly visited muse page.")
+
+(defvar muse-backlink-pending nil
+  "Internal variable.")
+
+(defvar muse-backlink-parent-buffer nil
+  "Internal variable.
+The parent buffer of the forthcomingly visited muse page.")
+
+
+;;; Attach hook to the derived mode hook, to avoid problems such as
+;;; planner-prepare-file thinking that the buffer needs no template.
+(defun muse-backlink-get-mode-hook ()
+  (derived-mode-hook-name major-mode))
+
+(defun muse-backlink-insert-hook-func ()
+  "Insert backlinks into the current buffer and clean up."
+  (when (and muse-backlink-links
+             muse-backlink-pending
+             (string= (car muse-backlink-links) (muse-page-name)))
+    (muse-backlink-insert-links (cdr muse-backlink-links))
+    (when muse-backlink-avoid-bad-links
+      (save-buffer)
+      (when muse-backlink-parent-buffer
+        (with-current-buffer muse-backlink-parent-buffer
+          (font-lock-fontify-buffer))))
+    (setq muse-backlink-links nil
+          muse-backlink-parent-buffer nil
+          muse-backlink-pending nil)
+    (remove-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func)))
+
+(defun muse-backlink-handle-link (link)
+  "When appropriate, arrange for backlinks on visiting LINK."
+  (when (and muse-backlink-create-backlinks
+             (not muse-backlink-pending)
+             (memq this-command
+                   '(muse-follow-name-at-point muse-follow-name-at-mouse))
+             (not muse-publishing-p)
+             (not (and (boundp 'muse-colors-fontifying-p)
+                       muse-colors-fontifying-p)))
+    (require 'muse-mode)
+    (setq
+     muse-backlink-links
+     (save-match-data
+       (let* ((orig-link (or link (match-string 1)))
+              (link (if (string-match "#" orig-link)
+                        (substring orig-link 0 (match-beginning 0))
+                      orig-link)))
+         (unless
+             (or (not muse-current-project)
+                 (string-match muse-url-regexp orig-link)
+                 (string-match muse-image-regexp orig-link)
+                 (and (boundp 'muse-wiki-interwiki-regexp)
+                      (string-match muse-wiki-interwiki-regexp
+                                    orig-link))
+                 ;; Don't add a backlink if the page already
+                 ;; exists, whether it has been saved or not.
+                 (or (muse-project-page-file link muse-current-project)
+                     (muse-backlink-unsaved-page-p link muse-current-project))
+                 (string-match muse-backlink-exclude-backlink-parent-regexp
+                               (muse-page-name))
+                 (string-match muse-backlink-exclude-backlink-regexp link))
+           ;; todo: Hmm. This will only work if the child page is the
+           ;; same mode as the parent page.
+           (add-hook (muse-backlink-get-mode-hook) #'muse-backlink-insert-hook-func)
+           (setq muse-backlink-pending t)
+           (when muse-backlink-avoid-bad-links
+             (setq muse-backlink-parent-buffer (current-buffer))
+             (unless (muse-project-page-file
+                      (muse-page-name) muse-current-project)
+               ;; It must be modified...
+               (save-buffer)))
+           (cons link
+                 (append (muse-backlink-get-current)
+                         (list (muse-make-link (muse-page-name))))))))))
+  ;; Make sure we always return nil
+  nil)
+
+(defun muse-backlink-install ()
+  "Add backlinking functionality to muse-mode."
+  (add-to-list 'muse-explicit-link-functions #'muse-backlink-handle-link))
+
+(defun muse-backlink-remove ()
+  "Remove backlinking functionality from muse-mode."
+  (setq muse-explicit-link-functions
+        (delq #'muse-backlink-handle-link muse-explicit-link-functions)))
+
+(provide 'muse-backlink)
+;;; muse-backlink.el ends here