X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-ew-e.el;h=1461b6531f40b478fcd3fae6319f1b4c1c279256;hb=d26bc385edbd0d6d6abdcdaf7fb011296ff7eba8;hp=0150f1902d767e5e17505d765dfe75435b4c329e;hpb=2ea28a6a167b312d383a06f09f6e09ffc96d110d;p=elisp%2Ftm.git

diff --git a/tm-ew-e.el b/tm-ew-e.el
index 0150f19..1461b65 100644
--- a/tm-ew-e.el
+++ b/tm-ew-e.el
@@ -1,21 +1,70 @@
 ;;;
-;;; tm-ew-d.el --- RFC 1522 based multilingual MIME message header
+;;; 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,1994,1995 MORIOKA Tomohiko
+;;; Copyright (C) 1993 .. 1996 MORIOKA Tomohiko
 ;;;
 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;;; Version:
-;;;	$Id: tm-ew-e.el,v 7.0 1995/10/03 04:35:11 morioka Exp $
+;;; Version: $Revision: 7.37 $
 ;;; 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.
+;;;
+;;; Code:
 
 (require 'mel)
 (require 'tl-822)
 (require 'tm-def)
 
 
+;;; @ version
+;;;
+
+(defconst tm-ew-e/RCS-ID
+  "$Id: tm-ew-e.el,v 7.37 1996/07/10 12:52:46 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-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")
+    ))
+
 ;;; @ encoded-text encoder
 ;;;
 
@@ -28,7 +77,8 @@
 	       )
 	 ))
     (if text
-	(concat "=?" charset "?" encoding "?" text "?=")
+	(concat "=?" (upcase (symbol-name charset)) "?"
+		encoding "?" text "?=")
       )))
 
 
