lisp/mail/footnote.el

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