1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
3 ;; Copyright (C) 1995,1996,1997,1998,1999,2000,2002,2003 Free Software Foundation, Inc.
5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
6 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
8 ;; This file is part of FLIM (Faithful Library about Internet Message).
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
30 (require 'eword-decode)
36 ;; User options are defined in mime-def.el.
38 (defvar mime-header-charset-encoding-alist
60 (iso-2022-int-1 . "B")
64 (defvar mime-header-default-charset-encoding "Q")
66 (defvar mime-header-encode-method-alist
67 '((eword-encode-address-list
70 Resent-Reply-To Resent-From
71 Resent-Sender To Resent-To
72 Cc Resent-Cc Bcc Resent-Bcc
74 (eword-encode-in-reply-to . (In-Reply-To))
75 (eword-encode-structured-field-body . (Mime-Version User-Agent))
76 (eword-encode-Content-Disposition-field-body . (Content-Disposition))
77 (eword-encode-Content-Type-field-body . (Content-Type))
78 (eword-encode-unstructured-field-body)))
81 ;;; @ encoded-text encoder
84 (defun eword-encode-text (charset encoding string &optional mode)
85 "Encode STRING as an encoded-word, and return the result.
86 CHARSET is a symbol to indicate MIME charset of the encoded-word.
87 ENCODING allows \"B\" or \"Q\".
88 MODE is allows `text', `comment', `phrase' or nil. Default value is
90 (let ((text (encoded-text-encode-string string encoding mode)))
92 (concat "=?" (upcase (symbol-name charset)) "?"
93 encoding "?" text "?=")
100 (defsubst eword-encode-char-type (character)
101 (if (memq character '(? ?\t ?\n))
103 (char-charset character)
106 (defun eword-encode-divide-into-charset-words (string)
107 (let ((len (length string))
110 (let* ((chr (aref string 0))
111 ;; (chr (sref string 0))
112 (charset (eword-encode-char-type chr))
114 ;; (i (char-length chr))
116 (while (and (< i len)
117 (setq chr (aref string i))
118 ;; (setq chr (sref string i))
119 (eq charset (eword-encode-char-type chr)))
121 ;; (setq i (char-next-index chr i))
123 (setq dest (cons (cons charset (substring string 0 i)) dest)
124 string (substring string i)
132 (defun eword-encode-charset-words-to-words (charset-words)
135 (let* ((charset-word (car charset-words))
136 (charset (car charset-word))
139 (let ((charsets (list charset))
140 (str (cdr charset-word))
143 (while (setq charset-words (cdr charset-words))
144 (setq charset-word (car charset-words)
145 charset (car charset-word))
149 (or (memq charset charsets)
150 (setq charsets (cons charset charsets))
152 (setq str (concat str (cdr charset-word)))
154 (setq dest (cons (cons charsets str) dest))
156 (setq dest (cons charset-word dest)
157 charset-words (cdr charset-words)
166 (defmacro make-ew-rword (text charset encoding type)
167 (` (list (, text)(, charset)(, encoding)(, type))))
168 (defmacro ew-rword-text (rword)
170 (defmacro ew-rword-charset (rword)
171 (` (car (cdr (, rword)))))
172 (defmacro ew-rword-encoding (rword)
173 (` (car (cdr (cdr (, rword))))))
174 (defmacro ew-rword-type (rword)
175 (` (car (cdr (cdr (cdr (, rword)))))))
177 (defun ew-find-charset-rule (charsets)
179 (let* ((charset (find-mime-charset-by-charsets charsets))
181 (cdr (or (assq charset mime-header-charset-encoding-alist)
182 (cons charset mime-header-default-charset-encoding)))))
183 (list charset encoding))))
185 ;; [tomo:2002-11-05] The following code is a quick-fix for emacsen
186 ;; which is not depended on the Mule model. We should redesign
187 ;; `eword-encode-split-string' to avoid to depend on the Mule model.
188 (if (featurep 'utf-2000)
189 ;; for CHISE Architecture
190 (defun tm-eword::words-to-ruled-words (wl &optional mode)
194 (setq mcs (detect-mime-charset-string (cdr word)))
198 (cdr (or (assq mcs mime-header-charset-encoding-alist)
199 (cons mcs mime-header-default-charset-encoding)))
205 (defun tm-eword::words-to-ruled-words (wl &optional mode)
208 (let ((ret (ew-find-charset-rule (car word))))
209 (make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
214 (defun ew-space-process (seq)
215 (let (prev a ac b c cc)
220 (setq cc (ew-rword-charset c))
221 (if (and (null (ew-rword-charset b))
222 (not (eq (ew-rword-type b) 'special)))
225 (setq ac (ew-rword-charset a))
226 (if (and (ew-rword-encoding a)
227 (ew-rword-encoding c))
230 (cons (concat (car a)(car b)(car c))
238 (cons (concat (car a)(car b))
243 (setq prev (cons b prev))
245 (setq prev (cons b prev))
250 (defun eword-encode-split-string (str &optional mode)
252 (tm-eword::words-to-ruled-words
253 (eword-encode-charset-words-to-words
254 (eword-encode-divide-into-charset-words str))
261 (defun tm-eword::encoded-word-length (rword)
262 (let ((string (ew-rword-text rword))
263 (charset (ew-rword-charset rword))
264 (encoding (ew-rword-encoding rword))
267 (cond ((string-equal encoding "B")
268 (setq string (encode-mime-charset-string string charset))
269 (base64-encoded-length string)
271 ((string-equal encoding "Q")
272 (setq string (encode-mime-charset-string string charset))
273 (Q-encoded-text-length string (ew-rword-type rword))
276 (cons (+ 7 (length (symbol-name charset)) ret) string)
283 (defun ew-encode-rword-1 (column rwl &optional must-output)
284 (catch 'can-not-output
285 (let* ((rword (car rwl))
286 (ret (tm-eword::encoded-word-length rword))
289 (cond ((and (setq string (car rword))
290 (or (<= (setq len (+ (length string) column)) 76)
295 ((memq (aref string 0) '(? ?\t))
296 (setq string (concat "\n" string)
305 (throw 'can-not-output nil)
307 (cond ((and (setq len (car ret))
308 (<= (+ column len) 76)
312 (ew-rword-charset rword)
313 (ew-rword-encoding rword)
315 (ew-rword-type rword)
317 (setq len (+ (length string) column))
321 (setq string (car rword))
324 (while (and (< p len)
327 ;;(setq np (char-next-index (sref string p) p))
328 (setq nstr (substring string 0 np))
329 (setq ret (tm-eword::encoded-word-length
330 (cons nstr (cdr rword))
332 (setq nstr (cdr ret))
333 (setq len (+ (car ret) column))
338 (if (string-equal str "")
342 (throw 'can-not-output nil))
343 (setq rwl (cons (cons (substring string p) (cdr rword))
347 (ew-rword-charset rword)
348 (ew-rword-encoding rword)
350 (ew-rword-type rword)))
351 (setq len (+ (length string) column))
355 (list string len rwl)
358 (defun eword-encode-rword-list (column rwl)
359 (let (ret dest str ew-f pew-f folded-points)
361 (setq ew-f (nth 2 (car rwl)))
363 (setq rwl (cons '(" ") rwl)
367 (if (null (setq ret (ew-encode-rword-1 column rwl)))
368 (let ((i (1- (length dest)))
373 (cond ((memq (setq c (aref dest i)) '(? ?\t))
374 (if (memq i folded-points)
376 (setq folded-points (cons i folded-points))
383 (setq s (substring dest i)
385 r-dest (concat (substring dest 0 i) "\n" s))
386 (when (setq ret (ew-encode-rword-1 r-column rwl))
391 (setq ret (ew-encode-rword-1 column rwl 'must-output))
394 (setq dest (concat dest str))
395 (setq column (nth 1 ret)
405 (defun eword-encode-phrase-to-rword-list (phrase)
406 (let (token type dest str)
408 (setq token (car phrase))
409 (setq type (car token))
410 (cond ((eq type 'quoted-string)
411 (setq str (concat "\"" (cdr token) "\""))
415 (let ((ret (ew-find-charset-rule
416 (find-charset-string str))))
418 str (car ret)(nth 1 ret) 'phrase)
425 '(("(" nil nil special))
426 (tm-eword::words-to-ruled-words
427 (eword-encode-charset-words-to-words
428 (eword-encode-divide-into-charset-words
431 '((")" nil nil special))
437 (tm-eword::words-to-ruled-words
438 (eword-encode-charset-words-to-words
439 (eword-encode-divide-into-charset-words
443 (setq phrase (cdr phrase))
445 (ew-space-process dest)
448 (defun eword-encode-addr-seq-to-rword-list (seq)
451 (let* ((token (car seq))
454 (cond ((eq name 'spaces)
455 (setq dest (nconc dest (list (list (cdr token) nil nil))))
461 (list (list "(" nil nil))
462 (eword-encode-split-string (cdr token) 'comment)
463 (list (list ")" nil nil))
466 ((eq name 'quoted-string)
471 (list (concat "\"" (cdr token) "\"") nil nil)
476 (if (or (eq pname 'spaces)
478 (nconc dest (list (list (cdr token) nil nil)))
479 (nconc (nreverse (cdr (reverse dest)))
482 (list (concat (car (car (last dest)))
491 (defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
492 (if (eq (car phrase-route-addr) 'phrase-route-addr)
493 (let ((phrase (nth 1 phrase-route-addr))
494 (route (nth 2 phrase-route-addr))
496 ;; (if (eq (car (car phrase)) 'spaces)
497 ;; (setq phrase (cdr phrase))
499 (setq dest (eword-encode-phrase-to-rword-list phrase))
501 (setq dest (append dest '((" " nil nil))))
505 (eword-encode-addr-seq-to-rword-list
506 (append '((specials . "<"))
508 '((specials . ">"))))
511 (defun eword-encode-addr-spec-to-rword-list (addr-spec)
512 (if (eq (car addr-spec) 'addr-spec)
513 (eword-encode-addr-seq-to-rword-list (cdr addr-spec))
516 (defun eword-encode-mailbox-to-rword-list (mbox)
517 (let ((addr (nth 1 mbox))
518 (comment (nth 2 mbox))
520 (setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
521 (eword-encode-addr-spec-to-rword-list addr)
528 (eword-encode-split-string comment 'comment)
529 (list '(")" nil nil))
533 (defsubst eword-encode-mailboxes-to-rword-list (mboxes)
534 (let ((dest (eword-encode-mailbox-to-rword-list (car mboxes))))
536 (while (setq mboxes (cdr mboxes))
539 (list '("," nil nil))
540 (eword-encode-mailbox-to-rword-list
544 (defsubst eword-encode-address-to-rword-list (address)
546 ((eq (car address) 'mailbox)
547 (eword-encode-mailbox-to-rword-list address))
548 ((eq (car address) 'group)
550 (eword-encode-phrase-to-rword-list (nth 1 address))
551 (list (list ":" nil nil))
552 (eword-encode-mailboxes-to-rword-list (nth 2 address))
553 (list (list ";" nil nil))))))
555 (defsubst eword-encode-addresses-to-rword-list (addresses)
556 (let ((dest (eword-encode-address-to-rword-list (car addresses))))
558 (while (setq addresses (cdr addresses))
561 (list '("," nil nil))
562 ;; (list '(" " nil nil))
563 (eword-encode-address-to-rword-list (car addresses))))))
566 (defsubst eword-encode-msg-id-to-rword-list (msg-id)
570 (caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
574 (defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
579 (let ((elt (car in-reply-to)))
580 (if (eq (car elt) 'phrase)
581 (eword-encode-phrase-to-rword-list (cdr elt))
582 (eword-encode-msg-id-to-rword-list elt)
584 (setq in-reply-to (cdr in-reply-to)))
588 ;;; @ application interfaces
591 (defvar eword-encode-default-start-column 10
592 "Default start column if it is omitted.")
594 (defun eword-encode-string (string &optional column mode)
595 "Encode STRING as encoded-words, and return the result.
596 Optional argument COLUMN is start-position of the field.
597 Optional argument MODE allows `text', `comment', `phrase' or nil.
598 Default value is `phrase'."
599 (car (eword-encode-rword-list
600 (or column eword-encode-default-start-column)
601 (eword-encode-split-string string mode))))
603 (defun eword-encode-address-list (string &optional column)
604 "Encode header field STRING as list of address, and return the result.
605 Optional argument COLUMN is start-position of the field."
606 (car (eword-encode-rword-list
607 (or column eword-encode-default-start-column)
608 (eword-encode-addresses-to-rword-list
609 (std11-parse-addresses-string string))
612 (defun eword-encode-in-reply-to (string &optional column)
613 "Encode header field STRING as In-Reply-To field, and return the result.
614 Optional argument COLUMN is start-position of the field."
615 (car (eword-encode-rword-list
617 (eword-encode-in-reply-to-to-rword-list
618 (std11-parse-msg-ids-string string)))))
620 (defun eword-encode-structured-field-body (string &optional column)
621 "Encode header field STRING as structured field, and return the result.
622 Optional argument COLUMN is start-position of the field."
623 (car (eword-encode-rword-list
624 (or column eword-encode-default-start-column)
625 (eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
628 (defun eword-encode-unstructured-field-body (string &optional column)
629 "Encode header field STRING as unstructured field, and return the result.
630 Optional argument COLUMN is start-position of the field."
631 (car (eword-encode-rword-list
632 (or column eword-encode-default-start-column)
633 (eword-encode-split-string string 'text))))
635 (defun eword-encode-Content-Type-field-body (field-body &optional column)
636 "Encode FIELD-BODY with MIME Parameter-Value Extensions, if necessary.
637 Optional second arg COLUMN is ignored."
638 (let ((tokens (mime-lexical-analyze field-body))
640 (unless (eq (car (car tokens)) 'mime-token)
641 (error "Invalid Content-Type value: %s" field-body))
642 (setq primary-type (downcase (cdr (car tokens)))
644 (unless (and (eq (car (car tokens)) 'tspecials)
645 (string= (cdr (car tokens)) "/")
646 (setq tokens (cdr tokens))
647 (eq (car (car tokens)) 'mime-token))
648 (error "Invalid Content-Type value: %s" field-body))
649 (concat " " primary-type "/" (downcase (cdr (car tokens)))
653 (concat ";\n " (car param) "=" (cdr param))))
654 (mime-encode-parameters
655 (mime-parse-parameters (cdr tokens)))
658 (defun eword-encode-Content-Disposition-field-body (field-body &optional column)
659 "Encode FIELD-BODY with MIME Parameter-Value Extensions, if necessary.
660 Optional second arg COLUMN is ignored."
661 (let ((tokens (mime-lexical-analyze field-body)))
662 (unless (eq (car (car tokens)) 'mime-token)
663 (error "Invalid Content-Disposition value: %s" field-body))
664 (concat " " (cdr (car tokens))
668 (concat ";\n " (car param) "=" (cdr param))))
669 (mime-encode-parameters
670 (mime-parse-parameters (cdr tokens)))
673 ;;; for MIME-Edit Next Generation.
674 ;;; (eword-encode-Content-Type type subtype parameters)
675 (defun eword-encode-Content-Type (content-type)
676 "Stringfy CONTENT-TYPE, using MIME Parameter-Value Extensions."
677 (concat " " ; XXX: Who requires this space?
678 (mime-type/subtype-string
679 (mime-content-type-primary-type content-type)
680 (mime-content-type-subtype content-type))
684 (concat ";\n " (car param) "=" (cdr param))))
685 (mime-encode-parameters
686 (mime-content-type-parameters content-type))
689 ;;; for MIME-Edit Next Generation.
690 ;;; (eword-encode-Content-Disposition type parameters)
691 (defun eword-encode-Content-Disposition (content-disposition)
692 "Stringfy CONTENT-DISPOSITION, using MIME Parameter-Value Extensions."
693 (concat " " ; XXX: Who requires this space?
694 (symbol-name (mime-content-disposition-type content-disposition))
698 (concat ";\n " (car param) "=" (cdr param))))
699 (mime-encode-parameters
700 (mime-content-disposition-parameters content-disposition))
704 (defun mime-encode-field-body (field-body field-name)
705 "Encode FIELD-BODY as FIELD-NAME, and return the result.
706 A lexical token includes non-ASCII character is encoded as MIME
707 encoded-word. ASCII token is not encoded."
708 (setq field-body (std11-unfold-string field-body))
709 (if (string= field-body "")
711 (let ((method-alist mime-header-encode-method-alist)
713 (if (symbolp field-name)
714 (setq start (1+ (length (symbol-name field-name))))
715 (setq start (1+ (length field-name))
716 field-name (intern (capitalize field-name))))
717 (while (car method-alist)
718 (if (or (not (cdr (car method-alist)))
720 (cdr (car method-alist))))
723 (apply (caar method-alist) (list field-body start)))
724 (setq method-alist nil)))
725 (setq method-alist (cdr method-alist)))
727 (defalias 'eword-encode-field-body 'mime-encode-field-body)
728 (make-obsolete 'eword-encode-field-body 'mime-encode-field-body)
730 (defun eword-in-subject-p ()
731 (let ((str (std11-field-body "Subject")))
732 (if (and str (string-match eword-encoded-word-regexp str))
734 (make-obsolete 'eword-in-subject-p "Don't use it.")
736 (defsubst eword-find-field-encoding-method (field-name)
737 (setq field-name (downcase field-name))
738 (let ((alist mime-field-encoding-method-alist))
741 (let* ((pair (car alist))
743 (if (and (stringp str)
744 (string= field-name (downcase str)))
745 (throw 'found (cdr pair))
747 (setq alist (cdr alist)))
748 (cdr (assq t mime-field-encoding-method-alist))
752 (defun mime-encode-header-in-buffer (&optional code-conversion)
753 "Encode header fields to network representation, such as MIME encoded-word.
754 It refers the `mime-field-encoding-method-alist' variable."
758 (std11-narrow-to-header mail-header-separator)
759 (goto-char (point-min))
760 (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
762 (while (re-search-forward std11-field-head-regexp nil t)
763 (setq bbeg (match-end 0)
764 field-name (buffer-substring-no-properties (match-beginning 0)
766 end (std11-field-end))
767 (and (delq 'ascii (find-charset-region bbeg end))
768 (let ((method (eword-find-field-encoding-method
769 (downcase field-name))))
770 (cond ((eq method 'mime)
772 (buffer-substring-no-properties bbeg end))
774 (mime-encode-field-body
775 field-body field-name)))
776 (if (not encoded-body)
777 (error "Cannot encode %s:%s"
778 field-name field-body)
779 (delete-region bbeg end)
780 (insert encoded-body))))
783 (or (mime-charset-to-coding-system
786 (encode-coding-region bbeg end cs)))))))))))
787 (defalias 'eword-encode-header 'mime-encode-header-in-buffer)
788 (make-obsolete 'eword-encode-header 'mime-encode-header-in-buffer)
794 (provide 'eword-encode)
796 ;;; eword-encode.el ends here