;;;
;;; A MIME viewer for GNU Emacs
;;;
;;; by Morioka Tomohiko, 1994/07/13

(provide 'tm-view)


;;; @ version
;;;

(defconst mime/viewer-RCS-ID
  "$Id: tm-view.el,v 3.8 1994/09/02 10:32:31 morioka Exp $")

(defconst mime/viewer-version
  (and (string-match "[0-9][0-9.]*" mime/viewer-RCS-ID)
       (substring mime/viewer-RCS-ID (match-beginning 0)(match-end 0))
       ))


;;; @ require modules
;;;

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


;;; @ constants
;;;

(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*")


;;; @ variables
;;;

(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/default-showing-Content-Type-list
  '("text/plain" "text/x-latex" "message/rfc822"))

(defvar mime/go-to-top-node-method-alist
  '((gnus-article-mode . (lambda ()
			   (gnus-article-show-summary)
			   ))
    (rmail-mode . (lambda ()
		    (mime/exit-view-mode)
		    (rmail-summary)
		    (delete-other-windows)
		    ))
    (mh-show-mode . (lambda ()
		      (pop-to-buffer
		       (let ((name (buffer-name)))
			 (string-match "show-" name)
			 (substring name (match-end 0))
			 ))
		      ))
    (mime/show-message-mode . (lambda ()
				(set-window-configuration
				 mime/show-mode-old-window-configuration)
				(let ((buf (current-buffer)))
				  (pop-to-buffer mime/mother-buffer)
				  (kill-buffer buf)
				  )))
    ))

(defvar mime/tmp-dir "/tmp/")

(defvar mime/hide-content-header nil)

(defvar mime/use-internal-decoder nil)

(defvar mime/body-decoding-mode "play" "MIME body decoding mode")


;;; @ parser
;;;

(defun mime/parse-content ()
  (save-excursion
    (save-restriction
      (mime/decode-message-header)
      (goto-char (point-min))
      (let* ((ctl (mime/Content-Type))
	     (boundary (assoc "boundary" (cdr ctl)))
	     beg end dest)
	(search-forward "\n\n" nil t)
	(cond (boundary
	       (let ((sep (concat "\n--"
				  (setq boundary
					(message/strip-quoted-string
					 (cdr boundary)))
				  "\n"))
		     cb ce ct ret ncb)
		 (setq beg (match-end 0))
		 (search-forward (concat "\n--" boundary "--\n") nil t)
		 (setq end (match-beginning 0))
		 (save-excursion
		   (save-restriction
		     (narrow-to-region beg end)
		     (goto-char (point-min))
		     (search-forward (concat "--" boundary "\n") nil t)
		     (setq cb (match-end 0))
		     (while (search-forward sep nil t)
		       (setq ce (match-beginning 0))
		       (setq ncb (match-end 0))
		       (save-excursion
			 (save-restriction
			   (narrow-to-region cb ce)
			   (setq ret (mime/parse-content))
			   ))
		       (setq dest (append dest (list ret)))
		       (goto-char (nth 1 ret))
		       (search-forward (concat "--" boundary "\n") nil t)
		       (goto-char (setq cb (match-end 0)))
		       )
		     (setq ce (point-max))
		     (save-excursion
		       (save-restriction
			 (narrow-to-region cb ce)
			 (setq ret (mime/parse-content))
			 ))
		     (setq dest (append dest (list ret)))
		     ))
		 (setq beg (point-min))
		 (goto-char beg)
		 (search-forward (concat "\n--" boundary "--\n") nil t)
		 (setq end (match-beginning 0))
		 ))
	      ((string= (car ctl) "message/rfc822")
	       (save-excursion
		 (save-restriction
		   (narrow-to-region (match-end 0) (point-max))
		   (setq dest (list (mime/parse-content)))
		   ))
	       (setq beg (point-min))
	       (setq end (point-max))
	       )
	      (t
	       (setq beg (point-min))
	       (setq end (point-max))
	       ))
	(list beg end dest)
	))))

