mu-cite.el

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