1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Version: $Revision: 0.30 $
7 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
9 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
32 (require 'eword-decode)
38 (defconst eword-encode-RCS-ID
39 "$Id: eword-encode.el,v 0.30 1997-07-13 19:30:26 morioka Exp $")
40 (defconst eword-encode-version (get-version-string eword-encode-RCS-ID))
46 (defvar eword-field-encoding-method-alist
47 '(("X-Nsubject" . iso-2022-jp-2)
52 "*Alist to specify field encoding method.
53 Its key is field-name, value is encoding method.
55 If method is `mime', this field will be encoded into MIME format.
57 If method is a MIME-charset, this field will be encoded as the charset
58 when it must be convert into network-code.
60 If method is `default-mime-charset', this field will be encoded as
61 variable `default-mime-charset' when it must be convert into
64 If method is nil, this field will not be encoded.")
66 (defvar eword-generate-X-Nsubject nil
67 "*If it is not nil, X-Nsubject field is generated
68 when Subject field is encoded by `eword-encode-header'.")
70 (defvar eword-charset-encoding-alist
88 (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
102 (cond ((string= encoding "B")
103 (base64-encode-string string))
104 ((string= encoding "Q")
105 (q-encoding-encode-string string mode))
109 (concat "=?" (upcase (symbol-name charset)) "?"
110 encoding "?" text "?=")
117 (defsubst eword-encode-char-type (character)
118 (if (or (eq character ? )(eq character ?\t))
120 (char-charset character)
123 (defun eword-encode-divide-into-charset-words (string)
124 (let ((len (length string))
127 (let* ((chr (sref string 0))
128 (charset (eword-encode-char-type chr))
131 (while (and (< i len)
132 (setq chr (sref string i))
133 (eq charset (eword-encode-char-type chr))
135 (setq i (+ i (char-bytes chr)))
137 (setq dest (cons (cons charset (substring string 0 i)) dest)
138 string (substring string i)
148 (defun eword-encode-charset-words-to-words (charset-words)
151 (let* ((charset-word (car charset-words))
152 (charset (car charset-word))
155 (let ((charsets (list charset))
156 (str (cdr charset-word))
159 (while (setq charset-words (cdr charset-words))
160 (setq charset-word (car charset-words)
161 charset (car charset-word))
165 (or (memq charset charsets)
166 (setq charsets (cons charset charsets))
168 (setq str (concat str (cdr charset-word)))
170 (setq dest (cons (cons charsets str) dest))
172 (setq dest (cons charset-word dest)
173 charset-words (cdr charset-words)
182 (defmacro tm-eword::make-rword (text charset encoding type)
183 (` (list (, text)(, charset)(, encoding)(, type))))
184 (defmacro tm-eword::rword-text (rword)
186 (defmacro tm-eword::rword-charset (rword)
187 (` (car (cdr (, rword)))))
188 (defmacro tm-eword::rword-encoding (rword)
189 (` (car (cdr (cdr (, rword))))))
190 (defmacro tm-eword::rword-type (rword)
191 (` (car (cdr (cdr (cdr (, rword)))))))
193 (defun tm-eword::find-charset-rule (charsets)
195 (let* ((charset (charsets-to-mime-charset charsets))
196 (encoding (cdr (assq charset eword-charset-encoding-alist)))
198 (list charset encoding)
201 (defun tm-eword::words-to-ruled-words (wl &optional mode)
204 (let ((ret (tm-eword::find-charset-rule (car word))))
205 (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
209 (defun tm-eword::space-process (seq)
210 (let (prev a ac b c cc)
215 (setq cc (tm-eword::rword-charset c))
216 (if (null (tm-eword::rword-charset b))
219 (setq ac (tm-eword::rword-charset a))
220 (if (and (tm-eword::rword-encoding a)
221 (tm-eword::rword-encoding c))
224 (cons (concat (car a)(car b)(car c))
232 (cons (concat (car a)(car b))
237 (setq prev (cons b prev))
239 (setq prev (cons b prev))
244 (defun tm-eword::split-string (str &optional mode)
245 (tm-eword::space-process
246 (tm-eword::words-to-ruled-words
247 (eword-encode-charset-words-to-words
248 (eword-encode-divide-into-charset-words str))
255 (defun tm-eword::encoded-word-length (rword)
256 (let ((string (tm-eword::rword-text rword))
257 (charset (tm-eword::rword-charset rword))
258 (encoding (tm-eword::rword-encoding rword))
261 (cond ((string-equal encoding "B")
262 (setq string (encode-mime-charset-string string charset))
263 (base64-encoded-length string)
265 ((string-equal encoding "Q")
266 (setq string (encode-mime-charset-string string charset))
267 (q-encoding-encoded-length string
268 (tm-eword::rword-type rword))
271 (cons (+ 7 (length (symbol-name charset)) ret) string)
278 (defun tm-eword::encode-string-1 (column rwl)
279 (let* ((rword (car rwl))
280 (ret (tm-eword::encoded-word-length rword))
283 (cond ((and (setq string (car rword))
284 (or (<= (setq len (+ (length string) column)) 76)
293 (cond ((and (setq len (car ret))
294 (<= (+ column len) 76)
298 (tm-eword::rword-charset rword)
299 (tm-eword::rword-encoding rword)
301 (tm-eword::rword-type rword)
303 (setq len (+ (length string) column))
307 (setq string (car rword))
310 (while (and (< p len)
312 (setq np (+ p (char-bytes (sref string p))))
313 (setq nstr (substring string 0 np))
314 (setq ret (tm-eword::encoded-word-length
315 (cons nstr (cdr rword))
317 (setq nstr (cdr ret))
318 (setq len (+ (car ret) column))
323 (if (string-equal str "")
326 (setq rwl (cons (cons (substring string p) (cdr rword))
330 (tm-eword::rword-charset rword)
331 (tm-eword::rword-encoding rword)
333 (tm-eword::rword-type rword)))
334 (setq len (+ (length string) column))
338 (list string len rwl)
341 (defun tm-eword::encode-rwl (column rwl)
342 (let (ret dest ps special str ew-f pew-f)
344 (setq ew-f (nth 2 (car rwl)))
346 (setq rwl (cons '(" ") rwl)
350 (setq ret (tm-eword::encode-string-1 column rwl))
352 (if (eq (elt str 0) ?\n)
355 (setq dest (concat dest "\n ("))
356 (setq ret (tm-eword::encode-string-1 2 rwl))
359 (cond ((eq special ? )
360 (if (string= str "(")
362 (setq dest (concat dest " "))
368 (setq dest (concat dest " ("))
371 (setq dest (concat dest "("))
374 (cond ((string= str " ")
382 (setq dest (concat dest str))
384 (setq column (nth 1 ret)
390 (defun tm-eword::encode-string (column str &optional mode)
391 (tm-eword::encode-rwl column (tm-eword::split-string str mode))
398 (defun tm-eword::phrase-to-rwl (phrase)
399 (let (token type dest str)
401 (setq token (car phrase))
402 (setq type (car token))
403 (cond ((eq type 'quoted-string)
404 (setq str (concat "\"" (cdr token) "\""))
408 (let ((ret (tm-eword::find-charset-rule
409 (find-non-ascii-charset-string str))))
410 (tm-eword::make-rword
411 str (car ret)(nth 1 ret) 'phrase)
419 (tm-eword::words-to-ruled-words
420 (eword-encode-charset-words-to-words
421 (eword-encode-divide-into-charset-words
430 (tm-eword::words-to-ruled-words
431 (eword-encode-charset-words-to-words
432 (eword-encode-divide-into-charset-words
436 (setq phrase (cdr phrase))
438 (tm-eword::space-process dest)
441 (defun eword-addr-seq-to-rwl (seq)
444 (let* ((token (car seq))
447 (cond ((eq name 'spaces)
448 (setq dest (nconc dest (list (list (cdr token) nil nil))))
454 (list (list "(" nil nil))
455 (tm-eword::split-string (cdr token) 'comment)
456 (list (list ")" nil nil))
459 ((eq name 'quoted-string)
464 (list (concat "\"" (cdr token) "\"") nil nil)
469 (if (or (eq pname 'spaces)
471 (nconc dest (list (list (cdr token) nil nil)))
472 (nconc (butlast dest)
474 (list (concat (car (car (last dest)))
483 (defun eword-phrase-route-addr-to-rwl (phrase-route-addr)
484 (if (eq (car phrase-route-addr) 'phrase-route-addr)
485 (let ((phrase (nth 1 phrase-route-addr))
486 (route (nth 2 phrase-route-addr))
488 (if (eq (car (car phrase)) 'spaces)
489 (setq phrase (cdr phrase))
491 (setq dest (tm-eword::phrase-to-rwl phrase))
493 (setq dest (append dest '((" " nil nil))))
497 (eword-addr-seq-to-rwl
498 (append '((specials . "<"))
500 '((specials . ">"))))
503 (defun eword-addr-spec-to-rwl (addr-spec)
504 (if (eq (car addr-spec) 'addr-spec)
505 (eword-addr-seq-to-rwl (cdr addr-spec))
508 (defun tm-eword::mailbox-to-rwl (mbox)
509 (let ((addr (nth 1 mbox))
510 (comment (nth 2 mbox))
512 (setq dest (or (eword-phrase-route-addr-to-rwl addr)
513 (eword-addr-spec-to-rwl addr)
520 (tm-eword::split-string comment 'comment)
525 (defun tm-eword::addresses-to-rwl (addresses)
526 (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
528 (while (setq addresses (cdr addresses))
529 (setq dest (append dest
532 (tm-eword::mailbox-to-rwl (car addresses))
537 (defun tm-eword::encode-address-list (column str)
538 (tm-eword::encode-rwl
540 (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
544 ;;; @ application interfaces
547 (defun eword-encode-field (string)
548 "Encode header field STRING, and return the result.
549 A lexical token includes non-ASCII character is encoded as MIME
550 encoded-word. ASCII token is not encoded."
551 (setq string (std11-unfold-string string))
552 (let ((ret (string-match std11-field-head-regexp string)))
554 (let ((field-name (substring string 0 (1- (match-end 0))))
555 (field-body (eliminate-top-spaces
556 (substring string (match-end 0))))
559 (cond ((string-equal field-body "") "")
560 ((memq (intern (downcase field-name))
563 resent-reply-to resent-from
564 resent-sender to resent-to
568 (car (tm-eword::encode-address-list
569 (+ (length field-name) 2) field-body))
572 (car (tm-eword::encode-string
573 (1+ (length field-name))
577 (concat field-name ": " ret)
579 (car (tm-eword::encode-string 0 string))
582 (defun eword-in-subject-p ()
583 (let ((str (std11-field-body "Subject")))
584 (if (and str (string-match eword-encoded-word-regexp str))
587 (defun eword-encode-header (&optional code-conversion)
588 "Encode header fields to network representation, such as MIME encoded-word.
590 It refer variable `eword-field-encoding-method-alist'."
594 (std11-narrow-to-header mail-header-separator)
595 (goto-char (point-min))
596 (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
598 (while (re-search-forward std11-field-head-regexp nil t)
599 (setq beg (match-beginning 0))
600 (setq field-name (buffer-substring beg (1- (match-end 0))))
601 (setq end (std11-field-end))
602 (and (find-non-ascii-charset-region beg end)
603 (let ((ret (or (let ((fname (downcase field-name)))
608 (string= fname (downcase str))
610 eword-field-encoding-method-alist))
611 (assq t eword-field-encoding-method-alist)
614 (let ((method (cdr ret)))
615 (cond ((eq method 'mime)
617 (buffer-substring-no-properties beg end)
619 (delete-region beg end)
620 (insert (eword-encode-field field))
624 (or (mime-charset-to-coding-system
627 (encode-coding-region beg end cs)
632 (and eword-generate-X-Nsubject
633 (or (std11-field-body "X-Nsubject")
634 (let ((str (eword-in-subject-p)))
639 (std11-unfold-string str)))
642 (encode-mime-charset-string
648 (string= "x-nsubject"
651 eword-field-encoding-method-alist))
654 (insert (concat "\nX-Nsubject: " str))
658 (defun eword-encode-string (str &optional column mode)
659 (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
666 (provide 'eword-encode)
668 ;;; eword-encode.el ends here