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