X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=eword-encode.el;h=80d2ee6fdd53421f7751ab0a726d2b082863a616;hb=af368f85cde63eccff0aa29a7cd7ea51e633aa72;hp=d3188b5db3caccc19c8c845db20a24b14538574f;hpb=9b03bef87be75b7260b82d80918328ec8a9c0687;p=elisp%2Fflim.git diff --git a/eword-encode.el b/eword-encode.el index d3188b5..80d2ee6 100644 --- a/eword-encode.el +++ b/eword-encode.el @@ -34,7 +34,11 @@ ;;; @ variables ;;; -(defvar eword-field-encoding-method-alist +(defgroup eword-encode nil + "Encoded-word encoding" + :group 'mime) + +(defcustom eword-field-encoding-method-alist '(("X-Nsubject" . iso-2022-jp-2) ("Newsgroups" . nil) ("Message-ID" . nil) @@ -52,7 +56,15 @@ 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.") +If method is nil, this field will not be encoded." + :group 'eword-encode + :type '(repeat (cons (choice :tag "Field" + (string :tag "Name") + (const :tag "Default" t)) + (choice :tag "Method" + (const :tag "MIME conversion" mime) + (symbol :tag "non-MIME conversion") + (const :tag "no-conversion" nil))))) (defvar eword-charset-encoding-alist '((us-ascii . nil) @@ -73,6 +85,7 @@ If method is nil, this field will not be encoded.") (euc-kr . "B") (iso-2022-jp-2 . "B") (iso-2022-int-1 . "B") + (utf-8 . "B") )) @@ -85,13 +98,7 @@ CHARSET is a symbol to indicate MIME charset of the encoded-word. ENCODING allows \"B\" or \"Q\". MODE is allows `text', `comment', `phrase' or nil. Default value is `phrase'." - (let ((text - (cond ((string= encoding "B") - (base64-encode-string string)) - ((string= encoding "Q") - (q-encoding-encode-string string mode)) - ) - )) + (let ((text (encoded-text-encode-string string encoding))) (if text (concat "=?" (upcase (symbol-name charset)) "?" encoding "?" text "?=") @@ -102,7 +109,7 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is ;;; (defsubst eword-encode-char-type (character) - (if (or (eq character ? )(eq character ?\t)) + (if (memq character '(? ?\t ?\n)) nil (char-charset character) )) @@ -250,8 +257,7 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is ) ((string-equal encoding "Q") (setq string (encode-mime-charset-string string charset)) - (q-encoding-encoded-length string - (ew-rword-type rword)) + (Q-encoded-text-length string (ew-rword-type rword)) ))) (if ret (cons (+ 7 (length (symbol-name charset)) ret) string) @@ -467,9 +473,9 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is (let ((phrase (nth 1 phrase-route-addr)) (route (nth 2 phrase-route-addr)) dest) - (if (eq (car (car phrase)) 'spaces) - (setq phrase (cdr phrase)) - ) + ;; (if (eq (car (car phrase)) 'spaces) + ;; (setq phrase (cdr phrase)) + ;; ) (setq dest (eword-encode-phrase-to-rword-list phrase)) (if dest (setq dest (append dest '((" " nil nil)))) @@ -487,7 +493,7 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is (eword-encode-addr-seq-to-rword-list (cdr addr-spec)) )) -(defun tm-eword::mailbox-to-rwl (mbox) +(defun eword-encode-mailbox-to-rword-list (mbox) (let ((addr (nth 1 mbox)) (comment (nth 2 mbox)) dest) @@ -500,95 +506,124 @@ MODE is allows `text', `comment', `phrase' or nil. Default value is '((" " nil nil) ("(" nil nil)) (eword-encode-split-string comment 'comment) - '((")" nil nil)) + (list '(")" nil nil)) ))) dest)) (defsubst eword-encode-addresses-to-rword-list (addresses) - (let ((dest (tm-eword::mailbox-to-rwl (car addresses)))) + (let ((dest (eword-encode-mailbox-to-rword-list (car addresses)))) (if dest (while (setq addresses (cdr addresses)) - (setq dest (append dest - '(("," nil nil)) - '((" " nil nil)) - (tm-eword::mailbox-to-rwl (car addresses)) - )) + (setq dest + (nconc dest + (list '("," nil nil)) + ;; (list '(" " nil nil)) + (eword-encode-mailbox-to-rword-list (car addresses)) + )) )) dest)) +(defsubst eword-encode-msg-id-to-rword-list (msg-id) + (cons '(" " nil nil) + (cons '("<" nil nil) + (nconc (eword-encode-addr-seq-to-rword-list (cdr msg-id)) + '((">" nil nil)))))) + +(defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to) + (let (dest) + (while in-reply-to + (setq dest + (append dest + (let ((elt (car in-reply-to))) + (if (eq (car elt) 'phrase) + (eword-encode-phrase-to-rword-list (cdr elt)) + (eword-encode-msg-id-to-rword-list elt) + )))) + (setq in-reply-to (cdr in-reply-to))) + dest)) + ;;; @ application interfaces ;;; +(defcustom eword-encode-default-start-column 10 + "Default start column if it is omitted." + :group 'eword-encode + :type 'integer) + (defun eword-encode-string (string &optional column mode) "Encode STRING as encoded-words, and return the result. Optional argument COLUMN is start-position of the field. Optional argument MODE allows `text', `comment', `phrase' or nil. Default value is `phrase'." - (car (eword-encode-rword-list (or column 0) - (eword-encode-split-string string mode)))) + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-split-string string mode)))) (defun eword-encode-address-list (string &optional column) "Encode header field STRING as list of address, and return the result. Optional argument COLUMN is start-position of the field." - (car (eword-encode-rword-list (or column 0) - (eword-encode-addresses-to-rword-list - (std11-parse-addresses-string string)) - ))) + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-addresses-to-rword-list + (std11-parse-addresses-string string)) + ))) + +(defun eword-encode-in-reply-to (string &optional column) + "Encode header field STRING as In-Reply-To field, and return the result. +Optional argument COLUMN is start-position of the field." + (car (eword-encode-rword-list + (or column 13) + (eword-encode-in-reply-to-to-rword-list + (std11-parse-in-reply-to + (std11-lexical-analyze string)))))) (defun eword-encode-structured-field-body (string &optional column) "Encode header field STRING as structured field, and return the result. Optional argument COLUMN is start-position of the field." (car (eword-encode-rword-list - (or column 0) + (or column eword-encode-default-start-column) (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string)) ))) (defun eword-encode-unstructured-field-body (string &optional column) "Encode header field STRING as unstructured field, and return the result. Optional argument COLUMN is start-position of the field." - (car (eword-encode-rword-list (or column 0) - (eword-encode-split-string string 'text)))) + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-split-string string 'text)))) -(defun eword-encode-field (string) - "Encode header field STRING, and return the result. +(defun eword-encode-field-body (field-body field-name) + "Encode FIELD-BODY as FIELD-NAME, and return the result. A lexical token includes non-ASCII character is encoded as MIME encoded-word. ASCII token is not encoded." - (setq string (std11-unfold-string string)) - (let ((ret (string-match std11-field-head-regexp string))) - (or (if ret - (let ((field-name (substring string 0 (1- (match-end 0)))) - (field-body (eliminate-top-spaces - (substring string (match-end 0)))) - field-name-symbol) - (if (setq ret - (cond ((string= field-body "") "") - ((memq (setq field-name-symbol - (intern (capitalize field-name))) - '(Reply-To - From Sender - Resent-Reply-To Resent-From - Resent-Sender To Resent-To - Cc Resent-Cc Bcc Resent-Bcc - Dcc)) - (eword-encode-address-list - field-body (+ (length field-name) 2)) - ) - ((memq field-name-symbol - '(In-Reply-To - Mime-Version User-Agent)) - (eword-encode-structured-field-body - field-body (+ (length field-name) 2)) - ) - (t - (eword-encode-unstructured-field-body - field-body (1+ (length field-name))) - )) - ) - (concat field-name ": " ret) - ))) - (eword-encode-string string 0) - ))) + (setq field-body (std11-unfold-string field-body)) + (if (string= field-body "") + "" + (let (start) + (if (symbolp field-name) + (setq start (1+ (length (symbol-name field-name)))) + (setq start (1+ (length field-name)) + field-name (intern (capitalize field-name)))) + (cond ((memq field-name + '(Reply-To + From Sender + Resent-Reply-To Resent-From + Resent-Sender To Resent-To + Cc Resent-Cc Bcc Resent-Bcc + Dcc)) + (eword-encode-address-list field-body start) + ) + ((eq field-name 'In-Reply-To) + (eword-encode-in-reply-to field-body start) + ) + ((memq field-name '(Mime-Version User-Agent)) + (eword-encode-structured-field-body field-body start) + ) + (t + (eword-encode-unstructured-field-body field-body start) + )) + ))) (defun eword-in-subject-p () (let ((str (std11-field-body "Subject"))) @@ -620,27 +655,28 @@ It refer variable `eword-field-encoding-method-alist'." (std11-narrow-to-header mail-header-separator) (goto-char (point-min)) (let ((default-cs (mime-charset-to-coding-system default-mime-charset)) - beg end field-name) + bbeg end field-name) (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0)) - (setq field-name (buffer-substring beg (1- (match-end 0)))) - (setq end (std11-field-end)) - (and (find-non-ascii-charset-region beg end) + (setq bbeg (match-end 0) + field-name (buffer-substring (match-beginning 0) (1- bbeg)) + end (std11-field-end)) + (and (find-non-ascii-charset-region bbeg end) (let ((method (eword-find-field-encoding-method (downcase field-name)))) (cond ((eq method 'mime) - (let ((field - (buffer-substring-no-properties beg end) + (let ((field-body + (buffer-substring-no-properties bbeg end) )) - (delete-region beg end) - (insert (eword-encode-field field)) + (delete-region bbeg end) + (insert (eword-encode-field-body field-body + field-name)) )) (code-conversion (let ((cs (or (mime-charset-to-coding-system method) default-cs))) - (encode-coding-region beg end cs) + (encode-coding-region bbeg end cs) ))) )) ))