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