328 lines
12 KiB
EmacsLisp
328 lines
12 KiB
EmacsLisp
|
;;; 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
|