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