Fetching contributors…
Cannot retrieve contributors at this time
559 lines (488 sloc) 15.7 KB
;;; mu-cite.el --- yet another citation tool for GNU Emacs
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2005, 2007
;; Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <>
;; Shuhei KOBAYASHI <>
;; Maintainer: Katsumi Yamaoka <>
;; Keywords: mail, news, citation
;; This file is part of MU (Message Utilities).
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; (APEL/FLIM dependency is removed from this code.)
;; - How to use
;; 1. Bytecompile this file and copy it to the apropriate directory.
;; 2. Put the following lines in your ~/.emacs file:
;; For EMACS 19 or later and XEmacs
;; (autoload 'mu-cite-original "mu-cite" nil t)
;; ;; for all but message-mode
;; (add-hook 'mail-citation-hook (function mu-cite-original))
;; ;; for message-mode only
;; (setq message-cite-function (function mu-cite-original))
;; For EMACS 18
;; ;; for all but mh-e
;; (add-hook 'mail-yank-hooks (function mu-cite-original))
;; ;; for mh-e only
;; (add-hook 'mh-yank-hooks (function mu-cite-original))
;;; Code:
;;; copied from APEL
(defun put-alist (key value alist)
"Set cdr of an element (KEY . ...) in ALIST to VALUE and return ALIST.
If there is no such element, create a new pair (KEY . VALUE) and
return a new alist whose car is the new pair and cdr is ALIST."
(let ((elm (assoc key alist)))
(if elm
(setcdr elm value)
(cons (cons key value) alist))))
(defun set-alist (symbol key value)
"Set cdr of an element (KEY . ...) in the alist bound to SYMBOL to VALUE."
(or (boundp symbol)
(set symbol nil))
(set symbol (put-alist key value (symbol-value symbol))))
;;; main
(autoload 'mu-cite-get-prefix-method "mu-register")
(autoload 'mu-cite-get-prefix-register-method "mu-register")
(autoload 'mu-cite-get-prefix-register-verbose-method "mu-register")
(autoload 'mu-bbdb-get-prefix-method "mu-bbdb")
(autoload 'mu-bbdb-get-prefix-register-method "mu-bbdb")
(autoload 'mu-bbdb-get-prefix-register-verbose-method "mu-bbdb")
;;; @ version
(defconst mu-cite-version "8.1")
;;; @ macro
(defmacro mu-cite-remove-text-properties (string)
"Remove text properties from STRING which is read from minibuffer."
(if (or (featurep 'xemacs)
(boundp 'minibuffer-allow-text-properties);; Emacs 20.1 or later.
(not (fboundp 'set-text-properties)));; under Emacs 19.7.
(` (let ((obj (copy-sequence (, string))))
(set-text-properties 0 (length obj) nil obj)
;;; @ set up
(defgroup mu-cite nil
"Yet another citation tool for GNU Emacs."
:prefix "mu-cite-"
:group 'mail
:group 'news)
(defvar mu-cite-default-methods-alist
(list (cons 'from
(lambda ()
(mu-cite-get-field-value "From"))))
(cons 'date
(lambda ()
(mu-cite-get-field-value "Date"))))
(cons 'message-id
(lambda ()
(mu-cite-get-field-value "Message-Id"))))
(cons 'subject
(lambda ()
(mu-cite-get-field-value "Subject"))))
(cons 'ml-name
(lambda ()
(mu-cite-get-field-value "X-Ml-Name"))))
(cons 'ml-count (function mu-cite-get-ml-count-method))
(cons 'address-structure
(lambda ()
(mail-extract-address-components (mu-cite-get-value 'from)))))
(cons 'full-name
(lambda ()
(mu-cite-get-value 'address-structure)))))
(cons 'address
(lambda ()
(mu-cite-get-value 'address-structure)))))
(cons 'id
(lambda ()
(let ((ml-name (mu-cite-get-value 'ml-name))
(ml-count (mu-cite-get-value 'ml-count)))
(if ml-name
(concat "["
(if ml-count
(concat " : No." ml-count))
(mu-cite-get-value 'message-id))))))
(cons 'in-id
(lambda ()
(let ((id (mu-cite-get-value 'id)))
(if id
(format ">>>>> In %s \n" id)
(cons 'x-attribution
(lambda ()
(mu-cite-get-field-value "X-Attribution"))))
(cons 'x-cite-me
(lambda ()
(mu-cite-get-field-value "X-Cite-Me"))))
;; mu-register
(cons 'prefix (function mu-cite-get-prefix-method))
(cons 'prefix-register
(function mu-cite-get-prefix-register-method))
(cons 'prefix-register-verbose
(function mu-cite-get-prefix-register-verbose-method))
;; mu-bbdb
(cons 'bbdb-prefix
(function mu-bbdb-get-prefix-method))
(cons 'bbdb-prefix-register
(function mu-bbdb-get-prefix-register-method))
(cons 'bbdb-prefix-register-verbose
(function mu-bbdb-get-prefix-register-verbose-method))
;;; @ formats
(defcustom mu-cite-cited-prefix-regexp
"\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)"
"Regexp to match the citation prefix.
If match, mu-cite doesn't insert citation prefix."
:type 'regexp
:group 'mu-cite)
(defcustom mu-cite-prefix-format '(prefix-register-verbose "> ")
"List to represent citation prefix.
Each elements must be a string or a method name."
:type (list
(lambda (widget)
:tag "Method or String"
(function (lambda (elem) (list 'choice-item (car elem))))
'((symbol :tag "Method")
(const :tag "-" nil)
(choice-item :tag "String: \"> \"" "> ")
:set (function (lambda (symbol value)
(set-default symbol (delq nil value))))
:group 'mu-cite)
(defcustom mu-cite-top-format '(in-id ">>>>>\t" from " wrote:\n")
"List to represent top string of citation.
Each elements must be a string or a method name."
:type (list
(lambda (widget)
(list 'choice
:tag "Method or String"
(function (lambda (elem) (list 'choice-item (car elem))))
'((symbol :tag "Method")
(const :tag "-" nil)
(choice-item :tag "String: \">>>>>\\t\"" ">>>>>\t")
(choice-item :tag "String: \" wrote:\\n\"" " wrote:\n")
(string :tag "String"))))))))
:set (function (lambda (symbol value)
(set-default symbol (delq nil value))))
:group 'mu-cite)
;;; @ hooks
(defcustom mu-cite-instantiation-hook nil
"List of functions called just before narrowing to the message."
:type 'hook
:group 'mu-cite)
(defcustom mu-cite-pre-cite-hook nil
"List of functions called before citing a region of text."
:type 'hook
:group 'mu-cite)
(defcustom mu-cite-post-cite-hook nil
"List of functions called after citing a region of text."
:type 'hook
:group 'mu-cite)
;;; @ field
(defvar mu-cite-get-field-value-method-alist nil
"Alist major-mode vs. function to get field-body of header.")
(defun mu-cite-get-field-value (name)
"Return the value of the header field NAME.
If the field is not found in the header, a method function which is
registered in variable `mu-cite-get-field-value-method-alist' is called."
(or (mail-fetch-field name)
(let ((method (assq major-mode mu-cite-get-field-value-method-alist)))
(if method
(funcall (cdr method) name)))))
;;; @ item methods
;;; @@ ML count
(defcustom mu-cite-ml-count-field-list
'("X-Ml-Count" "X-Mail-Count" "X-Seqno" "X-Sequence" "Mailinglist-Id")
"List of header fields which contains a sequence number of the mailing list."
:type '(repeat (choice :tag "Field Name"
(choice-item "X-Ml-Count")
(choice-item "X-Mail-Count")
(choice-item "X-Seqno")
(choice-item "X-Sequence")
(choice-item "Mailinglist-Id")
(const :tag "-" nil)
(string :tag "Other")))
:set (function (lambda (symbol value)
(set-default symbol (delq nil value))))
:group 'mu-cite)
(defun mu-cite-get-ml-count-method ()
"A mu-cite method to return a ML-count.
This function searches a field about ML-count, which is specified by
the variable `mu-cite-ml-count-field-list', in a header.
If the field is found, the function returns a number part of the
Notice that please use (mu-cite-get-value 'ml-count)
instead of to call the function directly."
(let ((field-list mu-cite-ml-count-field-list))
(catch 'tag
(while field-list
(let* ((field (car field-list))
(ml-count (mu-cite-get-field-value field)))
(if (and ml-count (string-match "[0-9]+" ml-count))
(throw 'tag (match-string 0 ml-count)))
(setq field-list (cdr field-list)))))))
;;; @ fundamentals
(defvar mu-cite-methods-alist nil)
(defun mu-cite-make-methods ()
(setq mu-cite-methods-alist
(copy-alist mu-cite-default-methods-alist))
(run-hooks 'mu-cite-instantiation-hook))
(defun mu-cite-get-value (item)
"Return a current value of ITEM."
(let ((ret (cdr (assoc item mu-cite-methods-alist))))
(if (functionp ret)
(setq ret (save-excursion (funcall ret)))
(set-alist 'mu-cite-methods-alist item ret))
(defun mu-cite-eval-format (list)
(mapconcat (function
(lambda (elt)
(cond ((stringp elt) elt)
((symbolp elt) (mu-cite-get-value elt)))))
list ""))
;;; @ main function
(defun mu-cite-original ()
"Citing filter function.
This is callable from the various mail and news readers' reply
function according to the agreed upon standard."
(if (< (mark t) (point))
(narrow-to-region (point)(point-max))
(run-hooks 'mu-cite-pre-cite-hook)
(let ((last-point (point))
(top (mu-cite-eval-format mu-cite-top-format))
(prefix (mu-cite-eval-format mu-cite-prefix-format)))
(if (re-search-forward "^-*$" nil nil)
(forward-line 1))
(delete-region last-point (point))
(insert top)
(setq last-point (point))
(while (< (point)(mark t))
(or (and mu-cite-cited-prefix-regexp
(looking-at mu-cite-cited-prefix-regexp))
(insert prefix))
(forward-line 1))
(goto-char last-point))
(run-hooks 'mu-cite-post-cite-hook)))
;;; @ message editing utilities
(defcustom citation-mark-chars ">}|"
"String of characters for citation delimiter."
:type 'string
:group 'mu-cite)
(defcustom citation-disable-chars "<{"
"String of characters not allowed as citation-prefix."
:type 'string
:group 'mu-cite)
(defun char-category (character)
"Return a string of category mnemonics for CHAR in TABLE.
CHAR can be any multilingual character,
TABLE defaults to the current buffer's category table."
(category-set-mnemonics (char-category-set character)))
(defun detect-paragraph-cited-prefix ()
(goto-char (point-min))
(let ((i 0)
(buffer-substring (line-beginning-position)
(let ((init prefix)
str ret)
(while (and (= (forward-line) 0)
(setq str (buffer-substring
(progn (beginning-of-line)(point))
(progn (end-of-line)(point))))
(setq ret (string-compare-from-top prefix str)))
(setq prefix
(if (stringp ret)
(car (cdr ret))))
(or (string-equal init prefix)
(setq i (1+ i)))))
(cond ((> i 1) prefix)
((> i 0)
(goto-char (point-min))
(narrow-to-region (point)
(+ (point)(length prefix)))
(goto-char (point-max))
(if (re-search-backward
(concat "[" citation-mark-chars "]") nil t)
(goto-char (match-end 0))
(if (looking-at "[ \t]+")
(goto-char (match-end 0)))
(buffer-substring (point-min)(point)))
(goto-char (point-max))
(concat "[" citation-disable-chars "]") nil t)
(concat "[" citation-mark-chars "]") nil t))
(goto-char (match-end 0))
(if (looking-at "[ \t]+")
(goto-char (match-end 0)))
(buffer-substring (line-beginning-position)(point)))
(t "")))))
(defcustom fill-column-for-fill-cited-region nil
"Integer to override `fill-column' while `fill-cited-region' is being
executed. If you wish people call you ****-san, you may set the value
of `fill-column' to 60 in the buffer for message sending and set this
to 70. :-)"
:type `(choice (const :tag "Off" nil)
(integer ,default-fill-column))
:group 'mu-cite)
(defun fill-cited-region (beg end)
"Fill each of the paragraphs in the region as a cited text."
(interactive "*r")
(goto-char end)
(and (search-backward "\n" nil t)
(setq end (match-end 0)))
(narrow-to-region beg end)
(let* ((fill-prefix (detect-paragraph-cited-prefix))
(fill-column (max (+ 1 (current-left-margin)
(string-width fill-prefix))
(or fill-column-for-fill-cited-region
(pat (concat fill-prefix "\n"))
(goto-char (point-min))
(while (search-forward pat nil t)
(let ((b (match-beginning 0))
(e (match-end 0)))
(delete-region b e)
(if (and (> b (point-min))
(let ((cat (char-category
(char-before b))))
(or (string-match "a" cat)
(string-match "l" cat))))
(insert " "))))
(goto-char (point-min))
(fill-region (point-min) (point-max))))))
(defun compress-cited-prefix ()
"Compress nested cited prefixes."
(goto-char (point-min))
(concat "^" (regexp-quote mail-header-separator) "$") nil t)
(while (re-search-forward
(concat "^\\([ \t]*[^ \t\n" citation-mark-chars "]*["
citation-mark-chars "]\\)+") nil t)
(let* ((b (match-beginning 0))
(e (match-end 0))
(prefix (buffer-substring b e))
ps pe (s 0)
(nest (let ((i 0))
(if (string-match "<[^<>]+>" prefix)
(setq prefix
(substring prefix 0 (match-beginning 0))))
(while (string-match
(concat "\\([" citation-mark-chars "]+\\)[ \t]*")
prefix s)
(setq i (+ i (- (match-end 1)(match-beginning 1)))
ps s
pe (match-beginning 1)
s (match-end 0)))
(if (and ps (< ps pe))
(delete-region b e)
(insert (concat (substring prefix ps pe)
(make-string nest ?>)))))
(defun replace-top-string (old new)
(interactive "*sOld string: \nsNew string: ")
(while (re-search-forward
(concat "^" (regexp-quote old)) nil t)
(replace-match new)))
(defun string-compare-from-top (str1 str2)
(let* ((len1 (length str1))
(len2 (length str2))
(len (min len1 len2))
(p 0)
c1 c2)
(while (and (< p len)
(setq c1 (sref str1 p)
c2 (sref str2 p))
(eq c1 c2)))
(setq p (char-next-index c1 p)))
(and (> p 0)
(let ((matched (substring str1 0 p))
(r1 (and (< p len1)(substring str1 p)))
(r2 (and (< p len2)(substring str2 p))))
(if (eq r1 r2)
(list 'seq matched (list 'or r1 r2)))))))
;;; @ end
(provide 'mu-cite)
(run-hooks 'mu-cite-load-hook)
;;; mu-cite.el ends here