code.delx.au - gnu-emacs/blob - lisp/mail/footnote.el

   1 ;;; footnote.el --- footnote support for message mode  -*- coding: iso-latin-1;-*-
   2
   3 ;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Steven L Baur <steve@xemacs.org>
   7 ;; Keywords: mail, news
   8 ;; Version: 0.19
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
  25 ;; MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This file provides footnote[1] support for message-mode in emacsen.
  30 ;; footnote-mode is implemented as a minor mode.
  31
  32 ;; [1] Footnotes look something like this.  Along with some decorative
  33 ;; stuff.
  34
  35 ;; TODO:
  36 ;; Reasonable Undo support.
  37 ;; more language styles.
  38
  39 ;;; Code:
  40
  41 (eval-when-compile
  42   (require 'cl)
  43   (defvar filladapt-token-table))
  44
  45 (defgroup footnote nil
  46   "Support for footnotes in mail and news messages."
  47   :version "21.1"
  48   :group 'message)
  49
  50 (defcustom footnote-mode-line-string " FN"
  51   "*String to display in modes section of the mode-line."
  52   :group 'footnote)
  53
  54 (defcustom footnote-mode-hook nil
  55   "*Hook functions run when footnote-mode is activated."
  56   :type 'hook
  57   :group 'footnote)
  58
  59 (defcustom footnote-narrow-to-footnotes-when-editing nil
  60   "*If set, narrow to footnote text body while editing a footnote."
  61   :type 'boolean
  62   :group 'footnote)
  63
  64 (defcustom footnote-prompt-before-deletion t
  65   "*If set, prompt before deleting a footnote.
  66 There is currently no way to undo deletions."
  67   :type 'boolean
  68   :group 'footnote)
  69
  70 (defcustom footnote-spaced-footnotes t
  71   "If set true it will put a blank line between each footnote.
  72 If nil, no blank line will be inserted."
  73   :type 'boolean
  74   :group 'footnote)
  75
  76 (defcustom footnote-use-message-mode t
  77   "*If non-nil assume Footnoting will be done in message-mode."
  78   :type 'boolean
  79   :group 'footnote)
  80
  81 (defcustom footnote-body-tag-spacing 2
  82   "*Number of blanks separating a footnote body tag and its text."
  83   :type 'integer
  84   :group 'footnote)
  85
  86 (defvar footnote-prefix [(control ?c) ?!]
  87   "*When not using message mode, the prefix to bind in `mode-specific-map'")
  88
  89 ;;; Interface variables that probably shouldn't be changed
  90
  91 (defcustom footnote-section-tag "Footnotes: "
  92   "*Tag inserted at beginning of footnote section."
  93   :version "22.1"
  94   :type 'string
  95   :group 'footnote)
  96
  97 (defcustom footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?: "
  98   "*Regexp which indicates the start of a footnote section.
  99 See also `footnote-section-tag'."
 100   :type 'regexp
 101   :group 'footnote)
 102
 103 ;; The following three should be consumed by footnote styles.
 104 (defcustom footnote-start-tag "["
 105   "*String used to denote start of numbered footnote."
 106   :type 'string
 107   :group 'footnote)
 108
 109 (defcustom footnote-end-tag "]"
 110   "*String used to denote end of numbered footnote."
 111   :type 'string
 112   :group 'footnote)
 113
 114 (defvar footnote-signature-separator (if (boundp 'message-signature-separator)
 115                                          message-signature-separator
 116                                        "^-- $")
 117   "*String used to recognize .signatures.")
 118
 119 ;;; Private variables
 120
 121 (defvar footnote-style-number nil
 122   "Footnote style represented as an index into footnote-style-alist.")
 123 (make-variable-buffer-local 'footnote-style-number)
 124
 125 (defvar footnote-text-marker-alist nil
 126   "List of markers pointing to text of footnotes in message buffer.")
 127 (make-variable-buffer-local 'footnote-text-marker-alist)
 128
 129 (defvar footnote-pointer-marker-alist nil
 130   "List of markers pointing to footnote pointers in message buffer.")
 131 (make-variable-buffer-local 'footnote-pointer-marker-alist)
 132
 133 (defvar footnote-mouse-highlight 'highlight
 134   "Text property name to enable mouse over highlight.")
 135
 136 (defvar footnote-mode nil
 137   "Variable indicating whether footnote minor mode is active.")
 138 (make-variable-buffer-local 'footnote-mode)
 139
 140 ;;; Default styles
 141 ;;; NUMERIC
 142 (defconst footnote-numeric-regexp "[0-9]+"
 143   "Regexp for digits.")
 144
 145 (defun Footnote-numeric (n)
 146   "Numeric footnote style.
 147 Use Arabic numerals for footnoting."
 148   (int-to-string n))
 149
 150 ;;; ENGLISH UPPER
 151 (defconst footnote-english-upper "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 152   "Upper case English alphabet.")
 153
 154 (defconst footnote-english-upper-regexp "[A-Z]+"
 155   "Regexp for upper case English alphabet.")
 156
 157 (defun Footnote-english-upper (n)
 158   "Upper case English footnoting.
 159 Wrapping around the alphabet implies successive repetitions of letters."
 160   (let* ((ltr (mod (1- n) (length footnote-english-upper)))
 161          (rep (/ (1- n) (length footnote-english-upper)))
 162          (chr (char-to-string (aref footnote-english-upper ltr)))
 163          rc)
 164     (while (>= rep 0)
 165       (setq rc (concat rc chr))
 166       (setq rep (1- rep)))
 167     rc))
 168
 169 ;;; ENGLISH LOWER
 170 (defconst footnote-english-lower "abcdefghijklmnopqrstuvwxyz"
 171   "Lower case English alphabet.")
 172
 173 (defconst footnote-english-lower-regexp "[a-z]+"
 174   "Regexp of lower case English alphabet.")
 175
 176 (defun Footnote-english-lower (n)
 177   "Lower case English footnoting.
 178 Wrapping around the alphabet implies successive repetitions of letters."
 179   (let* ((ltr (mod (1- n) (length footnote-english-lower)))
 180          (rep (/ (1- n) (length footnote-english-lower)))
 181          (chr (char-to-string (aref footnote-english-lower ltr)))
 182          rc)
 183     (while (>= rep 0)
 184       (setq rc (concat rc chr))
 185       (setq rep (1- rep)))
 186     rc))
 187
 188 ;;; ROMAN LOWER
 189 (defconst footnote-roman-lower-list
 190   '((1 . "i") (5 . "v") (10 . "x")
 191     (50 . "l") (100 . "c") (500 . "d") (1000 . "m"))
 192   "List of roman numerals with their values.")
 193
 194 (defconst footnote-roman-lower-regexp "[ivxlcdm]+"
 195   "Regexp of roman numerals.")
 196
 197 (defun Footnote-roman-lower (n)
 198   "Generic Roman number footnoting."
 199   (Footnote-roman-common n footnote-roman-lower-list))
 200
 201 ;;; ROMAN UPPER
 202 (defconst footnote-roman-upper-list
 203   '((1 . "I") (5 . "V") (10 . "X")
 204     (50 . "L") (100 . "C") (500 . "D") (1000 . "M"))
 205   "List of roman numerals with their values.")
 206
 207 (defconst footnote-roman-upper-regexp "[IVXLCDM]+"
 208   "Regexp of roman numerals.  Not complete")
 209
 210 (defun Footnote-roman-upper (n)
 211   "Generic Roman number footnoting."
 212   (Footnote-roman-common n footnote-roman-upper-list))
 213
 214 (defun Footnote-roman-common (n footnote-roman-list)
 215   "Lower case Roman footnoting."
 216   (let* ((our-list footnote-roman-list)
 217          (rom-lngth (length our-list))
 218          (rom-high 0)
 219          (rom-low 0)
 220          (rom-div -1)
 221          (count-high 0)
 222          (count-low 0))
 223     ;; find surrounding numbers
 224     (while (and (<= count-high (1- rom-lngth))
 225                 (>= n (car (nth count-high our-list))))
 226       ;; (message "Checking %d" (car (nth count-high our-list)))
 227       (setq count-high (1+ count-high)))
 228     (setq rom-high count-high)
 229     (setq rom-low (1- count-high))
 230     ;; find the appropriate divisor (if it exists)
 231     (while (and (= rom-div -1)
 232                 (< count-low rom-high))
 233       (when (or (> n (- (car (nth rom-high our-list))
 234                         (/ (car (nth count-low our-list))
 235                            2)))
 236                 (= n (- (car (nth rom-high our-list))
 237                         (car (nth count-low our-list)))))
 238         (setq rom-div count-low))
 239       ;; (message "Checking %d and %d in div loop" rom-high count-low)
 240       (setq count-low (1+ count-low)))
 241     ;;(message "We now have high: %d, low: %d, div: %d, n: %d"
 242     ;;         rom-high rom-low (if rom-div rom-div -1) n)
 243     (let ((rom-low-pair (nth rom-low our-list))
 244           (rom-high-pair (nth rom-high our-list))
 245           (rom-div-pair (if (not (= rom-div -1)) (nth rom-div our-list) nil)))
 246       ;; (message "pairs are: rom-low: %S, rom-high: %S, rom-div: %S"
 247       ;;          rom-low-pair rom-high-pair rom-div-pair)
 248       (cond
 249        ((< n 0) (error "Footnote-roman-common called with n < 0"))
 250        ((= n 0) "")
 251        ((= n (car rom-low-pair)) (cdr rom-low-pair))
 252        ((= n (car rom-high-pair)) (cdr rom-high-pair))
 253        ((= (car rom-low-pair) (car rom-high-pair))
 254         (concat (cdr rom-low-pair)
 255                 (Footnote-roman-common
 256                  (- n (car rom-low-pair))
 257                  footnote-roman-list)))
 258        ((>= rom-div 0) (concat (cdr rom-div-pair) (cdr rom-high-pair)
 259                                (Footnote-roman-common
 260                                 (- n (- (car rom-high-pair)
 261                                         (car rom-div-pair)))
 262                                 footnote-roman-list)))
 263        (t (concat (cdr rom-low-pair)
 264                   (Footnote-roman-common
 265                    (- n (car rom-low-pair))
 266                    footnote-roman-list)))))))
 267
 268 ;; Latin-1
 269
 270 (defconst footnote-latin-string "¹²³ºª§¶"
 271   "String of Latin-1 footnoting characters.")
 272
 273 ;; Note not [...]+, because this style cycles.
 274 (defconst footnote-latin-regexp (concat "[" footnote-latin-string "]")
 275   "Regexp for Latin-1 footnoting characters.")
 276
 277 (defun Footnote-latin (n)
 278   "Latin-1 footnote style.
 279 Use a range of Latin-1 non-ASCII characters for footnoting."
 280   (string (aref footnote-latin-string
 281                 (mod (1- n) (length footnote-latin-string)))))
 282
 283 ;;; list of all footnote styles
 284 (defvar footnote-style-alist
 285   `((numeric Footnote-numeric ,footnote-numeric-regexp)
 286     (english-lower Footnote-english-lower ,footnote-english-lower-regexp)
 287     (english-upper Footnote-english-upper ,footnote-english-upper-regexp)
 288     (roman-lower Footnote-roman-lower ,footnote-roman-lower-regexp)
 289     (roman-upper Footnote-roman-upper ,footnote-roman-upper-regexp)
 290     (latin Footnote-latin ,footnote-latin-regexp))
 291   "Styles of footnote tags available.
 292 By default only boring Arabic numbers, English letters and Roman Numerals
 293 are available.
 294 See footnote-han.el, footnote-greek.el and footnote-hebrew.el for more
 295 exciting styles.")
 296
 297 (defcustom footnote-style 'numeric
 298   "*Default style used for footnoting.
 299 numeric == 1, 2, 3, ...
 300 english-lower == a, b, c, ...
 301 english-upper == A, B, C, ...
 302 roman-lower == i, ii, iii, iv, v, ...
 303 roman-upper == I, II, III, IV, V, ...
 304 latin == ¹ ² ³ º ª § ¶
 305 See also variables `footnote-start-tag' and `footnote-end-tag'.
 306
 307 Customizing this variable has no effect on buffers already
 308 displaying footnotes.  You can change the style of existing
 309 buffers using the command `Footnote-set-style'."
 310   :type (cons 'choice (mapcar (lambda (x) (list 'const (car x)))
 311                               footnote-style-alist))
 312   :group 'footnote)
 313
 314 ;;; Style utilities & functions
 315 (defun Footnote-style-p (style)
 316   "Return non-nil if style is a valid style known to footnote-mode."
 317   (assq style footnote-style-alist))
 318
 319 (defun Footnote-index-to-string (index)
 320   "Convert a binary index into a string to display as a footnote.
 321 Conversion is done based upon the current selected style."
 322   (let ((alist (if (Footnote-style-p footnote-style)
 323                    (assq footnote-style footnote-style-alist)
 324                  (nth 0 footnote-style-alist))))
 325     (funcall (nth 1 alist) index)))
 326
 327 (defun Footnote-current-regexp ()
 328   "Return the regexp of the index of the current style."
 329   (concat (nth 2 (or (assq footnote-style footnote-style-alist)
 330                      (nth 0 footnote-style-alist)))
 331           "*"))
 332
 333 (defun Footnote-refresh-footnotes (&optional index-regexp)
 334   "Redraw all footnotes.
 335 You must call this or arrange to have this called after changing footnote
 336 styles."
 337   (unless index-regexp
 338     (setq index-regexp (Footnote-current-regexp)))
 339   (save-excursion
 340     ;; Take care of the pointers first
 341     (let ((i 0) locn alist)
 342       (while (setq alist (nth i footnote-pointer-marker-alist))
 343         (setq locn (cdr alist))
 344         (while locn
 345           (goto-char (car locn))
 346           (search-backward footnote-start-tag nil t)
 347           (when (looking-at (concat
 348                              (regexp-quote footnote-start-tag)
 349                              "\\(" index-regexp "+\\)"
 350                              (regexp-quote footnote-end-tag)))
 351             (replace-match (concat
 352                             footnote-start-tag
 353                             (Footnote-index-to-string (1+ i))
 354                             footnote-end-tag)
 355                            nil "\\1"))
 356           (setq locn (cdr locn)))
 357         (setq i (1+ i))))
 358
 359     ;; Now take care of the text section
 360     (let ((i 0) alist)
 361       (while (setq alist (nth i footnote-text-marker-alist))
 362         (goto-char (cdr alist))
 363         (when (looking-at (concat
 364                            (regexp-quote footnote-start-tag)
 365                            "\\(" index-regexp "+\\)"
 366                            (regexp-quote footnote-end-tag)))
 367           (replace-match (concat
 368                           footnote-start-tag
 369                           (Footnote-index-to-string (1+ i))
 370                           footnote-end-tag)
 371                          nil "\\1"))
 372         (setq i (1+ i))))))
 373
 374 (defun Footnote-assoc-index (key alist)
 375   "Give index of key in alist."
 376   (let ((i 0) (max (length alist)) rc)
 377     (while (and (null rc)
 378                 (< i max))
 379       (when (eq key (car (nth i alist)))
 380         (setq rc i))
 381       (setq i (1+ i)))
 382     rc))
 383
 384 (defun Footnote-cycle-style ()
 385   "Select next defined footnote style."
 386   (interactive)
 387   (let ((old (Footnote-assoc-index footnote-style footnote-style-alist))
 388         (max (length footnote-style-alist))
 389         idx)
 390     (setq idx (1+ old))
 391     (when (>= idx max)
 392       (setq idx 0))
 393     (setq footnote-style (car (nth idx footnote-style-alist)))
 394     (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
 395
 396 (defun Footnote-set-style (&optional style)
 397   "Select a specific style."
 398   (interactive
 399    (list (intern (completing-read
 400                   "Footnote Style: "
 401                   obarray #'Footnote-style-p 'require-match))))
 402   (setq footnote-style style))
 403
 404 ;; Internal functions
 405 (defun Footnote-insert-numbered-footnote (arg &optional mousable)
 406   "Insert numbered footnote at (point)."
 407   (let* ((start (point))
 408          (end (progn
 409                 (insert-before-markers (concat footnote-start-tag
 410                                                (Footnote-index-to-string arg)
 411                                                footnote-end-tag))
 412                 (point))))
 413
 414     (add-text-properties start end
 415                          (list 'footnote-number arg))
 416     (when mousable
 417       (add-text-properties start end
 418                            (list footnote-mouse-highlight t)))))
 419
 420 (defun Footnote-renumber (from to pointer-alist text-alist)
 421   "Renumber a single footnote."
 422   (let* ((posn-list (cdr pointer-alist)))
 423     (setcar pointer-alist to)
 424     (setcar text-alist to)
 425     (while posn-list
 426       (goto-char (car posn-list))
 427       (search-backward footnote-start-tag nil t)
 428       (when (looking-at (format "%s%s%s"
 429                                 (regexp-quote footnote-start-tag)
 430                                 (Footnote-current-regexp)
 431                                 (regexp-quote footnote-end-tag)))
 432         (add-text-properties (match-beginning 0) (match-end 0)
 433                              (list 'footnote-number to))
 434         (replace-match (format "%s%s%s"
 435                                footnote-start-tag
 436                                (Footnote-index-to-string to)
 437                                footnote-end-tag)))
 438       (setq posn-list (cdr posn-list)))
 439     (goto-char (cdr text-alist))
 440     (when (looking-at (format "%s%s%s"
 441                               (regexp-quote footnote-start-tag)
 442                               (Footnote-current-regexp)
 443                               (regexp-quote footnote-end-tag)))
 444       (add-text-properties (match-beginning 0) (match-end 0)
 445                            (list 'footnote-number to))
 446       (replace-match (format "%s%s%s"
 447                              footnote-start-tag
 448                              (Footnote-index-to-string to)
 449                              footnote-end-tag) nil t))))
 450
 451 ;; Not needed?
 452 (defun Footnote-narrow-to-footnotes ()
 453   "Restrict text in buffer to show only text of footnotes."
 454   (interactive) ; testing
 455   (goto-char (point-max))
 456   (when (re-search-backward footnote-signature-separator nil t)
 457     (let ((end (point)))
 458       (when (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)
 459         (narrow-to-region (point) end)))))
 460
 461 (defun Footnote-goto-char-point-max ()
 462   "Move to end of buffer or prior to start of .signature."
 463   (goto-char (point-max))
 464   (or (re-search-backward footnote-signature-separator nil t)
 465       (point)))
 466
 467 (defun Footnote-insert-text-marker (arg locn)
 468   "Insert a marker pointing to footnote arg, at buffer location locn."
 469   (let ((marker (make-marker)))
 470     (unless (assq arg footnote-text-marker-alist)
 471       (set-marker marker locn)
 472       (setq footnote-text-marker-alist
 473             (cons (cons arg marker) footnote-text-marker-alist))
 474       (setq footnote-text-marker-alist
 475             (Footnote-sort footnote-text-marker-alist)))))
 476
 477 (defun Footnote-insert-pointer-marker (arg locn)
 478   "Insert a marker pointing to footnote arg, at buffer location locn."
 479   (let ((marker (make-marker))
 480         alist)
 481     (set-marker marker locn)
 482     (if (setq alist (assq arg footnote-pointer-marker-alist))
 483         (setf alist
 484               (cons marker (cdr alist)))
 485       (setq footnote-pointer-marker-alist
 486             (cons (cons arg (list marker)) footnote-pointer-marker-alist))
 487       (setq footnote-pointer-marker-alist
 488             (Footnote-sort footnote-pointer-marker-alist)))))
 489
 490 (defun Footnote-insert-footnote (arg)
 491   "Insert a footnote numbered arg, at (point)."
 492   (push-mark)
 493   (Footnote-insert-pointer-marker arg (point))
 494   (Footnote-insert-numbered-footnote arg t)
 495   (Footnote-goto-char-point-max)
 496   (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)
 497       (save-restriction
 498         (when footnote-narrow-to-footnotes-when-editing
 499           (Footnote-narrow-to-footnotes))
 500         (Footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now)
 501         ;; (message "Inserting footnote %d" arg)
 502         (unless
 503             (or (eq arg 1)
 504                 (when (re-search-forward
 505                        (if footnote-spaced-footnotes
 506                            "\n\n"
 507                          (concat "\n"
 508                                  (regexp-quote footnote-start-tag)
 509                                  (Footnote-current-regexp)
 510                                  (regexp-quote footnote-end-tag)))
 511                        nil t)
 512                   (unless (beginning-of-line) t))
 513                 (Footnote-goto-char-point-max)
 514                 (re-search-backward (concat "^" footnote-section-tag-regexp) nil t))))
 515     (unless (looking-at "^$")
 516       (insert "\n"))
 517     (when (eobp)
 518       (insert "\n"))
 519     (insert footnote-section-tag "\n"))
 520   (let ((old-point (point)))
 521     (Footnote-insert-numbered-footnote arg nil)
 522     (Footnote-insert-text-marker arg old-point)))
 523
 524 (defun Footnote-sort (list)
 525   (sort list (lambda (e1 e2)
 526                (< (car e1) (car e2)))))
 527
 528 (defun Footnote-text-under-cursor ()
 529   "Return the number of footnote if in footnote text.
 530 Return nil if the cursor is not positioned over the text of
 531 a footnote."
 532   (when (and (let ((old-point (point)))
 533                (save-excursion
 534                  (save-restriction
 535                    (Footnote-narrow-to-footnotes)
 536                    (and (>= old-point (point-min))
 537                         (<= old-point (point-max))))))
 538              (>= (point) (cdar footnote-text-marker-alist)))
 539     (let ((i 1)
 540           alist-txt rc)
 541       (while (and (setq alist-txt (nth i footnote-text-marker-alist))
 542                   (null rc))
 543         (when (< (point) (cdr alist-txt))
 544           (setq rc (car (nth (1- i) footnote-text-marker-alist))))
 545         (setq i (1+ i)))
 546       (when (and (null rc)
 547                  (null alist-txt))
 548         (setq rc (car (nth (1- i) footnote-text-marker-alist))))
 549       rc)))
 550
 551 (defun Footnote-under-cursor ()
 552   "Return the number of the footnote underneath the cursor.
 553 Return nil if the cursor is not over a footnote."
 554   (or (get-text-property (point) 'footnote-number)
 555       (Footnote-text-under-cursor)))
 556
 557 ;;; User functions
 558
 559 (defun Footnote-make-hole ()
 560   (save-excursion
 561     (let ((i 0)
 562           (notes (length footnote-pointer-marker-alist))
 563           alist-ptr alist-txt rc)
 564       (while (< i notes)
 565         (setq alist-ptr (nth i footnote-pointer-marker-alist))
 566         (setq alist-txt (nth i footnote-text-marker-alist))
 567         (when (< (point) (- (cadr alist-ptr) 3))
 568           (unless rc
 569             (setq rc (car alist-ptr)))
 570           (save-excursion
 571             (message "Renumbering from %s to %s"
 572                      (Footnote-index-to-string (car alist-ptr))
 573                      (Footnote-index-to-string
 574                       (1+ (car alist-ptr))))
 575             (Footnote-renumber (car alist-ptr)
 576                                (1+ (car alist-ptr))
 577                                alist-ptr
 578                                alist-txt)))
 579         (setq i (1+ i)))
 580       rc)))
 581
 582 (defun Footnote-add-footnote (&optional arg)
 583   "Add a numbered footnote.
 584 The number the footnote receives is dependent upon the relative location
 585 of any other previously existing footnotes.
 586 If the variable `footnote-narrow-to-footnotes-when-editing' is set,
 587 the buffer is narrowed to the footnote body.  The restriction is removed
 588 by using `Footnote-back-to-message'."
 589   (interactive "*P")
 590   (let (num)
 591     (if footnote-text-marker-alist
 592         (if (< (point) (cadar (last footnote-pointer-marker-alist)))
 593             (setq num (Footnote-make-hole))
 594           (setq num (1+ (caar (last footnote-text-marker-alist)))))
 595       (setq num 1))
 596     (message "Adding footnote %d" num)
 597     (Footnote-insert-footnote num)
 598     (insert-before-markers (make-string footnote-body-tag-spacing ? ))
 599     (let ((opoint (point)))
 600       (save-excursion
 601         (insert-before-markers
 602          (if footnote-spaced-footnotes
 603              "\n\n"
 604            "\n"))
 605         (when footnote-narrow-to-footnotes-when-editing
 606           (Footnote-narrow-to-footnotes)))
 607       ;; Emacs/XEmacs bug?  save-excursion doesn't restore point when using
 608       ;; insert-before-markers.
 609       (goto-char opoint))))
 610
 611 (defun Footnote-delete-footnote (&optional arg)
 612   "Delete a numbered footnote.
 613 With no parameter, delete the footnote under (point).  With arg specified,
 614 delete the footnote with that number."
 615   (interactive "*P")
 616   (unless arg
 617     (setq arg (Footnote-under-cursor)))
 618   (when (and arg
 619              (or (not footnote-prompt-before-deletion)
 620                  (y-or-n-p (format "Really delete footnote %d?" arg))))
 621     (let (alist-ptr alist-txt locn)
 622       (setq alist-ptr (assq arg footnote-pointer-marker-alist))
 623       (setq alist-txt (assq arg footnote-text-marker-alist))
 624       (unless (and alist-ptr alist-txt)
 625         (error "Can't delete footnote %d" arg))
 626       (setq locn (cdr alist-ptr))
 627       (while (car locn)
 628         (save-excursion
 629           (goto-char (car locn))
 630           (let* ((end (point))
 631                  (start (search-backward footnote-start-tag nil t)))
 632             (kill-region start end)))
 633         (setq locn (cdr locn)))
 634       (save-excursion
 635         (goto-char (cdr alist-txt))
 636         (kill-region (point) (search-forward "\n\n" nil t)))
 637       (setq footnote-pointer-marker-alist
 638             (delq alist-ptr footnote-pointer-marker-alist))
 639       (setq footnote-text-marker-alist
 640             (delq alist-txt footnote-text-marker-alist))
 641       (Footnote-renumber-footnotes)
 642       (when (and (null footnote-text-marker-alist)
 643                  (null footnote-pointer-marker-alist))
 644         (save-excursion
 645           (let* ((end (Footnote-goto-char-point-max))
 646                  (start (1- (re-search-backward
 647                              (concat "^" footnote-section-tag-regexp)
 648                              nil t))))
 649             (forward-line -1)
 650             (when (looking-at "\n")
 651               (kill-line))
 652             (kill-region start (if (< end (point-max))
 653                                    end
 654                                  (point-max)))))))))
 655
 656 (defun Footnote-renumber-footnotes (&optional arg)
 657   "Renumber footnotes, starting from 1."
 658   (interactive "*P")
 659   (save-excursion
 660     (let ((i 0)
 661           (notes (length footnote-pointer-marker-alist))
 662           alist-ptr alist-txt)
 663       (while (< i notes)
 664         (setq alist-ptr (nth i footnote-pointer-marker-alist))
 665         (setq alist-txt (nth i footnote-text-marker-alist))
 666         (unless (= (1+ i) (car alist-ptr))
 667           (Footnote-renumber (car alist-ptr) (1+ i) alist-ptr alist-txt))
 668         (setq i (1+ i))))))
 669
 670 (defun Footnote-goto-footnote (&optional arg)
 671   "Jump to the text of a footnote.
 672 With no parameter, jump to the text of the footnote under (point).  With arg
 673 specified, jump to the text of that footnote."
 674   (interactive "P")
 675   (let (footnote)
 676     (if arg
 677         (setq footnote (assq arg footnote-text-marker-alist))
 678       (when (setq arg (Footnote-under-cursor))
 679         (setq footnote (assq arg footnote-text-marker-alist))))
 680     (if footnote
 681         (goto-char (cdr footnote))
 682       (if (eq arg 0)
 683           (progn
 684             (goto-char (point-max))
 685             (re-search-backward (concat "^" footnote-section-tag-regexp))
 686             (forward-line 1))
 687         (error "I don't see a footnote here")))))
 688
 689 (defun Footnote-back-to-message (&optional arg)
 690   "Move cursor back to footnote referent.
 691 If the cursor is not over the text of a footnote, point is not changed.
 692 If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing'
 693 being set it is automatically widened."
 694   (interactive "P")
 695   (let ((note (Footnote-text-under-cursor)))
 696     (when note
 697       (when footnote-narrow-to-footnotes-when-editing
 698         (widen))
 699       (goto-char (cadr (assq note footnote-pointer-marker-alist))))))
 700
 701 (defvar footnote-mode-map nil
 702   "Keymap used for footnote minor mode.")
 703
 704 ;; Set up our keys
 705 (unless footnote-mode-map
 706   (setq footnote-mode-map (make-sparse-keymap))
 707   (define-key footnote-mode-map "a" 'Footnote-add-footnote)
 708   (define-key footnote-mode-map "b" 'Footnote-back-to-message)
 709   (define-key footnote-mode-map "c" 'Footnote-cycle-style)
 710   (define-key footnote-mode-map "d" 'Footnote-delete-footnote)
 711   (define-key footnote-mode-map "g" 'Footnote-goto-footnote)
 712   (define-key footnote-mode-map "r" 'Footnote-renumber-footnotes)
 713   (define-key footnote-mode-map "s" 'Footnote-set-style))
 714
 715 (defvar footnote-minor-mode-map nil
 716   "Keymap used for binding footnote minor mode.")
 717
 718 (unless footnote-minor-mode-map
 719   (define-key global-map footnote-prefix footnote-mode-map))
 720
 721 ;;;###autoload
 722 (defun footnote-mode (&optional arg)
 723   "Toggle footnote minor mode.
 724 \\<message-mode-map>
 725 key             binding
 726 ---             -------
 727
 728 \\[Footnote-renumber-footnotes]         Footnote-renumber-footnotes
 729 \\[Footnote-goto-footnote]              Footnote-goto-footnote
 730 \\[Footnote-delete-footnote]            Footnote-delete-footnote
 731 \\[Footnote-cycle-style]                Footnote-cycle-style
 732 \\[Footnote-back-to-message]            Footnote-back-to-message
 733 \\[Footnote-add-footnote]               Footnote-add-footnote
 734 "
 735   (interactive "*P")
 736   ;; (filladapt-mode t)
 737   (setq footnote-mode
 738         (if (null arg) (not footnote-mode)
 739           (> (prefix-numeric-value arg) 0)))
 740   (when footnote-mode
 741     ;; (Footnote-setup-keybindings)
 742     (make-local-variable 'footnote-style)
 743     (if (fboundp 'force-mode-line-update)
 744         (force-mode-line-update)
 745       (set-buffer-modified-p (buffer-modified-p)))
 746
 747     (when (boundp 'filladapt-token-table)
 748       ;; add tokens to filladapt to match footnotes
 749       ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x
 750       ;;    xxx x xx xxx xxxx        x x x xxxxxxxxxx
 751       (let ((bullet-regexp (concat (regexp-quote footnote-start-tag)
 752                                    "?[0-9a-zA-Z]+"
 753                                    (regexp-quote footnote-end-tag)
 754                                    "[ \t]")))
 755         (unless (assoc bullet-regexp filladapt-token-table)
 756           (setq filladapt-token-table
 757                 (append filladapt-token-table
 758                         (list (list bullet-regexp 'bullet)))))))
 759
 760     (run-hooks 'footnote-mode-hook)))
 761
 762 (unless (assq 'footnote-mode minor-mode-alist)
 763   (setq minor-mode-alist
 764         (cons '(footnote-mode footnote-mode-line-string)
 765               minor-mode-alist)))
 766
 767 (provide 'footnote)
 768
 769 ;; arch-tag: 9bcfb6d7-2161-4caf-8793-700f62400398
 770 ;;; footnote.el ends here