X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=eword-encode.el;h=ee3f95cf45bb455d7b7f62c243e45feeeddd8ed9;hb=2e2f5b06a5d30fdf57394f764f2a36929f0e5f63;hp=da911a00189eeac591d6d77b20981bd6c4dfc4ce;hpb=621eb410aa43dd2d8009a08fc17e18517b1f372d;p=elisp%2Fsemi.git diff --git a/eword-encode.el b/eword-encode.el index da911a0..ee3f95c 100644 --- a/eword-encode.el +++ b/eword-encode.el @@ -1,12 +1,11 @@ ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Revision: 0.20 $ ;; Keywords: encoded-word, MIME, multilingual, header, mail, news -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). +;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -36,7 +35,7 @@ ;;; (defconst eword-encode-RCS-ID - "$Id: eword-encode.el,v 0.20 1997-06-21 14:25:21 morioka Exp $") + "$Id: eword-encode.el,v 1.2 1998-03-13 12:55:54 morioka Exp $") (defconst eword-encode-version (get-version-string eword-encode-RCS-ID)) @@ -46,6 +45,7 @@ (defvar eword-field-encoding-method-alist '(("X-Nsubject" . iso-2022-jp-2) ("Newsgroups" . nil) + ("Message-ID" . nil) (t . mime) ) "*Alist to specify field encoding method. @@ -62,10 +62,6 @@ network-code. If method is nil, this field will not be encoded.") -(defvar eword-generate-X-Nsubject nil - "*If it is not nil, X-Nsubject field is generated -when Subject field is encoded by `eword-encode-header'.") - (defvar eword-charset-encoding-alist '((us-ascii . nil) (iso-8859-1 . "Q") @@ -110,7 +106,7 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is ))) -;;; @ leading char +;;; @ charset word ;;; (defsubst eword-encode-char-type (character) @@ -119,61 +115,59 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is (char-charset character) )) -(defun tm-eword::split-to-lc-words (str) - (let (ret dest) - (while (not (string= str "")) - (let* ((chr (sref str 0)) +(defun eword-encode-divide-into-charset-words (string) + (let ((len (length string)) + dest) + (while (> len 0) + (let* ((chr (sref string 0)) (charset (eword-encode-char-type chr)) (i (char-bytes chr)) - (len (length str)) ) (while (and (< i len) - (setq chr (sref str i)) + (setq chr (sref string i)) (eq charset (eword-encode-char-type chr)) ) (setq i (+ i (char-bytes chr))) ) - (setq dest (cons (cons charset (substring str 0 i)) dest) - str (substring str i)) - )) - (reverse dest) + (setq dest (cons (cons charset (substring string 0 i)) dest) + string (substring string i) + len (- len i) + ))) + (nreverse dest) )) ;;; @ word ;;; -(defun tm-eword::parse-word (lcwl) - (let* ((lcw (car lcwl)) - (lc (car lcw)) - ) - (if (null lc) - lcwl - (let ((lcl (list lc)) - (str (cdr lcw)) - ) - (catch 'tag - (while (setq lcwl (cdr lcwl)) - (setq lcw (car lcwl)) - (setq lc (car lcw)) - (if (null lc) - (throw 'tag nil) - ) - (if (not (memq lc lcl)) - (setq lcl (cons lc lcl)) +(defun eword-encode-charset-words-to-words (charset-words) + (let (dest) + (while charset-words + (let* ((charset-word (car charset-words)) + (charset (car charset-word)) + ) + (if charset + (let ((charsets (list charset)) + (str (cdr charset-word)) + ) + (catch 'tag + (while (setq charset-words (cdr charset-words)) + (setq charset-word (car charset-words) + charset (car charset-word)) + (if (null charset) + (throw 'tag nil) + ) + (or (memq charset charsets) + (setq charsets (cons charset charsets)) + ) + (setq str (concat str (cdr charset-word))) + )) + (setq dest (cons (cons charsets str) dest)) ) - (setq str (concat str (cdr lcw))) - )) - (cons (cons lcl str) lcwl) - )))) - -(defun tm-eword::lc-words-to-words (lcwl) - (let (ret dest) - (while (setq ret (tm-eword::parse-word lcwl)) - (setq dest (cons (car ret) dest)) - (setq lcwl (cdr ret)) - ) - (reverse dest) + (setq dest (cons charset-word dest) + charset-words (cdr charset-words) + )))) + (nreverse dest) )) @@ -244,9 +238,10 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is (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)) - mode))) + (tm-eword::words-to-ruled-words + (eword-encode-charset-words-to-words + (eword-encode-divide-into-charset-words str)) + mode))) ;;; @ length @@ -281,7 +276,8 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is string len) (if (null ret) (cond ((and (setq string (car rword)) - (<= (setq len (+ (length string) column)) 76) + (or (<= (setq len (+ (length string) column)) 76) + (<= column 1)) ) (setq rwl (cdr rwl)) ) @@ -416,25 +412,70 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is (append dest '(("(" nil nil)) (tm-eword::words-to-ruled-words - (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words (cdr token))) + (eword-encode-charset-words-to-words + (eword-encode-divide-into-charset-words + (cdr token))) 'comment) '((")" nil nil)) )) ) (t - (setq dest (append dest - (tm-eword::words-to-ruled-words - (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words (cdr token)) - ) 'phrase))) + (setq dest + (append dest + (tm-eword::words-to-ruled-words + (eword-encode-charset-words-to-words + (eword-encode-divide-into-charset-words + (cdr token)) + ) 'phrase))) )) (setq phrase (cdr phrase)) ) (tm-eword::space-process dest) )) -(defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr) +(defun eword-addr-seq-to-rwl (seq) + (let (dest pname) + (while seq + (let* ((token (car seq)) + (name (car token)) + ) + (cond ((eq name 'spaces) + (setq dest (nconc dest (list (list (cdr token) nil nil)))) + ) + ((eq name 'comment) + (setq dest + (nconc + dest + (list (list "(" nil nil)) + (tm-eword::split-string (cdr token) 'comment) + (list (list ")" nil nil)) + )) + ) + ((eq name 'quoted-string) + (setq dest + (nconc + dest + (list + (list (concat "\"" (cdr token) "\"") nil nil) + ))) + ) + (t + (setq dest + (if (or (eq pname 'spaces) + (eq pname 'comment)) + (nconc dest (list (list (cdr token) nil nil))) + (nconc (butlast dest) + (list + (list (concat (car (car (last dest))) + (cdr token)) + nil nil))))) + )) + (setq seq (cdr seq) + pname name)) + ) + dest)) + +(defun eword-phrase-route-addr-to-rwl (phrase-route-addr) (if (eq (car phrase-route-addr) 'phrase-route-addr) (let ((phrase (nth 1 phrase-route-addr)) (route (nth 2 phrase-route-addr)) @@ -448,20 +489,23 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is ) (append dest - (list (list (concat "<" (std11-addr-to-string route) ">") nil nil)) + (eword-addr-seq-to-rwl + (append '((specials . "<")) + route + '((specials . ">")))) )))) -(defun tm-eword::addr-spec-to-rwl (addr-spec) +(defun eword-addr-spec-to-rwl (addr-spec) (if (eq (car addr-spec) 'addr-spec) - (list (list (std11-addr-to-string (cdr addr-spec)) nil nil)) + (eword-addr-seq-to-rwl (cdr addr-spec)) )) (defun tm-eword::mailbox-to-rwl (mbox) (let ((addr (nth 1 mbox)) (comment (nth 2 mbox)) dest) - (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr) - (tm-eword::addr-spec-to-rwl addr) + (setq dest (or (eword-phrase-route-addr-to-rwl addr) + (eword-addr-spec-to-rwl addr) )) (if comment (setq dest @@ -514,7 +558,8 @@ encoded-word. ASCII token is not encoded." resent-reply-to resent-from resent-sender to resent-to cc resent-cc - bcc resent-bcc dcc) + bcc resent-bcc dcc + mime-version) ) (car (tm-eword::encode-address-list (+ (length field-name) 2) field-body)) @@ -535,6 +580,21 @@ encoded-word. ASCII token is not encoded." (if (and str (string-match eword-encoded-word-regexp str)) str))) +(defsubst eword-find-field-encoding-method (field-name) + (setq field-name (downcase field-name)) + (let ((alist eword-field-encoding-method-alist)) + (catch 'found + (while alist + (let* ((pair (car alist)) + (str (car pair))) + (if (and (stringp str) + (string= field-name (downcase str))) + (throw 'found (cdr pair)) + )) + (setq alist (cdr alist))) + (cdr (assq t eword-field-encoding-method-alist)) + ))) + (defun eword-encode-header (&optional code-conversion) "Encode header fields to network representation, such as MIME encoded-word. @@ -551,59 +611,24 @@ It refer variable `eword-field-encoding-method-alist'." (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 (let ((fname (downcase field-name))) - (assoc-if - (function - (lambda (str) - (and (stringp str) - (string= fname (downcase str)) - ))) - eword-field-encoding-method-alist)) - (assq t eword-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 (eword-encode-field field)) - )) - (code-conversion - (let ((cs - (or (mime-charset-to-coding-system - method) - default-cs))) - (encode-coding-region beg end cs) - ))) - )) + (let ((method (eword-find-field-encoding-method + (downcase field-name)))) + (cond ((eq method 'mime) + (let ((field + (buffer-substring-no-properties beg end) + )) + (delete-region beg end) + (insert (eword-encode-field field)) + )) + (code-conversion + (let ((cs + (or (mime-charset-to-coding-system + method) + default-cs))) + (encode-coding-region beg end cs) + ))) )) )) - (and eword-generate-X-Nsubject - (or (std11-field-body "X-Nsubject") - (let ((str (eword-in-subject-p))) - (if str - (progn - (setq str - (eword-decode-string - (std11-unfold-string str))) - (if code-conversion - (setq str - (encode-mime-charset-string - str - (or (cdr (assoc-if - (function - (lambda (str) - (and (stringp str) - (string= "x-nsubject" - (downcase str)) - ))) - eword-field-encoding-method-alist)) - 'iso-2022-jp-2))) - ) - (insert (concat "\nX-Nsubject: " str)) - ))))) ))) (defun eword-encode-string (str &optional column mode)