mu-cite.el

   1 ;;; mu-cite.el --- yet another citation tool for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;;         Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   7 ;; Maintainer: Katsumi Yamaoka <yamaoka@jpl.org>
   8 ;; Keywords: mail, news, citation
   9
  10 ;; This file is part of MU (Message Utilities).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; 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; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; - How to use
  30 ;;   1. bytecompile this file and copy it to the apropriate directory.
  31 ;;   2. put the following lines to your ~/.emacs:
  32 ;;      for EMACS 19 or later and XEmacs
  33 ;;              (autoload 'mu-cite-original "mu-cite" nil t)
  34 ;;              ;; for all but message-mode
  35 ;;              (add-hook 'mail-citation-hook (function mu-cite-original))
  36 ;;              ;; for message-mode only
  37 ;;              (setq message-cite-function (function mu-cite-original))
  38 ;;      for EMACS 18
  39 ;;              ;; for all but mh-e
  40 ;;              (add-hook 'mail-yank-hooks (function mu-cite-original))
  41 ;;              ;; for mh-e only
  42 ;;              (add-hook 'mh-yank-hooks (function mu-cite-original))
  43
  44 ;;; Code:
  45
  46 ;; Pickup some macros, e.g. `with-temp-buffer', for old Emacsen.
  47 (require 'poe)
  48 (require 'pcustom)
  49 (require 'std11)
  50 (require 'alist)
  51
  52 (autoload 'mu-cite-get-prefix-method "mu-register")
  53 (autoload 'mu-cite-get-prefix-register-method "mu-register")
  54 (autoload 'mu-cite-get-prefix-register-verbose-method "mu-register")
  55
  56 (autoload 'mu-bbdb-get-prefix-method "mu-bbdb")
  57 (autoload 'mu-bbdb-get-prefix-register-method "mu-bbdb")
  58 (autoload 'mu-bbdb-get-prefix-register-verbose-method "mu-bbdb")
  59
  60
  61 ;;; @ version
  62 ;;;
  63
  64 (defconst mu-cite-version "8.0")
  65
  66
  67 ;;; @ set up
  68 ;;;
  69
  70 (defgroup mu-cite nil
  71   "yet another citation tool for GNU Emacs."
  72   :prefix "mu-cite-"
  73   :group 'mail
  74   :group 'news)
  75
  76 (defvar mu-cite-default-methods-alist
  77   (list (cons 'from
  78               (function
  79                (lambda ()
  80                  (mu-cite-get-field-value "From"))))
  81         (cons 'date
  82               (function
  83                (lambda ()
  84                  (mu-cite-get-field-value "Date"))))
  85         (cons 'message-id
  86               (function
  87                (lambda ()
  88                  (mu-cite-get-field-value "Message-Id"))))
  89         (cons 'subject
  90               (function
  91                (lambda ()
  92                  (mu-cite-get-field-value "Subject"))))
  93         (cons 'ml-name
  94               (function
  95                (lambda ()
  96                  (mu-cite-get-field-value "X-Ml-Name"))))
  97         (cons 'ml-count (function mu-cite-get-ml-count-method))
  98         (cons 'address-structure
  99               (function
 100                (lambda ()
 101                  (car
 102                   (std11-parse-address-string (mu-cite-get-value 'from))))))
 103         (cons 'full-name
 104               (function
 105                (lambda ()
 106                  (std11-full-name-string
 107                   (mu-cite-get-value 'address-structure)))))
 108         (cons 'address
 109               (function
 110                (lambda ()
 111                  (std11-address-string
 112                   (mu-cite-get-value 'address-structure)))))
 113         (cons 'id
 114               (function
 115                (lambda ()
 116                  (let ((ml-name (mu-cite-get-value 'ml-name)))
 117                    (if ml-name
 118                        (concat "["
 119                                ml-name
 120                                " : No."
 121                                (mu-cite-get-value 'ml-count)
 122                                "]")
 123                      (mu-cite-get-value 'message-id))))))
 124         (cons 'in-id
 125               (function
 126                (lambda ()
 127                  (let ((id (mu-cite-get-value 'id)))
 128                    (if id
 129                        (format ">>>>> In %s \n" id)
 130                      "")))))
 131         (cons 'x-attribution
 132               (function
 133                (lambda ()
 134                  (mu-cite-get-field-value "X-Attribution"))))
 135         ;; mu-register
 136         (cons 'prefix (function mu-cite-get-prefix-method))
 137         (cons 'prefix-register
 138               (function mu-cite-get-prefix-register-method))
 139         (cons 'prefix-register-verbose
 140               (function mu-cite-get-prefix-register-verbose-method))
 141         ;; mu-bbdb
 142         (cons 'bbdb-prefix
 143               (function mu-bbdb-get-prefix-method))
 144         (cons 'bbdb-prefix-register
 145               (function mu-bbdb-get-prefix-register-method))
 146         (cons 'bbdb-prefix-register-verbose
 147               (function mu-bbdb-get-prefix-register-verbose-method))
 148         ))
 149
 150
 151 ;;; @ formats
 152 ;;;
 153
 154 (defcustom mu-cite-cited-prefix-regexp
 155   "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)"
 156   "Regexp to match the citation prefix.
 157 If match, mu-cite doesn't insert citation prefix."
 158   :type 'regexp
 159   :group 'mu-cite)
 160
 161 (defcustom mu-cite-prefix-format '(prefix-register-verbose "> ")
 162   "List to represent citation prefix.
 163 Each elements must be string or method name."
 164   :type (list 'repeat
 165               (nconc '(choice :tag "String or Method name")
 166                      (mapcar
 167                       (function
 168                        (lambda (elem) (list 'choice-item (car elem))))
 169                       mu-cite-default-methods-alist)
 170                      '((symbol :tag "Other Method")
 171                        (item "-")
 172                        (choice-item :tag "String: \"> \"" "> ")
 173                        (string :tag "Other String"))))
 174   :group 'mu-cite)
 175
 176 (defcustom mu-cite-top-format '(in-id ">>>>>\t" from " wrote:\n")
 177   "List to represent top string of citation.
 178 Each elements must be string or method name."
 179   :type (list 'repeat
 180               (nconc
 181                '(choice :tag "String or Method name")
 182                (mapcar
 183                 (function
 184                  (lambda (elem) (list 'choice-item (car elem))))
 185                 mu-cite-default-methods-alist)
 186                '((symbol :tag "Other Method")
 187                  (item "-")
 188                  (choice-item :tag "String: \">>>>>\\t\"" ">>>>>\t")
 189                  (choice-item :tag "String: \" wrote:\\n\"" " wrote:\n")
 190                  (string :tag "Other String"))))
 191   :group 'mu-cite)
 192
 193
 194 ;;; @ hooks
 195 ;;;
 196
 197 (defcustom mu-cite-load-hook nil
 198   "List of functions called after mu-cite is loaded.
 199 Use this hook to add your own methods to `mu-cite-default-methods-alist'."
 200   :type 'hook
 201   :group 'mu-cite)
 202
 203 (defcustom mu-cite-instantiation-hook nil
 204   "List of functions called just before narrowing to the message."
 205   :type 'hook
 206   :group 'mu-cite)
 207
 208 (defcustom mu-cite-pre-cite-hook nil
 209   "List of functions called before citing a region of text."
 210   :type 'hook
 211   :group 'mu-cite)
 212
 213 (defcustom mu-cite-post-cite-hook nil
 214   "List of functions called after citing a region of text."
 215   :type 'hook
 216   :group 'mu-cite)
 217
 218
 219 ;;; @ field
 220 ;;;
 221
 222 (defvar mu-cite-get-field-value-method-alist nil
 223   "Alist major-mode vs. function to get field-body of header.")
 224
 225 (defun mu-cite-get-field-value (name)
 226   "Return the value of the header field NAME.
 227 If the field is not found in the header, a method function which is
 228 registered in variable `mu-cite-get-field-value-method-alist' is called."
 229   (or (std11-field-body name)
 230       (let ((method (assq major-mode mu-cite-get-field-value-method-alist)))
 231         (if method
 232             (funcall (cdr method) name)))))
 233
 234
 235 ;;; @ item methods
 236 ;;;
 237
 238 ;;; @@ ML count
 239 ;;;
 240
 241 (defcustom mu-cite-ml-count-field-list
 242   '("X-Ml-Count" "X-Mail-Count" "X-Seqno" "X-Sequence" "Mailinglist-Id")
 243   "List of header fields which contain sequence number of mailing list."
 244   :type '(repeat (choice (choice-item "X-Ml-Count")
 245                          (choice-item "X-Mail-Count")
 246                          (choice-item "X-Seqno")
 247                          (choice-item "X-Sequence")
 248                          (choice-item "Mailinglist-Id")
 249                          (item "-")
 250                          (string :tag "Other")))
 251   :group 'mu-cite)
 252
 253 (defun mu-cite-get-ml-count-method ()
 254   "A mu-cite method to return a ML-count.
 255 This function searches a field about ML-count, which is specified by
 256 variable `mu-cite-ml-count-field-list', in a header.
 257 If the field is found, the function returns a number part of the
 258 field.
 259
 260 Notice that please use (mu-cite-get-value 'ml-count)
 261 instead of call the function directly."
 262   (let ((field-list mu-cite-ml-count-field-list))
 263     (catch 'tag
 264       (while field-list
 265         (let* ((field (car field-list))
 266                (ml-count (mu-cite-get-field-value field)))
 267           (if (and ml-count (string-match "[0-9]+" ml-count))
 268               (throw 'tag (match-string 0 ml-count)))
 269           (setq field-list (cdr field-list)))))))
 270
 271
 272 ;;; @ fundamentals
 273 ;;;
 274
 275 (defvar mu-cite-methods-alist nil)
 276
 277 (defun mu-cite-make-methods ()
 278   (setq mu-cite-methods-alist
 279         (copy-alist mu-cite-default-methods-alist))
 280   (run-hooks 'mu-cite-instantiation-hook))
 281
 282 (defun mu-cite-get-value (item)
 283   "Return current value of ITEM."
 284   (let ((ret (cdr (assoc item mu-cite-methods-alist))))
 285     (if (functionp ret)
 286         (prog1
 287             (setq ret (save-excursion (funcall ret)))
 288           (set-alist 'mu-cite-methods-alist item ret))
 289       ret)))
 290
 291 (defun mu-cite-eval-format (list)
 292   (mapconcat (function
 293               (lambda (elt)
 294                 (cond ((stringp elt) elt)
 295                       ((symbolp elt) (mu-cite-get-value elt)))))
 296              list ""))
 297
 298
 299 ;;; @ main function
 300 ;;;
 301
 302 ;;;###autoload
 303 (defun mu-cite-original ()
 304   "Citing filter function.
 305 This is callable from the various mail and news readers' reply
 306 function according to the agreed upon standard."
 307   (interactive)
 308   (mu-cite-make-methods)
 309   (save-restriction
 310     (if (< (mark t) (point))
 311         (exchange-point-and-mark))
 312     (narrow-to-region (point)(point-max))
 313     (run-hooks 'mu-cite-pre-cite-hook)
 314     (let ((last-point (point))
 315           (top (mu-cite-eval-format mu-cite-top-format))
 316           (prefix (mu-cite-eval-format mu-cite-prefix-format)))
 317       (if (re-search-forward "^-*$" nil nil)
 318           (forward-line 1))
 319       (widen)
 320       (delete-region last-point (point))
 321       (insert top)
 322       (setq last-point (point))
 323       (while (< (point)(mark t))
 324         (unless (looking-at mu-cite-cited-prefix-regexp)
 325           (insert prefix))
 326         (forward-line 1))
 327       (goto-char last-point))
 328     (run-hooks 'mu-cite-post-cite-hook)))
 329
 330
 331 ;;; @ message editing utilities
 332 ;;;
 333
 334 (defcustom citation-mark-chars ">}|"
 335   "String of characters for citation delimiter."
 336   :type 'string
 337   :group 'mu-cite)
 338
 339 (defcustom citation-disable-chars "<{"
 340   "String of characters not allowed as citation-prefix."
 341   :type 'string
 342   :group 'mu-cite)
 343
 344 (defun-maybe-cond char-category (character)
 345   "Return string of category mnemonics for CHAR in TABLE.
 346 CHAR can be any multilingual character
 347 TABLE defaults to the current buffer's category table."
 348   ((and (subr-fboundp 'char-category-set)
 349         (subr-fboundp 'category-set-mnemonics))
 350    (category-set-mnemonics (char-category-set character))
 351    )
 352   ((fboundp 'char-category-list)
 353    (mapconcat (lambda (chr)
 354                 (char-to-string (int-char chr)))
 355               (char-category-list character)
 356               "")
 357    )
 358   ((boundp 'NEMACS)
 359    (if (< (char-int character) 128)
 360        "al"
 361      "j")
 362    )
 363   (t
 364    (if (< (char-int character) 128)
 365        "al"
 366      "l")
 367    ))
 368
 369 (defun detect-paragraph-cited-prefix ()
 370   (save-excursion
 371     (goto-char (point-min))
 372     (let ((i 0)
 373           (prefix
 374            (buffer-substring
 375             (progn (beginning-of-line)(point))
 376             (progn (end-of-line)(point))))
 377           str ret)
 378       (while (and (= (forward-line) 0)
 379                   (setq str (buffer-substring
 380                              (progn (beginning-of-line)(point))
 381                              (progn (end-of-line)(point))))
 382                   (setq ret (string-compare-from-top prefix str)))
 383         (setq prefix
 384               (if (stringp ret)
 385                   ret
 386                 (cadr ret)))
 387         (incf i))
 388       (cond ((> i 1) prefix)
 389             ((> i 0)
 390              (goto-char (point-min))
 391              (save-restriction
 392                (narrow-to-region (point)
 393                                  (+ (point)(length prefix)))
 394                (goto-char (point-max))
 395                (if (re-search-backward
 396                     (concat "[" citation-mark-chars "]") nil t)
 397                    (progn
 398                      (goto-char (match-end 0))
 399                      (if (looking-at "[ \t]+")
 400                          (goto-char (match-end 0)))
 401                      (buffer-substring (point-min)(point)))
 402                  prefix)))
 403             ((progn
 404                (goto-char (point-max))
 405                (re-search-backward
 406                 (concat "[" citation-disable-chars "]") nil t)
 407                (re-search-backward
 408                 (concat "[" citation-mark-chars "]") nil t))
 409              (goto-char (match-end 0))
 410              (if (looking-at "[ \t]+")
 411                  (goto-char (match-end 0)))
 412              (buffer-substring (point-min)(point)))
 413             (t "")))))
 414
 415 ;;;###autoload
 416 (defun fill-cited-region (beg end)
 417   "Fill each of the paragraphs in the region as a cited text."
 418   (interactive "*r")
 419   (save-excursion
 420     (save-restriction
 421       (goto-char end)
 422       (and (search-backward "\n" nil t)
 423            (setq end (match-end 0)))
 424       (narrow-to-region beg end)
 425       (let* ((fill-prefix (detect-paragraph-cited-prefix))
 426              (pat (concat fill-prefix "\n")))
 427         (goto-char (point-min))
 428         (while (search-forward pat nil t)
 429           (let ((b (match-beginning 0))
 430                 (e (match-end 0)))
 431             (delete-region b e)
 432             (when (and (> b (point-min))
 433                        (let ((cat (char-category
 434                                    (char-before b))))
 435                          (or (string-match "a" cat)
 436                              (string-match "l" cat))))
 437               (insert " "))))
 438         (goto-char (point-min))
 439         (fill-region (point-min) (point-max))))))
 440
 441 ;;;###autoload
 442 (defun compress-cited-prefix ()
 443   "Compress nested cited prefixes."
 444   (interactive)
 445   (save-excursion
 446     (goto-char (point-min))
 447     (re-search-forward
 448      (concat "^" (regexp-quote mail-header-separator) "$") nil t)
 449     (while (re-search-forward
 450             (concat "^\\([ \t]*[^ \t\n" citation-mark-chars "]*["
 451                     citation-mark-chars "]\\)+") nil t)
 452       (let* ((b (match-beginning 0))
 453              (e (match-end 0))
 454              (prefix (buffer-substring b e))
 455              ps pe (s 0)
 456              (nest (let ((i 0))
 457                      (when (string-match "<[^<>]+>" prefix)
 458                        (setq prefix (substring prefix 0 (match-beginning 0))))
 459                      (while (string-match
 460                              (concat "\\([" citation-mark-chars "]+\\)[ \t]*")
 461                              prefix s)
 462                        (setq i (+ i (- (match-end 1)(match-beginning 1)))
 463                              ps s
 464                              pe (match-beginning 1)
 465                              s (match-end 0)))
 466                      i)))
 467         (when (and ps (< ps pe))
 468           (delete-region b e)
 469           (insert (concat (substring prefix ps pe) (make-string nest ?>))))
 470         ))))
 471
 472 (defun replace-top-string (old new)
 473   (interactive "*sOld string: \nsNew string: ")
 474   (while (re-search-forward
 475           (concat "^" (regexp-quote old)) nil t)
 476     (replace-match new)))
 477
 478 (defun string-compare-from-top (str1 str2)
 479   (let* ((len1 (length str1))
 480          (len2 (length str2))
 481          (len (min len1 len2))
 482          (p 0)
 483          c1 c2)
 484     (while (and (< p len)
 485                 (progn
 486                   (setq c1 (aref str1 p)
 487                         c2 (aref str2 p))
 488                   (eq c1 c2)))
 489       (setq p (+ p (char-length c1))))
 490     (and (> p 0)
 491          (let ((matched (substring str1 0 p))
 492                (r1 (and (< p len1)(substring str1 p)))
 493                (r2 (and (< p len2)(substring str2 p))))
 494            (if (eq r1 r2)
 495                matched
 496              (list 'seq matched (list 'or r1 r2)))))))
 497
 498
 499 ;;; @ obsoletes
 500 ;;;
 501
 502 ;; This part will be abolished in the future.
 503
 504 (define-obsolete-function-alias
 505   'mu-cite/cite-original 'mu-cite-original)
 506 (define-obsolete-function-alias
 507   'mu-cite/get-field-value 'mu-cite-get-field-value)
 508 (define-obsolete-function-alias
 509   'mu-cite/get-value 'mu-cite-get-value)
 510
 511 (eval-when-compile (require 'static))
 512
 513 (static-when (featurep 'xemacs)
 514   (define-obsolete-variable-alias
 515     'mu-cite/default-methods-alist
 516     'mu-cite-default-methods-alist)
 517   (define-obsolete-variable-alias
 518     'mu-cite/cited-prefix-regexp
 519     'mu-cite-cited-prefix-regexp)
 520   (define-obsolete-variable-alias
 521     'mu-cite/prefix-format
 522     'mu-cite-prefix-format)
 523   (define-obsolete-variable-alias
 524     'mu-cite/top-format
 525     'mu-cite-top-format)
 526   (define-obsolete-variable-alias
 527     'mu-cite/instantiation-hook
 528     'mu-cite-instantiation-hook)
 529   (define-obsolete-variable-alias
 530     'mu-cite/pre-cite-hook
 531     'mu-cite-pre-cite-hook)
 532   (define-obsolete-variable-alias
 533     'mu-cite/post-cite-hook
 534     'mu-cite-post-cite-hook)
 535   (define-obsolete-variable-alias
 536     'mu-cite/get-field-value-method-alist
 537     'mu-cite-get-field-value-method-alist)
 538   (define-obsolete-variable-alias
 539     'mu-cite/ml-count-field-list
 540     'mu-cite-ml-count-field-list)
 541   )
 542
 543
 544 ;;; @ end
 545 ;;;
 546
 547 (provide 'mu-cite)
 548
 549 (run-hooks 'mu-cite-load-hook)
 550
 551 ;;; mu-cite.el ends here