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