;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Revision: 0.18 $
;; Keywords: encoded-word, MIME, multilingual, header, mail, news
-;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
+;; This file is part of SEMI (Spadework for Emacs MIME Interfaces).
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;;;
(defconst eword-encode-RCS-ID
- "$Id: eword-encode.el,v 0.18 1997-06-21 09:00:09 morioka Exp $")
+ "$Id: eword-encode.el,v 1.2 1998-03-13 12:55:54 morioka Exp $")
(defconst eword-encode-version (get-version-string eword-encode-RCS-ID))
(defvar eword-field-encoding-method-alist
'(("X-Nsubject" . iso-2022-jp-2)
("Newsgroups" . nil)
+ ("Message-ID" . nil)
(t . mime)
)
"*Alist to specify field encoding method.
If method is nil, this field will not be encoded.")
-(defvar eword-generate-X-Nsubject nil
- "*If it is not nil, X-Nsubject field is generated
-when Subject field is encoded by `eword-encode-header'.")
-
(defvar eword-charset-encoding-alist
'((us-ascii . nil)
(iso-8859-1 . "Q")
)))
-;;; @ leading char
+;;; @ charset word
;;;
-(defun tm-eword::char-type (chr)
- (if (or (= chr ? )(= chr ?\t))
+(defsubst eword-encode-char-type (character)
+ (if (or (eq character ? )(eq character ?\t))
nil
- (char-charset chr)
+ (char-charset character)
))
-(defun tm-eword::parse-lc-word (str)
- (let* ((chr (sref str 0))
- (lc (tm-eword::char-type chr))
- (i (char-bytes 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)))
- )
- (cons (cons lc (substring str 0 i)) (substring str i))
- ))
-
-(defun tm-eword::split-to-lc-words (str)
- (let (ret dest)
- (while (and (not (string= str ""))
- (setq ret (tm-eword::parse-lc-word str))
- )
- (setq dest (cons (car ret) dest))
- (setq str (cdr ret))
- )
- (reverse dest)
+(defun eword-encode-divide-into-charset-words (string)
+ (let ((len (length string))
+ dest)
+ (while (> len 0)
+ (let* ((chr (sref string 0))
+ (charset (eword-encode-char-type chr))
+ (i (char-bytes chr))
+ )
+ (while (and (< i len)
+ (setq chr (sref string i))
+ (eq charset (eword-encode-char-type chr))
+ )
+ (setq i (+ i (char-bytes chr)))
+ )
+ (setq dest (cons (cons charset (substring string 0 i)) dest)
+ string (substring string i)
+ len (- len i)
+ )))
+ (nreverse dest)
))
;;; @ word
;;;
-(defun tm-eword::parse-word (lcwl)
- (let* ((lcw (car lcwl))
- (lc (car lcw))
- )
- (if (null lc)
- lcwl
- (let ((lcl (list lc))
- (str (cdr lcw))
- )
- (catch 'tag
- (while (setq lcwl (cdr lcwl))
- (setq lcw (car lcwl))
- (setq lc (car lcw))
- (if (null lc)
- (throw 'tag nil)
- )
- (if (not (memq lc lcl))
- (setq lcl (cons lc lcl))
+(defun eword-encode-charset-words-to-words (charset-words)
+ (let (dest)
+ (while charset-words
+ (let* ((charset-word (car charset-words))
+ (charset (car charset-word))
+ )
+ (if charset
+ (let ((charsets (list charset))
+ (str (cdr charset-word))
+ )
+ (catch 'tag
+ (while (setq charset-words (cdr charset-words))
+ (setq charset-word (car charset-words)
+ charset (car charset-word))
+ (if (null charset)
+ (throw 'tag nil)
+ )
+ (or (memq charset charsets)
+ (setq charsets (cons charset charsets))
+ )
+ (setq str (concat str (cdr charset-word)))
+ ))
+ (setq dest (cons (cons charsets str) dest))
)
- (setq str (concat str (cdr lcw)))
- ))
- (cons (cons lcl str) lcwl)
- ))))
-
-(defun tm-eword::lc-words-to-words (lcwl)
- (let (ret dest)
- (while (setq ret (tm-eword::parse-word lcwl))
- (setq dest (cons (car ret) dest))
- (setq lcwl (cdr ret))
- )
- (reverse dest)
+ (setq dest (cons charset-word dest)
+ charset-words (cdr charset-words)
+ ))))
+ (nreverse dest)
))
(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))
- mode)))
+ (tm-eword::words-to-ruled-words
+ (eword-encode-charset-words-to-words
+ (eword-encode-divide-into-charset-words str))
+ mode)))
;;; @ length
string len)
(if (null ret)
(cond ((and (setq string (car rword))
- (<= (setq len (+ (length string) column)) 76)
+ (or (<= (setq len (+ (length string) column)) 76)
+ (<= column 1))
)
(setq rwl (cdr rwl))
)
(append dest
'(("(" nil nil))
(tm-eword::words-to-ruled-words
- (tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words (cdr token)))
+ (eword-encode-charset-words-to-words
+ (eword-encode-divide-into-charset-words
+ (cdr token)))
'comment)
'((")" nil nil))
))
)
(t
- (setq dest (append dest
- (tm-eword::words-to-ruled-words
- (tm-eword::lc-words-to-words
- (tm-eword::split-to-lc-words (cdr token))
- ) 'phrase)))
+ (setq dest
+ (append dest
+ (tm-eword::words-to-ruled-words
+ (eword-encode-charset-words-to-words
+ (eword-encode-divide-into-charset-words
+ (cdr token))
+ ) 'phrase)))
))
(setq phrase (cdr phrase))
)
(tm-eword::space-process dest)
))
-(defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
+(defun eword-addr-seq-to-rwl (seq)
+ (let (dest pname)
+ (while seq
+ (let* ((token (car seq))
+ (name (car token))
+ )
+ (cond ((eq name 'spaces)
+ (setq dest (nconc dest (list (list (cdr token) nil nil))))
+ )
+ ((eq name 'comment)
+ (setq dest
+ (nconc
+ dest
+ (list (list "(" nil nil))
+ (tm-eword::split-string (cdr token) 'comment)
+ (list (list ")" nil nil))
+ ))
+ )
+ ((eq name 'quoted-string)
+ (setq dest
+ (nconc
+ dest
+ (list
+ (list (concat "\"" (cdr token) "\"") nil nil)
+ )))
+ )
+ (t
+ (setq dest
+ (if (or (eq pname 'spaces)
+ (eq pname 'comment))
+ (nconc dest (list (list (cdr token) nil nil)))
+ (nconc (butlast dest)
+ (list
+ (list (concat (car (car (last dest)))
+ (cdr token))
+ nil nil)))))
+ ))
+ (setq seq (cdr seq)
+ pname name))
+ )
+ dest))
+
+(defun eword-phrase-route-addr-to-rwl (phrase-route-addr)
(if (eq (car phrase-route-addr) 'phrase-route-addr)
(let ((phrase (nth 1 phrase-route-addr))
(route (nth 2 phrase-route-addr))
)
(append
dest
- (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
+ (eword-addr-seq-to-rwl
+ (append '((specials . "<"))
+ route
+ '((specials . ">"))))
))))
-(defun tm-eword::addr-spec-to-rwl (addr-spec)
+(defun eword-addr-spec-to-rwl (addr-spec)
(if (eq (car addr-spec) 'addr-spec)
- (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
+ (eword-addr-seq-to-rwl (cdr addr-spec))
))
(defun tm-eword::mailbox-to-rwl (mbox)
(let ((addr (nth 1 mbox))
(comment (nth 2 mbox))
dest)
- (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
- (tm-eword::addr-spec-to-rwl addr)
+ (setq dest (or (eword-phrase-route-addr-to-rwl addr)
+ (eword-addr-spec-to-rwl addr)
))
(if comment
(setq dest
resent-reply-to resent-from
resent-sender to resent-to
cc resent-cc
- bcc resent-bcc dcc)
+ bcc resent-bcc dcc
+ mime-version)
)
(car (tm-eword::encode-address-list
(+ (length field-name) 2) field-body))
(if (and str (string-match eword-encoded-word-regexp str))
str)))
+(defsubst eword-find-field-encoding-method (field-name)
+ (setq field-name (downcase field-name))
+ (let ((alist eword-field-encoding-method-alist))
+ (catch 'found
+ (while alist
+ (let* ((pair (car alist))
+ (str (car pair)))
+ (if (and (stringp str)
+ (string= field-name (downcase str)))
+ (throw 'found (cdr pair))
+ ))
+ (setq alist (cdr alist)))
+ (cdr (assq t eword-field-encoding-method-alist))
+ )))
+
(defun eword-encode-header (&optional code-conversion)
"Encode header fields to network representation, such as MIME encoded-word.
(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 (let ((fname (downcase field-name)))
- (assoc-if
- (function
- (lambda (str)
- (and (stringp str)
- (string= fname (downcase str))
- )))
- eword-field-encoding-method-alist))
- (assq t eword-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 (eword-encode-field field))
- ))
- (code-conversion
- (let ((cs
- (or (mime-charset-to-coding-system
- method)
- default-cs)))
- (encode-coding-region beg end cs)
- )))
- ))
+ (let ((method (eword-find-field-encoding-method
+ (downcase field-name))))
+ (cond ((eq method 'mime)
+ (let ((field
+ (buffer-substring-no-properties beg end)
+ ))
+ (delete-region beg end)
+ (insert (eword-encode-field field))
+ ))
+ (code-conversion
+ (let ((cs
+ (or (mime-charset-to-coding-system
+ method)
+ default-cs)))
+ (encode-coding-region beg end cs)
+ )))
))
))
- (and eword-generate-X-Nsubject
- (or (std11-field-body "X-Nsubject")
- (let ((str (eword-in-subject-p)))
- (if str
- (progn
- (setq str
- (eword-decode-string
- (std11-unfold-string str)))
- (if code-conversion
- (setq str
- (encode-mime-charset-string
- str
- (or (cdr (assoc-if
- (function
- (lambda (str)
- (and (stringp str)
- (string= "x-nsubject"
- (downcase str))
- )))
- eword-field-encoding-method-alist))
- 'iso-2022-jp-2)))
- )
- (insert (concat "\nX-Nsubject: " str))
- )))))
)))
(defun eword-encode-string (str &optional column mode)
projects / elisp / semi.git / blobdiff