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