X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tm-ew-e.el;h=a08771ec6c5948c3d53ea922c78bc90e2601d844;hb=29e661110079bf0d047d34fa64f7a963d06b7522;hp=a01fb902c1df72b30776f82d378c06165255d4c1;hpb=15cb3afb2b5a34521da0c387f61bda4a72998615;p=elisp%2Ftm.git diff --git a/tm-ew-e.el b/tm-ew-e.el index a01fb90..a08771e 100644 --- a/tm-ew-e.el +++ b/tm-ew-e.el @@ -1,34 +1,32 @@ -;;; -;;; 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.17 $ -;;; 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 1522 based MIME encoded-word encoder for GNU Emacs + +;; Copyright (C) 1995,1996 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Version: $Revision: 7.47 $ +;; 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; 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) @@ -36,7 +34,7 @@ ;;; (defconst tm-ew-e/RCS-ID - "$Id: tm-ew-e.el,v 7.17 1996/05/04 04:58:37 morioka Exp $") + "$Id: tm-ew-e.el,v 7.47 1996/08/30 04:26:46 morioka Exp $") (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID)) @@ -48,24 +46,23 @@ (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") + '((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 ;;; @@ -78,7 +75,8 @@ ) )) (if text - (concat "=?" charset "?" encoding "?" text "?=") + (concat "=?" (upcase (symbol-name charset)) "?" + encoding "?" text "?=") ))) @@ -94,14 +92,14 @@ (defun tm-eword::parse-lc-word (str) (let* ((chr (sref str 0)) (lc (tm-eword::char-type chr)) - (i (char-bytes chr)) + (i (char-length 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))) + (setq i (+ i (char-length chr))) ) (cons (cons lc (substring str 0 i)) (substring str i)) )) @@ -158,20 +156,31 @@ ;;; @ rule ;;; -(defun tm-eword::find-charset-rule (lcl) - (if lcl - (let* ((charset (mime/find-charset lcl)) - (encoding - (cdr (assoc charset mime-eword/charset-encoding-alist)) - )) +(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) (tm-eword::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) @@ -180,13 +189,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)) @@ -208,60 +218,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) @@ -280,7 +270,10 @@ ) (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)) @@ -292,7 +285,7 @@ (str "") nstr) (while (and (< p len) (progn - (setq np (+ p (char-bytes (sref string p)))) + (setq np (+ p (char-length (sref string p)))) (setq nstr (substring string 0 np)) (setq ret (tm-eword::encoded-word-length (cons nstr (cdr rword)) @@ -310,7 +303,10 @@ (cdr rwl))) (setq string (tm-eword::encode-encoded-text - (nth 1 rword) (nth 2 rword) str)) + (tm-eword::rword-charset rword) + (tm-eword::rword-encoding rword) + str + (tm-eword::rword-type rword))) (setq len (+ (length string) column)) ) ))) @@ -318,16 +314,22 @@ (list string len rwl) )) -(defun tm-eword::encode-rwl (column rwl &optional mode) - (let (ret dest ps special str) +(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 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 mode)) + (setq ret (tm-eword::encode-string-1 2 rwl)) (setq str (car ret)) )) (cond ((eq special 32) @@ -362,7 +364,7 @@ )) (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)) ) @@ -379,8 +381,11 @@ (setq dest (append dest (list - (cons str (tm-eword::find-charset-rule - (find-charset-string str))) + (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) @@ -389,7 +394,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)) )) ) @@ -398,7 +404,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)) ) @@ -419,12 +425,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) @@ -439,7 +445,7 @@ (append dest '((" " nil nil) ("(" nil nil)) - (tm-eword::split-string comment) + (tm-eword::split-string comment 'comment) '((")" nil nil)) ))) dest)) @@ -459,24 +465,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" @@ -485,7 +490,7 @@ "bcc" "resent-bcc" "dcc") ) (car (tm-eword::encode-address-list - (+ (length field-name) 1) field-body)) + (+ (length field-name) 2) field-body)) ) (t (catch 'tag @@ -493,22 +498,23 @@ fn) (while r (setq fn (car r)) - (if (string= (downcase fn) fname) + (if (string-equal (downcase fn) fname) (throw 'tag field-body) ) (setq r (cdr r)) )) (car (tm-eword::encode-string - (+ (length field-name) 1) field-body)) + (+ (length field-name) 1) + field-body 'text)) )) )) (concat field-name ": " ret) ))) - (tm-eword::encode-string 0 str) + (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))) @@ -516,18 +522,12 @@ (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) + (while (re-search-forward std11-field-head-regexp nil t) (setq beg (match-beginning 0)) - (setq end (rfc822/field-end)) + (setq end (std11-field-end)) (if (and (find-charset-region beg end) (setq field (mime/encode-field @@ -545,13 +545,12 @@ (insert (concat "\nX-Nsubject: " - (mime-eword/decode-string (rfc822/unfolding-string str)) + (mime-eword/decode-string (std11-unfold-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)) + (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode))) )