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