1 ;;; muse-backlink.el --- backlinks for Muse
3 ;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2014
4 ;; Free Software Foundation, Inc.
6 ;; Author: Jim Ottaway <j.ottaway@lse.ac.uk>
9 ;; This file is part of Emacs Muse. It is not part of GNU Emacs.
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.
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.
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.
28 ;; Hierarchical backlink insertion into new muse pages.
32 ;; (require 'muse-backlink)
33 ;; (muse-backlink-install)
35 ;; To control what gets backlinked, modify
36 ;; `muse-backlink-exclude-backlink-regexp' and
37 ;; `muse-backlink-exclude-backlink-parent-regexp'.
39 ;; To stop backlinking temporarily:
40 ;; (setq muse-backlink-create-backlinks nil)
42 ;; To remove the backlink functionality completely:
44 ;; (muse-backlink-remove)
51 (require 'muse-project)
53 (eval-when-compile (require 'muse-mode))
56 (if (< emacs-major-version 22)
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'.
62 A regexp matching strings of whitespace. May be locale-dependent
63 \(as yet unimplemented). Should not match non-breaking spaces.
65 Warning: binding this to a different value and using it as default is
66 likely to have undesired semantics.")
68 (defun muse-backlink-split-string (string &optional separators omit-nulls)
69 "Split STRING into substrings bounded by matches for SEPARATORS.
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,
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.
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.
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)'.
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))
97 (while (and (string-match rexp string
99 (= start (match-beginning 0))
100 (< start (length string)))
102 (< start (length string)))
104 (if (or keep-nulls (< start (match-beginning 0)))
106 (cons (substring string start (match-beginning 0))
108 (setq start (match-end 0)))
109 (if (or keep-nulls (< start (length string)))
111 (cons (substring string start)
114 (defalias 'muse-backlink-split-string 'split-string)))
116 (defgroup muse-backlink nil
117 "Hierarchical backlinking for Muse."
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'."
126 :group 'muse-backlink)
128 (defcustom muse-backlink-avoid-bad-links t
129 "When non-nil, avoid bad links when backlinking."
131 :group 'muse-backlink)
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."
139 :group 'muse-backlink)
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."
145 :group 'muse-backlink)
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."
152 :group 'muse-backlink)
154 (defcustom muse-backlink-before-string "backlinks: "
155 "String to come before the backlink list."
157 :group 'muse-backlink)
159 (defcustom muse-backlink-after-string ""
160 "String to come after the backlink list."
162 :group 'muse-backlink)
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."
169 :group 'muse-backlink)
171 (defcustom muse-backlink-regexp
173 (regexp-quote muse-backlink-before-string)
175 (regexp-quote muse-backlink-separator)
177 (regexp-quote muse-backlink-after-string))
178 ;; Really, I want something like this, but I can't make it work:
180 ;; (regexp-quote muse-backlink-separator)
182 ;; muse-explicit-link-regexp
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'."
188 :group 'muse-backlink)
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))))
196 (defun muse-backlink-get-current ()
197 "Return a list of backlinks in the current buffer."
199 (goto-char (point-min))
200 (when (re-search-forward muse-backlink-regexp nil t)
201 (muse-backlink-split-string
203 (regexp-quote muse-backlink-separator) t))))
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)))
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
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
222 (defun muse-backlink-unsaved-page-p (page project)
223 "Return non-nil if PAGE is in PROJECT but has not been saved."
228 (with-current-buffer b
229 (and (derived-mode-p 'muse-mode)
230 (equal muse-current-project project)
231 (not (muse-project-page-file
233 muse-current-project))
237 (defvar muse-backlink-links nil
239 The links to insert in the forthcomingly visited muse page.")
241 (defvar muse-backlink-pending nil
242 "Internal variable.")
244 (defvar muse-backlink-parent-buffer nil
246 The parent buffer of the forthcomingly visited muse page.")
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))
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
262 (when muse-backlink-parent-buffer
263 (with-current-buffer muse-backlink-parent-buffer
264 (font-lock-fontify-buffer)))) ;FIXME: Why? --Stef
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)))
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)
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)))
283 (let* ((orig-link (or link (match-string 1)))
284 (link (if (string-match "#" orig-link)
285 (substring orig-link 0 (match-beginning 0))
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
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
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...
312 (append (muse-backlink-get-current)
313 (list (muse-make-link (muse-page-name))))))))))
314 ;; Make sure we always return nil
317 (defun muse-backlink-install ()
318 "Add backlinking functionality to muse-mode."
319 (add-to-list 'muse-explicit-link-functions #'muse-backlink-handle-link))
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)))
326 (provide 'muse-backlink)
327 ;;; muse-backlink.el ends here