;;;
;;; $Id: tm-body.el,v 0.16 1994/08/20 12:38:07 morioka Exp $
;;;

(provide 'tm-body)

(require 'tl-list)
(require 'tl-header)
(require 'tiny-mime)

(defun replace-as-filename (str)
  (let ((dest "")
	(i 0)(len (length str))
	chr)
    (while (< i len)
      (setq chr (elt str i))
      (if (or (and (<= ?+ chr)(<= chr ?.))
	      (and (<= ?0 chr)(<= chr ?:))
	      (= chr ?=)
	      (and (<= ?@ chr)(<= chr ?\[))
	      (and (<= ?\] chr)(<= chr ?_))
	      (and (<= ?a chr)(<= chr ?{))
	      (and (<= ?} chr)(<= chr ?~))
	      )
	  (setq dest (concat dest
			     (char-to-string chr)))
	)
      (setq i (+ i 1))
      )
    dest))

(defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=")
(defconst mime/token-regexp
  (concat "[^" mime/tspecials "]*"))
(defconst mime/content-type-subtype-regexp
  (concat mime/token-regexp "/" mime/token-regexp))
(defconst mime/content-parameter-value-regexp
  (concat "\\("
	  message/quoted-string-regexp
	  "\\|[^; \t\n]\\)*"))

(defconst mime/output-buffer-name "*MIME-out*")
(defconst mime/decoding-buffer-name "*MIME-decoding*")

(defvar mime/content-decoding-method-alist
  '(("text/plain"   . "tm-plain")
    ("text/x-latex" . "tm-latex")
    ("audio/basic"  . "tm-au")
    ("image/gif"    . "tm-image")
    ("image/jpeg"   . "tm-image")
    ("image/tiff"   . "tm-image")
    ("image/x-tiff" . "tm-image")
    ("image/x-xbm"  . "tm-image")
    ("image/x-pic"  . "tm-image")
    ("video/mpeg"   . "tm-mpeg")
    ("application/octet-stream" . "tm-file")
    ))

(defvar mime/use-internal-decoder nil)
;;; (setq mime/use-internal-decoder t)

(defun mime/decode-body ()
  (interactive)
  (if (get-buffer mime/output-buffer-name)
      (kill-buffer mime/output-buffer-name))
  (save-excursion
    (save-restriction
      (goto-char (point-min))
      (let ((ctype (mime/Content-Type "^$"))
	    (encoding (mime/Content-Transfer-Encoding "^$" "7bit"))
	    )
	(if ctype 
	    (cond ((equal (car ctype) "multipart/mixed")
		   (mime/decode-multipart/mixed ctype encoding)
		   )
		  ((equal (car ctype) "message/partial")
		   (mime/decode-message/partial ctype encoding)
		   )
		  (t
		   (mime/decode-content nil (car ctype) encoding
					(mime/get-name ctype))
		   ))
	  )))))

(defun mime/decode-multipart/mixed (ctype default-encoding)
  (let ((boundary (cdr (assoc "boundary" (cdr ctype))))
	encoding b)
    (if (eq (elt boundary 0) ?\")
	(setq boundary
	      (substring boundary 1 (- (length boundary) 1))
	      ))
    (setq boundary (concat "^--" (regexp-quote boundary) "\\(--\\)?$"))
    (while (re-search-forward boundary nil t)
      (goto-char (point-min))
      (setq b (+ (match-end 0) 1))
      (goto-char b)
      (and (setq ctype (mime/Content-Type))
	   (setq encoding
		 (mime/Content-Transfer-Encoding boundary
						 default-encoding))
	   (mime/decode-content boundary
				(car ctype) encoding
				(mime/get-name ctype boundary)
				)
	   )
      )))

(defun mime/decode-message/partial (ctype default-encoding)
  (let ((root-dir (concat "/tmp/m-prts-" (user-login-name)))
	(id (cdr (assoc "id" (cdr ctype))))
	(number (cdr (assoc "number" (cdr ctype))))
	(total (cdr (assoc "total" (cdr ctype))))
	file
	(the-buf (current-buffer))
	)
    (if (not (file-exists-p root-dir))
	(shell-command (concat "mkdir " root-dir))
      )
    (setq id (replace-as-filename id))
    (setq root-dir (concat root-dir "/" id))
    (if (not (file-exists-p root-dir))
	(shell-command (concat "mkdir " root-dir))
      )
    (setq file (concat root-dir "/FULL"))
    (if (not (file-exists-p file))
	(progn
	  (setq file (concat root-dir "/CT"))
	  (if (not (file-exists-p file))
	      (progn
		(if (get-buffer "*MIME-temp*")
		    (kill-buffer "*MIME-temp*")
		  )
		(switch-to-buffer "*MIME-temp*")
		(insert (concat total "\n"))
		(write-file file)
		(switch-to-buffer the-buf)
		))
	  (re-search-forward "^$")
	  (goto-char (+ (match-end 0) 1))
	  (setq file (concat root-dir "/" number))
	  (write-region (point)
			(point-max)
			file)
	  (if (get-buffer "*MIME-temp*")
	      (kill-buffer "*MIME-temp*")
	    )
	  (switch-to-buffer "*MIME-temp*")
	  (let ((i 1)
		(max (string-to-int total))
		)
	    (catch 'tag
	      (while (<= i max)
		(setq file (concat root-dir "/"
				   (int-to-string i)
				   ))
		(if (not (file-exists-p file))
		    (throw 'tag nil)) 
		(insert-file-contents file)
		(goto-char (point-max))
		(setq i (+ i 1))
		)
	      (write-file (concat root-dir "/FULL"))
	      (mime/decode-body)
	      (kill-buffer "FULL")
	      ))
	  (switch-to-buffer the-buf)
	  )
      (progn
	(find-file file)
	(mime/decode-body)
	(kill-buffer "FULL")
	))
    ))

(defun mime/narrow-to-content (boundary)
  (if boundary
      (progn
	(narrow-to-region (point)
			  (progn
			    (re-search-forward boundary nil t)
			    (match-beginning 0)
			    ))
	(goto-char (point-min))
	)))

(defun mime/get-name (ctype &optional boundary)
  (save-excursion
    (save-restriction
      (mime/narrow-to-content boundary)
      (replace-as-filename
       (or (cdr (assoc "name" (cdr ctype)))
	   (cdr (assoc "x-name" (cdr ctype)))
	   (message/get-field-body "Content-Description")
	   ""))
      )))

(defun mime/Content-Type (&optional boundary)
  (save-excursion
    (save-restriction
      (mime/narrow-to-content boundary)
      (if (and (re-search-forward "^Content-Type:[ \t]*" nil t)
		 (progn
		   (narrow-to-region
		    (point)
		    (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t)
			 (match-end 0))
		    )
		   (goto-char (point-min))
		   (re-search-forward mime/content-type-subtype-regexp nil t)
		   ))
	    (let ((ctype
		   (downcase
		    (buffer-substring (match-beginning 0) (match-end 0))
		    ))
		  dest attribute value)
	      (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t)
			  (re-search-forward mime/token-regexp nil t)
			  )
		(setq attribute
		      (downcase
		       (buffer-substring (match-beginning 0) (match-end 0))
		       ))
		(if (and (re-search-forward "=[ \t\n]*" nil t)
			 (re-search-forward mime/content-parameter-value-regexp
					    nil t)
			 )
		    (setq dest
			  (put-alist attribute
				     (buffer-substring (match-beginning 0)
						       (match-end 0))
				     dest))
		  )
		)
	      (cons ctype dest)
	      )))))

(defun mime/Content-Transfer-Encoding (&optional boundary default-encoding)
  (save-excursion
    (save-restriction
      (mime/narrow-to-content boundary)
      (or
       (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t)
		(re-search-forward mime/token-regexp nil t)
		)
	   (downcase (buffer-substring (match-beginning 0) (match-end 0)))
	 )
       default-encoding)
      )))

(defun mime/base64-decode-region (beg end &optional buf filename)
  (let ((the-buf (current-buffer)) ret)
    (if (null buf)
	(setq buf (get-buffer-create mime/decoding-buffer-name))
      )
    (save-excursion
      (save-restriction
	(switch-to-buffer buf)
	(erase-buffer)
	(switch-to-buffer the-buf)
	(narrow-to-region beg end)
	(goto-char (point-min))
	(while (re-search-forward
		(concat "^"
			mime/Base64-encoded-text-regexp
			"$") nil t)
	  (setq ret (mime/base64-decode-string
		     (buffer-substring (match-beginning 0)
				       (match-end 0)
				       )))
	  (switch-to-buffer buf)
	  (insert ret)
	  (switch-to-buffer the-buf)
	  )))
    (if filename
	(progn
	  (switch-to-buffer buf)
	  (let ((kanji-flag nil)
		(mc-flag nil)
		(file-coding-system
		 (if (featurep 'mule) *noconv*))
		)
	    (write-file filename)
	    (kill-buffer buf)
	    (switch-to-buffer the-buf)
	    )))
    ))

(defun mime/decode-content (boundary ctype encoding name)
  (let ((method (cdr (assoc ctype mime/content-decoding-method-alist))))
    (if method
	(save-excursion
	  (save-restriction
	    (re-search-forward "^$")
	    (goto-char (+ (match-end 0) 1))
	    (let ((file (make-temp-name "/tmp/TM"))
		  (b (point)) e
		  )
	      (setq e (if boundary
			  (and (re-search-forward boundary nil t)
			       (match-beginning 0))
			(point-max)
			))
	      (if (and (string= encoding "base64")
		       mime/use-internal-decoder)
		  (progn
		    (mime/base64-decode-region b e nil file)
		    (setq encoding "binary")
		    )
		(write-region b e file)
		)
	      (start-process method mime/output-buffer-name method file
			     ctype (if encoding
				       encoding
				     "7bit")
			     (if mime/body-decoding-mode
				 mime/body-decoding-mode
			       "decode")
			     (replace-as-filename name))
	      ))))))

(defun mime/show-body-decoded-result ()
  (interactive)
  (if (get-buffer mime/output-buffer-name)
      (set-window-buffer (get-largest-window)
			 mime/output-buffer-name)
    ))