tm 7.22.

[elisp/tm.git] / tm-ew-e.el

diff --git a/tm-ew-e.el b/tm-ew-e.el
index 0150f19..6bddae5 100644 (file)
--- a/tm-ew-e.el
+++ b/tm-ew-e.el
@@ -5,9 +5,7 @@
 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
 ;;; Copyright (C) 1993,1994,1995 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 $
+;;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
 ;;;
 
@@ -16,6 +14,22 @@
 (require 'tm-def)
 
 
+;;; @ version
+;;;
+
+(defconst tm-ew-e/RCS-ID
+  "$Id: tm-ew-e.el,v 7.5 1995/10/24 00:18:39 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)
+
+
 ;;; @ encoded-text encoder
 ;;;
 
@@ -299,19 +313,18 @@
 ;;;
 
 (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
+                           (cons str (mime/find-charset-rule
+                                      (find-charset-string str)))
+                           )))
             )
            ((eq type 'comment)
             (setq dest
@@ -340,6 +353,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))))
@@ -391,6 +407,95 @@
      (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)))
+    (if ret
+       (let ((field-name (substring str 0 (match-end 1)))
+             (field-body (eliminate-top-spaces
+                          (substring str (match-end 0))))
+             fname)
+         (concat field-name ": "
+                 (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) 1) 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))
+                          ))
+                       ))
+         )
+      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))
+                       (progn
+                         (re-search-forward
+                          (concat
+                           "^" (regexp-quote mail-header-separator) "$")
+                          nil t)
+                         (match-beginning 0)
+                         ))
+      (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
 ;;;