lisp/mail/footnote.el

   1 ;;; footnote.el --- footnote support for message mode  -*- coding: iso-latin-1;-*-
   2
   3 ;; Copyright (C) 1997, 2000-2011 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 (defvar footnote-signature-separator (if (boundp 'message-signature-separator)
 130                                          message-signature-separator
 131                                        "^-- $")
 132   "*String used to recognize .signatures.")
 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 ;;; list of all footnote styles
 295 (defvar footnote-style-alist
 296   `((numeric Footnote-numeric ,footnote-numeric-regexp)
 297     (english-lower Footnote-english-lower ,footnote-english-lower-regexp)
 298     (english-upper Footnote-english-upper ,footnote-english-upper-regexp)
 299     (roman-lower Footnote-roman-lower ,footnote-roman-lower-regexp)
 300     (roman-upper Footnote-roman-upper ,footnote-roman-upper-regexp)
 301     (latin Footnote-latin ,footnote-latin-regexp))
 302   "Styles of footnote tags available.
 303 By default only boring Arabic numbers, English letters and Roman Numerals
 304 are available.
 305 See footnote-han.el, footnote-greek.el and footnote-hebrew.el for more
 306 exciting styles.")
 307
 308 (defcustom footnote-style 'numeric
 309   "Default style used for footnoting.
 310 numeric == 1, 2, 3, ...
 311 english-lower == a, b, c, ...
 312 english-upper == A, B, C, ...
 313 roman-lower == i, ii, iii, iv, v, ...
 314 roman-upper == I, II, III, IV, V, ...
 315 latin == ¹ ² ³ º ª § ¶
 316 See also variables `footnote-start-tag' and `footnote-end-tag'.
 317
 318 Customizing this variable has no effect on buffers already
 319 displaying footnotes.  To change the style of footnotes in such a
 320 buffer use the command `Footnote-set-style'."
 321   :type (cons 'choice (mapcar (lambda (x) (list 'const (car x)))
 322                               footnote-style-alist))
 323   :group 'footnote)
 324
 325 ;;; Style utilities & functions
 326 (defun Footnote-style-p (style)
 327   "Return non-nil if style is a valid style known to footnote-mode."
 328   (assq style footnote-style-alist))
 329
 330 (defun Footnote-index-to-string (index)
 331   "Convert a binary index into a string to display as a footnote.
 332 Conversion is done based upon the current selected style."
 333   (let ((alist (if (Footnote-style-p footnote-style)
 334                    (assq footnote-style footnote-style-alist)
 335                  (nth 0 footnote-style-alist))))
 336     (funcall (nth 1 alist) index)))
 337
 338 (defun Footnote-current-regexp ()
 339   "Return the regexp of the index of the current style."
 340   (concat (nth 2 (or (assq footnote-style footnote-style-alist)
 341                      (nth 0 footnote-style-alist)))
 342           "*"))
 343
 344 (defun Footnote-refresh-footnotes (&optional index-regexp)
 345   "Redraw all footnotes.
 346 You must call this or arrange to have this called after changing footnote
 347 styles."
 348   (unless index-regexp
 349     (setq index-regexp (Footnote-current-regexp)))
 350   (save-excursion
 351     ;; Take care of the pointers first
 352     (let ((i 0) locn alist)
 353       (while (setq alist (nth i footnote-pointer-marker-alist))
 354         (setq locn (cdr alist))
 355         (while locn
 356           (goto-char (car locn))
 357           ;; Try to handle the case where `footnote-start-tag' and
 358           ;; `footnote-end-tag' are the same string.
 359           (when (looking-back (concat
 360                                (regexp-quote footnote-start-tag)
 361                                "\\(" index-regexp "+\\)"
 362                                (regexp-quote footnote-end-tag))
 363                               (line-beginning-position))
 364             (replace-match
 365              (propertize
 366               (concat
 367                footnote-start-tag
 368                (Footnote-index-to-string (1+ i))
 369                footnote-end-tag)
 370               'footnote-number (1+ i) footnote-mouse-highlight t)
 371              nil "\\1"))
 372           (setq locn (cdr locn)))
 373         (setq i (1+ i))))
 374
 375     ;; Now take care of the text section
 376     (let ((i 0) alist)
 377       (while (setq alist (nth i footnote-text-marker-alist))
 378         (goto-char (cdr alist))
 379         (when (looking-at (concat
 380                            (regexp-quote footnote-start-tag)
 381                            "\\(" index-regexp "+\\)"
 382                            (regexp-quote footnote-end-tag)))
 383           (replace-match
 384            (propertize
 385             (concat
 386              footnote-start-tag
 387              (Footnote-index-to-string (1+ i))
 388              footnote-end-tag)
 389             'footnote-number (1+ i))
 390            nil "\\1"))
 391         (setq i (1+ i))))))
 392
 393 (defun Footnote-assoc-index (key alist)
 394   "Give index of key in alist."
 395   (let ((i 0) (max (length alist)) rc)
 396     (while (and (null rc)
 397                 (< i max))
 398       (when (eq key (car (nth i alist)))
 399         (setq rc i))
 400       (setq i (1+ i)))
 401     rc))
 402
 403 (defun Footnote-cycle-style ()
 404   "Select next defined footnote style."
 405   (interactive)
 406   (let ((old (Footnote-assoc-index footnote-style footnote-style-alist))
 407         (max (length footnote-style-alist))
 408         idx)
 409     (setq idx (1+ old))
 410     (when (>= idx max)
 411       (setq idx 0))
 412     (setq footnote-style (car (nth idx footnote-style-alist)))
 413     (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
 414
 415 (defun Footnote-set-style (&optional style)
 416   "Select a specific style."
 417   (interactive
 418    (list (intern (completing-read
 419                   "Footnote Style: "
 420                   obarray #'Footnote-style-p 'require-match))))
 421   (let ((old (Footnote-assoc-index footnote-style footnote-style-alist)))
 422     (setq footnote-style style)
 423     (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist)))))
 424
 425 ;; Internal functions
 426 (defun Footnote-insert-numbered-footnote (arg &optional mousable)
 427   "Insert numbered footnote at (point)."
 428   (let ((string (concat footnote-start-tag
 429                         (Footnote-index-to-string arg)
 430                         footnote-end-tag)))
 431     (insert-before-markers
 432      (if mousable
 433          (propertize
 434           string 'footnote-number arg footnote-mouse-highlight t)
 435        (propertize string 'footnote-number arg)))))
 436
 437 (defun Footnote-renumber (from to pointer-alist text-alist)
 438   "Renumber a single footnote."
 439   (let* ((posn-list (cdr pointer-alist)))
 440     (setcar pointer-alist to)
 441     (setcar text-alist to)
 442     (while posn-list
 443       (goto-char (car posn-list))
 444       (when (looking-back (concat (regexp-quote footnote-start-tag)
 445                                   (Footnote-current-regexp)
 446                                   (regexp-quote footnote-end-tag))
 447                           (line-beginning-position))
 448         (replace-match
 449          (propertize
 450           (concat footnote-start-tag
 451                   (Footnote-index-to-string to)
 452                   footnote-end-tag)
 453           'footnote-number to footnote-mouse-highlight t)))
 454       (setq posn-list (cdr posn-list)))
 455     (goto-char (cdr text-alist))
 456     (when (looking-at (concat (regexp-quote footnote-start-tag)
 457                               (Footnote-current-regexp)
 458                               (regexp-quote footnote-end-tag)))
 459       (replace-match
 460        (propertize
 461         (concat footnote-start-tag
 462                 (Footnote-index-to-string to)
 463                 footnote-end-tag)
 464         'footnote-number to)))))
 465
 466 ;; Not needed?
 467 (defun Footnote-narrow-to-footnotes ()
 468   "Restrict text in buffer to show only text of footnotes."
 469   (interactive) ; testing
 470   (goto-char (point-max))
 471   (when (re-search-backward footnote-signature-separator nil t)
 472     (let ((end (point)))
 473       (cond
 474        ((and (not (string-equal footnote-section-tag ""))
 475              (re-search-backward
 476               (concat "^" footnote-section-tag-regexp) nil t))
 477         (narrow-to-region (point) end))
 478        (footnote-text-marker-alist
 479         (narrow-to-region (cdar footnote-text-marker-alist) end))))))
 480
 481 (defun Footnote-goto-char-point-max ()
 482   "Move to end of buffer or prior to start of .signature."
 483   (goto-char (point-max))
 484   (or (re-search-backward footnote-signature-separator nil t)
 485       (point)))
 486
 487 (defun Footnote-insert-text-marker (arg locn)
 488   "Insert a marker pointing to footnote ARG, at buffer location LOCN."
 489   (let ((marker (make-marker)))
 490     (unless (assq arg footnote-text-marker-alist)
 491       (set-marker marker locn)
 492       (setq footnote-text-marker-alist
 493             (cons (cons arg marker) footnote-text-marker-alist))
 494       (setq footnote-text-marker-alist
 495             (Footnote-sort footnote-text-marker-alist)))))
 496
 497 (defun Footnote-insert-pointer-marker (arg locn)
 498   "Insert a marker pointing to footnote ARG, at buffer location LOCN."
 499   (let ((marker (make-marker))
 500         alist)
 501     (set-marker marker locn)
 502     (if (setq alist (assq arg footnote-pointer-marker-alist))
 503         (setf alist
 504               (cons marker (cdr alist)))
 505       (setq footnote-pointer-marker-alist
 506             (cons (cons arg (list marker)) footnote-pointer-marker-alist))
 507       (setq footnote-pointer-marker-alist
 508             (Footnote-sort footnote-pointer-marker-alist)))))
 509
 510 (defun Footnote-insert-footnote (arg)
 511   "Insert a footnote numbered ARG, at (point)."
 512   (push-mark)
 513   (Footnote-insert-pointer-marker arg (point))
 514   (Footnote-insert-numbered-footnote arg t)
 515   (Footnote-goto-char-point-max)
 516   (if (cond
 517        ((not (string-equal footnote-section-tag ""))
 518         (re-search-backward (concat "^" footnote-section-tag-regexp) nil t))
 519        (footnote-text-marker-alist
 520         (goto-char (cdar footnote-text-marker-alist))))
 521       (save-restriction
 522         (when footnote-narrow-to-footnotes-when-editing
 523           (Footnote-narrow-to-footnotes))
 524         (Footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now)
 525         ;; (message "Inserting footnote %d" arg)
 526         (unless
 527             (or (eq arg 1)
 528                 (when (re-search-forward
 529                        (if footnote-spaced-footnotes
 530                            "\n\n"
 531                          (concat "\n"
 532                                  (regexp-quote footnote-start-tag)
 533                                  (Footnote-current-regexp)
 534                                  (regexp-quote footnote-end-tag)))
 535                        nil t)
 536                   (unless (beginning-of-line) t))
 537                 (Footnote-goto-char-point-max)
 538                 (cond
 539                  ((not (string-equal footnote-section-tag ""))
 540                   (re-search-backward
 541                    (concat "^" footnote-section-tag-regexp) nil t))
 542                  (footnote-text-marker-alist
 543                   (goto-char (cdar footnote-text-marker-alist)))))))
 544     (unless (looking-at "^$")
 545       (insert "\n"))
 546     (when (eobp)
 547       (insert "\n"))
 548     (unless (string-equal footnote-section-tag "")
 549       (insert footnote-section-tag "\n")))
 550   (let ((old-point (point)))
 551     (Footnote-insert-numbered-footnote arg nil)
 552     (Footnote-insert-text-marker arg old-point)))
 553
 554 (defun Footnote-sort (list)
 555   (sort list (lambda (e1 e2)
 556                (< (car e1) (car e2)))))
 557
 558 (defun Footnote-text-under-cursor ()
 559   "Return the number of footnote if in footnote text.
 560 Return nil if the cursor is not positioned over the text of
 561 a footnote."
 562   (when (and (let ((old-point (point)))
 563                (save-excursion
 564                  (save-restriction
 565                    (Footnote-narrow-to-footnotes)
 566                    (and (>= old-point (point-min))
 567                         (<= old-point (point-max))))))
 568              footnote-text-marker-alist
 569              (>= (point) (cdar footnote-text-marker-alist)))
 570     (let ((i 1)
 571           alist-txt rc)
 572       (while (and (setq alist-txt (nth i footnote-text-marker-alist))
 573                   (null rc))
 574         (when (< (point) (cdr alist-txt))
 575           (setq rc (car (nth (1- i) footnote-text-marker-alist))))
 576         (setq i (1+ i)))
 577       (when (and (null rc)
 578                  (null alist-txt))
 579         (setq rc (car (nth (1- i) footnote-text-marker-alist))))
 580       rc)))
 581
 582 (defun Footnote-under-cursor ()
 583   "Return the number of the footnote underneath the cursor.
 584 Return nil if the cursor is not over a footnote."
 585   (or (get-text-property (point) 'footnote-number)
 586       (Footnote-text-under-cursor)))
 587
 588 ;;; User functions
 589
 590 (defun Footnote-make-hole ()
 591   (save-excursion
 592     (let ((i 0)
 593           (notes (length footnote-pointer-marker-alist))
 594           alist-ptr alist-txt rc)
 595       (while (< i notes)
 596         (setq alist-ptr (nth i footnote-pointer-marker-alist))
 597         (setq alist-txt (nth i footnote-text-marker-alist))
 598         (when (< (point) (- (cadr alist-ptr) 3))
 599           (unless rc
 600             (setq rc (car alist-ptr)))
 601           (save-excursion
 602             (message "Renumbering from %s to %s"
 603                      (Footnote-index-to-string (car alist-ptr))
 604                      (Footnote-index-to-string
 605                       (1+ (car alist-ptr))))
 606             (Footnote-renumber (car alist-ptr)
 607                                (1+ (car alist-ptr))
 608                                alist-ptr
 609                                alist-txt)))
 610         (setq i (1+ i)))
 611       rc)))
 612
 613 (defun Footnote-add-footnote (&optional arg)
 614   "Add a numbered footnote.
 615 The number the footnote receives is dependent upon the relative location
 616 of any other previously existing footnotes.
 617 If the variable `footnote-narrow-to-footnotes-when-editing' is set,
 618 the buffer is narrowed to the footnote body.  The restriction is removed
 619 by using `Footnote-back-to-message'."
 620   (interactive "*P")
 621   (let (num)
 622     (if footnote-text-marker-alist
 623         (if (< (point) (cadar (last footnote-pointer-marker-alist)))
 624             (setq num (Footnote-make-hole))
 625           (setq num (1+ (caar (last footnote-text-marker-alist)))))
 626       (setq num 1))
 627     (message "Adding footnote %d" num)
 628     (Footnote-insert-footnote num)
 629     (insert-before-markers (make-string footnote-body-tag-spacing ? ))
 630     (let ((opoint (point)))
 631       (save-excursion
 632         (insert-before-markers
 633          (if footnote-spaced-footnotes
 634              "\n\n"
 635            "\n"))
 636         (when footnote-narrow-to-footnotes-when-editing
 637           (Footnote-narrow-to-footnotes)))
 638       ;; Emacs/XEmacs bug?  save-excursion doesn't restore point when using
 639       ;; insert-before-markers.
 640       (goto-char opoint))))
 641
 642 (defun Footnote-delete-footnote (&optional arg)
 643   "Delete a numbered footnote.
 644 With no parameter, delete the footnote under (point).  With ARG specified,
 645 delete the footnote with that number."
 646   (interactive "*P")
 647   (unless arg
 648     (setq arg (Footnote-under-cursor)))
 649   (when (and arg
 650              (or (not footnote-prompt-before-deletion)
 651                  (y-or-n-p (format "Really delete footnote %d?" arg))))
 652     (let (alist-ptr alist-txt locn)
 653       (setq alist-ptr (assq arg footnote-pointer-marker-alist))
 654       (setq alist-txt (assq arg footnote-text-marker-alist))
 655       (unless (and alist-ptr alist-txt)
 656         (error "Can't delete footnote %d" arg))
 657       (setq locn (cdr alist-ptr))
 658       (while (car locn)
 659         (save-excursion
 660           (goto-char (car locn))
 661           (when (looking-back (concat (regexp-quote footnote-start-tag)
 662                                       (Footnote-current-regexp)
 663                                       (regexp-quote footnote-end-tag))
 664                               (line-beginning-position))
 665             (delete-region (match-beginning 0) (match-end 0))))
 666         (setq locn (cdr locn)))
 667       (save-excursion
 668         (goto-char (cdr alist-txt))
 669         (delete-region
 670          (point)
 671          (if footnote-spaced-footnotes
 672              (search-forward "\n\n" nil t)
 673            (save-restriction
 674              (end-of-line)
 675              (next-single-char-property-change
 676               (point) 'footnote-number nil (Footnote-goto-char-point-max))))))
 677       (setq footnote-pointer-marker-alist
 678             (delq alist-ptr footnote-pointer-marker-alist))
 679       (setq footnote-text-marker-alist
 680             (delq alist-txt footnote-text-marker-alist))
 681       (Footnote-renumber-footnotes)
 682       (when (and (null footnote-text-marker-alist)
 683                  (null footnote-pointer-marker-alist))
 684         (save-excursion
 685           (if (not (string-equal footnote-section-tag ""))
 686               (let* ((end (Footnote-goto-char-point-max))
 687                      (start (1- (re-search-backward
 688                                  (concat "^" footnote-section-tag-regexp)
 689                                  nil t))))
 690                 (forward-line -1)
 691                 (when (looking-at "\n")
 692                   (kill-line))
 693                 (delete-region start (if (< end (point-max))
 694                                          end
 695                                        (point-max))))
 696             (Footnote-goto-char-point-max)
 697             (when (looking-back "\n\n")
 698               (kill-line -1))))))))
 699
 700 (defun Footnote-renumber-footnotes (&optional arg)
 701   "Renumber footnotes, starting from 1."
 702   (interactive "*P")
 703   (save-excursion
 704     (let ((i 0)
 705           (notes (length footnote-pointer-marker-alist))
 706           alist-ptr alist-txt)
 707       (while (< i notes)
 708         (setq alist-ptr (nth i footnote-pointer-marker-alist))
 709         (setq alist-txt (nth i footnote-text-marker-alist))
 710         (unless (= (1+ i) (car alist-ptr))
 711           (Footnote-renumber (car alist-ptr) (1+ i) alist-ptr alist-txt))
 712         (setq i (1+ i))))))
 713
 714 (defun Footnote-goto-footnote (&optional arg)
 715   "Jump to the text of a footnote.
 716 With no parameter, jump to the text of the footnote under (point).  With ARG
 717 specified, jump to the text of that footnote."
 718   (interactive "P")
 719   (unless arg
 720     (setq arg (Footnote-under-cursor)))
 721   (let ((footnote (assq arg footnote-text-marker-alist)))
 722     (cond
 723      (footnote
 724       (goto-char (cdr footnote)))
 725      ((eq arg 0)
 726       (goto-char (point-max))
 727       (cond
 728        ((not (string-equal footnote-section-tag ""))
 729         (re-search-backward (concat "^" footnote-section-tag-regexp))
 730         (forward-line 1))
 731        (footnote-text-marker-alist
 732         (goto-char (cdar footnote-text-marker-alist)))))
 733      (t
 734       (error "I don't see a footnote here")))))
 735
 736 (defun Footnote-back-to-message (&optional arg)
 737   "Move cursor back to footnote referent.
 738 If the cursor is not over the text of a footnote, point is not changed.
 739 If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing'
 740 being set it is automatically widened."
 741   (interactive "P")
 742   (let ((note (Footnote-text-under-cursor)))
 743     (when note
 744       (when footnote-narrow-to-footnotes-when-editing
 745         (widen))
 746       (goto-char (cadr (assq note footnote-pointer-marker-alist))))))
 747
 748 (defvar footnote-mode-map
 749   (let ((map (make-sparse-keymap)))
 750     (define-key map "a" 'Footnote-add-footnote)
 751     (define-key map "b" 'Footnote-back-to-message)
 752     (define-key map "c" 'Footnote-cycle-style)
 753     (define-key map "d" 'Footnote-delete-footnote)
 754     (define-key map "g" 'Footnote-goto-footnote)
 755     (define-key map "r" 'Footnote-renumber-footnotes)
 756     (define-key map "s" 'Footnote-set-style)
 757     map))
 758
 759 (defvar footnote-minor-mode-map
 760   (let ((map (make-sparse-keymap)))
 761     (define-key map footnote-prefix footnote-mode-map)
 762     map)
 763   "Keymap used for binding footnote minor mode.")
 764
 765 ;;;###autoload
 766 (define-minor-mode footnote-mode
 767   "Toggle footnote minor mode.
 768 This minor mode provides footnote support for `message-mode'.  To get
 769 started, play around with the following keys:
 770 \\{footnote-minor-mode-map}"
 771   :lighter    footnote-mode-line-string
 772   :keymap     footnote-minor-mode-map
 773   ;; (filladapt-mode t)
 774   (when footnote-mode
 775     ;; (Footnote-setup-keybindings)
 776     (make-local-variable 'footnote-style)
 777     (make-local-variable 'footnote-body-tag-spacing)
 778     (make-local-variable 'footnote-spaced-footnotes)
 779     (make-local-variable 'footnote-section-tag)
 780     (make-local-variable 'footnote-section-tag-regexp)
 781     (make-local-variable 'footnote-start-tag)
 782     (make-local-variable 'footnote-end-tag)
 783
 784     (when (boundp 'filladapt-token-table)
 785       ;; add tokens to filladapt to match footnotes
 786       ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x
 787       ;;    xxx x xx xxx xxxx        x x x xxxxxxxxxx
 788       (let ((bullet-regexp (concat (regexp-quote footnote-start-tag)
 789                                    "?[0-9a-zA-Z]+"
 790                                    (regexp-quote footnote-end-tag)
 791                                    "[ \t]")))
 792         (unless (assoc bullet-regexp filladapt-token-table)
 793           (setq filladapt-token-table
 794                 (append filladapt-token-table
 795                         (list (list bullet-regexp 'bullet)))))))))
 796
 797 (provide 'footnote)
 798
 799 ;;; footnote.el ends here