lisp/mail/footnote.el

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