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