;;; mime-view.el --- interactive MIME viewer for GNU Emacs  -*- lexical-binding: t -*-

;; 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)
(require 'path-util)

(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
  '("~/.mailcap" "/usr/etc/mailcap" "/etc/mailcap")
  "List of mailcap files."
  :group 'mime-view
  :type '(repeat file))

(defcustom mime-view-buttons-visible t
  "Toggle visibility of MIME buttons."
  :group 'mime-view
  :type 'boolean)

(defcustom mime-view-nobreak-char-display nil
  "Override `nobreak-char-display' in preview buffer.
See `nobreak-char-display' for details."
  :type '(choice (const :tag "Use harcoded face" t)
		 (const :tag "Use escape glyph" escape)
		 (const :tag "No special handling" nil))
  :group 'mime-view)

(defcustom mime-view-multipart/related-show-all-children t
  "When non-nil, do not hide child entities."
  :group 'mime-view
  :type 'boolean)

(defcustom mime-view-multipart/alternative-show-all-children t
  "When non-nil, show hidden descendant entities's buttons in
multipart/alternative entities."
  :group 'mime-view
  :type 'boolean)

(defvar mime-display-multipart/multilingual-unknown-translation-type
  "(unknown)")

(defcustom mime-display-multipart/multilingual-prefered-languages
  (mapcar (lambda (lang)
	    (format "^%s\\(-.+\\)?" (regexp-quote (symbol-name lang))))
	  (let ((result (get-language-info
			 current-language-environment 'iso639-language)))
	    (if (eq result 'en)
		(list result)
	      (cons result '(en)))))
  "Specify language automatically choiced for
multipart/multilingual entities. See docstring of
`mime-display-multipart/multilingual' for details."
  :group 'mime-view
  :type '(repeat regexp))

(defcustom mime-display-multipart/multilingual-translation-type-score
  `(("original" . 2)
    ("human" . 1)
    ("automated" . -1)
    (,mime-display-multipart/multilingual-unknown-translation-type . 0))
  "Specify scores Content-Translation-Type: header fields.  When
score is negative value, corresponding entity is not displayed
automatically.  If field calue is missing or field does not
exist, field value is treated as \"(unknown)\".  See docstring of
`mime-display-multipart/multilingual' for details."
  :group 'mime-view
  :type '(repeat (cons string integer)))

(defcustom mime-display-multipart/multilingual-interactive nil
  "When non-nil, you are asked which language entity should be
displayed for multipart/multilingual entity."
  :group 'mime-view
  :type 'boolean)

(defcustom mime-view-text/html-score 3
  "Score for text/html entity when previewer is available."
  :group 'mime-view
  :type 'integer)

(defcustom mime-view-text/html-previewer-alist
  (delq nil `((w3m mime-w3m-preview-text/html mime-w3m)
	      ,(and (fboundp 'libxml-parse-html-region)
		    '(shr mime-shr-preview-text/html mime-shr))
	      (w3 mime-preview-text/html mime-w3)))
  "Alist for text/html entity previewer.
Each element is a list consists of required module, previewer
function and required feature for previewer function."
  :group 'mime-view
  :type '(repeat (list (symbol :tag "Module")
		       (symbol :tag "Function")
		       (symbol :tag "Feature"))))

(defcustom mime-view-text/html-previewer
  (let ((alist mime-view-text/html-previewer-alist))
    (while (and alist (null (module-installed-p (caar alist))))
      (setq alist (cdr alist)))
    (caar alist))
  "Indicate text/html entity previewer.  Possible vaules are each
car of `mime-view-text/html-previewer-alist' element or nil.
When this value is nil or previewer is not available, text/html
entity is displayed as if text/plain part."
  :group 'mime-view
  :type `(choice ,@(mapcar (lambda (elt) (list 'const (car elt)))
			   mime-view-text/html-previewer-alist)
		 (const :tag "Disable previewer" nil)))

(defcustom mime-display-text/plain-flowed-fill-column nil
  "Fill column for formatting flowed text."
  :group 'mime-view
  :type '(choice (integer :tag "Fixed value")
		 (number :tag "ratio to window's width")
		 (sexp :tag "S-expression")
		 (const :tag "Use fill-column's value" nil)))

(defcustom mime-pgp-verify-when-preview t
  "When non-nil, verify signed part while viewing."
  :group 'mime-view
  :type 'boolean)

(defcustom mime-pgp-decrypt-when-preview nil
  "When non-nil, decrypt encrypted part while viewing."
  :group 'mime-view
  :type 'boolean)

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

(defvar-local mime-preview-buffer nil
  "MIME-preview buffer corresponding with the (raw) 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-local 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'.")

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

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

(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)
      (with-current-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-filename entity)
      (mime-entity-read-field entity 'Subject)
      ""))

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

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

(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
	      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)
        (when file
          (with-temp-buffer
	    (setq buffer-file-coding-system
		  (or mime-situation-examples-file-coding-system
		      buffer-file-coding-system))
	    (insert ";;; " (file-name-nondirectory file)
		    " -*- mode: emacs-lisp; coding: "
		    (symbol-name
		     (coding-system-base buffer-file-coding-system))
		    "; lexical-binding: nil; -*-\n"
		    "\n;; This file is generated automatically by "
		    mime-view-version "\n\n"
		    ";;; 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")
            (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))
		   (language (mime-entity-read-field
			      entity "Content-Language"))
		   (rest (format " <%s/%s%s%s%s>"
				 (mime-entity-media-type entity)
				 (mime-entity-media-subtype entity)
				 (if language
				     (concat " (" language ")")
				   "")
				 (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)

(defun mime-calist::field-match-method-ignore-case (calist
						    field-type field-value)
  (let ((s-field (assoc field-type calist)))
    (cond ((null s-field)
	   (cons (cons field-type field-value) calist))
	  ((eq field-value t)
	   calist)
	  ((string= (downcase (cdr s-field)) (downcase field-value))
	   calist))))

(define-calist-field-match-method
  'access-type #'mime-calist::field-match-method-ignore-case)


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . message)(subtype . rfc822)
   (body . visible)
   (major-mode . t)
   (body-presentation-method . mime-display-message/rfc822)
   (childrens-situation (header . visible))))

(ctree-set-calist-strictly
 'mime-preview-condition
 '((type . message)(subtype . news)
   (body . visible)
   (major-mode . t)
   (body-presentation-method . mime-display-message/rfc822)
   (childrens-situation (header . visible))))


;;; @@@ entity presentation
;;;

(defun mime-display-insert-text-content (entity)
  (condition-case signal
      (progn (mime-insert-text-content entity)
	     (run-hooks 'mime-text-decode-hook)
	     t)
    (error   (let ((point (point)))
	       (insert (format "This entity can't be decoded.  %s"
			       (or (cadr signal) "")))
	       (add-text-properties point (point) '(face highlight)))
	     (insert "\nHere is original data.\n\n")
	     (mime-insert-entity-body entity)
	     nil)))

(defun mime-display-text/plain-flowed-parse-line ()
  (cons (point)
	(cond
	 ;; End of buffer
	 ((eobp) nil)
	 ;; Signature separator line
	 ((looking-at "\\(>+\\)? ?\\(-- \\)$")
	  (list (length (match-string 1)) 'hard (match-beginning 2)))
	 ;; Quoted line
	 ((looking-at "\\(>+\\) ?\\(.*?\\)\\( ?\\)$")
	  (list (length (match-string 1))
		(if (zerop (length (match-string 3))) t nil)
		(match-beginning 2)))
	 ;; Stuffed or normal line
	 ((looking-at " ?\\(.*?\\)\\( ?\\)$")
	  (list 0 (if (zerop (length (match-string 2))) t nil)
		(match-beginning 1))))))

(defun mime-display-text/plain-flowed (&optional buffer delete-space)
  (with-current-buffer (or buffer (current-buffer))
    (goto-char (point-min))
    (let ((fill-column
	   (cond
	    ((and (integerp mime-display-text/plain-flowed-fill-column)
		  (< mime-display-text/plain-flowed-fill-column 1))
	     (+ (window-width) mime-display-text/plain-flowed-fill-column))
	    ((integerp mime-display-text/plain-flowed-fill-column)
	     mime-display-text/plain-flowed-fill-column)
	    ((numberp mime-display-text/plain-flowed-fill-column)
	     (floor
	      (* (window-width) mime-display-text/plain-flowed-fill-column)))
	    (mime-display-text/plain-flowed-fill-column
	     (eval mime-display-text/plain-flowed-fill-column))
	    (t fill-column)))
	  (line (mime-display-text/plain-flowed-parse-line))
	  beg-flow depth next point fill-prefix adaptive-fill-mode)
      (setq delete-space (if delete-space -2 -1))
      (while (cdr line)
	(unless (eq (point) (car line))
	  (setcar (cdr (cddr line)) (+ (nth 3 line) (- (point) (car line))))
	  (setcar line (point)))
	(forward-line)
	(setq next (mime-display-text/plain-flowed-parse-line))
	(when (or (null (cdr next))
		  (null (eq (nth 1 line) (nth 1 next)))
		  (eq (nth 2 next) 'hard))
	  (setcar (cddr line) t))
	(if beg-flow
	    ;; Following flowed line.
	    (progn
	      (delete-region (+ (car line) delete-space) (nth 3 line))
	      (when (nth 2 line)
		;; Fixed line
		(setq fill-prefix (unless (zerop depth)
				    (concat (make-string depth ?>) " ")))
		(fill-region beg-flow (point) 'left t)
		(setq beg-flow nil)))
	  ;; Following fixed line.
	  (if (zerop (nth 1 line))
	      ;; Remove stuffed space
	      (delete-region (car line) (nth 3 line))
	    (when (eq (+ (car line) (nth 1 line)) (nth 3 line))
	      ;; Insert stuffing space for quoted text
	      (setq point (point))
	      (goto-char (nth 3 line))
	      (insert 32)
	      (goto-char (1+ point))))
	  (unless (nth 2 line)
	    ;; Beginnig of flowed text
	    (setq beg-flow (car line)
		  depth (nth 1 line))))
	(setq line next)))))

(defun mime-display-text/plain (entity situation)
  (save-restriction
    (narrow-to-region (point-max)(point-max))
    (when (mime-display-insert-text-content entity)
      (when (null (eq (char-before (point-max)) ?\n))
	(goto-char (point-max))
	(insert "\n"))
      (when (equal (downcase (or (cdr (assoc "format" situation)) ""))
		   "flowed")
	(mime-display-text/plain-flowed
	 nil (equal (downcase (or (cdr (assoc "delsp" situation)) ""))
		    "yes")))
      (mime-add-url-buttons)
      (run-hooks 'mime-display-text/plain-hook))))

(autoload 'richtext-decode "richtext")

(defun mime-display-text/richtext (entity _situation)
  (save-restriction
    (narrow-to-region (point-max)(point-max))
    (when (mime-display-insert-text-content entity)
      (remove-text-properties (point-min) (point-max) '(face nil))
      (richtext-decode (point-min) (point-max)))))

(defun mime-display-text/enriched (entity _situation)
  (save-restriction
    (narrow-to-region (point-max)(point-max))
    (when (mime-display-insert-text-content entity)
      (remove-text-properties (point-min) (point-max) '(face nil))
      (enriched-decode (point-min) (point-max)))))

(defun mime-display-text/html-previewer-params ()
  (and mime-view-text/html-previewer
       (or (assq mime-view-text/html-previewer
		 mime-view-text/html-previewer-alist)
	   ;; For compatibility with mime-setup-enable-inline-html.
	   (assq 'w3 mime-view-text/html-previewer-alist))))

(defun mime-display-text/html (entity situation)
  (let ((list (mime-display-text/html-previewer-params)))
    (if (and list
	     (require (nth 2 list) nil t)
	     (fboundp (nth 1 list)))
	(funcall (nth 1 list) entity situation)
      ;; text/html entity previewer is not available.
      (mime-display-text/plain entity situation))))


(defvar mime-view-announcement-for-message/partial
  (when 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-message/rfc822 (entity situation)
  (let ((child (car (mime-entity-children entity)))
	(default-situation
	  (copy-alist
	   (delq nil (cons (assq 'major-mode situation)
			   (cdr (assq 'childrens-situation situation)))))))
    (mime-display-entity
     child nil
     (if (memq (mime-entity-media-type child)
	       '(text multipart nil))
	 (put-alist 'entity-button 'invisible default-situation)
       (put-alist 'button-position 'after default-situation)))))

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

(defvar mime-view-entity-lowest-score -1)

(defcustom mime-view-type-subtype-score-alist
  '(((text . enriched) . 3)
    ((text . richtext) . 2)
    ((text . plain)    . 1)
    ((text . html)     . mime-view-text/html-entity-score)
    (multipart . mime-view-multipart-entity-score))
  "Alist MEDIA-TYPE vs corresponding score.
MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default.

If MEDIA-TYPE does not have corresponding score,
`mime-view-entity-lowest-score' is used.
Score is integer or function or variable.  The function receives
entity and returns integer."
  :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))
		       (choice (integer :tag "score")
			       (function :tag "function")
			       (variable :tag "variable")))))

(defun mime-view-entity-score (entity &optional situation)
  (or situation (setq situation (mime-entity-situation entity)))
  (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)))))
    (cond
     ((functionp score)
      (setq score (funcall score entity)))
     ((and (symbolp score) (boundp score))
      (setq score (symbol-value score))))
    (if (numberp score)
	score
      mime-view-entity-lowest-score)))

(defun mime-view-multipart-entity-score (entity)
  (apply 'max (or (mapcar 'mime-view-entity-score
			  (mime-entity-children entity))
		  (list (or (assq t mime-view-type-subtype-score-alist)
			    mime-view-entity-lowest-score)))))

(defun mime-view-text/html-entity-score (_entity)
  ;; Module loading is done in mime-display-text/html.
  ;; So, availability is not checked here.
  (if (mime-display-text/html-previewer-params)
      mime-view-text/html-score
    mime-view-entity-lowest-score))

(defun mime-view-multipart-descendant-button (entity situation)
  (let ((default-situation
	  (delq nil (cons (assq 'major-mode situation)
			  (cdr (assq 'childrens-situation situation))))))
    (mapc
     (lambda (child)
       (setq situation (copy-alist (mime-find-entity-preview-situation
				    child default-situation)))
       (mime-display-entity
	child nil (if (eq (cdr (assq 'type situation)) 'multipart)
		      (put-alist 'body-presentation-method
				 'mime-view-multipart-descendant-button
				 situation)
		    (put-alist 'body 'invisible situation))))
     (mime-entity-children entity))))

(defun mime-display-multipart/alternative (entity situation)
  (let ((original-major-mode-cell (assq 'major-mode situation))
	(default-situation
	  (cdr (assq 'childrens-situation situation)))
	(max-score 0)
	p pairs
	child-situation score)
    (when original-major-mode-cell
      (setq default-situation
	    (cons original-major-mode-cell default-situation)))
    (setq pairs
	  (mapcar
	   (lambda (child)
	     (setq child-situation
		   (mime-find-entity-preview-situation
		    child default-situation))
	     (when (cdr (assq 'body-presentation-method child-situation))
	       (setq score (mime-view-entity-score child child-situation))
	       (when (>= score max-score)
		 (setq p child
		       max-score score)))
	     (cons child child-situation))
	   (mime-entity-children entity)))
    (or p (setq p (caar pairs)))
    (mapc (lambda (pair)
	    (mime-display-entity
	     (car pair) nil
	     (cond
	      ((eq p (car pair))
	       (cdr pair))
	      ((and mime-view-multipart/alternative-show-all-children
		    (eq (cdr (assq 'type (cdr pair))) 'multipart))
	       (put-alist 'body-presentation-method
			  'mime-view-multipart-descendant-button
			  (copy-alist (cdr pair))))
	      (t (put-alist 'body 'invisible (copy-alist (cdr pair)))))))
	  pairs)))

(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))))
    (if original-major-mode-cell
	(setq default-situation
	      (cons original-major-mode-cell default-situation)))
    (mapc
     (lambda (child)
       (cond
	((eq start child)
	 (mime-display-entity start nil default-situation))
	(mime-view-multipart/related-show-all-children
	 (let ((child-situation (copy-alist (mime-find-entity-preview-situation
					     child default-situation))))
	   (mime-display-entity
	    child nil
	    (if (eq (mime-entity-media-type child) 'multipart)
		(put-alist 'body-presentation-method
			   'mime-view-multipart-descendant-button
			   child-situation)
	      (put-alist 'body 'invisible child-situation)))))))
     (mime-entity-children entity))))

(defun mime-display-multipart/multilingual-select-interactively (pairs)
  (let (count counts result elt)
    (setq pairs
	  (dolist (pair pairs (nreverse result))
	    (when (caar pair)
	      (setq elt (format "%s/%s"
				(or (caar pair) "")
				(or (cdar pair)
				    mime-display-multipart/multilingual-unknown-translation-type)))
	      (if (setq count (assoc elt counts))
		  (setq elt
			(format "%s:%d" elt (setcdr count (1+ (cdr count)))))
		(setq counts (cons (cons elt 1) counts)))
	      (setq result (cons (cons elt (cdr pair)) result)))))
    (when (> (length pairs) 0)
      (cdr (assoc
	    (completing-read
	     "Which language is displayed for this multilingual message? "
	     (mapcar 'car pairs) nil t nil nil (caar pairs))
	    pairs)))))

(defun mime-display-multipart/multilingual-select-automatically (pairs)
  (let ((max-score '(0 . 0))
	(case-fold-search t)
	score choice first zxx)
    (dolist (pair pairs)
      (when (caar pair)
	(unless first
	  ;; The first language message part
	  (setq first (cdr pair)))
	(when (string-match "^zxx$" (caar pair))
	  ;; The language-independent message part
	  (setq zxx (cdr pair)))
	(setq score
	      (cons
	       (let ((langs
		      mime-display-multipart/multilingual-prefered-languages))
		 (catch 'done
		   (while langs
		     (when (string-match (car langs) (caar pair))
		       (throw 'done (length langs)))
		     (setq langs (cdr langs)))
		   -1))
	       (or
		(cdr
		 (assoc
		  (or (cdar pair)
		      mime-display-multipart/multilingual-unknown-translation-type)
		  mime-display-multipart/multilingual-translation-type-score))
		-1)))
	(when (or (> (cdr score) (cdr max-score))
		  (and (eq (cdr score) (cdr max-score))
		       (> (car score) (car max-score))))
	  (setq max-score score)
	  (setq choice (cdr pair)))))
    (or choice zxx first)))

(defun mime-display-multipart/multilingual (entity situation)
  "MIME-View mode preview method for multipart/multilingual entity.
When `mime-display-multipart/multilingual-interactive' is nil,
select child entity to display automatically.
Automatic selection algorithm is below.

1. Select highest score entity calculated from
Content-Translation-Type: field and
`mime-display-multipart/multilingual-translation-type-score'.
But if score is negative, never selected.
2. If there are multiple highest score entities, select entities
whose Content-Language: field values matches former element of
`mime-display-multipart/multilingual-prefered-languages'.  If not
matched, never selected.
3. If no entity is selected, select the language-independent
part (if exist) or the first language message part."
  (let ((default-situation
	  (delq nil (cons (assq 'major-mode situation)
			  (cdr (assq 'childrens-situation situation)))))
	choice pairs)
    (setq pairs
	  (mapcar
	   (lambda (child)
	     (cons (cons
		    (cdr (assq 'atom
			       (std11-lexical-analyze
				(mime-entity-read-field
				 child "Content-Language"))))
		    (cdr (assq 'atom
			       (std11-lexical-analyze
				(mime-entity-fetch-field
				 child "Content-Translation-Type")))))
		   child))
	   (mime-entity-children entity)))
    (setq choice
	  (if mime-display-multipart/multilingual-interactive
	      (mime-display-multipart/multilingual-select-interactively pairs)
	    (mime-display-multipart/multilingual-select-automatically pairs)))
    (mapc (lambda (child)
	    (mime-display-entity
	     child nil
	     (if (eq choice child)
		 default-situation
	       (put-alist 'body 'invisible
			  (copy-alist (mime-find-entity-preview-situation
				       child default-situation))))))
	  (mime-entity-children entity))))

;;; @ 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
	    (if mime-mailcap-file
		(cons mime-mailcap-file
		      (remove mime-mailcap-file mime-view-mailcap-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")
   (major-mode . t)
   (method . mime-detect-content)))

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

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

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

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

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

(ctree-set-calist-strictly
 'mime-acting-condition
 '((type . application)(subtype . octet-stream)
   (major-mode . t)
   (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-visible-p (elements situation &optional default)
  (catch 'done
    (let (result)
      (while elements
	(when (setq result (cdr (assq (car elements) situation)))
	  (unless (memq result '(visible invisible))
	    (setq result (cond ((functionp result)
				(funcall result situation))
			       ((and (symbolp result) (boundp result))
				(symbol-value result))
			       (t default))))
	  ;; Non-nil values other than invisible are treated as
	  ;; visible.
	  (throw 'done (if (memq result '(invisible nil))
			   nil t)))
	(setq elements (cdr elements))))
    default))

(defvar mime-display-header-hook nil)

(defun mime-display-entity (entity &optional situation
				   default-situation preview-buffer)
  (or preview-buffer
      (setq preview-buffer (current-buffer)))
  (let* (nb ne nbb)
    (in-calist-package 'mime-view)
    (or situation
	(setq situation
	      (mime-find-entity-preview-situation entity default-situation)))
    (let ((button-is-visible
	   (and mime-view-buttons-visible
		(mime-display-entity-visible-p
		 '(*entity-button entity-button) situation t)))
	  (button-position (cdr (assq 'button-position situation)))
	  (header-is-visible
	   (mime-display-entity-visible-p '(*header header) situation))
	  (body-is-visible
	   (mime-display-entity-visible-p '(*body body) situation))
	  (children (mime-entity-children entity)))
      (set-buffer preview-buffer)
      (setq nb (point))
      (narrow-to-region nb nb)
      (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)))))
	    (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 nb (point-max) 'mime-view-entity-header entity)
	    (goto-char (point-max))
	    (insert "\n")))
      (when button-is-visible
	(unless (eq button-position 'after)
	  (goto-char (point-min)))
	(mime-view-insert-entity-button entity)
	(goto-char (point-max)))
      (setq nbb (point))
      (unless children
	(when 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))))
	(goto-char (point-max))
	;; Insert LF if needed.
	(unless (eq (preceding-char) 10) (insert 10)))
      (setq ne (or (next-single-property-change nb 'mime-view-entity)
		   (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")

(defvar mime-view-popup-menu
  (let ((menu (make-sparse-keymap mime-view-menu-title)))
    (nconc menu
           (mapcar (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 mime-view-mode-map
  (let ((keymap (make-sparse-keymap)))
    (mapc (lambda (elt)
	    (when elt
	      (define-key keymap (car elt) (cdr elt))))
	  `(("u"            . mime-preview-move-to-upper)
	    ("p"            . mime-preview-move-to-previous)
	    ("n"            . mime-preview-move-to-next)
	    ("\e\t"         . mime-preview-move-to-previous)
	    ("\t"           . mime-preview-move-to-next)
	    (" "            . mime-preview-scroll-up-entity)
	    ("\M- "         . mime-preview-scroll-down-entity)
	    ("\177"         . mime-preview-scroll-down-entity)
	    ("\C-m"         . mime-preview-next-line-entity)
	    ("\C-\M-m"      . mime-preview-previous-line-entity)
	    ("v"            . mime-preview-play-current-entity)
	    ("e"            . mime-preview-extract-current-entity)
	    ("\C-c\C-p"     . mime-preview-print-current-entity)
	    ("\C-c\C-t\C-f" . mime-preview-toggle-header)
	    ("\C-c\C-th"    . mime-preview-toggle-header)
	    ("\C-c\C-t\C-c" . mime-preview-toggle-content)
	    ("\C-c\C-v\C-f" . mime-preview-show-header)
	    ("\C-c\C-vh"    . mime-preview-show-header)
	    ("\C-c\C-v\C-c" . mime-preview-show-content)
	    ("\C-c\C-d\C-f" . mime-preview-hide-header)
	    ("\C-c\C-dh"    . mime-preview-hide-header)
	    ("\C-c\C-d\C-c" . mime-preview-hide-content)
	    ("a"            . mime-preview-follow-current-entity)
	    ("q"            . mime-preview-quit)
	    ("\C-c\C-x"     . mime-preview-kill-buffer)
	    ("?"            . describe-mode)
	    ([tab]          . mime-preview-move-to-next)
	    ([delete]       . mime-preview-scroll-down-entity)
	    ([backspace]    . mime-preview-scroll-down-entity)
	    ([mouse-2]      . mime-button-dispatcher)
	    ([mouse-3]      . mime-view-popup-menu)
	    ([menu-bar mime-view] .
	     ,(cons mime-view-menu-title
		    (make-sparse-keymap mime-view-menu-title)))))
    (mapc (lambda (item)
	    (define-key keymap
			(vector 'menu-bar 'mime-view (car item))
			(cons (nth 1 item) (nth 2 item))))
	  (reverse mime-view-menu-list))
    keymap))

(make-obsolete-variable 'mime-view-mode-default-map
			'mime-view-mode-map "8 Jun 2025")


(defun mime-view-define-keymap (&optional default)
  (let ((keymap (copy-keymap mime-view-mode-map)))
    (cond
     ((keymapp default)
      (set-keymap-parent keymap default))
     ((functionp default)
      (setq keymap
	    (append keymap (list (cons t default))))))
    ;; (run-hooks 'mime-view-define-keymap-hook)
    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
	(with-current-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-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")
      (make-local-variable 'nobreak-char-display)
      (setq nobreak-char-display mime-view-nobreak-char-display)
      ;; Do not hide button when first entity is
      ;; neither text nor multipart.
      (mime-display-entity
       message nil `(,(if (memq (mime-entity-media-type message)
				'(text multipart nil))
			  '(entity-button . invisible)
			'(button-position . after))
		     (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-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
	    (with-current-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)
  (let (message)
    (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 message (mime-open-entity type raw-buffer))
	  (or (mime-entity-content-type message)
	      (mime-entity-set-content-type message ctl)))
	(or (mime-entity-encoding message)
	    (mime-entity-set-encoding message encoding))))
    (mime-display-message message 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)
      ;; Do not use `with-current-buffer'.  Inner save-excursion(),
      ;; the current buffer may be accessed.
      (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
		  (with-current-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 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)

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

;;; mime-view.el ends here
