2 ;;; tm-ew-e.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 .. 1996 MORIOKA Tomohiko
8 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
9 ;;; Version: $Revision: 7.13 $
10 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
12 ;;; This file is part of tm (Tools for MIME).
14 ;;; This program is free software; you can redistribute it and/or
15 ;;; modify it under the terms of the GNU General Public License as
16 ;;; published by the Free Software Foundation; either version 2, or
17 ;;; (at your option) any later version.
19 ;;; This program is distributed in the hope that it will be useful,
20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 ;;; General Public License for more details.
24 ;;; You should have received a copy of the GNU General Public License
25 ;;; along with This program. If not, write to the Free Software
26 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
38 (defconst tm-ew-e/RCS-ID
39 "$Id: tm-ew-e.el,v 7.13 1996/03/04 08:55:23 morioka Exp $")
40 (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID))
46 (defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
48 (defvar mime/use-X-Nsubject nil)
50 (defvar mime-eword/charset-encoding-alist
56 ;;; ("ISO-8859-5" . "Q")
64 ("ISO-2022-JP-2" . "B")
65 ("ISO-2022-INT-1" . "B")
69 ;;; @ encoded-text encoder
72 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
74 (cond ((string= encoding "B")
75 (base64-encode-string string))
76 ((string= encoding "Q")
77 (q-encoding-encode-string string mode))
81 (concat "=?" charset "?" encoding "?" text "?=")
88 (defun tm-eword::char-type (chr)
89 (if (or (= chr 32)(= chr ?\t))
91 (char-leading-char chr)
94 (defun tm-eword::parse-lc-word (str)
95 (let* ((rest (string-to-char-list str))
97 (lc (tm-eword::char-type chr))
101 (while (setq rest (cdr rest))
102 (setq chr (car rest))
103 (if (not (eq lc (tm-eword::char-type chr)))
106 (setq p (+ p (char-bytes chr)))
108 (cons (cons lc (substring str 0 p)) (substring str p))
111 (defun tm-eword::split-to-lc-words (str)
113 (while (and (not (string= str ""))
114 (setq ret (tm-eword::parse-lc-word str))
116 (setq dest (cons (car ret) dest))
126 (defun tm-eword::parse-word (lcwl)
127 (let* ((lcw (car lcwl))
132 (let ((lcl (list lc))
136 (while (setq lcwl (cdr lcwl))
137 (setq lcw (car lcwl))
142 (if (not (memq lc lcl))
143 (setq lcl (cons lc lcl))
145 (setq str (concat str (cdr lcw)))
147 (cons (cons lcl str) lcwl)
150 (defun tm-eword::lc-words-to-words (lcwl)
152 (while (setq ret (tm-eword::parse-word lcwl))
153 (setq dest (cons (car ret) dest))
154 (setq lcwl (cdr ret))
163 (defun tm-eword::find-charset-rule (lcl)
165 (let* ((charset (mime/find-charset lcl))
167 (cdr (assoc charset mime-eword/charset-encoding-alist))
169 (list charset encoding)
172 (defun tm-eword::words-to-ruled-words (wl)
175 (cons (cdr word) (tm-eword::find-charset-rule (car word)))
179 (defun tm-eword::space-process (seq)
180 (let (prev a ac b c cc)
190 (if (and (nth 2 a)(nth 2 c))
193 (cons (concat (car a)(car b)(car c))
201 (cons (concat (car a)(car b))
206 (setq prev (cons b prev))
208 (setq prev (cons b prev))
213 (defun tm-eword::split-string (str)
214 (tm-eword::space-process
215 (tm-eword::words-to-ruled-words
216 (tm-eword::lc-words-to-words
217 (tm-eword::split-to-lc-words str)
224 (defun base64-length (string)
225 (let ((l (length string)))
227 (if (= (mod l 3) 0) 0 1)
231 (defun q-encoding-length (string)
232 (let ((l 0)(i 0)(len (length string)) chr)
234 (setq chr (elt string i))
235 (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
242 (defun tm-eword::encoded-word-length (rword)
243 (let ((charset (nth 1 rword))
244 (encoding (nth 2 rword))
248 (cond ((equal encoding "B")
250 (mime/convert-string-from-emacs string charset))
251 (base64-length string)
253 ((equal encoding "Q")
255 (mime/convert-string-from-emacs string charset))
256 (q-encoding-length string)
259 (cons (+ 7 (length charset) ret) string)
266 (defun tm-eword::encode-string-1 (column rwl &optional mode)
267 (let* ((rword (car rwl))
268 (ret (tm-eword::encoded-word-length rword))
271 (cond ((and (setq string (car rword))
272 (<= (setq len (+ (length string) column)) 76)
280 (cond ((and (setq len (car ret))
281 (<= (+ column len) 76)
284 (tm-eword::encode-encoded-text
285 (nth 1 rword) (nth 2 rword) (cdr ret)
287 (setq len (+ (length string) column))
291 (setq string (car rword))
292 (let* ((ls (reverse (string-to-char-list string)))
297 (setq p (- p (char-bytes (car ls))))
298 (setq str (substring string 0 p))
299 (setq ret (tm-eword::encoded-word-length
300 (cons str (cdr rword))
303 (setq len (+ (car ret) column))
308 (if (and ls (not (string= str "")))
310 (setq rwl (cons (cons (substring string p) (cdr rword))
313 (tm-eword::encode-encoded-text
314 (nth 1 rword) (nth 2 rword) str))
315 (setq len (+ (length string) column))
322 (list string len rwl)
325 (defun tm-eword::encode-rwl (column rwl &optional mode)
326 (let (ret dest ps special str)
328 (setq ret (tm-eword::encode-string-1 column rwl mode))
330 (if (eq (elt str 0) ?\n)
333 (setq dest (concat dest "\n ("))
334 (setq ret (tm-eword::encode-string-1 2 rwl mode))
337 (cond ((eq special 32)
338 (if (string= str "(")
340 (setq dest (concat dest " "))
346 (setq dest (concat dest " ("))
349 (setq dest (concat dest "("))
352 (cond ((string= str " ")
360 (setq dest (concat dest str))
362 (setq column (nth 1 ret)
368 (defun tm-eword::encode-string (column str &optional mode)
369 (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
376 (defun tm-eword::phrase-to-rwl (phrase)
377 (let (token type dest str)
379 (setq token (car phrase))
380 (setq type (car token))
381 (cond ((eq type 'quoted-string)
382 (setq str (concat "\"" (cdr token) "\""))
386 (cons str (tm-eword::find-charset-rule
387 (find-charset-string str)))
394 (tm-eword::words-to-ruled-words
395 (tm-eword::lc-words-to-words
396 (tm-eword::split-to-lc-words (cdr token))))
401 (setq dest (append dest
402 (tm-eword::words-to-ruled-words
403 (tm-eword::lc-words-to-words
404 (tm-eword::split-to-lc-words (cdr token))
407 (setq phrase (cdr phrase))
409 (tm-eword::space-process dest)
412 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
413 (if (eq (car phrase-route-addr) 'phrase-route-addr)
414 (let ((phrase (nth 1 phrase-route-addr))
415 (route (nth 2 phrase-route-addr))
417 (if (eq (car (car phrase)) 'spaces)
418 (setq phrase (cdr phrase))
420 (setq dest (tm-eword::phrase-to-rwl phrase))
422 (setq dest (append dest '((" " nil nil))))
426 (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
429 (defun tm-eword::addr-spec-to-rwl (addr-spec)
430 (if (eq (car addr-spec) 'addr-spec)
431 (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
434 (defun tm-eword::mailbox-to-rwl (mbox)
435 (let ((addr (nth 1 mbox))
436 (comment (nth 2 mbox))
438 (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
439 (tm-eword::addr-spec-to-rwl addr)
446 (tm-eword::split-string comment)
451 (defun tm-eword::addresses-to-rwl (addresses)
452 (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
454 (while (setq addresses (cdr addresses))
455 (setq dest (append dest
458 (tm-eword::mailbox-to-rwl (car addresses))
463 (defun tm-eword::encode-address-list (column str)
464 (tm-eword::encode-rwl
466 (tm-eword::addresses-to-rwl
467 (rfc822/parse-addresses
468 (rfc822/lexical-analyze str)))))
471 ;;; @ application interfaces
474 (defun mime/encode-field (str)
475 (setq str (rfc822/unfolding-string str))
476 (let ((ret (string-match rfc822/field-top-regexp str)))
478 (let ((field-name (substring str 0 (match-end 1)))
479 (field-body (eliminate-top-spaces
480 (substring str (match-end 0))))
483 (cond ((string= field-body "") "")
484 ((member (setq fname (downcase field-name))
485 '("reply-to" "from" "sender"
486 "resent-reply-to" "resent-from"
487 "resent-sender" "to" "resent-to"
489 "bcc" "resent-bcc" "dcc")
491 (car (tm-eword::encode-address-list
492 (+ (length field-name) 1) field-body))
496 (let ((r mime/no-encoding-header-fields)
500 (if (string= (downcase fn) fname)
501 (throw 'tag field-body)
505 (car (tm-eword::encode-string
506 (+ (length field-name) 1) field-body))
509 (concat field-name ": " ret)
511 (tm-eword::encode-string 0 str)
514 (defun mime/exist-encoded-word-in-subject ()
515 (let ((str (rfc822/get-field-body "Subject")))
516 (if (and str (string-match mime/encoded-word-regexp str))
519 (defun mime/encode-message-header ()
523 (narrow-to-region (goto-char (point-min))
527 "^" (regexp-quote mail-header-separator) "$")
531 (goto-char (point-min))
533 (while (re-search-forward rfc822/field-top-regexp nil t)
534 (setq beg (match-beginning 0))
535 (setq end (rfc822/field-end))
536 (if (and (find-charset-region beg end)
539 (buffer-substring-no-properties beg end)
543 (delete-region beg end)
547 (if mime/use-X-Nsubject
548 (let ((str (mime/exist-encoded-word-in-subject)))
553 (mime-eword/decode-string (rfc822/unfolding-string str))
557 (defun mime-eword/encode-string (str &optional column mode)
558 (car (tm-eword::encode-rwl (or column 0)
559 (tm-eword::split-string str) mode))
568 ;;; tm-ew-e.el ends here