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

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