lisp/mail/footnote.el

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