-;;;
-;;; tm-ew-e.el --- RFC 1522 based multilingual MIME message header
-;;; encoder for GNU Emacs
-;;;
-;;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;; Copyright (C) 1993 .. 1996 MORIOKA Tomohiko
-;;;
-;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;;; Version: $Revision: 7.21 $
-;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
-;;;
-;;; This file is part of tm (Tools for MIME).
-;;;
-;;; This program is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation; either version 2, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with This program. If not, write to the Free Software
-;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;
+;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs
+
+;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Version: $Revision: 7.58 $
+;; Keywords: encoded-word, MIME, multilingual, header, mail, news
+
+;; This file is part of tm (Tools for MIME).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
;;; Code:
(require 'mel)
-(require 'tl-822)
+(require 'std11)
(require 'tm-def)
+(require 'tl-list)
;;; @ version
;;;
(defconst tm-ew-e/RCS-ID
- "$Id: tm-ew-e.el,v 7.21 1996/06/06 15:03:38 morioka Exp $")
+ "$Id: tm-ew-e.el,v 7.58 1997/02/11 10:49:13 morioka Exp $")
(defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID))
;;; @ variables
;;;
-(defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
-
-(defvar mime/use-X-Nsubject nil)
+(defvar mime/field-encoding-method-alist
+ (if (boundp 'mime/no-encoding-header-fields)
+ (nconc
+ (mapcar (function
+ (lambda (field-name)
+ (cons field-name 'default-mime-charset)
+ ))
+ mime/no-encoding-header-fields)
+ '((t . mime))
+ )
+ '(("X-Nsubject" . iso-2022-jp-2)
+ ("Newsgroups" . nil)
+ (t . mime)
+ ))
+ "*Alist to specify field encoding method.
+Its key is field-name, value is encoding method.
+
+If method is `mime', this field will be encoded into MIME format.
+
+If method is a MIME-charset, this field will be encoded as the charset
+when it must be convert into network-code.
+
+If method is `default-mime-charset', this field will be encoded as
+variable `default-mime-charset' when it must be convert into
+network-code.
+
+If method is nil, this field will not be encoded. [tm-ew-e.el]")
+
+(defvar mime/generate-X-Nsubject
+ (and (boundp 'mime/use-X-Nsubject)
+ mime/use-X-Nsubject)
+ "*If it is not nil, X-Nsubject field is generated
+when Subject field is encoded by `mime/encode-message-header'.
+\[tm-ew-e.el]")
(defvar mime-eword/charset-encoding-alist
- '(("US-ASCII" . nil)
- ("ISO-8859-1" . "Q")
- ("ISO-8859-2" . "Q")
- ("ISO-8859-3" . "Q")
- ("ISO-8859-4" . "Q")
-;;; ("ISO-8859-5" . "Q")
- ("KOI8-R" . "Q")
- ("ISO-8859-7" . "Q")
- ("ISO-8859-8" . "Q")
- ("ISO-8859-9" . "Q")
- ("ISO-2022-JP" . "B")
- ("ISO-2022-KR" . "B")
- ("EUC-KR" . "B")
- ("ISO-2022-JP-2" . "B")
- ("ISO-2022-INT-1" . "B")
+ '((us-ascii . nil)
+ (iso-8859-1 . "Q")
+ (iso-8859-2 . "Q")
+ (iso-8859-3 . "Q")
+ (iso-8859-4 . "Q")
+ (iso-8859-5 . "Q")
+ (koi8-r . "Q")
+ (iso-8859-7 . "Q")
+ (iso-8859-8 . "Q")
+ (iso-8859-9 . "Q")
+ (iso-2022-jp . "B")
+ (iso-2022-kr . "B")
+ (gb2312 . "B")
+ (cn-gb . "B")
+ (cn-gb-2312 . "B")
+ (euc-kr . "B")
+ (iso-2022-jp-2 . "B")
+ (iso-2022-int-1 . "B")
))
)
))
(if text
- (concat "=?" charset "?" encoding "?" text "?=")
+ (concat "=?" (upcase (symbol-name charset)) "?"
+ encoding "?" text "?=")
)))
(defun tm-eword::char-type (chr)
(if (or (= chr 32)(= chr ?\t))
nil
- (char-leading-char chr)
+ (char-charset chr)
))
(defun tm-eword::parse-lc-word (str)
(let* ((chr (sref str 0))
(lc (tm-eword::char-type chr))
- (i (char-bytes chr))
+ (i (char-length chr))
(len (length str))
)
(while (and (< i len)
(setq chr (sref str i))
(eq lc (tm-eword::char-type chr))
)
- (setq i (+ i (char-bytes chr)))
+ (setq i (+ i (char-length chr)))
)
(cons (cons lc (substring str 0 i)) (substring str i))
))
;;; @ rule
;;;
-(defun tm-eword::find-charset-rule (lcl)
- (if lcl
- (let* ((charset (mime/find-charset lcl))
- (encoding
- (cdr (assoc charset mime-eword/charset-encoding-alist))
- ))
+(defmacro tm-eword::make-rword (text charset encoding type)
+ (` (list (, text)(, charset)(, encoding)(, type))))
+(defmacro tm-eword::rword-text (rword)
+ (` (car (, rword))))
+(defmacro tm-eword::rword-charset (rword)
+ (` (car (cdr (, rword)))))
+(defmacro tm-eword::rword-encoding (rword)
+ (` (car (cdr (cdr (, rword))))))
+(defmacro tm-eword::rword-type (rword)
+ (` (car (cdr (cdr (cdr (, rword)))))))
+
+(defun tm-eword::find-charset-rule (charsets)
+ (if charsets
+ (let* ((charset (charsets-to-mime-charset charsets))
+ (encoding (cdr (assq charset mime-eword/charset-encoding-alist)))
+ )
(list charset encoding)
)))
-(defun tm-eword::words-to-ruled-words (wl)
+(defun tm-eword::words-to-ruled-words (wl &optional mode)
(mapcar (function
(lambda (word)
- (cons (cdr word) (tm-eword::find-charset-rule (car word)))
- ))
+ (let ((ret (tm-eword::find-charset-rule (car word))))
+ (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
+ )))
wl))
(defun tm-eword::space-process (seq)
(setq b (car seq))
(setq seq (cdr seq))
(setq c (car seq))
- (setq cc (nth 1 c))
- (if (null (nth 1 b))
+ (setq cc (tm-eword::rword-charset c))
+ (if (null (tm-eword::rword-charset b))
(progn
(setq a (car prev))
- (setq ac (nth 1 a))
- (if (and (nth 2 a)(nth 2 c))
- (cond ((equal ac cc)
+ (setq ac (tm-eword::rword-charset a))
+ (if (and (tm-eword::rword-encoding a)
+ (tm-eword::rword-encoding c))
+ (cond ((eq ac cc)
(setq prev (cons
(cons (concat (car a)(car b)(car c))
(cdr a))
(reverse prev)
))
-(defun tm-eword::split-string (str)
+(defun tm-eword::split-string (str &optional mode)
(tm-eword::space-process
- (tm-eword::words-to-ruled-words
- (tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words str)
- ))))
+ (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words
+ (tm-eword::split-to-lc-words str))
+ mode)))
;;; @ length
;;;
-(defun base64-length (string)
- (let ((l (length string)))
- (* (+ (/ l 3)
- (if (= (mod l 3) 0) 0 1)
- ) 4)
- ))
-
-(defun q-encoding-length (string)
- (let ((l 0)(i 0)(len (length string)) chr)
- (while (< i len)
- (setq chr (elt string i))
- (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
- (setq l (+ l 1))
- (setq l (+ l 3))
- )
- (setq i (+ i 1)) )
- l))
-
(defun tm-eword::encoded-word-length (rword)
- (let ((charset (nth 1 rword))
- (encoding (nth 2 rword))
- (string (car rword))
+ (let ((string (tm-eword::rword-text rword))
+ (charset (tm-eword::rword-charset rword))
+ (encoding (tm-eword::rword-encoding rword))
ret)
(setq ret
- (cond ((equal encoding "B")
- (setq string (mime-charset-encode-string string charset))
- (base64-length string)
+ (cond ((string-equal encoding "B")
+ (setq string (encode-mime-charset-string string charset))
+ (base64-encoded-length string)
)
- ((equal encoding "Q")
- (setq string (mime-charset-encode-string string charset))
- (q-encoding-length string)
+ ((string-equal encoding "Q")
+ (setq string (encode-mime-charset-string string charset))
+ (q-encoding-encoded-length string
+ (tm-eword::rword-type rword))
)))
(if ret
- (cons (+ 7 (length charset) ret) string)
+ (cons (+ 7 (length (symbol-name charset)) ret) string)
)))
;;; @ encode-string
;;;
-(defun tm-eword::encode-string-1 (column rwl &optional mode)
+(defun tm-eword::encode-string-1 (column rwl)
(let* ((rword (car rwl))
(ret (tm-eword::encoded-word-length rword))
string len)
)
(setq string
(tm-eword::encode-encoded-text
- (nth 1 rword) (nth 2 rword) (cdr ret)
+ (tm-eword::rword-charset rword)
+ (tm-eword::rword-encoding rword)
+ (cdr ret)
+ (tm-eword::rword-type rword)
))
(setq len (+ (length string) column))
(setq rwl (cdr rwl))
)
(t
(setq string (car rword))
- (let* ((sl (length string))
- (p 0) np
+ (let* ((p 0) np
(str "") nstr)
(while (and (< p len)
(progn
- (setq np (+ p (char-bytes (sref string p))))
+ (setq np (+ p (char-length (sref string p))))
(setq nstr (substring string 0 np))
(setq ret (tm-eword::encoded-word-length
(cons nstr (cdr rword))
(cdr rwl)))
(setq string
(tm-eword::encode-encoded-text
- (nth 1 rword) (nth 2 rword) str))
+ (tm-eword::rword-charset rword)
+ (tm-eword::rword-encoding rword)
+ str
+ (tm-eword::rword-type rword)))
(setq len (+ (length string) column))
)
)))
(list string len rwl)
))
-(defun tm-eword::encode-rwl (column rwl &optional mode)
+(defun tm-eword::encode-rwl (column rwl)
(let (ret dest ps special str ew-f pew-f)
(while rwl
(setq ew-f (nth 2 (car rwl)))
pew-f nil)
(setq pew-f ew-f)
)
- (setq ret (tm-eword::encode-string-1 column rwl mode))
+ (setq ret (tm-eword::encode-string-1 column rwl))
(setq str (car ret))
(if (eq (elt str 0) ?\n)
(if (eq special ?\()
(progn
(setq dest (concat dest "\n ("))
- (setq ret (tm-eword::encode-string-1 2 rwl mode))
+ (setq ret (tm-eword::encode-string-1 2 rwl))
(setq str (car ret))
))
(cond ((eq special 32)
))
(defun tm-eword::encode-string (column str &optional mode)
- (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
+ (tm-eword::encode-rwl column (tm-eword::split-string str mode))
)
(setq dest
(append dest
(list
- (cons str (tm-eword::find-charset-rule
- (find-charset-string str)))
+ (let ((ret (tm-eword::find-charset-rule
+ (find-non-ascii-charset-string str))))
+ (tm-eword::make-rword
+ str (car ret)(nth 1 ret) 'phrase)
+ )
)))
)
((eq type 'comment)
'(("(" nil nil))
(tm-eword::words-to-ruled-words
(tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words (cdr token))))
+ (tm-eword::split-to-lc-words (cdr token)))
+ 'comment)
'((")" nil nil))
))
)
(tm-eword::words-to-ruled-words
(tm-eword::lc-words-to-words
(tm-eword::split-to-lc-words (cdr token))
- ))))
+ ) 'phrase)))
))
(setq phrase (cdr phrase))
)
)
(append
dest
- (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
+ (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
))))
(defun tm-eword::addr-spec-to-rwl (addr-spec)
(if (eq (car addr-spec) 'addr-spec)
- (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
+ (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
))
(defun tm-eword::mailbox-to-rwl (mbox)
(append dest
'((" " nil nil)
("(" nil nil))
- (tm-eword::split-string comment)
+ (tm-eword::split-string comment 'comment)
'((")" nil nil))
)))
dest))
(defun tm-eword::encode-address-list (column str)
(tm-eword::encode-rwl
column
- (tm-eword::addresses-to-rwl
- (rfc822/parse-addresses
- (rfc822/lexical-analyze str)))))
+ (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
+ ))
;;; @ application interfaces
;;;
(defun mime/encode-field (str)
- (setq str (rfc822/unfolding-string str))
- (let ((ret (string-match rfc822/field-top-regexp str)))
+ (setq str (std11-unfold-string str))
+ (let ((ret (string-match std11-field-head-regexp str)))
(or (if ret
- (let ((field-name (substring str 0 (match-end 1)))
+ (let ((field-name (substring str 0 (1- (match-end 0))))
(field-body (eliminate-top-spaces
(substring str (match-end 0))))
fname)
(if (setq ret
- (cond ((string= field-body "") "")
+ (cond ((string-equal field-body "") "")
((member (setq fname (downcase field-name))
'("reply-to" "from" "sender"
"resent-reply-to" "resent-from"
(+ (length field-name) 2) field-body))
)
(t
- (catch 'tag
- (let ((r mime/no-encoding-header-fields)
- fn)
- (while r
- (setq fn (car r))
- (if (string= (downcase fn) fname)
- (throw 'tag field-body)
- )
- (setq r (cdr r))
- ))
- (car (tm-eword::encode-string
- (+ (length field-name) 1) field-body))
- ))
- ))
+ (car (tm-eword::encode-string
+ (+ (length field-name) 1)
+ field-body 'text))
+ ))
+ )
(concat field-name ": " ret)
)))
(car (tm-eword::encode-string 0 str))
)))
(defun mime/exist-encoded-word-in-subject ()
- (let ((str (rfc822/get-field-body "Subject")))
+ (let ((str (std11-field-body "Subject")))
(if (and str (string-match mime/encoded-word-regexp str))
str)))
-(defun mime/encode-message-header ()
+(defun mime/encode-message-header (&optional code-conversion)
(interactive "*")
(save-excursion
(save-restriction
- (narrow-to-region (goto-char (point-min))
- (if (re-search-forward
- (concat
- "^" (regexp-quote mail-header-separator) "$")
- nil t)
- (match-beginning 0)
- (point-max)))
+ (std11-narrow-to-header mail-header-separator)
(goto-char (point-min))
- (let (beg end field)
- (while (re-search-forward rfc822/field-top-regexp nil t)
+ (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
+ beg end field-name)
+ (while (re-search-forward std11-field-head-regexp nil t)
(setq beg (match-beginning 0))
- (setq end (rfc822/field-end))
- (if (and (find-charset-region beg end)
- (setq field
- (mime/encode-field
- (buffer-substring-no-properties beg end)
- ))
- )
- (progn
- (delete-region beg end)
- (insert field)
- ))
+ (setq field-name (buffer-substring beg (1- (match-end 0))))
+ (setq end (std11-field-end))
+ (and (find-non-ascii-charset-region beg end)
+ (let ((ret (or (ASSOC (downcase field-name)
+ mime/field-encoding-method-alist
+ :test (function
+ (lambda (str1 str2)
+ (and (stringp str2)
+ (string= str1
+ (downcase str2))
+ ))))
+ (assq t mime/field-encoding-method-alist)
+ )))
+ (if ret
+ (let ((method (cdr ret)))
+ (cond ((eq method 'mime)
+ (let ((field
+ (buffer-substring-no-properties beg end)
+ ))
+ (delete-region beg end)
+ (insert (mime/encode-field field))
+ ))
+ (code-conversion
+ (let ((cs
+ (or (mime-charset-to-coding-system
+ method)
+ default-cs)))
+ (encode-coding-region beg end cs)
+ )))
+ ))
+ ))
))
- (if mime/use-X-Nsubject
- (let ((str (mime/exist-encoded-word-in-subject)))
- (if str
- (insert
- (concat
- "\nX-Nsubject: "
- (mime-eword/decode-string (rfc822/unfolding-string str))
- )))))
+ (and mime/generate-X-Nsubject
+ (or (std11-field-body "X-Nsubject")
+ (let ((str (mime/exist-encoded-word-in-subject)))
+ (if str
+ (progn
+ (setq str
+ (mime-eword/decode-string
+ (std11-unfold-string str)))
+ (if code-conversion
+ (setq str
+ (encode-mime-charset-string
+ str
+ (or (cdr (ASSOC
+ "x-nsubject"
+ mime/field-encoding-method-alist
+ :test
+ (function
+ (lambda (str1 str2)
+ (and (stringp str2)
+ (string= str1
+ (downcase str2))
+ )))))
+ 'iso-2022-jp-2)))
+ )
+ (insert (concat "\nX-Nsubject: " str))
+ )))))
)))
(defun mime-eword/encode-string (str &optional column mode)
- (car (tm-eword::encode-rwl (or column 0)
- (tm-eword::split-string str) mode))
+ (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
)