1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
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
|
