2 ;;; tm-ew-d.el --- RFC 1522 based multilingual MIME message header
3 ;;; encoder for GNU Emacs
5 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
6 ;;; Copyright (C) 1993,1994,1995 MORIOKA Tomohiko
8 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
10 ;;; $Id: tm-ew-e.el,v 7.0 1995/10/03 04:35:11 morioka Exp $
11 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
19 ;;; @ encoded-text encoder
22 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
24 (cond ((string= encoding "B")
25 (base64-encode-string string))
26 ((string= encoding "Q")
27 (q-encoding-encode-string string mode))
31 (concat "=?" charset "?" encoding "?" text "?=")
38 (defun tm-eword::char-type (chr)
39 (if (or (= chr 32)(= chr ?\t))
41 (char-leading-char chr)
44 (defun tm-eword::parse-lc-word (str)
45 (let* ((rest (string-to-char-list str))
47 (lc (tm-eword::char-type chr))
51 (while (setq rest (cdr rest))
53 (if (not (eq lc (tm-eword::char-type chr)))
56 (setq p (+ p (char-bytes chr)))
58 (cons (cons lc (substring str 0 p)) (substring str p))
61 (defun tm-eword::split-to-lc-words (str)
63 (while (and (not (string= str ""))
64 (setq ret (tm-eword::parse-lc-word str))
66 (setq dest (cons (car ret) dest))
76 (defun tm-eword::parse-word (lcwl)
77 (let* ((lcw (car lcwl))
86 (while (setq lcwl (cdr lcwl))
92 (if (not (memq lc lcl))
93 (setq lcl (cons lc lcl))
95 (setq str (concat str (cdr lcw)))
97 (cons (cons lcl str) lcwl)
100 (defun tm-eword::lc-words-to-words (lcwl)
102 (while (setq ret (tm-eword::parse-word lcwl))
103 (setq dest (cons (car ret) dest))
104 (setq lcwl (cdr ret))
113 (defun mime/find-charset-rule (lcl)
115 (let ((ret (some-element
118 (subsetp lcl (car elt))
120 mime/lc-charset-rule-list)
124 mime/unknown-charset-rule)
129 (defun tm-eword::words-to-ruled-words (wl)
132 (cons (cdr word) (mime/find-charset-rule (car word)))
136 (defun tm-eword::space-process (seq)
137 (let (prev a ac b c cc)
147 (if (and (nth 2 a)(nth 2 c))
150 (cons (concat (car a)(car b)(car c))
158 (cons (concat (car a)(car b))
163 (setq prev (cons b prev))
165 (setq prev (cons b prev))
170 (defun tm-eword::split-string (str)
171 (tm-eword::space-process
172 (tm-eword::words-to-ruled-words
173 (tm-eword::lc-words-to-words
174 (tm-eword::split-to-lc-words str)
181 (defun base64-length (string)
182 (let ((l (length string)))
184 (if (= (mod l 3) 0) 0 1)
188 (defun q-encoding-length (string)
189 (let ((l 0)(i 0)(len (length string)) chr)
191 (setq chr (elt string i))
192 (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
199 (defun tm-eword::encoded-word-length (rword)
200 (let ((charset (nth 1 rword))
201 (encoding (nth 2 rword))
205 (cond ((equal encoding "B")
207 (mime/convert-string-from-emacs string charset))
208 (base64-length string)
210 ((equal encoding "Q")
212 (mime/convert-string-from-emacs string charset))
213 (q-encoding-length string)
216 (cons (+ 7 (length charset) ret) string)
223 (defun tm-eword::encode-string-1 (column rwl &optional mode)
224 (let* ((rword (car rwl))
225 (ret (tm-eword::encoded-word-length rword))
228 (cond ((and (setq string (car rword))
229 (<= (setq len (+ (length string) column)) 76)
237 (cond ((and (setq len (car ret))
238 (<= (+ column len) 76)
241 (tm-eword::encode-encoded-text
242 (nth 1 rword) (nth 2 rword) (cdr ret)
244 (setq len (+ (length string) column))
248 (setq string (car rword))
249 (let* ((ls (reverse (string-to-char-list string)))
254 (setq p (- p (char-bytes (car ls))))
255 (setq str (substring string 0 p))
256 (setq ret (tm-eword::encoded-word-length
257 (cons str (cdr rword))
260 (setq len (+ (car ret) column))
267 (setq rwl (cons (cons (substring string p) (cdr rword))
270 (tm-eword::encode-encoded-text
271 (nth 1 rword) (nth 2 rword) str))
272 (setq len (+ (length string) column))
279 (list string len rwl)
282 (defun tm-eword::encode-rwl (column rwl &optional mode)
285 (setq ret (tm-eword::encode-string-1 column rwl mode))
286 (setq dest (concat dest (car ret))
293 (defun tm-eword::encode-string (column str &optional mode)
294 (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
301 (defun tm-eword::phrase-to-rwl (phrase)
302 (let (token type dest)
304 (setq token (car phrase))
305 (setq type (car token))
306 (cond ((eq type 'quoted-string)
310 (tm-eword::words-to-ruled-words
311 (tm-eword::lc-words-to-words
312 (tm-eword::split-to-lc-words (cdr token))))
320 (tm-eword::words-to-ruled-words
321 (tm-eword::lc-words-to-words
322 (tm-eword::split-to-lc-words (cdr token))))
327 (setq dest (append dest
328 (tm-eword::words-to-ruled-words
329 (tm-eword::lc-words-to-words
330 (tm-eword::split-to-lc-words (cdr token))
333 (setq phrase (cdr phrase))
335 (tm-eword::space-process dest)
338 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
339 (if (eq (car phrase-route-addr) 'phrase-route-addr)
340 (let ((phrase (nth 1 phrase-route-addr))
341 (route (nth 2 phrase-route-addr))
343 (setq dest (tm-eword::phrase-to-rwl phrase))
345 (setq dest (append dest '((" " nil nil))))
349 (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
352 (defun tm-eword::addr-spec-to-rwl (addr-spec)
353 (if (eq (car addr-spec) 'addr-spec)
354 (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
357 (defun tm-eword::mailbox-to-rwl (mbox)
358 (let ((addr (nth 1 mbox))
359 (comment (nth 2 mbox))
361 (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
362 (tm-eword::addr-spec-to-rwl addr)
369 (tm-eword::split-string comment)
374 (defun tm-eword::addresses-to-rwl (addresses)
375 (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
377 (while (setq addresses (cdr addresses))
378 (setq dest (append dest
381 (tm-eword::mailbox-to-rwl (car addresses))
386 (defun tm-eword::encode-address-list (column str)
387 (tm-eword::encode-rwl
389 (tm-eword::addresses-to-rwl
390 (rfc822/parse-addresses
391 (rfc822/lexical-analyze str)))))