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
 183 ;;; @ formats
 184 ;;;
 185
 186 (defcustom mu-cite-cited-prefix-regexp
 187   "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)"
 188   "Regexp to match the citation prefix.
 189 If match, mu-cite doesn't insert citation prefix."
 190   :type 'regexp
 191   :group 'mu-cite)
 192
 193 (defcustom mu-cite-prefix-format '(prefix-register-verbose "> ")
 194   "List to represent citation prefix.
 195 Each elements must be string or method name."
 196   :type (list 'repeat
 197               (nconc '(choice :tag "String or Method name")
 198                      (mapcar
 199                       (function
 200                        (lambda (elem) (list 'choice-item (car elem))))
 201                       mu-cite-default-methods-alist)
 202                      '((symbol :tag "Other Method")
 203                        (item "-")
 204                        (choice-item :tag "String: \"> \"" "> ")
 205                        (string :tag "Other String"))))
 206   :group 'mu-cite)
 207
 208 (defcustom mu-cite-top-format '(in-id ">>>>>\t" from " wrote:\n")
 209   "List to represent top string of citation.
 210 Each elements must be string or method name."
 211   :type (list 'repeat
 212               (nconc
 213                '(choice :tag "String or Method name")
 214                (mapcar
 215                 (function
 216                  (lambda (elem) (list 'choice-item (car elem))))
 217                 mu-cite-default-methods-alist)
 218                '((symbol :tag "Other Method")
 219                  (item "-")
 220                  (choice-item :tag "String: \">>>>>\\t\"" ">>>>>\t")
 221                  (choice-item :tag "String: \" wrote:\\n\"" " wrote:\n")
 222                  (string :tag "Other String"))))
 223   :group 'mu-cite)
 224
 225
 226 ;;; @ hooks
 227 ;;;
 228
 229 (defcustom mu-cite-instantiation-hook nil
 230   "List of functions called just before narrowing to the message."
 231   :type 'hook
 232   :group 'mu-cite)
 233
 234 (defcustom mu-cite-pre-cite-hook nil
 235   "List of functions called before citing a region of text."
 236   :type 'hook
 237   :group 'mu-cite)
 238
 239 (defcustom mu-cite-post-cite-hook nil
 240   "List of functions called after citing a region of text."
 241   :type 'hook
 242   :group 'mu-cite)
 243
 244
 245 ;;; @ field
 246 ;;;
 247
 248 (defvar mu-cite-get-field-value-method-alist nil
 249   "Alist major-mode vs. function to get field-body of header.")
 250
 251 (defun mu-cite-get-field-value (name)
 252   "Return the value of the header field NAME.
 253 If the field is not found in the header, a method function which is
 254 registered in variable `mu-cite-get-field-value-method-alist' is called."
 255   (or (std11-field-body name)
 256       (let ((method (assq major-mode mu-cite-get-field-value-method-alist)))
 257         (if method
 258             (funcall (cdr method) name)))))
 259
 260
 261 ;;; @ item methods
 262 ;;;
 263
 264 ;;; @@ ML count
 265 ;;;
 266
 267 (defcustom mu-cite-ml-count-field-list
 268   '("X-Ml-Count" "X-Mail-Count" "X-Seqno" "X-Sequence" "Mailinglist-Id")
 269   "List of header fields which contain sequence number of mailing list."
 270   :type '(repeat (choice (choice-item "X-Ml-Count")
 271                          (choice-item "X-Mail-Count")
 272                          (choice-item "X-Seqno")
 273                          (choice-item "X-Sequence")
 274                          (choice-item "Mailinglist-Id")
 275                          (item "-")
 276                          (string :tag "Other")))
 277   :group 'mu-cite)
 278
 279 (defun mu-cite-get-ml-count-method ()
 280   "A mu-cite method to return a ML-count.
 281 This function searches a field about ML-count, which is specified by
 282 variable `mu-cite-ml-count-field-list', in a header.
 283 If the field is found, the function returns a number part of the
 284 field.
 285
 286 Notice that please use (mu-cite-get-value 'ml-count)
 287 instead of call the function directly."
 288   (let ((field-list mu-cite-ml-count-field-list))
 289     (catch 'tag
 290       (while field-list
 291         (let* ((field (car field-list))
 292                (ml-count (mu-cite-get-field-value field)))
 293           (if (and ml-count (string-match "[0-9]+" ml-count))
 294               (throw 'tag (match-string 0 ml-count)))
 295           (setq field-list (cdr field-list)))))))
 296
 297
 298 ;;; @ fundamentals
 299 ;;;
 300
 301 (defvar mu-cite-methods-alist nil)
 302
 303 (defun mu-cite-make-methods ()
 304   (setq mu-cite-methods-alist
 305         (copy-alist mu-cite-default-methods-alist))
 306   (run-hooks 'mu-cite-instantiation-hook))
 307
 308 (defun mu-cite-get-value (item)
 309   "Return current value of ITEM."
 310   (let ((ret (cdr (assoc item mu-cite-methods-alist))))
 311     (if (functionp ret)
 312         (prog1
 313             (setq ret (save-excursion (funcall ret)))
 314           (set-alist 'mu-cite-methods-alist item ret))
 315       ret)))
 316
 317 (defun mu-cite-eval-format (list)
 318   (mapconcat (function
 319               (lambda (elt)
 320                 (cond ((stringp elt) elt)
 321                       ((symbolp elt) (mu-cite-get-value elt)))))
 322              list ""))
 323
 324
 325 ;;; @ main function
 326 ;;;
 327
 328 ;;;###autoload
 329 (defun mu-cite-original ()
 330   "Citing filter function.
 331 This is callable from the various mail and news readers' reply
 332 function according to the agreed upon standard."
 333   (interactive)
 334   (mu-cite-make-methods)
 335   (save-restriction
 336     (if (< (mark t) (point))
 337         (exchange-point-and-mark))
 338     (narrow-to-region (point)(point-max))
 339     (run-hooks 'mu-cite-pre-cite-hook)
 340     (let ((last-point (point))
 341           (top (mu-cite-eval-format mu-cite-top-format))
 342           (prefix (mu-cite-eval-format mu-cite-prefix-format)))
 343       (if (re-search-forward "^-*$" nil nil)
 344           (forward-line 1))
 345       (widen)
 346       (delete-region last-point (point))
 347       (insert top)
 348       (setq last-point (point))
 349       (while (< (point)(mark t))
 350         (or (looking-at mu-cite-cited-prefix-regexp)
 351             (insert prefix))
 352         (forward-line 1))
 353       (goto-char last-point))
 354     (run-hooks 'mu-cite-post-cite-hook)))
 355
 356
 357 ;;; @ message editing utilities
 358 ;;;
 359
 360 (defcustom citation-mark-chars ">}|"
 361   "String of characters for citation delimiter."
 362   :type 'string
 363   :group 'mu-cite)
 364
 365 (defcustom citation-disable-chars "<{"
 366   "String of characters not allowed as citation-prefix."
 367   :type 'string
 368   :group 'mu-cite)
 369
 370 (defun-maybe-cond char-category (character)
 371   "Return string of category mnemonics for CHAR in TABLE.
 372 CHAR can be any multilingual character
 373 TABLE defaults to the current buffer's category table."
 374   ((and (subr-fboundp 'char-category-set)
 375         (subr-fboundp 'category-set-mnemonics))
 376    (category-set-mnemonics (char-category-set character))
 377    )
 378   ((fboundp 'char-category-list)
 379    (mapconcat (lambda (chr)
 380                 (char-to-string (int-char chr)))
 381               (char-category-list character)
 382               "")
 383    )
 384   ((boundp 'NEMACS)
 385    (if (< (char-int character) 128)
 386        "al"
 387      "j")
 388    )
 389   (t
 390    (if (< (char-int character) 128)
 391        "al"
 392      "l")
 393    ))
 394
 395 (defun detect-paragraph-cited-prefix ()
 396   (save-excursion
 397     (goto-char (point-min))
 398     (let ((i 0)
 399           (prefix
 400            (buffer-substring (line-beginning-position)
 401                              (line-end-position)))
 402           str ret)
 403       (while (and (= (forward-line) 0)
 404                   (setq str (buffer-substring
 405                              (progn (beginning-of-line)(point))
 406                              (progn (end-of-line)(point))))
 407                   (setq ret (string-compare-from-top prefix str)))
 408         (setq prefix
 409               (if (stringp ret)
 410                   ret
 411                 (cadr ret)))
 412         (setq i (1+ i)))
 413       (cond ((> i 1) prefix)
 414             ((> i 0)
 415              (goto-char (point-min))
 416              (save-restriction
 417                (narrow-to-region (point)
 418                                  (+ (point)(length prefix)))
 419                (goto-char (point-max))
 420                (if (re-search-backward
 421                     (concat "[" citation-mark-chars "]") nil t)
 422                    (progn
 423                      (goto-char (match-end 0))
 424                      (if (looking-at "[ \t]+")
 425                          (goto-char (match-end 0)))
 426                      (buffer-substring (point-min)(point)))
 427                  prefix)))
 428             ((progn
 429                (goto-char (point-max))
 430                (re-search-backward
 431                 (concat "[" citation-disable-chars "]") nil t)
 432                (re-search-backward
 433                 (concat "[" citation-mark-chars "]") nil t))
 434              (goto-char (match-end 0))
 435              (if (looking-at "[ \t]+")
 436                  (goto-char (match-end 0)))
 437              (buffer-substring (point-min)(point)))
 438             (t "")))))
 439
 440 ;;;###autoload
 441 (defun fill-cited-region (beg end)
 442   "Fill each of the paragraphs in the region as a cited text."
 443   (interactive "*r")
 444   (save-excursion
 445     (save-restriction
 446       (goto-char end)
 447       (and (search-backward "\n" nil t)
 448            (setq end (match-end 0)))
 449       (narrow-to-region beg end)
 450       (let* ((fill-prefix (detect-paragraph-cited-prefix))
 451              (pat (concat fill-prefix "\n")))
 452         (goto-char (point-min))
 453         (while (search-forward pat nil t)
 454           (let ((b (match-beginning 0))
 455                 (e (match-end 0)))
 456             (delete-region b e)
 457             (if (and (> b (point-min))
 458                      (let ((cat (char-category
 459                                  (char-before b))))
 460                        (or (string-match "a" cat)
 461                            (string-match "l" cat))))
 462                 (insert " "))))
 463         (goto-char (point-min))
 464         (fill-region (point-min) (point-max))))))
 465
 466 ;;;###autoload
 467 (defun compress-cited-prefix ()
 468   "Compress nested cited prefixes."
 469   (interactive)
 470   (save-excursion
 471     (goto-char (point-min))
 472     (re-search-forward
 473      (concat "^" (regexp-quote mail-header-separator) "$") nil t)
 474     (while (re-search-forward
 475             (concat "^\\([ \t]*[^ \t\n" citation-mark-chars "]*["
 476                     citation-mark-chars "]\\)+") nil t)
 477       (let* ((b (match-beginning 0))
 478              (e (match-end 0))
 479              (prefix (buffer-substring b e))
 480              ps pe (s 0)
 481              (nest (let ((i 0))
 482                      (if (string-match "<[^<>]+>" prefix)
 483                          (setq prefix
 484                                (substring prefix 0 (match-beginning 0))))
 485                      (while (string-match
 486                              (concat "\\([" citation-mark-chars "]+\\)[ \t]*")
 487                              prefix s)
 488                        (setq i (+ i (- (match-end 1)(match-beginning 1)))
 489                              ps s
 490                              pe (match-beginning 1)
 491                              s (match-end 0)))
 492                      i)))
 493         (when (and ps (< ps pe))
 494           (delete-region b e)
 495           (insert (concat (substring prefix ps pe) (make-string nest ?>))))
 496         ))))
 497
 498 (defun replace-top-string (old new)
 499   (interactive "*sOld string: \nsNew string: ")
 500   (while (re-search-forward
 501           (concat "^" (regexp-quote old)) nil t)
 502     (replace-match new)))
 503
 504 (defun string-compare-from-top (str1 str2)
 505   (let* ((len1 (length str1))
 506          (len2 (length str2))
 507          (len (min len1 len2))
 508          (p 0)
 509          c1 c2)
 510     (while (and (< p len)
 511                 (progn
 512                   (setq c1 (sref str1 p)
 513                         c2 (sref str2 p))
 514                   (eq c1 c2)))
 515       (setq p (char-next-index c1 p)))
 516     (and (> p 0)
 517          (let ((matched (substring str1 0 p))
 518                (r1 (and (< p len1)(substring str1 p)))
 519                (r2 (and (< p len2)(substring str2 p))))
 520            (if (eq r1 r2)
 521                matched
 522              (list 'seq matched (list 'or r1 r2)))))))
 523
 524
 525 ;;; @ obsoletes
 526 ;;;
 527
 528 ;; This part will be abolished in the future.
 529
 530 (define-obsolete-function-alias
 531   'mu-cite/cite-original 'mu-cite-original)
 532 (define-obsolete-function-alias
 533   'mu-cite/get-field-value 'mu-cite-get-field-value)
 534 (define-obsolete-function-alias
 535   'mu-cite/get-value 'mu-cite-get-value)
 536
 537
 538 ;;; @ end
 539 ;;;
 540
 541 (provide 'mu-cite)
 542
 543 (run-hooks 'mu-cite-load-hook)
 544
 545 ;; This part will be abolished in the future.
 546
 547 (static-unless (featurep 'xemacs)
 548   (let ((rest mu-cite-obsolete-variable-alist)
 549         def new-sym old-sym)
 550     (while rest
 551       (setq def (car rest))
 552       (apply (function make-obsolete-variable) def)
 553       (setq old-sym (car def)
 554             new-sym (car (cdr def)))
 555       (or (get new-sym 'saved-value) ; saved?
 556           (not (eq (eval (car (get new-sym 'standard-value)))
 557                    (symbol-value new-sym))) ; set as new name?
 558           (and (boundp old-sym) ; old name seems used
 559                (or (eq (symbol-value new-sym)
 560                        (symbol-value old-sym))
 561                    (set new-sym (symbol-value old-sym)))))
 562       (setq rest (cdr rest)))))
 563
 564 ;;; mu-cite.el ends here