X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-ew-e.el;h=e8a71bc17f5edf87b20a71c26b74378a0b62ba41;hb=86824724a2d5325e296ee93a1abb3952d2320a20;hp=ec267f2144b86bf05cac36687c3b4910092b1bba;hpb=05b13728a22475e6336880af82c01e03038c1481;p=elisp%2Ftm.git diff --git a/tm-ew-e.el b/tm-ew-e.el index ec267f2..e8a71bc 100644 --- a/tm-ew-e.el +++ b/tm-ew-e.el @@ -1,68 +1,101 @@ -;;; -;;; 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 -;;; Version: $Revision: 7.33 $ -;;; 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 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Revision: 7.57 $ +;; 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.33 1996/06/11 14:34:28 morioka Exp $") + "$Id: tm-ew-e.el,v 7.57 1996/12/12 02:30:04 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") )) @@ -78,7 +111,8 @@ ) )) (if text - (concat "=?" charset "?" encoding "?" text "?=") + (concat "=?" (upcase (symbol-name charset)) "?" + encoding "?" text "?=") ))) @@ -88,7 +122,7 @@ (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) @@ -169,12 +203,11 @@ (defmacro tm-eword::rword-type (rword) (` (car (cdr (cdr (cdr (, rword))))))) -(defun tm-eword::find-charset-rule (lcl) - (if lcl - (let* ((charset (mime/find-charset lcl)) - (encoding - (cdr (assoc charset mime-eword/charset-encoding-alist)) - )) +(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) ))) @@ -199,7 +232,7 @@ (setq ac (tm-eword::rword-charset a)) (if (and (tm-eword::rword-encoding a) (tm-eword::rword-encoding c)) - (cond ((equal ac cc) + (cond ((eq ac cc) (setq prev (cons (cons (concat (car a)(car b)(car c)) (cdr a)) @@ -237,17 +270,17 @@ (encoding (tm-eword::rword-encoding rword)) ret) (setq ret - (cond ((equal encoding "B") - (setq string (mime-charset-encode-string string charset)) + (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)) + ((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) ))) @@ -385,7 +418,7 @@ (append dest (list (let ((ret (tm-eword::find-charset-rule - (find-charset-string str)))) + (find-non-ascii-charset-string str)))) (tm-eword::make-rword str (car ret)(nth 1 ret) 'phrase) ) @@ -428,12 +461,12 @@ ) (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) @@ -468,24 +501,23 @@ (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" @@ -497,66 +529,89 @@ (+ (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)) - )) - )) + (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)