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