1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
8 ;; This file is part of FLIM (Faithful Library about Internet Message).
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
31 (require 'eword-decode)
37 (defgroup eword-encode nil
38 "Encoded-word encoding"
41 (defcustom eword-field-encoding-method-alist
42 '(("X-Nsubject" . iso-2022-jp-2)
47 "*Alist to specify field encoding method.
48 Its key is field-name, value is encoding method.
50 If method is `mime', this field will be encoded into MIME format.
52 If method is a MIME-charset, this field will be encoded as the charset
53 when it must be convert into network-code.
55 If method is `default-mime-charset', this field will be encoded as
56 variable `default-mime-charset' when it must be convert into
59 If method is nil, this field will not be encoded."
61 :type '(repeat (cons (choice :tag "Field"
63 (const :tag "Default" t))
65 (const :tag "MIME conversion" mime)
66 (symbol :tag "non-MIME conversion")
67 (const :tag "no-conversion" nil)))))
69 (defvar eword-charset-encoding-alist
87 (iso-2022-int-1 . "B")
92 ;;; @ encoded-text encoder
95 (defun eword-encode-text (charset encoding string &optional mode)
96 "Encode STRING as an encoded-word, and return the result.
97 CHARSET is a symbol to indicate MIME charset of the encoded-word.
98 ENCODING allows \"B\" or \"Q\".
99 MODE is allows `text', `comment', `phrase' or nil. Default value is
101 (let ((text (encoded-text-encode-string string encoding)))
103 (concat "=?" (upcase (symbol-name charset)) "?"
104 encoding "?" text "?=")
111 (defsubst eword-encode-char-type (character)
112 (if (or (eq character ? )(eq character ?\t))
114 (char-charset character)
117 (defun eword-encode-divide-into-charset-words (string)
118 (let ((len (length string))
121 (let* ((chr (sref string 0))
122 (charset (eword-encode-char-type chr))
123 (i (char-length chr)))
124 (while (and (< i len)
125 (setq chr (sref string i))
126 (eq charset (eword-encode-char-type chr))
128 (setq i (char-next-index chr i))
130 (setq dest (cons (cons charset (substring string 0 i)) dest)
131 string (substring string i)
141 (defun eword-encode-charset-words-to-words (charset-words)
144 (let* ((charset-word (car charset-words))
145 (charset (car charset-word))
148 (let ((charsets (list charset))
149 (str (cdr charset-word))
152 (while (setq charset-words (cdr charset-words))
153 (setq charset-word (car charset-words)
154 charset (car charset-word))
158 (or (memq charset charsets)
159 (setq charsets (cons charset charsets))
161 (setq str (concat str (cdr charset-word)))
163 (setq dest (cons (cons charsets str) dest))
165 (setq dest (cons charset-word dest)
166 charset-words (cdr charset-words)
175 (defmacro make-ew-rword (text charset encoding type)
176 (` (list (, text)(, charset)(, encoding)(, type))))
177 (defmacro ew-rword-text (rword)
179 (defmacro ew-rword-charset (rword)
180 (` (car (cdr (, rword)))))
181 (defmacro ew-rword-encoding (rword)
182 (` (car (cdr (cdr (, rword))))))
183 (defmacro ew-rword-type (rword)
184 (` (car (cdr (cdr (cdr (, rword)))))))
186 (defun tm-eword::find-charset-rule (charsets)
188 (let* ((charset (charsets-to-mime-charset charsets))
189 (encoding (cdr (assq charset eword-charset-encoding-alist)))
191 (list charset encoding)
194 (defun tm-eword::words-to-ruled-words (wl &optional mode)
197 (let ((ret (tm-eword::find-charset-rule (car word))))
198 (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
202 (defun tm-eword::space-process (seq)
203 (let (prev a ac b c cc)
208 (setq cc (ew-rword-charset c))
209 (if (null (ew-rword-charset b))
212 (setq ac (ew-rword-charset a))
213 (if (and (ew-rword-encoding a)
214 (ew-rword-encoding c))
217 (cons (concat (car a)(car b)(car c))
225 (cons (concat (car a)(car b))
230 (setq prev (cons b prev))
232 (setq prev (cons b prev))
237 (defun eword-encode-split-string (str &optional mode)
238 (tm-eword::space-process
239 (tm-eword::words-to-ruled-words
240 (eword-encode-charset-words-to-words
241 (eword-encode-divide-into-charset-words str))
248 (defun tm-eword::encoded-word-length (rword)
249 (let ((string (ew-rword-text rword))
250 (charset (ew-rword-charset rword))
251 (encoding (ew-rword-encoding rword))
254 (cond ((string-equal encoding "B")
255 (setq string (encode-mime-charset-string string charset))
256 (base64-encoded-length string)
258 ((string-equal encoding "Q")
259 (setq string (encode-mime-charset-string string charset))
260 (Q-encoded-text-length string (ew-rword-type rword))
263 (cons (+ 7 (length (symbol-name charset)) ret) string)
270 (defun tm-eword::encode-string-1 (column rwl)
271 (let* ((rword (car rwl))
272 (ret (tm-eword::encoded-word-length rword))
275 (cond ((and (setq string (car rword))
276 (or (<= (setq len (+ (length string) column)) 76)
285 (cond ((and (setq len (car ret))
286 (<= (+ column len) 76)
290 (ew-rword-charset rword)
291 (ew-rword-encoding rword)
293 (ew-rword-type rword)
295 (setq len (+ (length string) column))
299 (setq string (car rword))
302 (while (and (< p len)
304 (setq np (char-next-index (sref string p) p))
305 (setq nstr (substring string 0 np))
306 (setq ret (tm-eword::encoded-word-length
307 (cons nstr (cdr rword))
309 (setq nstr (cdr ret))
310 (setq len (+ (car ret) column))
315 (if (string-equal str "")
318 (setq rwl (cons (cons (substring string p) (cdr rword))
322 (ew-rword-charset rword)
323 (ew-rword-encoding rword)
325 (ew-rword-type rword)))
326 (setq len (+ (length string) column))
330 (list string len rwl)
333 (defun eword-encode-rword-list (column rwl)
334 (let (ret dest ps special str ew-f pew-f)
336 (setq ew-f (nth 2 (car rwl)))
338 (setq rwl (cons '(" ") rwl)
342 (setq ret (tm-eword::encode-string-1 column rwl))
344 (if (eq (elt str 0) ?\n)
347 (setq dest (concat dest "\n ("))
348 (setq ret (tm-eword::encode-string-1 2 rwl))
351 (cond ((eq special ? )
352 (if (string= str "(")
354 (setq dest (concat dest " "))
360 (setq dest (concat dest " ("))
363 (setq dest (concat dest "("))
366 (cond ((string= str " ")
374 (setq dest (concat dest str))
376 (setq column (nth 1 ret)
386 (defun eword-encode-phrase-to-rword-list (phrase)
387 (let (token type dest str)
389 (setq token (car phrase))
390 (setq type (car token))
391 (cond ((eq type 'quoted-string)
392 (setq str (concat "\"" (cdr token) "\""))
396 (let ((ret (tm-eword::find-charset-rule
397 (find-non-ascii-charset-string str))))
399 str (car ret)(nth 1 ret) 'phrase)
407 (tm-eword::words-to-ruled-words
408 (eword-encode-charset-words-to-words
409 (eword-encode-divide-into-charset-words
418 (tm-eword::words-to-ruled-words
419 (eword-encode-charset-words-to-words
420 (eword-encode-divide-into-charset-words
424 (setq phrase (cdr phrase))
426 (tm-eword::space-process dest)
429 (defun eword-encode-addr-seq-to-rword-list (seq)
432 (let* ((token (car seq))
435 (cond ((eq name 'spaces)
436 (setq dest (nconc dest (list (list (cdr token) nil nil))))
442 (list (list "(" nil nil))
443 (eword-encode-split-string (cdr token) 'comment)
444 (list (list ")" nil nil))
447 ((eq name 'quoted-string)
452 (list (concat "\"" (cdr token) "\"") nil nil)
457 (if (or (eq pname 'spaces)
459 (nconc dest (list (list (cdr token) nil nil)))
460 (nconc (butlast dest)
462 (list (concat (car (car (last dest)))
471 (defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
472 (if (eq (car phrase-route-addr) 'phrase-route-addr)
473 (let ((phrase (nth 1 phrase-route-addr))
474 (route (nth 2 phrase-route-addr))
476 (if (eq (car (car phrase)) 'spaces)
477 (setq phrase (cdr phrase))
479 (setq dest (eword-encode-phrase-to-rword-list phrase))
481 (setq dest (append dest '((" " nil nil))))
485 (eword-encode-addr-seq-to-rword-list
486 (append '((specials . "<"))
488 '((specials . ">"))))
491 (defun eword-encode-addr-spec-to-rword-list (addr-spec)
492 (if (eq (car addr-spec) 'addr-spec)
493 (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
496 (defun eword-encode-mailbox-to-rword-list (mbox)
497 (let ((addr (nth 1 mbox))
498 (comment (nth 2 mbox))
500 (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
501 (eword-encode-addr-spec-to-rword-list addr)
508 (eword-encode-split-string comment 'comment)
513 (defsubst eword-encode-addresses-to-rword-list (addresses)
514 (let ((dest (eword-encode-mailbox-to-rword-list (car addresses))))
516 (while (setq addresses (cdr addresses))
521 (eword-encode-mailbox-to-rword-list (car addresses))
526 (defsubst eword-encode-msg-id-to-rword-list (msg-id)
528 (append (eword-encode-addr-seq-to-rword-list (cdr msg-id))
531 (defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
536 (let ((elt (car in-reply-to)))
537 (if (eq (car elt) 'phrase)
538 (eword-encode-phrase-to-rword-list (cdr elt))
539 (eword-encode-msg-id-to-rword-list elt)
541 (setq in-reply-to (cdr in-reply-to)))
545 ;;; @ application interfaces
548 (defcustom eword-encode-default-start-column 10
549 "Default start column if it is omitted."
553 (defun eword-encode-string (string &optional column mode)
554 "Encode STRING as encoded-words, and return the result.
555 Optional argument COLUMN is start-position of the field.
556 Optional argument MODE allows `text', `comment', `phrase' or nil.
557 Default value is `phrase'."
558 (car (eword-encode-rword-list
559 (or column eword-encode-default-start-column)
560 (eword-encode-split-string string mode))))
562 (defun eword-encode-address-list (string &optional column)
563 "Encode header field STRING as list of address, and return the result.
564 Optional argument COLUMN is start-position of the field."
565 (car (eword-encode-rword-list
566 (or column eword-encode-default-start-column)
567 (eword-encode-addresses-to-rword-list
568 (std11-parse-addresses-string string))
571 (defun eword-encode-in-reply-to (string &optional column)
572 "Encode header field STRING as In-Reply-To field, and return the result.
573 Optional argument COLUMN is start-position of the field."
574 (car (eword-encode-rword-list
576 (eword-encode-in-reply-to-to-rword-list
577 (std11-parse-in-reply-to
578 (std11-lexical-analyze string))))))
580 (defun eword-encode-structured-field-body (string &optional column)
581 "Encode header field STRING as structured field, and return the result.
582 Optional argument COLUMN is start-position of the field."
583 (car (eword-encode-rword-list
584 (or column eword-encode-default-start-column)
585 (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
588 (defun eword-encode-unstructured-field-body (string &optional column)
589 "Encode header field STRING as unstructured field, and return the result.
590 Optional argument COLUMN is start-position of the field."
591 (car (eword-encode-rword-list
592 (or column eword-encode-default-start-column)
593 (eword-encode-split-string string 'text))))
595 (defun eword-encode-field (string)
596 "Encode header field STRING, and return the result.
597 A lexical token includes non-ASCII character is encoded as MIME
598 encoded-word. ASCII token is not encoded."
599 (setq string (std11-unfold-string string))
600 (let ((ret (string-match std11-field-head-regexp string)))
602 (let ((field-name (substring string 0 (1- (match-end 0))))
603 (field-body (eliminate-top-spaces
604 (substring string (match-end 0))))
607 (cond ((string= field-body "") "")
608 ((memq (setq field-name-symbol
609 (intern (capitalize field-name)))
612 Resent-Reply-To Resent-From
613 Resent-Sender To Resent-To
614 Cc Resent-Cc Bcc Resent-Bcc
616 (eword-encode-address-list
617 field-body (+ (length field-name) 2))
619 ((eq field-name-symbol 'In-Reply-To)
620 (eword-encode-in-reply-to
621 field-body (+ (length field-name) 2))
623 ((memq field-name-symbol
624 '(Mime-Version User-Agent))
625 (eword-encode-structured-field-body
626 field-body (+ (length field-name) 2))
629 (eword-encode-unstructured-field-body
630 field-body (1+ (length field-name)))
633 (concat field-name ": " ret)
635 (eword-encode-string string 0)
638 (defun eword-in-subject-p ()
639 (let ((str (std11-field-body "Subject")))
640 (if (and str (string-match eword-encoded-word-regexp str))
643 (defsubst eword-find-field-encoding-method (field-name)
644 (setq field-name (downcase field-name))
645 (let ((alist eword-field-encoding-method-alist))
648 (let* ((pair (car alist))
650 (if (and (stringp str)
651 (string= field-name (downcase str)))
652 (throw 'found (cdr pair))
654 (setq alist (cdr alist)))
655 (cdr (assq t eword-field-encoding-method-alist))
658 (defun eword-encode-header (&optional code-conversion)
659 "Encode header fields to network representation, such as MIME encoded-word.
661 It refer variable `eword-field-encoding-method-alist'."
665 (std11-narrow-to-header mail-header-separator)
666 (goto-char (point-min))
667 (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
669 (while (re-search-forward std11-field-head-regexp nil t)
670 (setq beg (match-beginning 0))
671 (setq field-name (buffer-substring beg (1- (match-end 0))))
672 (setq end (std11-field-end))
673 (and (find-non-ascii-charset-region beg end)
674 (let ((method (eword-find-field-encoding-method
675 (downcase field-name))))
676 (cond ((eq method 'mime)
678 (buffer-substring-no-properties beg end)
680 (delete-region beg end)
681 (insert (eword-encode-field field))
685 (or (mime-charset-to-coding-system
688 (encode-coding-region beg end cs)
698 (provide 'eword-encode)
700 ;;; eword-encode.el ends here