(defun mime/Content-Type ()
  (save-excursion
    (save-restriction
      (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 default-encoding)
  (save-excursion
    (save-restriction
      (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/get-name (ctype)
  (save-excursion
    (save-restriction
      (replace-as-filename
       (let (ret)
	 (or (and (setq ret (assoc "name" ctype))
		  (message/strip-quoted-string (cdr ret))
		  )
	     (and (setq ret (assoc "x-name" ctype))
		  (message/strip-quoted-string (cdr ret))
		  )
	     (message/get-field-body "Content-Description")
	     ""))
       ))))

(defun mime/parse-message ()
  (interactive)
  (save-excursion
    (save-restriction
      (setq selective-display t)
      (make-variable-buffer-local 'mime/content-list)
      (let ((buffer-read-only nil))
	(setq mime/content-list (mime/parse-content))
	)
      (mime/hide-all)
      (set-buffer-modified-p nil)
      )))


;;; @ content information
;;;

(defun mime/get-point-content-number (p &optional cl)
  (if (null cl)
      (setq cl mime/content-list)
    )
  (let ((b (car cl))
	(e (nth 1 cl))
	(c (nth 2 cl))
	)
    (if (and (<= b p)(<= p e))
	(or (let (co ret (sn 0))
	      (catch 'tag
		(while c
		  (setq co (car c))
		  (setq ret (mime/get-point-content-number p co))
		  (cond ((eq ret t) (throw 'tag (list sn)))
			(ret (throw 'tag (cons sn ret)))
			)
		  (setq c (cdr c))
		  (setq sn (+ sn 1))
		  )))
	    t))))

(defun mime/get-content-region (cn &optional cl)
  (if (null cl)
      (setq cl mime/content-list)
    )
  (if (eq cn t)
      cl
    (let ((sn (car cn)))
      (if (null sn)
	  cl
	(let ((rcl (nth sn (nth 2 cl))))
	  (if rcl
	      (mime/get-content-region (cdr cn) rcl)
	    ))
	))))

(defun mime/make-flat-content-list (&optional cl)
  (if (null cl)
      (setq cl mime/content-list)
    )
  (let ((dest (list cl))
	(rcl (nth 2 cl))
	)
    (while rcl
      (setq dest (append dest (mime/make-flat-content-list (car rcl))))
      (setq rcl (cdr rcl))
      )
    dest))


;;; @ decoder
;;;

(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/start-external-method-region (beg end ctype ctl encoding)
  (goto-char beg)
  (let ((method (cdr (assoc ctype mime/content-decoding-method-alist)))
	(name (mime/get-name ctl))
	)
    (if method
	(progn
	  (search-forward "\n\n" nil t)
	  (let ((file (make-temp-name
		       (expand-file-name "TM" mime/tmp-dir)))
		(b (match-end 0))
		(e end))
	    (goto-char b)
	    (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 encoding
			   (if mime/body-decoding-mode
			       mime/body-decoding-mode
			     "play")
			   (replace-as-filename name)
			   )
	    (if (null (get-buffer-window mime/output-buffer-name))
		(let ((the-buf (current-buffer)))
		  (split-window-vertically (/ (* (window-height) 3) 4))
		  (pop-to-buffer mime/output-buffer-name)
		  (pop-to-buffer the-buf)
		  ))
	    )))))

(defun mime/decode-message/partial-region (beg end ctype default-encoding)
  (goto-char beg)
  (let ((root-dir (expand-file-name
		   (concat "m-prts-" (user-login-name)) mime/tmp-dir))
	(id (cdr (assoc "id" ctype)))
	(number (cdr (assoc "number" ctype)))
	(total (cdr (assoc "total" ctype)))
	(the-buf (current-buffer))
	file)
    (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
	  (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))
		    (progn
		      (switch-to-buffer the-buf)
		      (throw 'tag nil)
		      ))
		(insert-file-contents file)
		(goto-char (point-max))
		(setq i (+ i 1))
		)
	      (write-file (concat root-dir "/FULL"))
	      (delete-other-windows)
	      (pop-to-buffer (current-buffer))
	      (goto-char (point-min))
	      (mime/show-message-mode the-buf)
	      ))
	  )
      (progn
	(delete-other-windows)
	(find-file file)
	(mime/show-message-mode the-buf)
	))
    ))

(defun mime/decode-content-region (beg end)
  (interactive "*r")
  (save-excursion
    (save-restriction
      (outline-flag-region beg end ?\n)
      (let ((e end))
	(if (< end (point-max))
	    (setq e (+ end 1))
	  )
	(narrow-to-region beg e)
	(goto-char beg)
	(let ((ctl (mime/Content-Type)))
	  (if ctl
	      (let ((ctype (downcase (car ctl)))
		    (encoding (mime/Content-Transfer-Encoding "7bit"))
		    )
		(setq ctl (cdr ctl))
		(cond ((string= ctype "message/partial")
		       (mime/decode-message/partial-region beg e
							   ctl encoding)
		       )
		      (t (mime/start-external-method-region beg e
							    ctype ctl encoding)
			 (if (not (member
				   ctype
				   mime/default-showing-Content-Type-list))
			     (mime/hide-region beg end)
			   )
			 ))
		))))
      )))


;;; @ hide
;;;

(defun mime/hide-region (beg end)
  (save-excursion
    (save-restriction
      (goto-char beg)
      (if (not mime/hide-content-header)
	  (progn
	    (search-forward "\n\n" nil t)
	    (setq beg (match-end 0))
	    ))
      (outline-flag-region beg end ?\^M)
      )))

(defun mime/hide-all ()
  (let ((fl (mime/make-flat-content-list))
	p c)
    (while fl
      (setq p (car (car fl)))
      (setq c (mime/get-content-region (mime/get-point-content-number p)))
      (if (null (nth 2 c))
	  (save-excursion
	    (save-restriction
	      (narrow-to-region (car c)(nth 1 c))
	      (goto-char (car c))
	      (let ((ctl (mime/Content-Type)))
		(if (and ctl
			 (not (member
			       (car ctl)
			       mime/default-showing-Content-Type-list)))
		    (mime/hide-region (car c)(nth 1 c))
		  )))))
      (setq fl (cdr fl))
      )))


;;; @ MIME show message mode (major-mode)
;;;
(defun mime/show-message-mode (mother)
  (kill-all-local-variables)
  (make-variable-buffer-local 'mime/show-mode-old-window-configuration)
  (setq mime/show-mode-old-window-configuration
	(current-window-configuration))
  (make-variable-buffer-local 'mime/mother-buffer)
  (setq mime/mother-buffer mother)
  (setq major-mode 'mime/show-message-mode)
  (setq mode-name "MIME-View")
  (mime/view-mode)
  (run-hooks 'mime/show-message-mode-hook)
  )


;;; @ MIME view message mode (minor-mode)
;;;

(defun mime/view-mode ()
  (interactive)
  (make-local-variable 'mime/view-mode-old-local-map)
  (let ((keymap (current-local-map)))
    (if (null keymap)
	(setq keymap (make-sparse-keymap))
      (progn
	(setq mime/view-mode-old-local-map keymap)
	(setq keymap (copy-keymap keymap))
	))
    (let ((buf (get-buffer mime/output-buffer-name)))
      (if buf
	  (let ((the-buf (current-buffer)))
	    (switch-to-buffer buf)
	    (erase-buffer)
	    (switch-to-buffer the-buf)
	    )))
    (use-local-map keymap)
    (define-key keymap "u" 'mime/up-content)
    (define-key keymap "p" 'mime/previous-content)
    (define-key keymap "n" 'mime/next-content)
    (define-key keymap " " 'mime/scroll-up-content)
    (define-key keymap "\M- " 'mime/scroll-down-content)
    (define-key keymap "v" 'mime/play-content)
    (define-key keymap "e" 'mime/extract-content)
    (define-key keymap "\C-c\C-p" 'mime/print-content)
    (define-key keymap "\C-c\C-x" 'mime/exit-view-mode)
    )
  (mime/parse-message)
  (search-forward "\n\n" nil t)
  )

(defun mime/decode-content ()
  (interactive)
  (let ((cr (mime/get-content-region
	     (mime/get-point-content-number (point))))
	)
    (and cr
	 (null (nth 2 cr))
	 (mime/decode-content-region (car cr)(nth 1 cr))
	 )))

(defun mime/play-content ()
  (interactive)
  (let ((mime/body-decoding-mode "play"))
    (mime/decode-content)
    ))

(defun mime/extract-content ()
  (interactive)
  (let ((mime/body-decoding-mode "extract"))
    (mime/decode-content)
    ))

(defun mime/print-content ()
  (interactive)
  (let ((mime/body-decoding-mode "print"))
    (mime/decode-content)
    ))

(defun mime/up-content ()
  (interactive)
  (let ((cn (mime/get-point-content-number (point)))
	r)
    (if (eq cn t)
	(and (setq r (assoc major-mode mime/go-to-top-node-method-alist))
	     (funcall (cdr r))
	     )
      (if (setq r (mime/get-content-region (butlast cn)))
	  (goto-char (car r))
	)
      )))

(defun mime/previous-content ()
  (interactive)
  (let* ((fcl (mime/make-flat-content-list))
	 (p (point))
	 (i (- (length fcl) 1))
	 )
    (catch 'tag
      (while (>= i 0)
	(if (> p (car (nth i fcl)))
	    (throw 'tag (goto-char (car (nth i fcl))))
	  )
	(setq i (- i 1))
	))
    ))

(defun mime/next-content ()
  (interactive)
  (let ((fcl (mime/make-flat-content-list))
	(p (point))
	)
    (catch 'tag
      (while fcl
	(if (< p (car (car fcl)))
	    (throw 'tag (goto-char (car (car fcl))))
	  )
	(setq fcl (cdr fcl))
	))
    ))

(defun mime/scroll-up-content ()
  (interactive)
  (let ((fcl (mime/make-flat-content-list))
	(p (point))
	(h (- (window-height) 1))
	np)
    (setq np (or (catch 'tag
		   (while fcl
		     (if (< p (car (car fcl)))
			 (throw 'tag (car (car fcl)))
		       )
		     (setq fcl (cdr fcl))
		     ))
		 (point-max)))
    (forward-line h)
    (if (> (point) np)
	(goto-char np)
      )))

(defun mime/scroll-down-content ()
  (interactive)
  (let ((fcl (mime/make-flat-content-list))
	(p (point))
	(h (- (window-height) 1))
	pp)
    (setq pp (or (let ((i (- (length fcl) 1)))
		   (catch 'tag
		     (while (> i 0)
		       (if (> p (nth 1 (nth i fcl)))
			   (throw 'tag (nth 1 (nth i fcl)))
			 )
		       (setq i (- i 1))
		       )))
		 (point-min)))
    (forward-line (- h))
    (if (< (point) pp)
	(goto-char pp)
      )))

(defun mime/exit-view-mode ()
  (interactive)
  (if (and (boundp 'mime/view-mode-old-local-map)
	   (keymapp mime/view-mode-old-local-map))
      (use-local-map mime/view-mode-old-local-map)
    )
  (show-all)
  )