;;;
;;; A multilingual MIME message header encoder/decoder.
;;;	by Morioka Tomohiko (morioka@jaist.ac.jp)
;;;
;;; original MIME decoder is
;;;	mime.el,v 1.5 1992/07/18 07:52:08 by Enami Tsugutomo
;;;


;;; @ require modules
;;;

(require 'emu)
(require 'mel)
(require 'tl-header)
(require 'tl-str)
(require 'tm-def)


;;; @ version
;;;

(defconst mime/RCS-ID
  "$Id: tiny-mime.el,v 6.7 1995/09/20 12:17:28 morioka Exp $")

(defconst mime/tiny-mime-version (get-version-string mime/RCS-ID))


;;; @ MIME encoded-word definition
;;;

(defconst mime/encoded-text-regexp "[!->@-~]+")
(defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
					   "\\("
					   mime/charset-regexp
					   "\\)"
					   (regexp-quote "?")
					   "\\(B\\|Q\\)"
					   (regexp-quote "?")
					   "\\("
					   mime/encoded-text-regexp
					   "\\)"
					   (regexp-quote "?=")))

(defun mime/nth-string (s n)
  (if (stringp s)
      (substring s (match-beginning n) (match-end n))
    (buffer-substring (match-beginning n) (match-end n))))

(defun mime/encoded-word-charset (str)
  (mime/nth-string str 1))

(defun mime/encoded-word-encoding (str)
  (mime/nth-string str 2))

(defun mime/encoded-word-encoded-text (str)
  (mime/nth-string str 3))

(defun mime/rest-of-string (str)
  (if (stringp str)
      (substring str (match-end 0))
    (buffer-substring (match-end 0)(point-max))
    ))


;;; @ variables
;;;

(defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))

(defvar mime/use-X-Nsubject nil)


;;; @ Application Interface
;;;

;;; @@ MIME header decoders
;;;

(defun mime/decode-encoded-text (charset encoding str)
  (let ((dest
	 (cond ((string= "B" encoding)
		(base64-decode-string str))
	       ((string= "Q" encoding)
		(q-encoding-decode-string str))
	       (t (message "unknown encoding %s" encoding)
		  nil))))
    (if dest
	(mime/convert-string-to-emacs charset dest)
      )))

(defun mime/decode-encoded-word (word)
  (or (if (string-match mime/encoded-word-regexp word)
	  (let ((charset (upcase (mime/encoded-word-charset word)))
		(encoding (upcase (mime/encoded-word-encoding word)))
		(text (mime/encoded-word-encoded-text word)))
	    (mime/decode-encoded-text charset encoding text)
	    ))
      word))

(defun mime/decode-region (beg end)
  (interactive "*r")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (let (charset encoding text)
	(while (re-search-forward mime/encoded-word-regexp nil t)
	  (insert (mime/decode-encoded-word 
		   (prog1
		       (buffer-substring (match-beginning 0) (match-end 0))
		     (delete-region (match-beginning 0) (match-end 0))
		     )
		  ))
	  ))
      )))

(defun mime/decode-message-header ()
  (interactive "*")
  (save-excursion
    (save-restriction
      (narrow-to-region (goto-char (point-min))
			(progn (re-search-forward "^$" nil t) (point)))
      (mime/prepare-decode-message-header)
      (mime/decode-region (point-min) (point-max))
      )))

(defun mime/decode-string (str)
  (let ((dest "")(ew nil)
	beg end)
    (while (setq beg (string-match mime/encoded-word-regexp str))
      (if (> beg 0)
	  (if (not (and (eq ew t) (string= (substring str 0 beg) " ")))
	      (setq dest (concat dest (substring str 0 beg)
				 ))
	    )
	)
      (setq end (match-end 0))
      (setq dest (concat dest
			 (mime/decode-encoded-word (substring str beg end))
			 ))
      (setq str (substring str end))
      (setq ew t)
      )
    (concat dest str)
    ))

;;; @@ MIME header encoders
;;;

(defun mime/encode-string (string encoding &optional mode)
  (cond ((string= encoding "B") (base64-encode-string string))
	((string= encoding "Q") (q-encoding-encode-string string mode))
	))

(defun mime/encode-field (str)
  (setq str (message/unfolding-string str))
  (let ((ret (message/divide-field str))
	field-name field-body)
    (setq field-name (car ret))
    (setq field-body (nth 1 ret))
    (concat field-name " "
	    (cond ((string= field-body "") "")
		  ((or (string-match "^Reply-To:$" field-name)
		       (string-match "^From:$" field-name)
		       (string-match "^Sender:$" field-name)
		       (string-match "^Resent-Reply-To:$" field-name)
		       (string-match "^Resent-From:$" field-name)
		       (string-match "^Resent-Sender:$" field-name)
		       (string-match "^To:$" field-name)
		       (string-match "^Resent-To:$" field-name)
		       (string-match "^cc:$" field-name)
		       (string-match "^Resent-cc:$" field-name)
		       (string-match "^bcc:$" field-name)
		       (string-match "^Resent-bcc:$" field-name)
		       )
		   (mime/encode-address-list
		    (+ (length field-name) 1) field-body)
		   )
		  (t
		   (catch 'tag
		     (let ((r mime/no-encoding-header-fields) fn)
		       (while r
			 (setq fn (car r))
			 (if (string-match (concat "^" fn ":$") field-name)
			     (throw 'tag field-body)
			   )
			 (setq r (cdr r))
			 ))
		     (nth 1 (mime/encode-header-string
			     (+ (length field-name) 1) field-body))
		     ))
		  ))
    ))

(defun mime/exist-encoded-word-in-subject ()
  (let ((str (message/get-field-body "Subject")))
    (if (and str (string-match mime/encoded-word-regexp str))
	str)))

(defun mime/encode-message-header ()
  (interactive "*")
  (save-excursion
    (save-restriction
      (narrow-to-region (goto-char (point-min))
			(progn
			  (re-search-forward
			   (concat
			    "^" (regexp-quote mail-header-separator) "$")
			   nil t)
			  (match-beginning 0)
			  ))
      (goto-char (point-min))
      (let (beg end field)
	(while (re-search-forward "^.+:.*\\(\n\\s +.*\\)*" nil t)
	  (setq beg (match-beginning 0))
	  (setq end  (match-end 0))
	  (setq field (buffer-substring beg end))
	  (insert (mime/encode-field
		   (prog1
		       (buffer-substring beg end)
		     (delete-region beg end)
		     )))
	  ))
      (if mime/use-X-Nsubject
	  (let ((str (mime/exist-encoded-word-in-subject)))
	    (if str
		(insert (concat
			 "\nX-Nsubject: "
			 (mime/decode-string (message/unfolding-string str))
			 )))))
      )))


;;; @ functions for message header encoding
;;;

(defun mime/encode-and-split-string (n string charset encoding)
  (let ((i 0) (j 0)
	(len (length string))
	(js (mime/convert-string-from-emacs string charset))
	(cesl (+ (length charset) (length encoding) 6 ))
	ewl m rest)
    (setq ewl (mime/encoded-word-length js encoding))
    (if (null ewl) nil
      (progn
	(setq m (+ n ewl cesl))
	(if (> m 76)
	    (progn
	      (while (and (< i len)
			  (setq js (mime/convert-string-from-emacs
				    (substring string 0 i) charset))
			  (setq m (+ n
				     (mime/encoded-word-length js encoding)
				     cesl))
			  (< m 76))
		(setq j i)
		(setq i (+ i (char-bytes (elt string i))))
		)
	      (setq js (mime/convert-string-from-emacs
			(substring string 0 j) charset))
	      (setq m (+ n (mime/encoded-word-length js encoding) cesl))
	      (setq rest (substring string j))
	      )
	  (setq rest nil))
	(if (string= js "")
	    (list 1 "" string)
	  (list m (concat "=?" charset "?" encoding "?"
			  (mime/encode-string js encoding)
			  "?=") rest))
	))
    ))

(defun mime/encode-header-word (n string charset encoding)
  (let (dest str ret m)
    (if (null (setq ret
		    (mime/encode-and-split-string n string charset encoding)))
	nil
      (progn
	(setq dest (nth 1 ret))
	(setq m (car ret))
	(setq str (nth 2 ret))
	(while (and (stringp str)
		    (setq ret
			  (mime/encode-and-split-string
			   1 str charset encoding))
		    )
	  (setq dest (concat dest "\n " (nth 1 ret)))
	  (setq m (car ret))
	  (setq str (nth 2 ret))
	  )
	(list m dest)
	))
    ))

(defun mime/encode-header-string (n string &optional mode)
  (if (string= string "")
      (list n "")
    (let ((ssl (mime/separate-string-for-encoder string))
	  i len cell et w ew (dest "") b l)
      (setq len (length ssl))
      (setq cell (nth 0 ssl))
      (setq et (car cell))
      ;; string-width crashes when the argument is nil,
      ;; so replace the argument
      ;; (original modification by Kenji Rikitake 9-JAN-1995)
      (setq w (or (cdr cell) ""))
      (if (eq et nil)
	  (progn
	    (if (> (+ n (string-width w)) 76)
		(progn
		  (setq dest (concat dest "\n "))
		  (setq b 1)
		  )
	      (setq b n))
	    (setq dest (concat dest w))
	    (setq b (+ b (string-width w)))
	    )
	(progn
	  (setq ew (mime/encode-header-word n (cdr cell) (car et) (cdr et)))
	  (setq dest (nth 1 ew))
	  (setq b (car ew))
	  ))
      (setq i 1)
      (while (< i len)
	(setq cell (nth i ssl))
	(setq et (car cell))
	(setq w (cdr cell))
	(cond ((string-match "^[ \t]*$" w)
	       (setq b (+ b (string-width (cdr cell))))
	       (setq dest (concat dest (cdr cell)))
	       )
	      ((eq et nil)
	       (if (> (+ b (string-width w)) 76)
		   (progn
		     (if (eq (elt dest (- (length dest) 1)) 32)
			 (setq dest (substring dest 0 (- (length dest) 1)))
		       )
		     (setq dest (concat dest "\n " w))
		     (setq b (+ (length w) 1))
		     )
		 (setq l (length dest))
		 (if (and (>= l 2)
			  (eq (elt dest (- l 2)) ?\?)
			  (eq (elt dest (- l 1)) ?=)
			  )
		     (progn
		       (setq dest (concat dest " "))
		       (setq b (+ b 1))
		       ))
		 (setq dest (concat dest w))
		 (setq b (+ b (string-width w)))
		 ))
	      (t
	       (if (not (eq (elt dest (- (length dest) 1)) 32))
		   (progn
		     (setq dest (concat dest " "))
		     (setq b (+ b 1))
		     ))
	       (setq ew
		     (mime/encode-header-word b (cdr cell) (car et) (cdr et)))
	       (setq b (car ew)) 
	       (if (string-match "^\n" (nth 1 ew))
		   (setq dest (concat (substring dest 0 (- (length dest) 1))
				      (nth 1 ew)))
		 (setq dest (concat dest (nth 1 ew)))
		 )
	       ))
	(setq i (+ i 1))
	)
      (list b dest)
      )))

(defun mime/encode-address-list (n str)
  (let* ((ret (message/parse-addresses str))
	 (r ret) cell en-ret j cl (dest "") s)
    (while r
      (setq cell (car r))
      (cond ((string= (nth 1 cell) "<")
	     (setq en-ret (mime/encode-header-string n (nth 0 cell) 'phrase))
	     (setq dest (concat dest (nth 1 en-ret)))
	     (setq n (car en-ret))
	     (if (> (length r) 1)
		 (setq en-ret
		       (mime/encode-header-string
			n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell) ", "))) 
	       (setq en-ret (mime/encode-header-string
			     n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell))))
	       )
	     (if (and (eq (elt (nth 1 en-ret) 0) ?\n)
		      (eq (elt dest (- (length dest) 1)) 32))
		 (setq dest (substring dest 0 (- (length dest) 1)))
	       )
	     (setq dest (concat dest (nth 1 en-ret)))
	     (setq n (car en-ret))
	     )
	    ((= (length cell) 4)
	     (setq en-ret (mime/encode-header-string n (nth 0 cell)))
	     (setq dest (concat dest (nth 1 en-ret)))
	     (setq n (car en-ret))
	     
	     (setq en-ret (mime/encode-header-string (+ n 2) (nth 2 cell)
						     'comment))
	     (if (eq (elt (nth 1 en-ret) 0) ?\n)
		 (progn
		   (setq dest (concat dest "\n ("))
		   (setq en-ret (mime/encode-header-string 2 (nth 2 cell)
							   'comment))
		   )
	       (progn
		 (setq dest (concat dest " ("))
		 ))
	     (setq dest (concat dest (nth 1 en-ret)))
	     (setq n (car en-ret))
	     (if (> (length r) 1)
		 (setq en-ret
		       (mime/encode-header-string n (concat (nth 3 cell) ", "))
		       )
	       (setq en-ret (mime/encode-header-string n (nth 3 cell)))
	       )
	     (setq dest (concat dest (nth 1 en-ret)))
	     (setq n (car en-ret))
	     )
	    (t
	     (if (> (length r) 1)
		 (setq en-ret
		       (mime/encode-header-string n (concat (nth 0 cell) ", "))
		       )
	       (setq en-ret (mime/encode-header-string n (nth 0 cell)))
	       )
	     (setq dest (concat dest (nth 1 en-ret)))
	     (setq n (car en-ret))
	     ))
      (setq r (cdr r))
      )
    dest))


;;; @ utility for encoder
;;;

;;; @@ encoded-word length
;;;

(defun mime/encoded-word-length (string encoding)
  (cond ((equal encoding "B") (mime/base64-length string))
	((equal encoding "Q") (mime/Quoted-Printable-length string))
	(t nil)
	))

(defun mime/base64-length (string)
  (let ((l (length string))
	)
    (* (+ (/ l 3)
	  (if (= (mod l 3) 0) 0 1)
	  ) 4)
    ))

(defun mime/Quoted-Printable-length (string &optional mode)
  (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))

;;; @@ separate by character set
;;;

;; by mol. 1993/11/2
(defconst LC-space 2)

;; by mol. 1993/10/16
(defun mime/char-type (chr)
  (if (or (= chr 32)(= chr ?\t))
      LC-space
    (get-lc chr)
    ))

(defun mime/separate-string-by-chartype (string)
  (let ((len (length string))
	(dest nil) (ds "") s
	pcs i j cs chr)
    (if (= len 0) nil
      (progn
	(setq chr (elt string 0))
	(setq pcs (mime/char-type chr))
	(setq i (char-bytes chr))
	(setq ds (substring string 0 i))
	(while (< i len)
	  (setq chr (elt string i))
	  (setq cs (mime/char-type chr))
	  (setq j (+ i (char-bytes chr)))
	  (setq s (substring string i j))
	  (setq i j)
	  (if (= cs pcs)
	      (setq ds (concat ds s))
	    (progn (setq dest (append dest (list (cons pcs ds))))
		   (setq pcs cs)
		   (setq ds s)
		   ))
	  )
	(if (not (string= ds ""))
	    (setq dest (append dest (list (cons pcs ds)))))
	dest)
      )))

(defun mime/separate-string-by-charset (str)
  (let ((rl (mime/separate-string-by-chartype str))
	(i 1) len (pcell nil) cell ncell dpcell (dest nil) LC)
    (setq len (length rl))
    (setq dpcell (list (nth 0 rl)))
    (setq cell (nth 1 rl))
    (setq ncell (nth 2 rl))
    (while (< i len)
      (setq LC (car (car dpcell)))
      (cond ((and (not (eq LC lc-ascii))
		  (eq (car cell) LC-space)
		  (not (eq (car ncell) lc-ascii)))
	     (setq dpcell (list (cons LC
				      (concat (cdr (car dpcell)) (cdr cell))
				      )))
	     )
	    ((and (not (eq LC lc-ascii))
		  (eq LC (car cell)))
	     (setq dpcell (list (cons LC
				      (concat (cdr (car dpcell)) (cdr cell))
				      )))
	     )
	    ((and (eq LC lc-ascii)
		  (member (car cell) mime/latin-lc-list))
	     (setq dpcell (list (cons (car cell)
				      (concat (cdr (car dpcell)) (cdr cell))
				      )))
	     )
	    ((and (member LC mime/latin-lc-list)
		  (eq (car cell) lc-ascii))
	     (setq dpcell (list (cons LC
				      (concat (cdr (car dpcell)) (cdr cell))
				      )))
	     )
	    (t
	     (setq dest (append dest dpcell))
	     (setq dpcell (list cell))
	     ))
      (setq i (+ i 1))
      (setq cell ncell)
      (setq ncell (nth (+ i 1) rl))
      )
    (setq dest (append dest dpcell))
    ))

(defun mime/separate-string-for-encoder (string)
  (let (lastspace)
    (if (string-match "[ \t]+$" string)
	(progn
	  (setq lastspace (substring string
				     (match-beginning 0)
				     (match-end 0)))
	  (setq string (substring string 0 (match-beginning 0)))
	  ))
    (let ((rl (mime/separate-string-by-charset string))
	  (i 0) len cell0 cell1 cell2 (dest nil))
      (setq len (length rl))
      (setq cell0 (nth 0 rl))
      (setq cell1 (nth 1 rl))
      (setq cell2 (nth 2 rl))
      (while (< i len)
	(cond ((and (not (eq (car cell0) lc-ascii))
		    (eq (car cell1) LC-space)
		    (not (eq (car cell2) lc-ascii))
		    )
	       (setq dest
		     (append dest (list
				   (cons
				    (cdr (assoc (car cell0)
						mime/lc-charset-and-encoding-alist))
				    (concat (cdr cell0) (cdr cell1))
				    ))))
	       (setq i (+ i 2))
	       (setq cell0 (nth i rl))
	       (setq cell1 (nth (+ i 1) rl))
	       (setq cell2 (nth (+ i 2) rl))
	       )
	      (t
	       (setq dest
		     (append dest (list
				   (cons
				    (cdr (assoc (car cell0)
						mime/lc-charset-and-encoding-alist))
				    (cdr cell0)))))
	       (setq i (+ i 1))
	       (setq cell0 cell1)
	       (setq cell1 cell2)
	       (setq cell2 (nth (+ i 2) rl))
	       ))
	)
      (append dest
	      (if lastspace
		  (list (cons nil lastspace))))
      )))
	      
	      

;;;
;;; basic functions for MIME header decoder
;;;

;;; @ utility for decoder
;;;

(defun mime/unfolding ()
  (goto-char (point-min))
  (let (field beg end)
    (while (re-search-forward message/field-name-regexp nil t)
      (setq beg (match-beginning 0))
      (setq end (message/field-end))
      (setq field (buffer-substring beg end))
      (if (string-match mime/encoded-word-regexp field)
	  (save-restriction
	    (narrow-to-region (goto-char beg) end)
	    (while (re-search-forward "\n[ \t]+" nil t)
	      (replace-match " ")
	      )
	    (goto-char (point-max))
	    ))
      )))

(defun mime/prepare-decode-message-header ()
  (mime/unfolding)
  (goto-char (point-min))
  (while (re-search-forward
	  (concat (regexp-quote "?=")
		  "\\s +"
		  (regexp-quote "=?"))
	  nil t)
    (replace-match "?==?")
    )
  )

(run-hooks 'mime/tiny-mime-load-hook)

(provide 'tiny-mime)

;;; @
;;; Local Variables:
;;; mode: emacs-lisp
;;; mode: outline-minor
;;; outline-regexp: ";;; @+\\|(......"
;;; End: