~ubuntu-branches/ubuntu/edgy/semi/edgy

;;; mime-view.el --- interactive MIME viewer for GNU Emacs

;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.

;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Created: 1994/07/13
;;	Renamed: 1994/08/31 from tm-body.el
;;	Renamed: 1997/02/19 from tm-view.el
;; Keywords: MIME, multimedia, mail, news

;; This file is part of SEMI (Sample of Elastic MIME Interfaces).

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(require 'mime)
(require 'semi-def)
(require 'calist)
(require 'alist)
(require 'mime-conf)

(eval-when-compile (require 'static))


;;; @ version
;;;

(defconst mime-view-version
  (concat (mime-product-name mime-user-interface-product) " MIME-View "
	  (mapconcat #'number-to-string
		     (mime-product-version mime-user-interface-product) ".")
	  " (" (mime-product-code-name mime-user-interface-product) ")"))


;;; @ variables
;;;

(defgroup mime-view nil
  "MIME view mode"
  :group 'mime)

(defcustom mime-situation-examples-file "~/.mime-example"
  "*File name of situation-examples demonstrated by user."
  :group 'mime-view
  :type 'file)

(defcustom mime-preview-move-scroll nil
  "*Decides whether to scroll when moving to next entity.
When t, scroll the buffer. Non-nil but not t means scroll when
the next entity is within next-screen-context-lines from top or
buttom. Nil means don't scroll at all."
  :group 'mime-view
  :type '(choice (const :tag "Off" nil)
		 (const :tag "On" t)
		 (sexp :tag "Situation" 1)))

(defcustom mime-view-mailcap-files
  (let ((files '("/etc/mailcap" "/usr/etc/mailcap" "~/.mailcap")))
    (or (member mime-mailcap-file files)
	(setq files (cons mime-mailcap-file files)))
    files)
  "List of mailcap files."
  :group 'mime-view
  :type '(repeat file))


;;; @ in raw-buffer (representation space)
;;;

(defvar mime-preview-buffer nil
  "MIME-preview buffer corresponding with the (raw) buffer.")
(make-variable-buffer-local 'mime-preview-buffer)


(defvar mime-raw-representation-type-alist
  '((mime-show-message-mode     . binary)
    (mime-temp-message-mode     . binary)
    (t                          . cooked)
    )
  "Alist of major-mode vs. representation-type of mime-raw-buffer.
Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
major-mode or t.  t means default.  REPRESENTATION-TYPE must be
`binary' or `cooked'.")


;;; @ in preview-buffer (presentation space)
;;;

(defvar mime-mother-buffer nil
  "Mother buffer corresponding with the (MIME-preview) buffer.
If current MIME-preview buffer is generated by other buffer, such as
message/partial, it is called `mother-buffer'.")
(make-variable-buffer-local 'mime-mother-buffer)

;; (defvar mime-raw-buffer nil
;;   "Raw buffer corresponding with the (MIME-preview) buffer.")
;; (make-variable-buffer-local 'mime-raw-buffer)

(defvar mime-preview-original-window-configuration nil
  "Window-configuration before mime-view-mode is called.")
(make-variable-buffer-local 'mime-preview-original-window-configuration)

(defun mime-preview-original-major-mode (&optional recursive point)
  "Return major-mode of original buffer.
If optional argument RECURSIVE is non-nil and current buffer has
mime-mother-buffer, it returns original major-mode of the
mother-buffer."
  (if (and recursive mime-mother-buffer)
      (save-excursion
	(set-buffer mime-mother-buffer)
	(mime-preview-original-major-mode recursive)
	)
    (cdr (assq 'major-mode
	       (get-text-property (or point
				      (if (> (point) (buffer-size))
					  (max (1- (point-max)) (point-min))
					(point)))
				  'mime-view-situation)))))


;;; @ entity information
;;;

(defun mime-entity-situation (entity &optional situation)
  "Return situation of ENTITY."
  (let (rest param name)
    ;; Content-Type
    (unless (assq 'type situation)
      (setq rest (or (mime-entity-content-type entity)
		     (make-mime-content-type 'text 'plain))
	    situation (cons (car rest) situation)
	    rest (cdr rest))
      )
    (unless (assq 'subtype situation)
      (or rest
	  (setq rest (or (cdr (mime-entity-content-type entity))
			 '((subtype . plain)))))
      (setq situation (cons (car rest) situation)
	    rest (cdr rest))
      )
    (while rest
      (setq param (car rest))
      (or (assoc (car param) situation)
	  (setq situation (cons param situation)))
      (setq rest (cdr rest)))
    
    ;; Content-Disposition
    (setq rest nil)
    (unless (assq 'disposition-type situation)
      (setq rest (mime-entity-content-disposition entity))
      (if rest
	  (setq situation (cons (cons 'disposition-type
				      (mime-content-disposition-type rest))
				situation)
		rest (mime-content-disposition-parameters rest))
	))
    (while rest
      (setq param (car rest)
	    name (car param))
      (if (cond ((string= name "filename")
		 (if (assq 'filename situation)
		     nil
		   (setq name 'filename)))
		((string= name "creation-date")
		 (if (assq 'creation-date situation)
		     nil
		   (setq name 'creation-date)))
		((string= name "modification-date")
		 (if (assq 'modification-date situation)
		     nil
		   (setq name 'modification-date)))
		((string= name "read-date")
		 (if (assq 'read-date situation)
		     nil
		   (setq name 'read-date)))
		((string= name "size")
		 (if (assq 'size situation)
		     nil
		   (setq name 'size)))
		(t (setq name (cons 'disposition name))
		   (if (assoc name situation)
		       nil
		     name)))
	  (setq situation
		(cons (cons name (cdr param))
		      situation)))
      (setq rest (cdr rest)))
    
    ;; Content-Transfer-Encoding
    (or (assq 'encoding situation)
	(setq situation
	      (cons (cons 'encoding (or (mime-entity-encoding entity)
					"7bit"))
		    situation)))
    
    situation))

(defsubst mime-delq-null-situation (situations field
					       &rest ignored-values)
  (let (dest)
    (while situations
      (let* ((situation (car situations))
	     (cell (assq field situation)))
	(if cell
	    (or (memq (cdr cell) ignored-values)
		(setq dest (cons situation dest))
		)))
      (setq situations (cdr situations)))
    dest))

(defun mime-compare-situation-with-example (situation example)
  (let ((example (copy-alist example))
	(match 0))
    (while situation
      (let* ((cell (car situation))
	     (key (car cell))
	     (ecell (assoc key example)))
	(when ecell
	  (if (equal cell ecell)
	      (setq match (1+ match))
	    (setq example (delq ecell example))
	    ))
	)
      (setq situation (cdr situation))
      )
    (cons match example)
    ))

(defun mime-sort-situation (situation)
  (sort situation
	#'(lambda (a b)
	    (let ((a-t (car a))
		  (b-t (car b))
		  (order '((type . 1)
			   (subtype . 2)
			   (mode . 3)
			   (method . 4)
			   (major-mode . 5)
			   (disposition-type . 6)
			   ))
		  a-order b-order)
	      (if (symbolp a-t)
		  (let ((ret (assq a-t order)))
		    (if ret
			(setq a-order (cdr ret))
		      (setq a-order 7)
		      ))
		(setq a-order 8)
		)
	      (if (symbolp b-t)
		  (let ((ret (assq b-t order)))
		    (if ret
			(setq b-order (cdr ret))
		      (setq b-order 7)
		      ))
		(setq b-order 8)
		)
	      (if (= a-order b-order)
		  (string< (format "%s" a-t)(format "%s" b-t))
		(< a-order b-order))
	      )))
  )

(defun mime-unify-situations (entity-situation
			      condition situation-examples
			      &optional required-name ignored-value
			      every-situations)
  (let (ret)
    (in-calist-package 'mime-view)
    (setq ret
	  (ctree-find-calist condition entity-situation
			     every-situations))
    (if required-name
	(setq ret (mime-delq-null-situation ret required-name
					    ignored-value t)))
    (or (assq 'ignore-examples entity-situation)
	(if (cdr ret)
	    (let ((rest ret)
		  (max-score 0)
		  (max-escore 0)
		  max-examples
		  max-situations)
	      (while rest
		(let ((situation (car rest))
		      (examples situation-examples))
		  (while examples
		    (let* ((ret
			    (mime-compare-situation-with-example
			     situation (caar examples)))
			   (ret-score (car ret)))
		      (cond ((> ret-score max-score)
			     (setq max-score ret-score
				   max-escore (cdar examples)
				   max-examples (list (cdr ret))
				   max-situations (list situation))
			     )
			    ((= ret-score max-score)
			     (cond ((> (cdar examples) max-escore)
				    (setq max-escore (cdar examples)
					  max-examples (list (cdr ret))
					  max-situations (list situation))
				    )
				   ((= (cdar examples) max-escore)
				    (setq max-examples
					  (cons (cdr ret) max-examples))
				    (or (member situation max-situations)
					(setq max-situations
					      (cons situation max-situations)))
				    )))))
		    (setq examples (cdr examples))))
		(setq rest (cdr rest)))
	      (when max-situations
		(setq ret max-situations)
		(while max-examples
		  (let* ((example (car max-examples))
			 (cell
			  (assoc example situation-examples)))
		    (if cell
			(setcdr cell (1+ (cdr cell)))
		      (setq situation-examples
			    (cons (cons example 0)
				  situation-examples))
		      ))
		  (setq max-examples (cdr max-examples))
		  )))))
    (cons ret situation-examples)
    ;; ret: list of situations
    ;; situation-examples: new examples (notoce that contents of
    ;;                     argument `situation-examples' has bees modified)
    ))

(defun mime-view-entity-title (entity)
  (or (mime-entity-read-field entity 'Content-Description)
      (mime-entity-read-field entity 'Subject)
      (mime-entity-filename entity)
      ""))

(defvar mime-preview-situation-example-list nil)
(defvar mime-preview-situation-example-list-max-size 16)
;; (defvar mime-preview-situation-example-condition nil)

(defun mime-find-entity-preview-situation (entity
					   &optional default-situation)
  (or (let ((ret
	     (mime-unify-situations
	      (append (mime-entity-situation entity)
		      default-situation)
	      mime-preview-condition
	      mime-preview-situation-example-list)))
	(setq mime-preview-situation-example-list
	      (cdr ret))
	(caar ret))
      default-situation))

  
(defvar mime-acting-situation-example-list nil)
(defvar mime-acting-situation-example-list-max-size 16)
(defvar mime-situation-examples-file-coding-system nil)

(defun mime-view-read-situation-examples-file (&optional file)
  (or file
      (setq file mime-situation-examples-file))
  (if (and file
	   (file-readable-p file))
      (with-temp-buffer
	(insert-file-contents file)
	(setq mime-situation-examples-file-coding-system
              (static-cond
	       ((boundp 'buffer-file-coding-system)
		(symbol-value 'buffer-file-coding-system))
	       ((boundp 'file-coding-system)
		(symbol-value 'file-coding-system))
	       (t nil))
	      ;; (and (boundp 'buffer-file-coding-system)
              ;;      buffer-file-coding-system)
	      )
	(condition-case error
	    (eval-buffer)
	  (error (message "%s is broken: %s" file (cdr error))))
	;; format check
	(condition-case nil
	    (let ((i 0))
	      (while (and (> (length mime-preview-situation-example-list)
			     mime-preview-situation-example-list-max-size)
			  (< i 16))
		(setq mime-preview-situation-example-list
		      (mime-reduce-situation-examples
		       mime-preview-situation-example-list))
		(setq i (1+ i))))
	  (error (setq mime-preview-situation-example-list nil)))
	;; (let ((rest mime-preview-situation-example-list))
	;;   (while rest
	;;     (ctree-set-calist-strictly 'mime-preview-condition
	;;                                (caar rest))
	;;     (setq rest (cdr rest))))
	(condition-case nil
	    (let ((i 0))
	      (while (and (> (length mime-acting-situation-example-list)
			     mime-acting-situation-example-list-max-size)
			  (< i 16))
		(setq mime-acting-situation-example-list
		      (mime-reduce-situation-examples
		       mime-acting-situation-example-list))
		(setq i (1+ i))))
	  (error (setq mime-acting-situation-example-list nil))))))

(defun mime-save-situation-examples ()
  (if (or mime-preview-situation-example-list
	  mime-acting-situation-example-list)
      (let ((file mime-situation-examples-file)
	    print-length print-level)
	(with-temp-buffer
	  (insert ";;; " (file-name-nondirectory file) "\n")
	  (insert "\n;; This file is generated automatically by "
		  mime-view-version "\n\n")
	  (insert ";;; Code:\n\n")
	  (if mime-preview-situation-example-list
	      (pp `(setq mime-preview-situation-example-list
			 ',mime-preview-situation-example-list)
		  (current-buffer)))
	  (if mime-acting-situation-example-list
	      (pp `(setq mime-acting-situation-example-list
			 ',mime-acting-situation-example-list)
		  (current-buffer)))
	  (insert "\n;;; "
		  (file-name-nondirectory file)
		  " ends here.\n")
	  (static-cond
	   ((boundp 'buffer-file-coding-system)
	    (setq buffer-file-coding-system
		  mime-situation-examples-file-coding-system))
	   ((boundp 'file-coding-system)
	    (setq file-coding-system
		  mime-situation-examples-file-coding-system)))
	  ;; (setq buffer-file-coding-system
	  ;;       mime-situation-examples-file-coding-system)
	  (setq buffer-file-name file)
	  (save-buffer)))))

(add-hook 'kill-emacs-hook 'mime-save-situation-examples)

(defun mime-reduce-situation-examples (situation-examples)
  (let ((len (length situation-examples))
	i ir ic j jr jc ret
	dest d-i d-j
	(max-sim 0) sim
	min-det-ret det-ret
	min-det-org det-org
	min-freq freq)
    (setq i 0
	  ir situation-examples)
    (while (< i len)
      (setq ic (car ir)
	    j 0
	    jr situation-examples)
      (while (< j len)
	(unless (= i j)
	  (setq jc (car jr))
	  (setq ret (mime-compare-situation-with-example (car ic)(car jc))
		sim (car ret)
		det-ret (+ (length (car ic))(length (car jc)))
		det-org (length (cdr ret))
		freq (+ (cdr ic)(cdr jc)))
	  (cond ((< max-sim sim)
		 (setq max-sim sim
		       min-det-ret det-ret
		       min-det-org det-org
		       min-freq freq
		       d-i i
		       d-j j
		       dest (cons (cdr ret) freq))
		 )
		((= max-sim sim)
		 (cond ((> min-det-ret det-ret)
			(setq min-det-ret det-ret
			      min-det-org det-org
			      min-freq freq
			      d-i i
			      d-j j
			      dest (cons (cdr ret) freq))
			)
		       ((= min-det-ret det-ret)
			(cond ((> min-det-org det-org)
			       (setq min-det-org det-org
				     min-freq freq
				     d-i i
				     d-j j
				     dest (cons (cdr ret) freq))
			       )
			      ((= min-det-org det-org)
			       (cond ((> min-freq freq)
				      (setq min-freq freq
					    d-i i
					    d-j j
					    dest (cons (cdr ret) freq))
				      ))
			       ))
			))
		 ))
	  )
	(setq jr (cdr jr)
	      j (1+ j)))
      (setq ir (cdr ir)
	    i (1+ i)))
    (if (> d-i d-j)
	(setq i d-i
	      d-i d-j
	      d-j i))
    (setq jr (nthcdr (1- d-j) situation-examples))
    (setcdr jr (cddr jr))
    (if (= d-i 0)
	(setq situation-examples
	      (cdr situation-examples))
      (setq ir (nthcdr (1- d-i) situation-examples))
      (setcdr ir (cddr ir))
      )
    (if (setq ir (assoc (car dest) situation-examples))
	(progn
	  (setcdr ir (+ (cdr ir)(cdr dest)))
	  situation-examples)
      (cons dest situation-examples)
      ;; situation-examples may be modified.
      )))


;;; @ presentation of preview
;;;

;;; @@ entity-button
;;;

;;; @@@ predicate function
;;;

;; (defun mime-view-entity-button-visible-p (entity)
;;   "Return non-nil if header of ENTITY is visible.
;; Please redefine this function if you want to change default setting."
;;   (let ((media-type (mime-entity-media-type entity))
;;         (media-subtype (mime-entity-media-subtype entity)))
;;     (or (not (eq media-type 'application))
;;         (and (not (eq media-subtype 'x-selection))
;;              (or (not (eq media-subtype 'octet-stream))
;;                  (let ((mother-entity (mime-entity-parent entity)))
;;                    (or (not (eq (mime-entity-media-type mother-entity)
;;                                 'multipart))
;;                        (not (eq (mime-entity-media-subtype mother-entity)
;;                                 'encrypted)))
;;                    )
;;                  )))))

;;; @@@ entity button generator
;;;

(defun mime-view-insert-entity-button (entity)
  "Insert entity-button of ENTITY."
  (let ((entity-node-id (mime-entity-node-id entity))
	(params (mime-entity-parameters entity))
	(subject (mime-view-entity-title entity)))
    (mime-insert-button
     (let ((access-type (assoc "access-type" params))
	   (num (or (cdr (assoc "x-part-number" params))
		    (if (consp entity-node-id)
			(mapconcat (function
				    (lambda (num)
				      (format "%s" (1+ num))
				      ))
				   (reverse entity-node-id) ".")
		      "0"))
		))
       (cond (access-type
	      (let ((server (assoc "server" params)))
		(setq access-type (cdr access-type))
		(if server
		    (format "%s %s ([%s] %s)"
			    num subject access-type (cdr server))
		(let ((site (cdr (assoc "site" params)))
		      (dir (cdr (assoc "directory" params)))
		      (url (cdr (assoc "url" params)))
		      )
		  (if url
		      (format "%s %s ([%s] %s)"
			      num subject access-type url)
		    (format "%s %s ([%s] %s:%s)"
			    num subject access-type site dir))
		  )))
	    )
	   (t
	    (let* ((charset (cdr (assoc "charset" params)))
		   (encoding (mime-entity-encoding entity))
		   (rest (format " <%s/%s%s%s>"
				 (mime-entity-media-type entity)
				 (mime-entity-media-subtype entity)
				 (if charset
				     (concat "; " charset)
				   "")
				 (if encoding
				     (concat " (" encoding ")")
				   ""))))
	      (concat
	       num " " subject
	       (if (>= (+ (current-column)(length rest))(window-width))
		   "\n\t")
	       rest))
	    )))
     (function mime-preview-play-current-entity))
    ))


;;; @@ entity-header
;;;

(defvar mime-header-presentation-method-alist nil
  "Alist of major mode vs. corresponding header-presentation-method functions.
Each element looks like (SYMBOL . FUNCTION).
SYMBOL must be major mode in raw-buffer or t.  t means default.
Interface of FUNCTION must be (ENTITY SITUATION).")

(defvar mime-view-ignored-field-list
  '(".*Received:" ".*Path:" ".*Id:" "^References:"
    "^Replied:" "^Errors-To:"
    "^Lines:" "^Sender:" ".*Host:" "^Xref:"
    "^Content-Type:" "^Precedence:"
    "^Status:" "^X-VM-.*:")
  "All fields that match this list will be hidden in MIME preview buffer.
Each elements are regexp of field-name.")

(defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
  "All fields that match this list will be displayed in MIME preview buffer.
Each elements are regexp of field-name.")


;;; @@ entity-body
;;;

;;; @@@ predicate function
;;;

(in-calist-package 'mime-view)

(defun mime-calist::field-match-method-as-default-rule (calist
							field-type field-value)
  (let ((s-field (assq field-type calist)))
    (cond ((null s-field)
	   (cons (cons field-type field-value) calist)
	   )
	  (t calist))))

(define-calist-field-match-method
  'header #'mime-calist::field-match-method-as-default-rule)

(define-calist-field-match-method
  'body #'mime-calist::field-match-method-as-default-rule)


(defvar mime-preview-condition nil
  "Condition-tree about how to display entity.")

(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . octet-stream)
			   (encoding . nil)
			   (body . visible)))
(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . octet-stream)
			   (encoding . "7bit")
			   (body . visible)))
(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . octet-stream)
			   (encoding . "8bit")
			   (body . visible)))

(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . pgp)
			   (body . visible)))

(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . x-latex)
			   (body . visible)))

(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . x-selection)
			   (body . visible)))

(ctree-set-calist-strictly
 'mime-preview-condition '((type . application)(subtype . x-comment)
			   (body . visible)))

(ctree-set-calist-strictly
 'mime-preview-condition '((type . message)(subtype . delivery-status)
			   (body . visible)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((body . visible)
   (body-presentation-method . mime-display-text/plain)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . nil)
   (body . visible)
   (body-presentation-method . mime-display-text/plain)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . text)(subtype . enriched)
   (body . visible)
   (body-presentation-method . mime-display-text/enriched)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . text)(subtype . richtext)
   (body . visible)
   (body-presentation-method . mime-display-text/richtext)))

(autoload 'mime-display-application/x-postpet "postpet")

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . application)(subtype . x-postpet)
   (body . visible)
   (body-presentation-method . mime-display-application/x-postpet)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . text)(subtype . t)
   (body . visible)
   (body-presentation-method . mime-display-text/plain)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . multipart)(subtype . alternative)
   (body . visible)
   (body-presentation-method . mime-display-multipart/alternative)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . multipart)(subtype . related)
   (body . visible)
   (body-presentation-method . mime-display-multipart/related)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . multipart)(subtype . t)
   (body . visible)
   (body-presentation-method . mime-display-multipart/mixed)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . message)(subtype . partial)
   (body . visible)
   (body-presentation-method . mime-display-message/partial-button)))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . message)(subtype . rfc822)
   (body . visible)
   (body-presentation-method . mime-display-multipart/mixed)
   (childrens-situation (header . visible)
			(entity-button . invisible))))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . message)(subtype . news)
   (body . visible)
   (body-presentation-method . mime-display-multipart/mixed)
   (childrens-situation (header . visible)
			(entity-button . invisible))))


;;; @@@ entity presentation
;;;

(defun mime-display-text/plain (entity situation)
  (save-restriction
    (narrow-to-region (point-max)(point-max))
    (condition-case nil
	(mime-insert-text-content entity)
      (error (progn
	       (message "Can't decode current entity.")
	       (sit-for 1))))
    (run-hooks 'mime-text-decode-hook)
    (goto-char (point-max))
    (if (not (eq (char-after (1- (point))) ?\n))
	(insert "\n")
      )
    (mime-add-url-buttons)
    (run-hooks 'mime-display-text/plain-hook)
    ))

(defun mime-display-text/richtext (entity situation)
  (save-restriction
    (narrow-to-region (point-max)(point-max))
    (mime-insert-text-content entity)
    (run-hooks 'mime-text-decode-hook)
    (let ((beg (point-min)))
      (remove-text-properties beg (point-max) '(face nil))
      (richtext-decode beg (point-max))
      )))

(defun mime-display-text/enriched (entity situation)
  (save-restriction
    (narrow-to-region (point-max)(point-max))
    (mime-insert-text-content entity)
    (run-hooks 'mime-text-decode-hook)
    (let ((beg (point-min)))
      (remove-text-properties beg (point-max) '(face nil))
      (enriched-decode beg (point-max))
      )))


(defvar mime-view-announcement-for-message/partial
  (if (and (>= emacs-major-version 19) window-system)
      "\
\[[ This is message/partial style split message. ]]
\[[ Please press `v' key in this buffer          ]]
\[[ or click here by mouse button-2.             ]]"
    "\
\[[ This is message/partial style split message. ]]
\[[ Please press `v' key in this buffer.         ]]"
    ))

(defun mime-display-message/partial-button (&optional entity situation)
  (save-restriction
    (goto-char (point-max))
    (if (not (search-backward "\n\n" nil t))
	(insert "\n")
      )
    (goto-char (point-max))
    (narrow-to-region (point-max)(point-max))
    (insert mime-view-announcement-for-message/partial)
    (mime-add-button (point-min)(point-max)
		     #'mime-preview-play-current-entity)
    ))

(defun mime-display-multipart/mixed (entity situation)
  (let ((children (mime-entity-children entity))
	(original-major-mode-cell (assq 'major-mode situation))
	(default-situation
	  (cdr (assq 'childrens-situation situation))))
    (if original-major-mode-cell
	(setq default-situation
	      (cons original-major-mode-cell default-situation)))
    (while children
      (mime-display-entity (car children) nil default-situation)
      (setq children (cdr children))
      )))

(defcustom mime-view-type-subtype-score-alist
  '(((text . enriched) . 3)
    ((text . richtext) . 2)
    ((text . plain)    . 1)
    (t . 0))
  "Alist MEDIA-TYPE vs corresponding score.
MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
  :group 'mime-view
  :type '(repeat (cons (choice :tag "Media-Type"
			       (cons :tag "Type/Subtype"
				     (symbol :tag "Primary-type")
				     (symbol :tag "Subtype"))
			       (symbol :tag "Type")
			       (const :tag "Default" t))
		       integer)))

(defun mime-display-multipart/alternative (entity situation)
  (let* ((children (mime-entity-children entity))
	 (original-major-mode-cell (assq 'major-mode situation))
	 (default-situation
	   (cdr (assq 'childrens-situation situation)))
	 (i 0)
	 (p 0)
	 (max-score 0)
	 situations)
    (if original-major-mode-cell
	(setq default-situation
	      (cons original-major-mode-cell default-situation)))
    (setq situations
	  (mapcar (function
		   (lambda (child)
		     (let ((situation
			    (mime-find-entity-preview-situation
			     child default-situation)))
		       (if (cdr (assq 'body-presentation-method situation))
			   (let ((score
				  (cdr
				   (or (assoc
					(cons
					 (cdr (assq 'type situation))
					 (cdr (assq 'subtype situation)))
					mime-view-type-subtype-score-alist)
				       (assq
					(cdr (assq 'type situation))
					mime-view-type-subtype-score-alist)
				       (assq
					t
					mime-view-type-subtype-score-alist)
				       ))))
			     (if (> score max-score)
				 (setq p i
				       max-score score)
			       )))
		       (setq i (1+ i))
		       situation)
		     ))
		  children))
    (setq i 0)
    (while children
      (let ((child (car children))
	    (situation (car situations)))
	(mime-display-entity child (if (= i p)
				       situation
				     (put-alist 'body 'invisible
						(copy-alist situation)))))
      (setq children (cdr children)
	    situations (cdr situations)
	    i (1+ i)))))

(defun mime-display-multipart/related (entity situation)
  (let* ((param-start (mime-parse-msg-id
		       (std11-lexical-analyze
			(cdr (assoc "start"
				    (mime-content-type-parameters
				     (mime-entity-content-type entity)))))))
	 (start (or (and param-start (mime-find-entity-from-content-id
				      param-start
				      entity))
		    (car (mime-entity-children entity))))
	 (original-major-mode-cell (assq 'major-mode situation))
	 (default-situation (cdr (assq 'childrens-situation situation))))
    (when start
      (if original-major-mode-cell
	  (setq default-situation
		(cons original-major-mode-cell default-situation)))
      (mime-display-entity start nil default-situation))))

;;; @ acting-condition
;;;

(defvar mime-acting-condition nil
  "Condition-tree about how to process entity.")

(defun mime-view-read-mailcap-files (&optional files)
  (or files
      (setq files mime-view-mailcap-files))
  (let (entries file)
    (while files
      (setq file (car files))
      (if (file-readable-p file)
	  (setq entries (append entries (mime-parse-mailcap-file file))))
      (setq files (cdr files)))
    (while entries
      (let ((entry (car entries))
	    view print shared)
	(while entry
	  (let* ((field (car entry))
		 (field-type (car field)))
	    (cond ((eq field-type 'view)  (setq view field))
		  ((eq field-type 'print) (setq print field))
		  ((memq field-type '(compose composetyped edit)))
		  (t (setq shared (cons field shared))))
	    )
	  (setq entry (cdr entry)))
	(setq shared (nreverse shared))
	(ctree-set-calist-with-default
	 'mime-acting-condition
	 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
	(if print
	    (ctree-set-calist-with-default
	     'mime-acting-condition
	     (append shared
		     (list '(mode . "print")(cons 'method (cdr view)))))))
      (setq entries (cdr entries)))))

(mime-view-read-mailcap-files)

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . application)(subtype . octet-stream)
   (mode . "play")
   (method . mime-detect-content)
   ))

(ctree-set-calist-with-default
 'mime-acting-condition
 '((mode . "extract")
   (method . mime-save-content)))

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . text)(subtype . x-rot13-47)(mode . "play")
   (method . mime-view-caesar)
   ))
(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
   (method . mime-view-caesar)
   ))

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . message)(subtype . rfc822)(mode . "play")
   (method . mime-view-message/rfc822)
   ))
(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . message)(subtype . partial)(mode . "play")
   (method . mime-store-message/partial-piece)
   ))

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . message)(subtype . external-body)
   ("access-type" . "anon-ftp")
   (method . mime-view-message/external-anon-ftp)
   ))

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . message)(subtype . external-body)
   ("access-type" . "url")
   (method . mime-view-message/external-url)
   ))

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . application)(subtype . octet-stream)
   (method . mime-save-content)
   ))


;;; @ quitting method
;;;

(defvar mime-preview-quitting-method-alist
  '((mime-show-message-mode
     . mime-preview-quitting-method-for-mime-show-message-mode))
  "Alist of major-mode vs. quitting-method of mime-view.")

(defvar mime-preview-over-to-previous-method-alist nil
  "Alist of major-mode vs. over-to-previous-method of mime-view.")

(defvar mime-preview-over-to-next-method-alist nil
  "Alist of major-mode vs. over-to-next-method of mime-view.")


;;; @ following method
;;;

(defvar mime-preview-following-method-alist nil
  "Alist of major-mode vs. following-method of mime-view.")

(defvar mime-view-following-required-fields-list
  '("From"))


;;; @ buffer setup
;;;

(defun mime-display-entity (entity &optional situation
				   default-situation preview-buffer)
  (or preview-buffer
      (setq preview-buffer (current-buffer)))
  (let* (e nb ne nhb nbb)
    (in-calist-package 'mime-view)
    (or situation
	(setq situation
	      (mime-find-entity-preview-situation entity default-situation)))
    (let ((button-is-invisible
	   (eq (cdr (or (assq '*entity-button situation)
			(assq 'entity-button situation)))
	       'invisible))
	  (header-is-visible
	   (eq (cdr (or (assq '*header situation)
			(assq 'header situation)))
	       'visible))
	  (body-is-visible
	   (eq (cdr (or (assq '*body situation)
			(assq 'body situation)))
	       'visible))
	  (children (mime-entity-children entity)))
      (set-buffer preview-buffer)
      (setq nb (point))
      (narrow-to-region nb nb)
      (or button-is-invisible
          ;; (if (mime-view-entity-button-visible-p entity)
	  (mime-view-insert-entity-button entity)
          ;;   )
	  )
      (if header-is-visible
	  (let ((header-presentation-method
		 (or (cdr (assq 'header-presentation-method situation))
		     (cdr (assq (cdr (assq 'major-mode situation))
				mime-header-presentation-method-alist)))))
	    (setq nhb (point))
	    (if header-presentation-method
		(funcall header-presentation-method entity situation)
	      (mime-insert-header entity
				  mime-view-ignored-field-list
				  mime-view-visible-field-list))
	    (run-hooks 'mime-display-header-hook)
	    (put-text-property nhb (point-max) 'mime-view-entity-header entity)
	    (goto-char (point-max))
	    (insert "\n")))
      (setq nbb (point))
      (unless children
	(if body-is-visible
	    (let ((body-presentation-method
		   (cdr (assq 'body-presentation-method situation))))
	      (if (functionp body-presentation-method)
		  (funcall body-presentation-method entity situation)
		(mime-display-text/plain entity situation)))
	  (when button-is-invisible
	    (goto-char (point-max))
	    (mime-view-insert-entity-button entity)
	    )
	  (unless header-is-visible
	    (goto-char (point-max))
	    (insert "\n"))
	  ))
      (setq ne (point-max))
      (widen)
      (put-text-property nb ne 'mime-view-entity entity)
      (put-text-property nb ne 'mime-view-situation situation)
      (put-text-property nbb ne 'mime-view-entity-body entity)
      (goto-char ne)
      (if (and children body-is-visible)
	  (let ((body-presentation-method
		 (cdr (assq 'body-presentation-method situation))))
	    (if (functionp body-presentation-method)
		(funcall body-presentation-method entity situation)
	      (mime-display-multipart/mixed entity situation))))
      )))


;;; @ MIME viewer mode
;;;

(defconst mime-view-menu-title "MIME-View")
(defconst mime-view-menu-list
  '((up		 "Move to upper entity"    mime-preview-move-to-upper)
    (previous	 "Move to previous entity" mime-preview-move-to-previous)
    (next	 "Move to next entity"	   mime-preview-move-to-next)
    (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
    (scroll-up	 "Scroll-up"               mime-preview-scroll-up-entity)
    (play	 "Play current entity"     mime-preview-play-current-entity)
    (extract	 "Extract current entity"  mime-preview-extract-current-entity)
    (print	 "Print current entity"    mime-preview-print-current-entity)
    )
  "Menu for MIME Viewer")

(cond ((featurep 'xemacs)
       (defvar mime-view-xemacs-popup-menu
	 (cons mime-view-menu-title
	       (mapcar (function
			(lambda (item)
			  (vector (nth 1 item)(nth 2 item) t)
			  ))
		       mime-view-menu-list)))
       (defun mime-view-xemacs-popup-menu (event)
	 "Popup the menu in the MIME Viewer buffer"
	 (interactive "e")
	 (select-window (event-window event))
	 (set-buffer (event-buffer event))
	 (popup-menu 'mime-view-xemacs-popup-menu))
       (defvar mouse-button-2 'button2)
       (defvar mouse-button-3 'button3)
       )
      (t
       (defvar mime-view-popup-menu 
         (let ((menu (make-sparse-keymap mime-view-menu-title)))
           (nconc menu
                  (mapcar (function
                           (lambda (item)
                             (list (intern (nth 1 item)) 'menu-item 
                                   (nth 1 item)(nth 2 item))
                             ))
                          mime-view-menu-list))))
       (defun mime-view-popup-menu (event)
         "Popup the menu in the MIME Viewer buffer"
         (interactive "@e")
         (let ((menu mime-view-popup-menu) events func)
           (setq events (x-popup-menu t menu))
           (and events
                (setq func (lookup-key menu (apply #'vector events)))
                (commandp func)
                (funcall func))))
       (defvar mouse-button-2 [mouse-2])
       (defvar mouse-button-3 [mouse-3])
       ))

(defun mime-view-define-keymap (&optional default)
  (let ((mime-view-mode-map (if (keymapp default)
				(copy-keymap default)
			      (make-sparse-keymap))))
    (define-key mime-view-mode-map
      "u"        (function mime-preview-move-to-upper))
    (define-key mime-view-mode-map
      "p"        (function mime-preview-move-to-previous))
    (define-key mime-view-mode-map
      "n"        (function mime-preview-move-to-next))
    (define-key mime-view-mode-map
      "\e\t"     (function mime-preview-move-to-previous))
    (define-key mime-view-mode-map
      "\t"       (function mime-preview-move-to-next))
    (define-key mime-view-mode-map
      " "        (function mime-preview-scroll-up-entity))
    (define-key mime-view-mode-map
      "\M- "     (function mime-preview-scroll-down-entity))
    (define-key mime-view-mode-map
      "\177"     (function mime-preview-scroll-down-entity))
    (define-key mime-view-mode-map
      "\C-m"     (function mime-preview-next-line-entity))
    (define-key mime-view-mode-map
      "\C-\M-m"  (function mime-preview-previous-line-entity))
    (define-key mime-view-mode-map
      "v"        (function mime-preview-play-current-entity))
    (define-key mime-view-mode-map
      "e"        (function mime-preview-extract-current-entity))
    (define-key mime-view-mode-map
      "\C-c\C-p" (function mime-preview-print-current-entity))

    (define-key mime-view-mode-map
      "\C-c\C-t\C-f" (function mime-preview-toggle-header))
    (define-key mime-view-mode-map
      "\C-c\C-th" (function mime-preview-toggle-header))
    (define-key mime-view-mode-map
      "\C-c\C-t\C-c" (function mime-preview-toggle-content))

    (define-key mime-view-mode-map
      "\C-c\C-v\C-f" (function mime-preview-show-header))
    (define-key mime-view-mode-map
      "\C-c\C-vh" (function mime-preview-show-header))
    (define-key mime-view-mode-map
      "\C-c\C-v\C-c" (function mime-preview-show-content))

    (define-key mime-view-mode-map
      "\C-c\C-d\C-f" (function mime-preview-hide-header))
    (define-key mime-view-mode-map
      "\C-c\C-dh" (function mime-preview-hide-header))
    (define-key mime-view-mode-map
      "\C-c\C-d\C-c" (function mime-preview-hide-content))

    (define-key mime-view-mode-map
      "a"        (function mime-preview-follow-current-entity))
    (define-key mime-view-mode-map
      "q"        (function mime-preview-quit))
    (define-key mime-view-mode-map
      "\C-c\C-x" (function mime-preview-kill-buffer))
    ;; (define-key mime-view-mode-map
    ;;   "<"        (function beginning-of-buffer))
    ;; (define-key mime-view-mode-map
    ;;   ">"        (function end-of-buffer))
    (define-key mime-view-mode-map
      "?"        (function describe-mode))
    (define-key mime-view-mode-map
      [tab] (function mime-preview-move-to-next))
    (define-key mime-view-mode-map
      [delete] (function mime-preview-scroll-down-entity))
    (define-key mime-view-mode-map
      [backspace] (function mime-preview-scroll-down-entity))
    (if (functionp default)
	(cond ((featurep 'xemacs)
	       (set-keymap-default-binding mime-view-mode-map default)
	       )
	      (t
	       (setq mime-view-mode-map
		     (append mime-view-mode-map (list (cons t default))))
	       )))
    (if mouse-button-2
	(define-key mime-view-mode-map
	  mouse-button-2 (function mime-button-dispatcher))
      )
    (cond ((featurep 'xemacs)
	   (define-key mime-view-mode-map
	     mouse-button-3 (function mime-view-xemacs-popup-menu))
	   )
	  ((>= emacs-major-version 19)
	   (define-key mime-view-mode-map
             mouse-button-3 (function mime-view-popup-menu))
	   (define-key mime-view-mode-map [menu-bar mime-view]
	     (cons mime-view-menu-title
		   (make-sparse-keymap mime-view-menu-title)))
	   (mapcar (function
		    (lambda (item)
		      (define-key mime-view-mode-map
			(vector 'menu-bar 'mime-view (car item))
			(cons (nth 1 item)(nth 2 item)))
		      ))
		   (reverse mime-view-menu-list))
	   ))
    ;; (run-hooks 'mime-view-define-keymap-hook)
    mime-view-mode-map))

(defvar mime-view-mode-default-map (mime-view-define-keymap))


(defsubst mime-maybe-hide-echo-buffer ()
  "Clear mime-echo buffer and delete window for it."
  (let ((buf (get-buffer mime-echo-buffer-name)))
    (if buf
	(save-excursion
	  (set-buffer buf)
	  (erase-buffer)
	  (let ((win (get-buffer-window buf)))
	    (if win
		(delete-window win)
	      ))
	  (bury-buffer buf)
	  ))))

(defvar mime-view-redisplay nil)

;;;###autoload
(defun mime-display-message (message &optional preview-buffer
				     mother default-keymap-or-function
				     original-major-mode keymap)
  "View MESSAGE in MIME-View mode.

Optional argument PREVIEW-BUFFER specifies the buffer of the
presentation.  It must be either nil or a name of preview buffer.

Optional argument MOTHER specifies mother-buffer of the preview-buffer.

Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
function.  If it is a keymap, keymap of MIME-View mode will be added
to it.  If it is a function, it will be bound as default binding of
keymap of MIME-View mode.

Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
buffer of MESSAGE.  If it is nil, current `major-mode' is used.

Optional argument KEYMAP is keymap of MIME-View mode.  If it is
non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored.  If it is nil,
`mime-view-mode-default-map' is used."
  (mime-maybe-hide-echo-buffer)
  (let ((win-conf (current-window-configuration)))
    (or preview-buffer
	(setq preview-buffer
	      (concat "*Preview-" (mime-entity-name message) "*")))
    (or original-major-mode
	(setq original-major-mode major-mode))
    (let ((inhibit-read-only t))
      (set-buffer (get-buffer-create preview-buffer))
      (widen)
      (erase-buffer)
      (if mother
	  (setq mime-mother-buffer mother))
      (setq mime-preview-original-window-configuration win-conf)
      (setq major-mode 'mime-view-mode)
      (setq mode-name "MIME-View")
      (mime-display-entity message nil
			   `((entity-button . invisible)
			     (header . visible)
			     (major-mode . ,original-major-mode))
			   preview-buffer)
      (use-local-map
       (or keymap
	   (if default-keymap-or-function
	       (mime-view-define-keymap default-keymap-or-function)
	     mime-view-mode-default-map)))
      (let ((point
	     (next-single-property-change (point-min) 'mime-view-entity)))
	(if point
	    (goto-char point)
	  (goto-char (point-min))
	  (search-forward "\n\n" nil t)))
      (run-hooks 'mime-view-mode-hook)
      (set-buffer-modified-p nil)
      (setq buffer-read-only t)
      preview-buffer)))

;;;###autoload
(defun mime-view-buffer (&optional raw-buffer preview-buffer mother
				   default-keymap-or-function
				   representation-type)
  "View RAW-BUFFER in MIME-View mode.
Optional argument PREVIEW-BUFFER is either nil or a name of preview
buffer.
Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
function.  If it is a keymap, keymap of MIME-View mode will be added
to it.  If it is a function, it will be bound as default binding of
keymap of MIME-View mode.
Optional argument REPRESENTATION-TYPE is representation-type of
message.  It must be nil, `binary' or `cooked'.  If it is nil,
`cooked' is used as default."
  (interactive)
  (or raw-buffer
      (setq raw-buffer (current-buffer)))
  (or representation-type
      (setq representation-type
	    (save-excursion
	      (set-buffer raw-buffer)
	      (cdr (or (assq major-mode mime-raw-representation-type-alist)
		       (assq t mime-raw-representation-type-alist)))
	      )))
  (if (eq representation-type 'binary)
      (setq representation-type 'buffer)
    )
  (setq preview-buffer (mime-display-message
			(mime-open-entity representation-type raw-buffer)
			preview-buffer mother default-keymap-or-function))
  (or (get-buffer-window preview-buffer)
      (let ((r-win (get-buffer-window raw-buffer)))
	(if r-win
	    (set-window-buffer r-win preview-buffer)
	  (let ((m-win (and mother (get-buffer-window mother))))
	    (if m-win
		(set-window-buffer m-win preview-buffer)
	      (switch-to-buffer preview-buffer)
	      ))))))

(defun mime-view-mode (&optional mother ctl encoding
				 raw-buffer preview-buffer
				 default-keymap-or-function)
  "Major mode for viewing MIME message.

Here is a list of the standard keys for mime-view-mode.

key		feature
---		-------

u		Move to upper content
p or M-TAB	Move to previous content
n or TAB	Move to next content
SPC		Scroll up or move to next content
M-SPC or DEL	Scroll down or move to previous content
RET		Move to next line
M-RET		Move to previous line
v		Decode current content as `play mode'
e		Decode current content as `extract mode'
C-c C-p		Decode current content as `print mode'
a		Followup to current content.
q		Quit
button-2	Move to point under the mouse cursor
        	and decode current content as `play mode'
"
  (interactive)
  (unless mime-view-redisplay
    (save-excursion
      (if raw-buffer (set-buffer raw-buffer))
      (let ((type
	     (cdr
	      (or (assq major-mode mime-raw-representation-type-alist)
		  (assq t mime-raw-representation-type-alist)))))
	(if (eq type 'binary)
	    (setq type 'buffer)
	  )
	(setq mime-message-structure (mime-open-entity type raw-buffer))
	(or (mime-entity-content-type mime-message-structure)
	    (mime-entity-set-content-type mime-message-structure ctl))
	)
      (or (mime-entity-encoding mime-message-structure)
	  (mime-entity-set-encoding mime-message-structure encoding))
      ))
  (mime-display-message mime-message-structure preview-buffer
			mother default-keymap-or-function)
  )


;;; @@ utility
;;;

(defun mime-preview-find-boundary-info (&optional with-children)
  "Return boundary information of current part.
If WITH-CHILDREN, refer boundary surrounding current part and its branches."
  (let (entity
	p-beg p-end
	entity-node-id len)
    (while (and
	    (null (setq entity
			(get-text-property (point) 'mime-view-entity)))
	    (> (point) (point-min)))
      (backward-char))
    (setq p-beg (previous-single-property-change (point) 'mime-view-entity))
    (setq entity-node-id (and entity (mime-entity-node-id entity)))
    (setq len (length entity-node-id))
    (cond ((null p-beg)
	   (setq p-beg
		 (if (eq (next-single-property-change (point-min)
						      'mime-view-entity)
			 (point))
		     (point)
		   (point-min)))
	   )
	  ((eq (next-single-property-change p-beg 'mime-view-entity)
	       (point))
	   (setq p-beg (point))
	   ))
    (setq p-end (next-single-property-change p-beg 'mime-view-entity))
    (cond ((null p-end)
	   (setq p-end (point-max))
	   )
	  ((null entity-node-id)
	   (setq p-end (point-max))
	   )
	  (with-children
	   (save-excursion
	     (catch 'tag
	       (let (e i)
		 (while (setq e
			      (next-single-property-change
			       (point) 'mime-view-entity))
		   (goto-char e)
		   (let ((rc (mime-entity-node-id
			      (get-text-property (point)
						 'mime-view-entity))))
		     (or (and (>= (setq i (- (length rc) len)) 0)
			      (equal entity-node-id (nthcdr i rc)))
			 (throw 'tag nil)))
		   (setq p-end (or (next-single-property-change
				    (point) 'mime-view-entity)
				   (point-max)))))
	       (setq p-end (point-max))))
	   ))
    (vector p-beg p-end entity)))


;;; @@ playing
;;;

(autoload 'mime-preview-play-current-entity "mime-play"
  "Play current entity." t)

(defun mime-preview-extract-current-entity (&optional ignore-examples)
  "Extract current entity into file (maybe).
It decodes current entity to call internal or external method as
\"extract\" mode.  The method is selected from variable
`mime-acting-condition'."
  (interactive "P")
  (mime-preview-play-current-entity ignore-examples "extract")
  )

(defun mime-preview-print-current-entity (&optional ignore-examples)
  "Print current entity (maybe).
It decodes current entity to call internal or external method as
\"print\" mode.  The method is selected from variable
`mime-acting-condition'."
  (interactive "P")
  (mime-preview-play-current-entity ignore-examples "print")
  )


;;; @@ following
;;;

(defun mime-preview-follow-current-entity ()
  "Write follow message to current entity.
It calls following-method selected from variable
`mime-preview-following-method-alist'."
  (interactive)
  (let* ((boundary-info (mime-preview-find-boundary-info t))
	 (p-beg (aref boundary-info 0))
	 (p-end (aref boundary-info 1))
	 (entity (aref boundary-info 2))
	 pb-beg)
    (if (or (get-text-property p-beg 'mime-view-entity-body)
	    (null entity))
	(setq pb-beg p-beg)
      (setq pb-beg
	    (next-single-property-change
	     p-beg 'mime-view-entity-body nil
	     (or (next-single-property-change p-beg 'mime-view-entity)
		 p-end))))
    (let* ((mode (mime-preview-original-major-mode 'recursive))
	   (entity-node-id (and entity (mime-entity-node-id entity)))
	   (new-name
	    (format "%s-%s" (buffer-name) (reverse entity-node-id)))
	   new-buf
	   (the-buf (current-buffer))
	   fields)
      (save-excursion
	(set-buffer (setq new-buf (get-buffer-create new-name)))
	(erase-buffer)
	(insert ?\n)
	(insert-buffer-substring the-buf pb-beg p-end)
	(goto-char (point-min))
	(let ((current-entity
	       (if (and entity
			(eq (mime-entity-media-type entity) 'message)
			(eq (mime-entity-media-subtype entity) 'rfc822))
		   (car (mime-entity-children entity))
		 entity)))
	  (while (and current-entity
		      (if (and (eq (mime-entity-media-type
				    current-entity) 'message)
			       (eq (mime-entity-media-subtype
				    current-entity) 'rfc822))
			  nil
			(mime-insert-header current-entity fields)
			t))
	    (setq fields (std11-collect-field-names)
		  current-entity (mime-entity-parent current-entity))
	    ))
	(let ((rest mime-view-following-required-fields-list)
	      field-name ret)
	  (while rest
	    (setq field-name (car rest))
	    (or (std11-field-body field-name)
		(progn
		  (save-excursion
		    (set-buffer the-buf)
		    (let ((entity (when mime-mother-buffer
				    (set-buffer mime-mother-buffer)
				    (get-text-property (point)
						       'mime-view-entity))))
		      (while (and entity
				  (null (setq ret (mime-entity-fetch-field
						   entity field-name))))
			(setq entity (mime-entity-parent entity)))))
		  (if ret
		      (insert (concat field-name ": " ret "\n"))
		    )))
	    (setq rest (cdr rest))
	    ))
	)
      (let ((f (cdr (assq mode mime-preview-following-method-alist))))
	(if (functionp f)
	    (funcall f new-buf)
	  (message
	   "Sorry, following method for %s is not implemented yet."
	   mode)
	  ))
      )))


;;; @@ moving
;;;

(defun mime-preview-move-to-upper ()
  "Move to upper entity.
If there is no upper entity, call function `mime-preview-quit'."
  (interactive)
  (let (cinfo)
    (while (null (setq cinfo
		       (get-text-property (point) 'mime-view-entity)))
      (backward-char)
      )
    (let ((r (mime-entity-parent cinfo))
	  point)
      (catch 'tag
	(while (setq point (previous-single-property-change
			    (point) 'mime-view-entity))
	  (goto-char point)
	  (when (eq r (get-text-property (point) 'mime-view-entity))
	    (if (or (eq mime-preview-move-scroll t)
		    (and mime-preview-move-scroll
			 (>= point
			     (save-excursion
			       (move-to-window-line -1)
			       (forward-line (* -1 next-screen-context-lines))
			       (beginning-of-line)
			       (point)))))
		(recenter next-screen-context-lines))
	    (throw 'tag t)
	    )
	  )
	(mime-preview-quit)
	))))

(defun mime-preview-move-to-previous ()
  "Move to previous entity.
If there is no previous entity, it calls function registered in
variable `mime-preview-over-to-previous-method-alist'."
  (interactive)
  (while (and (not (bobp))
	      (null (get-text-property (point) 'mime-view-entity)))
    (backward-char)
    )
  (let ((point (previous-single-property-change (point) 'mime-view-entity)))
    (if (and point
	     (>= point (point-min)))
	(if (get-text-property (1- point) 'mime-view-entity)
	    (progn (goto-char point)
		   (if
		    (or (eq mime-preview-move-scroll t)
			(and mime-preview-move-scroll
			     (<= point
				(save-excursion
				  (move-to-window-line 0)
				  (forward-line next-screen-context-lines)
				  (end-of-line)
				  (point)))))
			(recenter (* -1 next-screen-context-lines))))
	  (goto-char (1- point))
	  (mime-preview-move-to-previous)
	  )
      (let ((f (assq (mime-preview-original-major-mode)
		     mime-preview-over-to-previous-method-alist)))
	(if f
	    (funcall (cdr f))
	  ))
      )))

(defun mime-preview-move-to-next ()
  "Move to next entity.
If there is no previous entity, it calls function registered in
variable `mime-preview-over-to-next-method-alist'."
  (interactive)
  (while (and (not (eobp))
	      (null (get-text-property (point) 'mime-view-entity)))
    (forward-char)
    )
  (let ((point (next-single-property-change (point) 'mime-view-entity)))
    (if (and point
	     (<= point (point-max)))
	(progn
	  (goto-char point)
	  (if (null (get-text-property point 'mime-view-entity))
	      (mime-preview-move-to-next)
	    (and
	     (or (eq mime-preview-move-scroll t)
		 (and mime-preview-move-scroll
		      (>= point
			 (save-excursion
			   (move-to-window-line -1)
			   (forward-line
			    (* -1 next-screen-context-lines))
			   (beginning-of-line)
			   (point)))))
		 (recenter next-screen-context-lines))
	    ))
      (let ((f (assq (mime-preview-original-major-mode)
		     mime-preview-over-to-next-method-alist)))
	(if f
	    (funcall (cdr f))
	  ))
      )))

(defun mime-preview-scroll-up-entity (&optional h)
  "Scroll up current entity.
If reached to (point-max), it calls function registered in variable
`mime-preview-over-to-next-method-alist'."
  (interactive)
  (if (eobp)
      (let ((f (assq (mime-preview-original-major-mode)
		     mime-preview-over-to-next-method-alist)))
	(if f
	    (funcall (cdr f))
	  ))
    (let ((point
	   (or (next-single-property-change (point) 'mime-view-entity)
	       (point-max)))
	  (bottom (window-end (selected-window))))
      (if (and (not h)
	       (> bottom point))
	  (progn (goto-char point)
		 (recenter next-screen-context-lines))
	(condition-case nil
	    (scroll-up h)
	  (end-of-buffer
	   (goto-char (point-max)))))
      )))

(defun mime-preview-scroll-down-entity (&optional h)
  "Scroll down current entity.
If reached to (point-min), it calls function registered in variable
`mime-preview-over-to-previous-method-alist'."
  (interactive)
  (if (bobp)
      (let ((f (assq (mime-preview-original-major-mode)
		     mime-preview-over-to-previous-method-alist)))
	(if f
	    (funcall (cdr f))
	  ))
    (let ((point
	   (or (previous-single-property-change (point) 'mime-view-entity)
	       (point-min)))
	  (top (window-start (selected-window))))
      (if (and (not h)
	       (< top point))
	  (progn (goto-char point)
		 (recenter (* -1 next-screen-context-lines)))
	(condition-case nil
	    (scroll-down h)
	  (beginning-of-buffer
	   (goto-char (point-min)))))
      )))

(defun mime-preview-next-line-entity (&optional lines)
  "Scroll up one line (or prefix LINES lines).
If LINES is negative, scroll down LINES lines."
  (interactive "p")
  (mime-preview-scroll-up-entity (or lines 1))
  )

(defun mime-preview-previous-line-entity (&optional lines)
  "Scrroll down one line (or prefix LINES lines).
If LINES is negative, scroll up LINES lines."
  (interactive "p")
  (mime-preview-scroll-down-entity (or lines 1))
  )


;;; @@ display
;;;

(defun mime-preview-toggle-display (type &optional display)
  (let ((situation (mime-preview-find-boundary-info t))
	(sym (intern (concat "*" (symbol-name type))))
	entity p-beg p-end)
    (setq p-beg (aref situation 0)
	  p-end (aref situation 1)
	  entity (aref situation 2)
	  situation (get-text-property p-beg 'mime-view-situation))
    (cond ((eq display 'invisible)
	   (setq display nil))
	  (display)
	  (t
	   (setq display
		 (memq (cdr (or (assq sym situation)
				(assq type situation)))
		       '(nil invisible)))))
    (setq situation (put-alist sym (if display
				       'visible
				     'invisible)
			       situation))
    (save-excursion
      (let ((inhibit-read-only t))
	(delete-region p-beg p-end)
	(mime-display-entity entity situation)))
    (let ((ret (assoc situation mime-preview-situation-example-list)))
      (if ret
	  (setcdr ret (1+ (cdr ret)))
	(add-to-list 'mime-preview-situation-example-list
		     (cons situation 0))))))

(defun mime-preview-toggle-header (&optional force-visible)
  (interactive "P")
  (mime-preview-toggle-display 'header force-visible))

(defun mime-preview-toggle-content (&optional force-visible)
  (interactive "P")
  (mime-preview-toggle-display 'body force-visible))

(defun mime-preview-show-header ()
  (interactive)
  (mime-preview-toggle-display 'header 'visible))

(defun mime-preview-show-content ()
  (interactive)
  (mime-preview-toggle-display 'body 'visible))

(defun mime-preview-hide-header ()
  (interactive)
  (mime-preview-toggle-display 'header 'invisible))

(defun mime-preview-hide-content ()
  (interactive)
  (mime-preview-toggle-display 'body 'invisible))

    
;;; @@ quitting
;;;

(defun mime-preview-quit ()
  "Quit from MIME-preview buffer.
It calls function registered in variable
`mime-preview-quitting-method-alist'."
  (interactive)
  (let ((r (assq (mime-preview-original-major-mode)
		 mime-preview-quitting-method-alist)))
    (if r
	(funcall (cdr r))
      )))

(defun mime-preview-kill-buffer ()
  (interactive)
  (kill-buffer (current-buffer))
  )


;;; @ end
;;;

(provide 'mime-view)

(eval-when-compile
  (setq mime-situation-examples-file nil)
  ;; to avoid to read situation-examples-file at compile time.
  )

(mime-view-read-situation-examples-file)

;;; mime-view.el ends here