tm-eword.el

   1 ;;;
   2 ;;; tm-eword.el --- RFC 1522 based multilingual MIME message header
   3 ;;;                 encoder/decoder for GNU Emacs
   4 ;;;
   5 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   6 ;;; Copyright (C) 1993,1994,1995 MORIOKA Tomohiko
   7 ;;;
   8 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
  10 ;;;
  11
  12 (require 'tl-822)
  13 (require 'tl-str)
  14 (require 'tm-def)
  15
  16 (autoload 'mime/decode-encoded-words-string "tm-ew-d")
  17 (autoload 'mime/decode-encoded-words-region "tm-ew-d" nil t)
  18 (autoload 'mime/decode-message-header "tm-ew-d" nil t)
  19
  20 (require 'tm-ew-e)
  21
  22
  23 ;;; @ version
  24 ;;;
  25
  26 (defconst tm-eword/RCS-ID
  27   "$Id: tm-eword.el,v 7.4 1995/10/11 11:53:17 morioka Exp $")
  28
  29 (defconst tm-eword/version (get-version-string tm-eword/RCS-ID))
  30
  31
  32 ;;; @ variables
  33 ;;;
  34
  35 (defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
  36
  37 (defvar mime/use-X-Nsubject nil)
  38
  39
  40 ;;; @ Application Interface
  41 ;;;
  42
  43 ;;; @@ MIME header encoders
  44 ;;;
  45
  46 (defun mime/encode-field (str)
  47   (setq str (rfc822/unfolding-string str))
  48   (let ((ret (string-match rfc822/field-top-regexp str)))
  49     (if ret
  50         (let ((field-name (substring str 0 (match-end 1)))
  51               (field-body (eliminate-top-spaces
  52                            (substring str (match-end 0))))
  53               fname)
  54           (concat field-name ": "
  55                   (cond ((string= field-body "") "")
  56                         ((member (setq fname (downcase field-name))
  57                                  '("reply-to" "from" "sender"
  58                                    "resent-reply-to" "resent-from"
  59                                    "resent-sender" "to" "resent-to"
  60                                    "cc" "resent-cc"
  61                                    "bcc" "resent-bcc" "dcc")
  62                                  )
  63                          (car (tm-eword::encode-address-list
  64                                (+ (length field-name) 1) field-body))
  65                          )
  66                         (t
  67                          (catch 'tag
  68                            (let ((r mime/no-encoding-header-fields) fn)
  69                              (while r
  70                                (setq fn (car r))
  71                                (if (string= (downcase fn) fname)
  72                                    (throw 'tag field-body)
  73                                  )
  74                                (setq r (cdr r))
  75                                ))
  76                            (car (tm-eword::encode-string
  77                                  (+ (length field-name) 1) field-body))
  78                            ))
  79                         ))
  80           )
  81       str)))
  82
  83 (defun mime/exist-encoded-word-in-subject ()
  84   (let ((str (rfc822/get-field-body "Subject")))
  85     (if (and str (string-match mime/encoded-word-regexp str))
  86         str)))
  87
  88 (defun mime/encode-message-header ()
  89   (interactive "*")
  90   (save-excursion
  91     (save-restriction
  92       (narrow-to-region (goto-char (point-min))
  93                         (progn
  94                           (re-search-forward
  95                            (concat
  96                             "^" (regexp-quote mail-header-separator) "$")
  97                            nil t)
  98                           (match-beginning 0)
  99                           ))
 100       (goto-char (point-min))
 101       (let (beg end field)
 102         (while (re-search-forward rfc822/field-top-regexp nil t)
 103           (setq beg (match-beginning 0))
 104           (setq end (rfc822/field-end))
 105           (if (and (find-charset-region beg end)
 106                    (setq field
 107                          (mime/encode-field
 108                           (buffer-substring-no-properties beg end)
 109                           ))
 110                    )
 111               (progn
 112                 (delete-region beg end)
 113                 (insert field)
 114                 ))
 115           ))
 116       (if mime/use-X-Nsubject
 117           (let ((str (mime/exist-encoded-word-in-subject)))
 118             (if str
 119                 (insert
 120                  (concat
 121                   "\nX-Nsubject: "
 122                   (mime/decode-encoded-words-string
 123                    (rfc822/unfolding-string str))
 124                   )))))
 125       )))
 126
 127
 128 ;;; @ end
 129 ;;;
 130
 131 (provide 'tm-eword)
 132
 133 (run-hooks 'tm-eword-load-hook)