2 ;;; A multilingual MIME message header encoder/decoder.
3 ;;; by Morioka Tomohiko (morioka@jaist.ac.jp)
5 ;;; original MIME decoder is
6 ;;; mime.el,v 1.5 1992/07/18 07:52:08 by Enami Tsugutomo
24 "$Id: tiny-mime.el,v 6.7 1995/09/20 12:17:28 morioka Exp $")
26 (defconst mime/tiny-mime-version (get-version-string mime/RCS-ID))
29 ;;; @ MIME encoded-word definition
32 (defconst mime/encoded-text-regexp "[!->@-~]+")
33 (defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
41 mime/encoded-text-regexp
45 (defun mime/nth-string (s n)
47 (substring s (match-beginning n) (match-end n))
48 (buffer-substring (match-beginning n) (match-end n))))
50 (defun mime/encoded-word-charset (str)
51 (mime/nth-string str 1))
53 (defun mime/encoded-word-encoding (str)
54 (mime/nth-string str 2))
56 (defun mime/encoded-word-encoded-text (str)
57 (mime/nth-string str 3))
59 (defun mime/rest-of-string (str)
61 (substring str (match-end 0))
62 (buffer-substring (match-end 0)(point-max))
69 (defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
71 (defvar mime/use-X-Nsubject nil)
74 ;;; @ Application Interface
77 ;;; @@ MIME header decoders
80 (defun mime/decode-encoded-text (charset encoding str)
82 (cond ((string= "B" encoding)
83 (base64-decode-string str))
84 ((string= "Q" encoding)
85 (q-encoding-decode-string str))
86 (t (message "unknown encoding %s" encoding)
89 (mime/convert-string-to-emacs charset dest)
92 (defun mime/decode-encoded-word (word)
93 (or (if (string-match mime/encoded-word-regexp word)
94 (let ((charset (upcase (mime/encoded-word-charset word)))
95 (encoding (upcase (mime/encoded-word-encoding word)))
96 (text (mime/encoded-word-encoded-text word)))
97 (mime/decode-encoded-text charset encoding text)
101 (defun mime/decode-region (beg end)
105 (narrow-to-region beg end)
106 (goto-char (point-min))
107 (let (charset encoding text)
108 (while (re-search-forward mime/encoded-word-regexp nil t)
109 (insert (mime/decode-encoded-word
111 (buffer-substring (match-beginning 0) (match-end 0))
112 (delete-region (match-beginning 0) (match-end 0))
118 (defun mime/decode-message-header ()
122 (narrow-to-region (goto-char (point-min))
123 (progn (re-search-forward "^$" nil t) (point)))
124 (mime/prepare-decode-message-header)
125 (mime/decode-region (point-min) (point-max))
128 (defun mime/decode-string (str)
129 (let ((dest "")(ew nil)
131 (while (setq beg (string-match mime/encoded-word-regexp str))
133 (if (not (and (eq ew t) (string= (substring str 0 beg) " ")))
134 (setq dest (concat dest (substring str 0 beg)
138 (setq end (match-end 0))
139 (setq dest (concat dest
140 (mime/decode-encoded-word (substring str beg end))
142 (setq str (substring str end))
148 ;;; @@ MIME header encoders
151 (defun mime/encode-string (string encoding &optional mode)
152 (cond ((string= encoding "B") (base64-encode-string string))
153 ((string= encoding "Q") (q-encoding-encode-string string mode))
156 (defun mime/encode-field (str)
157 (setq str (message/unfolding-string str))
158 (let ((ret (message/divide-field str))
159 field-name field-body)
160 (setq field-name (car ret))
161 (setq field-body (nth 1 ret))
162 (concat field-name " "
163 (cond ((string= field-body "") "")
164 ((or (string-match "^Reply-To:$" field-name)
165 (string-match "^From:$" field-name)
166 (string-match "^Sender:$" field-name)
167 (string-match "^Resent-Reply-To:$" field-name)
168 (string-match "^Resent-From:$" field-name)
169 (string-match "^Resent-Sender:$" field-name)
170 (string-match "^To:$" field-name)
171 (string-match "^Resent-To:$" field-name)
172 (string-match "^cc:$" field-name)
173 (string-match "^Resent-cc:$" field-name)
174 (string-match "^bcc:$" field-name)
175 (string-match "^Resent-bcc:$" field-name)
177 (mime/encode-address-list
178 (+ (length field-name) 1) field-body)
182 (let ((r mime/no-encoding-header-fields) fn)
185 (if (string-match (concat "^" fn ":$") field-name)
186 (throw 'tag field-body)
190 (nth 1 (mime/encode-header-string
191 (+ (length field-name) 1) field-body))
196 (defun mime/exist-encoded-word-in-subject ()
197 (let ((str (message/get-field-body "Subject")))
198 (if (and str (string-match mime/encoded-word-regexp str))
201 (defun mime/encode-message-header ()
205 (narrow-to-region (goto-char (point-min))
209 "^" (regexp-quote mail-header-separator) "$")
213 (goto-char (point-min))
215 (while (re-search-forward "^.+:.*\\(\n\\s +.*\\)*" nil t)
216 (setq beg (match-beginning 0))
217 (setq end (match-end 0))
218 (setq field (buffer-substring beg end))
219 (insert (mime/encode-field
221 (buffer-substring beg end)
222 (delete-region beg end)
225 (if mime/use-X-Nsubject
226 (let ((str (mime/exist-encoded-word-in-subject)))
230 (mime/decode-string (message/unfolding-string str))
235 ;;; @ functions for message header encoding
238 (defun mime/encode-and-split-string (n string charset encoding)
240 (len (length string))
241 (js (mime/convert-string-from-emacs string charset))
242 (cesl (+ (length charset) (length encoding) 6 ))
244 (setq ewl (mime/encoded-word-length js encoding))
247 (setq m (+ n ewl cesl))
250 (while (and (< i len)
251 (setq js (mime/convert-string-from-emacs
252 (substring string 0 i) charset))
254 (mime/encoded-word-length js encoding)
258 (setq i (+ i (char-bytes (elt string i))))
260 (setq js (mime/convert-string-from-emacs
261 (substring string 0 j) charset))
262 (setq m (+ n (mime/encoded-word-length js encoding) cesl))
263 (setq rest (substring string j))
268 (list m (concat "=?" charset "?" encoding "?"
269 (mime/encode-string js encoding)
274 (defun mime/encode-header-word (n string charset encoding)
275 (let (dest str ret m)
277 (mime/encode-and-split-string n string charset encoding)))
280 (setq dest (nth 1 ret))
282 (setq str (nth 2 ret))
283 (while (and (stringp str)
285 (mime/encode-and-split-string
286 1 str charset encoding))
288 (setq dest (concat dest "\n " (nth 1 ret)))
290 (setq str (nth 2 ret))
296 (defun mime/encode-header-string (n string &optional mode)
297 (if (string= string "")
299 (let ((ssl (mime/separate-string-for-encoder string))
300 i len cell et w ew (dest "") b l)
301 (setq len (length ssl))
302 (setq cell (nth 0 ssl))
304 ;; string-width crashes when the argument is nil,
305 ;; so replace the argument
306 ;; (original modification by Kenji Rikitake 9-JAN-1995)
307 (setq w (or (cdr cell) ""))
310 (if (> (+ n (string-width w)) 76)
312 (setq dest (concat dest "\n "))
316 (setq dest (concat dest w))
317 (setq b (+ b (string-width w)))
320 (setq ew (mime/encode-header-word n (cdr cell) (car et) (cdr et)))
321 (setq dest (nth 1 ew))
326 (setq cell (nth i ssl))
329 (cond ((string-match "^[ \t]*$" w)
330 (setq b (+ b (string-width (cdr cell))))
331 (setq dest (concat dest (cdr cell)))
334 (if (> (+ b (string-width w)) 76)
336 (if (eq (elt dest (- (length dest) 1)) 32)
337 (setq dest (substring dest 0 (- (length dest) 1)))
339 (setq dest (concat dest "\n " w))
340 (setq b (+ (length w) 1))
342 (setq l (length dest))
344 (eq (elt dest (- l 2)) ?\?)
345 (eq (elt dest (- l 1)) ?=)
348 (setq dest (concat dest " "))
351 (setq dest (concat dest w))
352 (setq b (+ b (string-width w)))
355 (if (not (eq (elt dest (- (length dest) 1)) 32))
357 (setq dest (concat dest " "))
361 (mime/encode-header-word b (cdr cell) (car et) (cdr et)))
363 (if (string-match "^\n" (nth 1 ew))
364 (setq dest (concat (substring dest 0 (- (length dest) 1))
366 (setq dest (concat dest (nth 1 ew)))
374 (defun mime/encode-address-list (n str)
375 (let* ((ret (message/parse-addresses str))
376 (r ret) cell en-ret j cl (dest "") s)
379 (cond ((string= (nth 1 cell) "<")
380 (setq en-ret (mime/encode-header-string n (nth 0 cell) 'phrase))
381 (setq dest (concat dest (nth 1 en-ret)))
382 (setq n (car en-ret))
385 (mime/encode-header-string
386 n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell) ", ")))
387 (setq en-ret (mime/encode-header-string
388 n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell))))
390 (if (and (eq (elt (nth 1 en-ret) 0) ?\n)
391 (eq (elt dest (- (length dest) 1)) 32))
392 (setq dest (substring dest 0 (- (length dest) 1)))
394 (setq dest (concat dest (nth 1 en-ret)))
395 (setq n (car en-ret))
398 (setq en-ret (mime/encode-header-string n (nth 0 cell)))
399 (setq dest (concat dest (nth 1 en-ret)))
400 (setq n (car en-ret))
402 (setq en-ret (mime/encode-header-string (+ n 2) (nth 2 cell)
404 (if (eq (elt (nth 1 en-ret) 0) ?\n)
406 (setq dest (concat dest "\n ("))
407 (setq en-ret (mime/encode-header-string 2 (nth 2 cell)
411 (setq dest (concat dest " ("))
413 (setq dest (concat dest (nth 1 en-ret)))
414 (setq n (car en-ret))
417 (mime/encode-header-string n (concat (nth 3 cell) ", "))
419 (setq en-ret (mime/encode-header-string n (nth 3 cell)))
421 (setq dest (concat dest (nth 1 en-ret)))
422 (setq n (car en-ret))
427 (mime/encode-header-string n (concat (nth 0 cell) ", "))
429 (setq en-ret (mime/encode-header-string n (nth 0 cell)))
431 (setq dest (concat dest (nth 1 en-ret)))
432 (setq n (car en-ret))
439 ;;; @ utility for encoder
442 ;;; @@ encoded-word length
445 (defun mime/encoded-word-length (string encoding)
446 (cond ((equal encoding "B") (mime/base64-length string))
447 ((equal encoding "Q") (mime/Quoted-Printable-length string))
451 (defun mime/base64-length (string)
452 (let ((l (length string))
455 (if (= (mod l 3) 0) 0 1)
459 (defun mime/Quoted-Printable-length (string &optional mode)
460 (let ((l 0)(i 0)(len (length string)) chr)
462 (setq chr (elt string i))
463 (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
470 ;;; @@ separate by character set
474 (defconst LC-space 2)
476 ;; by mol. 1993/10/16
477 (defun mime/char-type (chr)
478 (if (or (= chr 32)(= chr ?\t))
483 (defun mime/separate-string-by-chartype (string)
484 (let ((len (length string))
489 (setq chr (elt string 0))
490 (setq pcs (mime/char-type chr))
491 (setq i (char-bytes chr))
492 (setq ds (substring string 0 i))
494 (setq chr (elt string i))
495 (setq cs (mime/char-type chr))
496 (setq j (+ i (char-bytes chr)))
497 (setq s (substring string i j))
500 (setq ds (concat ds s))
501 (progn (setq dest (append dest (list (cons pcs ds))))
506 (if (not (string= ds ""))
507 (setq dest (append dest (list (cons pcs ds)))))
511 (defun mime/separate-string-by-charset (str)
512 (let ((rl (mime/separate-string-by-chartype str))
513 (i 1) len (pcell nil) cell ncell dpcell (dest nil) LC)
514 (setq len (length rl))
515 (setq dpcell (list (nth 0 rl)))
516 (setq cell (nth 1 rl))
517 (setq ncell (nth 2 rl))
519 (setq LC (car (car dpcell)))
520 (cond ((and (not (eq LC lc-ascii))
521 (eq (car cell) LC-space)
522 (not (eq (car ncell) lc-ascii)))
523 (setq dpcell (list (cons LC
524 (concat (cdr (car dpcell)) (cdr cell))
527 ((and (not (eq LC lc-ascii))
529 (setq dpcell (list (cons LC
530 (concat (cdr (car dpcell)) (cdr cell))
533 ((and (eq LC lc-ascii)
534 (member (car cell) mime/latin-lc-list))
535 (setq dpcell (list (cons (car cell)
536 (concat (cdr (car dpcell)) (cdr cell))
539 ((and (member LC mime/latin-lc-list)
540 (eq (car cell) lc-ascii))
541 (setq dpcell (list (cons LC
542 (concat (cdr (car dpcell)) (cdr cell))
546 (setq dest (append dest dpcell))
547 (setq dpcell (list cell))
551 (setq ncell (nth (+ i 1) rl))
553 (setq dest (append dest dpcell))
556 (defun mime/separate-string-for-encoder (string)
558 (if (string-match "[ \t]+$" string)
560 (setq lastspace (substring string
563 (setq string (substring string 0 (match-beginning 0)))
565 (let ((rl (mime/separate-string-by-charset string))
566 (i 0) len cell0 cell1 cell2 (dest nil))
567 (setq len (length rl))
568 (setq cell0 (nth 0 rl))
569 (setq cell1 (nth 1 rl))
570 (setq cell2 (nth 2 rl))
572 (cond ((and (not (eq (car cell0) lc-ascii))
573 (eq (car cell1) LC-space)
574 (not (eq (car cell2) lc-ascii))
579 (cdr (assoc (car cell0)
580 mime/lc-charset-and-encoding-alist))
581 (concat (cdr cell0) (cdr cell1))
584 (setq cell0 (nth i rl))
585 (setq cell1 (nth (+ i 1) rl))
586 (setq cell2 (nth (+ i 2) rl))
592 (cdr (assoc (car cell0)
593 mime/lc-charset-and-encoding-alist))
598 (setq cell2 (nth (+ i 2) rl))
603 (list (cons nil lastspace))))
609 ;;; basic functions for MIME header decoder
612 ;;; @ utility for decoder
615 (defun mime/unfolding ()
616 (goto-char (point-min))
618 (while (re-search-forward message/field-name-regexp nil t)
619 (setq beg (match-beginning 0))
620 (setq end (message/field-end))
621 (setq field (buffer-substring beg end))
622 (if (string-match mime/encoded-word-regexp field)
624 (narrow-to-region (goto-char beg) end)
625 (while (re-search-forward "\n[ \t]+" nil t)
628 (goto-char (point-max))
632 (defun mime/prepare-decode-message-header ()
634 (goto-char (point-min))
635 (while (re-search-forward
636 (concat (regexp-quote "?=")
640 (replace-match "?==?")
644 (run-hooks 'mime/tiny-mime-load-hook)
651 ;;; mode: outline-minor
652 ;;; outline-regexp: ";;; @+\\|(......"