@@ -42,20 +92,18 @@
     ))
 
 (defun tm-eword::parse-lc-word (str)
-  (let* ((rest (string-to-char-list str))
-	 (chr (car rest))
+  (let* ((chr (sref str 0))
 	 (lc (tm-eword::char-type chr))
-	 (p (char-bytes chr))
+	 (i (char-length chr))
+	 (len (length str))
 	 )
-    (catch 'tag
-      (while (setq rest (cdr rest))
-	(setq chr (car rest))
-	(if (not (eq lc (tm-eword::char-type chr)))
-	    (throw 'tag nil)
-	  )
-	(setq p (+ p (char-bytes chr)))
-	))
-    (cons (cons lc (substring str 0 p)) (substring str p))
+    (while (and (< i len)
+		(setq chr (sref str i))
+		(eq lc (tm-eword::char-type chr))
+		)
+      (setq i (+ i (char-length chr)))
+      )
+    (cons (cons lc (substring str 0 i)) (substring str i))
     ))
 
 (defun tm-eword::split-to-lc-words (str)
@@ -110,27 +158,31 @@
 ;;; @ rule
 ;;;
 
-(defun mime/find-charset-rule (lcl)
-  (if lcl
-      (let ((ret (some-element
-		  (function
-		   (lambda (elt)
-		     (subsetp lcl (car elt))
-		     ))
-		  mime/lc-charset-rule-list)
-		 ))
-	(if ret
-	    (cdr ret)
-	  mime/unknown-charset-rule)
-	)
-    '(nil nil)
-    ))
+(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) (mime/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)
@@ -139,13 +191,14 @@
       (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))
@@ -167,60 +220,40 @@
     (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/convert-string-from-emacs 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/convert-string-from-emacs 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)
@@ -239,59 +272,101 @@
 		  )
 	     (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* ((ls (reverse (string-to-char-list string)))
-		    (sl (length string))
-		    (p sl) str)
-	       (while (and ls
+	     (let* ((sl (length string))
+		    (p 0) np
+		    (str "") nstr)
+	       (while (and (< p len)
 			   (progn
-			     (setq p (- p (char-bytes (car ls))))
-			     (setq str (substring string 0 p))
+			     (setq np (+ p (char-length (sref string p))))
+			     (setq nstr (substring string 0 np))
 			     (setq ret (tm-eword::encoded-word-length
-					(cons str (cdr rword))
+					(cons nstr (cdr rword))
 					))
-			     (setq str (cdr ret))
+			     (setq nstr (cdr ret))
 			     (setq len (+ (car ret) column))
-			     (> len 76)
+			     (<= len 76)
 			     ))
-		 (setq ls (cdr ls))
-		 )
-	       (if ls
-		   (progn
-		     (setq rwl (cons (cons (substring string p) (cdr rword))
-				     (cdr rwl)))
-		     (setq string
-			   (tm-eword::encode-encoded-text
-			    (nth 1 rword) (nth 2 rword) str))
-		     (setq len (+ (length string) column))
-		     )
-		 (setq string "\n ")
-		 (setq len 1)
+		 (setq str nstr
+		       p np))
+	       (if (string-equal str "")
+		   (setq string "\n "
+			 len 1)
+		 (setq rwl (cons (cons (substring string p) (cdr rword))
+				 (cdr rwl)))
+		 (setq string
+		       (tm-eword::encode-encoded-text
+			(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)
-  (let (ret dest)
+(defun tm-eword::encode-rwl (column rwl)
+  (let (ret dest ps special str ew-f pew-f)
     (while rwl
-      (setq ret (tm-eword::encode-string-1 column rwl mode))
-      (setq dest (concat dest (car ret))
-	    column (nth 1 ret)
+      (setq ew-f (nth 2 (car rwl)))
+      (if (and pew-f ew-f)
+	  (setq rwl (cons '(" ") rwl)
+		pew-f nil)
+	(setq pew-f ew-f)
+	)
+      (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))
+		(setq str (car ret))
+		))
+	(cond ((eq special 32)
+	       (if (string= str "(")
+		   (setq ps t)
+		 (setq dest (concat dest " "))
+		 (setq ps nil)
+		 ))
+	      ((eq special ?\()
+	       (if ps
+		   (progn
+		     (setq dest (concat dest " ("))
+		     (setq ps nil)
+		     )
+		 (setq dest (concat dest "("))
+		 )
+	       )))
+      (cond ((string= str " ")
+	     (setq special 32)
+	     )
+	    ((string= str "(")
+	     (setq special ?\()
+	     )
+	    (t
+	     (setq special nil)
+	     (setq dest (concat dest str))
+	     ))
+      (setq column (nth 1 ret)
 	    rwl (nth 2 ret))
       )
     (list dest column)
     ))
 
 (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))
   )
 
 
@@ -299,19 +374,21 @@
 ;;;
 
 (defun tm-eword::phrase-to-rwl (phrase)
-  (let (token type dest)
+  (let (token type dest str)
     (while phrase
       (setq token (car phrase))
       (setq type (car token))
       (cond ((eq type 'quoted-string)
+	     (setq str (concat "\"" (cdr token) "\""))
 	     (setq dest
 		   (append dest
-			   '(("\"" nil nil))
-			   (tm-eword::words-to-ruled-words
-			    (tm-eword::lc-words-to-words
-			     (tm-eword::split-to-lc-words (cdr token))))
-			   '(("\"" nil nil))
-			   ))
+			   (list
+			    (let ((ret (tm-eword::find-charset-rule
+					(find-charset-string str))))
+			      (tm-eword::make-rword
+			       str (car ret)(nth 1 ret) 'phrase)
+			      )
+			    )))
 	     )
 	    ((eq type 'comment)
 	     (setq dest
@@ -319,7 +396,8 @@
 			   '(("(" 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))
 			   ))
 	     )
@@ -328,7 +406,7 @@
 				(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))
       )
@@ -340,6 +418,9 @@
       (let ((phrase (nth 1 phrase-route-addr))
 	    (route (nth 2 phrase-route-addr))
 	    dest)
+	(if (eq (car (car phrase)) 'spaces)
+	    (setq phrase (cdr phrase))
+	  )
 	(setq dest (tm-eword::phrase-to-rwl phrase))
 	(if dest
 	    (setq dest (append dest '((" " nil nil))))
@@ -366,7 +447,7 @@
 	      (append dest
 		      '((" " nil nil)
 			("(" nil nil))
-		      (tm-eword::split-string comment)
+		      (tm-eword::split-string comment 'comment)
 		      '((")" nil nil))
 		      )))
     dest))
@@ -391,7 +472,100 @@
      (rfc822/lexical-analyze str)))))
 
 
+;;; @ application interfaces
+;;;
+
+(defun mime/encode-field (str)
+  (setq str (rfc822/unfolding-string str))
+  (let ((ret (string-match rfc822/field-top-regexp str)))
+    (or (if ret
+	    (let ((field-name (substring str 0 (match-end 1)))
+		  (field-body (eliminate-top-spaces
+			       (substring str (match-end 0))))
+		  fname)
+	      (if (setq ret
+			(cond ((string= field-body "") "")
+			      ((member (setq fname (downcase field-name))
+				       '("reply-to" "from" "sender"
+					 "resent-reply-to" "resent-from"
+					 "resent-sender" "to" "resent-to"
+					 "cc" "resent-cc"
+					 "bcc" "resent-bcc" "dcc")
+				       )
+			       (car (tm-eword::encode-address-list
+				     (+ (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 '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")))
+    (if (and str (string-match mime/encoded-word-regexp str))
+	str)))
+
+(defun mime/encode-message-header ()
+  (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)))
+      (goto-char (point-min))
+      (let (beg end field)
+	(while (re-search-forward rfc822/field-top-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)
+		))
+	  ))
+      (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))
+		  )))))
+      )))
+
+(defun mime-eword/encode-string (str &optional column mode)
+  (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
+  )
+
+
 ;;; @ end
 ;;;
 
 (provide 'tm-ew-e)
+
+;;; tm-ew-e.el ends here