mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1994/07/13
   7 ;;      Renamed: 1994/08/31 from tm-body.el
   8 ;;      Renamed: 1997/02/19 from tm-view.el
   9 ;; Keywords: MIME, multimedia, mail, news
  10
  11 ;; This file is part of SEMI (Sample of Elastic MIME Interfaces).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Code:
  29
  30 (require 'emu)
  31 (require 'mime)
  32 (require 'semi-def)
  33 (require 'calist)
  34 (require 'alist)
  35 (require 'mailcap)
  36
  37
  38 ;;; @ version
  39 ;;;
  40
  41 (defconst mime-view-version
  42   (concat (mime-product-name mime-user-interface-product) " MIME-View "
  43           (mapconcat #'number-to-string
  44                      (mime-product-version mime-user-interface-product) ".")
  45           " (" (mime-product-code-name mime-user-interface-product) ")"))
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defgroup mime-view nil
  52   "MIME view mode"
  53   :group 'mime)
  54
  55 (defcustom mime-view-find-every-acting-situation t
  56   "*Find every available acting-situation if non-nil."
  57   :group 'mime-view
  58   :type 'boolean)
  59
  60 (defcustom mime-acting-situation-examples-file "~/.mime-example"
  61   "*File name of example about acting-situation demonstrated by user."
  62   :group 'mime-view
  63   :type 'file)
  64
  65 (defcustom mime-preview-move-scroll nil
  66   "*Decides whether to scroll when moving to next entity.
  67 When t, scroll the buffer.  Non-nil but not t means scroll when
  68 the next entity is within `next-screen-context-lines' from top or
  69 buttom.  Nil means don't scroll at all."
  70   :group 'mime-view
  71   :type '(choice (const :tag "Off" nil)
  72                  (const :tag "On" t)
  73                  (sexp :tag "Situation" 1)))
  74
  75 (defcustom mime-preview-scroll-full-screen nil
  76   "*When non-nil, always scroll full screen.
  77 If nil, point will be moved to the next entity if exists."
  78   :group 'mime-view
  79   :type '(choice (const :tag "On" t)
  80                  (const :tag "Off" nil)))
  81
  82 (defcustom mime-view-force-inline-types '(text multipart)
  83   "*List of MIME types that \"attachment\" should be ignored.
  84 The element can be type or type/subtype. When t, inline everything
  85 if possible."
  86   :group 'mime-view
  87   :type '(choice (const :tag "Nothing" nil)
  88                  (const :tag "All" t)
  89                  (list (repeat symbol))))
  90
  91 (defcustom mime-view-button-place-alist
  92   '((message . around)
  93     (application . before)
  94     (multipart/alternative . around))
  95   "*Alist of MIME type or type/subtype vs. button place.
  96 When around, button will be inserted before and after that part.
  97 When after or before, button will be inserted that place.
  98 If not specified, that type will not have button."
  99   :group 'mime-view
 100   :type '(choice (const :tag "Nothing" nil)
 101                  (list (repeat symbol))))
 102
 103 ;; Rename this.
 104 (defcustom mime-view-type-subtype-score-alist
 105   '(((text . enriched) . 3)
 106     ((text . richtext) . 2)
 107     ((text . plain)    . 1)
 108     (t . 0))
 109   "Alist MEDIA-TYPE vs corresponding score.
 110 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 111   :group 'mime-view
 112   :type '(repeat (cons (choice :tag "Media-Type"
 113                                (cons :tag "Type/Subtype"
 114                                      (symbol :tag "Primary-type")
 115                                      (symbol :tag "Subtype"))
 116                                (symbol :tag "Type")
 117                                (const :tag "Default" t))
 118                        integer)))
 119
 120 (defcustom mime-view-mailcap-files
 121     (if (memq system-type '(ms-dos ms-windows windows-nt))
 122       '("~/mail.cap" "~/etc/mail.cap" "~/.mailcap")
 123       '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"
 124         "/usr/local/etc/mailcap"))
 125     "*Search path of mailcap files."
 126     :group 'mime
 127     :type '(repeat file))
 128
 129 (defvar mime-view-automatic-conversion
 130   (cond ((featurep 'xemacs)
 131          'automatic-conversion)
 132         ((boundp 'MULE)
 133          '*autoconv*)
 134         (t
 135          'undecided)))
 136
 137 ;;; @ in raw-buffer (representation space)
 138 ;;;
 139
 140 (defvar mime-preview-buffer nil
 141   "MIME-preview buffer corresponding with the (raw) buffer.")
 142 (make-variable-buffer-local 'mime-preview-buffer)
 143
 144
 145 (defvar mime-raw-representation-type-alist
 146   '((mime-show-message-mode     . binary)
 147     (mime-temp-message-mode     . binary)
 148     (t                          . cooked))
 149   "Alist of `major-mode' vs. representation-type of mime-raw-buffer.
 150 Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
 151 `major-mode' or t.  t means default.  REPRESENTATION-TYPE must be
 152 `binary' or `cooked'.")
 153
 154
 155 ;; (defun mime-raw-find-entity-from-point (point &optional message-info)
 156 ;;   "Return entity from POINT in mime-raw-buffer.
 157 ;; If optional argument MESSAGE-INFO is not specified,
 158 ;; `mime-message-structure' is used."
 159 ;;   (or message-info
 160 ;;       (setq message-info mime-message-structure))
 161 ;;   (if (and (<= (mime-entity-point-min message-info) point)
 162 ;;            (<= point (mime-entity-point-max message-info)))
 163 ;;       (let ((children (mime-entity-children message-info)))
 164 ;;         (catch 'tag
 165 ;;           (while children
 166 ;;             (let ((ret
 167 ;;                    (mime-raw-find-entity-from-point point (car children))))
 168 ;;               (if ret
 169 ;;                   (throw 'tag ret)
 170 ;;                 ))
 171 ;;             (setq children (cdr children)))
 172 ;;           message-info))))
 173 ;; (make-obsolete 'mime-raw-find-entity-from-point "don't use it.")
 174
 175
 176 ;;; @ in preview-buffer (presentation space)
 177 ;;;
 178
 179 (defvar mime-mother-buffer nil
 180   "Mother buffer corresponding with the (MIME-preview) buffer.
 181 If current MIME-preview buffer is generated by other buffer, such as
 182 message/partial, it is called `mother-buffer'.")
 183 (make-variable-buffer-local 'mime-mother-buffer)
 184
 185 ;; (defvar mime-raw-buffer nil
 186 ;;   "Raw buffer corresponding with the (MIME-preview) buffer.")
 187 ;; (make-variable-buffer-local 'mime-raw-buffer)
 188
 189 (defvar mime-preview-original-window-configuration nil
 190   "Window-configuration before `mime-view-mode' is called.")
 191 (make-variable-buffer-local 'mime-preview-original-window-configuration)
 192
 193 (defun mime-preview-original-major-mode (&optional recursive point)
 194   "Return major-mode of original buffer.
 195 If optional argument RECURSIVE is non-nil and current buffer has
 196 mime-mother-buffer, it returns original major-mode of the
 197 mother-buffer."
 198   (if (and recursive mime-mother-buffer)
 199       (save-excursion
 200         (set-buffer mime-mother-buffer)
 201         (mime-preview-original-major-mode recursive))
 202     (cdr (assq 'major-mode
 203                (get-text-property (or point
 204                                       (if (> (point) (buffer-size))
 205                                           (max (1- (point-max)) (point-min))
 206                                         (point)))
 207                                   'mime-view-situation)))))
 208
 209
 210 ;;; @ entity information
 211 ;;;
 212
 213 (defun mime-entity-situation (entity &optional situation)
 214   "Return situation of ENTITY."
 215   (let (rest param name)
 216     ;; Content-Type
 217     (unless (assq 'type situation)
 218       (setq rest (or (mime-entity-content-type entity)
 219                      (make-mime-content-type 'text 'plain))
 220             situation (cons (car rest) situation)
 221             rest (cdr rest)))
 222     (unless (assq 'subtype situation)
 223       (or rest
 224           (setq rest (or (cdr (mime-entity-content-type entity))
 225                          '((subtype . plain)))))
 226       (setq situation (cons (car rest) situation)
 227             rest (cdr rest)))
 228     (while rest
 229       (setq param (car rest))
 230       (or (assoc (car param) situation)
 231           (setq situation (cons param situation)))
 232       (setq rest (cdr rest)))
 233
 234     ;; Content-Disposition
 235     (setq rest nil)
 236     (unless (assq 'disposition-type situation)
 237       (setq rest (mime-entity-content-disposition entity))
 238       (if rest
 239           (setq situation (cons (cons 'disposition-type
 240                                       (mime-content-disposition-type rest))
 241                                 situation)
 242                 rest (mime-content-disposition-parameters rest))))
 243     (while rest
 244       (setq param (car rest)
 245             name (car param))
 246       (if (cond ((string= name "filename")
 247                  (if (assq 'filename situation)
 248                      nil
 249                    (setq name 'filename)))
 250                 ((string= name "creation-date")
 251                  (if (assq 'creation-date situation)
 252                      nil
 253                    (setq name 'creation-date)))
 254                 ((string= name "modification-date")
 255                  (if (assq 'modification-date situation)
 256                      nil
 257                    (setq name 'modification-date)))
 258                 ((string= name "read-date")
 259                  (if (assq 'read-date situation)
 260                      nil
 261                    (setq name 'read-date)))
 262                 ((string= name "size")
 263                  (if (assq 'size situation)
 264                      nil
 265                    (setq name 'size)))
 266                 (t (setq name (cons 'disposition name))
 267                    (if (assoc name situation)
 268                        nil
 269                      name)))
 270           (setq situation
 271                 (cons (cons name (cdr param))
 272                       situation)))
 273       (setq rest (cdr rest)))
 274
 275     ;; Content-Transfer-Encoding
 276     (or (assq 'encoding situation)
 277         (setq situation
 278               (cons (cons 'encoding (or (mime-entity-encoding entity)
 279                                         "7bit"))
 280                     situation)))
 281
 282     situation))
 283
 284 (defun mime-view-entity-title (entity)
 285   (or (mime-entity-read-field entity 'Content-Description)
 286       (mime-entity-read-field entity 'Subject)
 287       (mime-entity-filename entity)
 288       ""))
 289
 290
 291 ;; (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
 292 ;;   "Return entity-node-id from POINT in mime-raw-buffer.
 293 ;; If optional argument MESSAGE-INFO is not specified,
 294 ;; `mime-message-structure' is used."
 295 ;;   (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
 296
 297 ;; (make-obsolete 'mime-raw-point-to-entity-node-id "don't use it.")
 298
 299 ;; (defsubst mime-raw-point-to-entity-number (point &optional message-info)
 300 ;;   "Return entity-number from POINT in mime-raw-buffer.
 301 ;; If optional argument MESSAGE-INFO is not specified,
 302 ;; `mime-message-structure' is used."
 303 ;;   (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
 304
 305 ;; (make-obsolete 'mime-raw-point-to-entity-number "don't use it.")
 306
 307 ;; (defun mime-raw-flatten-message-info (&optional message-info)
 308 ;;   "Return list of entity in mime-raw-buffer.
 309 ;; If optional argument MESSAGE-INFO is not specified,
 310 ;; `mime-message-structure' is used."
 311 ;;   (or message-info
 312 ;;       (setq message-info mime-message-structure))
 313 ;;   (let ((dest (list message-info))
 314 ;;         (rcl (mime-entity-children message-info)))
 315 ;;     (while rcl
 316 ;;       (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
 317 ;;       (setq rcl (cdr rcl)))
 318 ;;     dest))
 319
 320 (defmacro mime-view-header-is-visible (situation)
 321   `(eq (cdr (or (assq '*header ,situation)
 322                 (assq 'header ,situation)))
 323        'visible))
 324
 325 (defmacro mime-view-body-is-visible (situation)
 326   `(eq (cdr (or (assq '*body ,situation)
 327                 (assq 'body ,situation)))
 328        'visible))
 329
 330 (defmacro mime-view-children-is-invisible (situation)
 331   `(eq (cdr (or (assq '*children ,situation)
 332                 (assq 'children ,situation)))
 333        'invisible))
 334
 335 (defmacro mime-view-button-is-visible (situation)
 336   ;; Kludge.
 337   `(or (eq (or (cdr (assq '*entity-button ,situation))
 338                (cdr (assq 'entity-button ,situation)))
 339            'visible)
 340        (and (not (eq (or (cdr (assq '*entity-button ,situation))
 341                          (cdr (assq 'entity-button ,situation)))
 342                      'invisible))
 343             (mime-view-entity-button-visible-p entity))))
 344
 345 ;;; @ presentation of preview
 346 ;;;
 347
 348 ;;; @@ entity-button
 349 ;;;
 350
 351 ;;; @@@ predicate function
 352 ;;;
 353
 354 ;; #### fix flim
 355 (defun mime-view-entity-type/subtype (entity)
 356   (if (not (mime-entity-media-type entity))
 357       'text/plain
 358     (intern (format "%s/%s"
 359                     (mime-entity-media-type entity)
 360                     (mime-entity-media-subtype entity)))))
 361
 362 (defun mime-view-entity-button-visible-p (entity)
 363   "Return non-nil if header of ENTITY is visible.
 364 You can customize the visibility by changing `mime-view-button-place-alist'."
 365   (or
 366    ;; Check current entity
 367    ;; type/subtype
 368    (memq (cdr (assq (mime-view-entity-type/subtype entity)
 369                     mime-view-button-place-alist))
 370          '(around before))
 371    ;; type
 372    (memq (cdr (assq (mime-entity-media-type entity)
 373                     mime-view-button-place-alist))
 374          '(around before))
 375    (and (mime-entity-parent entity)
 376         (let ((prev-entity
 377                (cadr (memq entity
 378                            (reverse (mime-entity-children
 379                                      (mime-entity-parent entity)))))))
 380           ;; When previous entity exists
 381           (and prev-entity
 382                (or
 383                 ;; Check previous entity
 384                 ;; type/subtype
 385                 (memq (cdr
 386                        (assq
 387                         (mime-view-entity-type/subtype prev-entity)
 388                         mime-view-button-place-alist))
 389                       '(around after))
 390                 ;; type
 391                 (memq (cdr
 392                        (assq
 393                         (mime-entity-media-type prev-entity)
 394                         mime-view-button-place-alist))
 395                       '(around after))))))
 396    ;; default for everything.
 397    (memq (cdr (assq t
 398                     mime-view-button-place-alist))
 399          '(around before))))
 400
 401 ;;; @@@ entity button generator
 402 ;;;
 403
 404 (defun mime-view-insert-entity-button (entity &optional body-is-invisible)
 405   "Insert entity-button of ENTITY."
 406   (let ((entity-node-id (mime-entity-node-id entity))
 407         (params (mime-entity-parameters entity))
 408         (subject (mime-view-entity-title entity)))
 409     (mime-insert-button
 410      (concat
 411       (let ((access-type (assoc "access-type" params))
 412             (num (or (cdr (assoc "x-part-number" params))
 413                      (if (consp entity-node-id)
 414                          (mapconcat (function
 415                                      (lambda (num)
 416                                        (format "%s" (1+ num))))
 417                                     (reverse entity-node-id) ".")
 418                        "0"))))
 419         (cond (access-type
 420                (let ((server (assoc "server" params)))
 421                  (setq access-type (cdr access-type))
 422                  (if server
 423                      (format "%s %s ([%s] %s)"
 424                              num subject access-type (cdr server))
 425                    (let ((site (cdr (assoc "site" params)))
 426                          (dir (cdr (assoc "directory" params)))
 427                          (url (cdr (assoc "url" params))))
 428                      (if url
 429                          (format "%s %s ([%s] %s)"
 430                                  num subject access-type url)
 431                        (format "%s %s ([%s] %s:%s)"
 432                                num subject access-type site dir))))))
 433               (t
 434                (let ((media-type (mime-entity-media-type entity))
 435                      (media-subtype (mime-entity-media-subtype entity))
 436                      (charset (cdr (assoc "charset" params)))
 437                      (encoding (mime-entity-encoding entity)))
 438                  (concat
 439                   num " " subject
 440                   (let ((rest
 441                          (format " <%s/%s%s%s>"
 442                                  media-type media-subtype
 443                                  (if charset
 444                                      (concat "; " charset)
 445                                    "")
 446                                  (if encoding
 447                                      (concat " (" encoding ")")
 448                                    ""))))
 449                     (if (>= (+ (current-column)(length rest))(window-width))
 450                         "\n\t")
 451                     rest))))))
 452       (if body-is-invisible
 453           " ..."
 454         ""))
 455      (function mime-preview-play-current-entity))))
 456
 457
 458 ;;; @@ entity-header
 459 ;;;
 460
 461 (defvar mime-header-presentation-method-alist nil
 462   "Alist of major mode vs. corresponding header-presentation-method functions.
 463 Each element looks like (SYMBOL . FUNCTION).
 464 SYMBOL must be major mode in raw-buffer or t.  t means default.
 465 Interface of FUNCTION must be (ENTITY SITUATION).")
 466
 467 (defvar mime-view-ignored-field-list
 468   '(".*Received:" ".*Path:" ".*Id:" "^References:"
 469     "^Replied:" "^Errors-To:"
 470     "^Lines:" "^Sender:" ".*Host:" "^Xref:"
 471     "^Content-Type:" "^Precedence:"
 472     "^Status:" "^X-VM-.*:")
 473   "All fields that match this list will be hidden in MIME preview buffer.
 474 Each elements are regexp of field-name.")
 475
 476 (defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
 477   "All fields that match this list will be displayed in MIME preview buffer.
 478 Each elements are regexp of field-name.")
 479
 480
 481 ;;; @@ entity-body
 482 ;;;
 483
 484 ;;; @@@ predicate function
 485 ;;;
 486
 487 (in-calist-package 'mime-view)
 488
 489 (defun mime-calist::field-match-method-as-default-rule (calist
 490                                                         field-type field-value)
 491   (let ((s-field (assq field-type calist)))
 492     (cond ((null s-field)
 493            (cons (cons field-type field-value) calist))
 494           (t calist))))
 495
 496 (define-calist-field-match-method
 497   'header #'mime-calist::field-match-method-as-default-rule)
 498
 499 (define-calist-field-match-method
 500   'body #'mime-calist::field-match-method-as-default-rule)
 501
 502
 503 (defvar mime-preview-condition nil
 504   "Condition-tree about how to display entity.")
 505
 506 ;;(ctree-set-calist-strictly
 507 ;; 'mime-preview-condition '((type . application)(subtype . octet-stream)
 508 ;;                         (encoding . nil)
 509 ;;                         (body . visible)))
 510
 511 (ctree-set-calist-strictly
 512  'mime-preview-condition '((type . application)(subtype . t)
 513                            (encoding . "7bit")
 514                            (body . visible)))
 515 (ctree-set-calist-strictly
 516  'mime-preview-condition '((type . application)(subtype . t)
 517                            (encoding . "8bit")
 518                            (body . visible)))
 519
 520 (ctree-set-calist-strictly
 521  'mime-preview-condition '((type . application)(subtype . pgp)
 522                            (body . visible)))
 523
 524 (ctree-set-calist-strictly
 525  'mime-preview-condition '((type . application)(subtype . x-latex)
 526                            (body . visible)))
 527
 528 (ctree-set-calist-strictly
 529  'mime-preview-condition '((type . application)(subtype . x-selection)
 530                            (body . visible)))
 531
 532 (ctree-set-calist-strictly
 533  'mime-preview-condition '((type . application)(subtype . x-comment)
 534                            (body . visible)))
 535
 536 (ctree-set-calist-strictly
 537  'mime-preview-condition '((type . message)(subtype . delivery-status)
 538                            (body . visible)))
 539
 540 (ctree-set-calist-strictly
 541  'mime-preview-condition
 542  '((body . visible)
 543    (body-presentation-method . mime-display-text/plain)))
 544
 545 (ctree-set-calist-strictly
 546  'mime-preview-condition
 547  '((type . nil)
 548    (body . visible)
 549    (body-presentation-method . mime-display-text/plain)))
 550
 551 (ctree-set-calist-strictly
 552  'mime-preview-condition
 553  '((type . text)(subtype . enriched)
 554    (body . visible)
 555    (body-presentation-method . mime-display-text/enriched)))
 556
 557 (ctree-set-calist-strictly
 558  'mime-preview-condition
 559  '((type . text)(subtype . richtext)
 560    (body . visible)
 561    (body-presentation-method . mime-display-text/richtext)))
 562
 563 (ctree-set-calist-strictly
 564  'mime-preview-condition
 565  '((type . application)(subtype . x-postpet)
 566    (body . visible)
 567    (body-presentation-method . mime-display-application/x-postpet)))
 568
 569 (ctree-set-calist-strictly
 570  'mime-preview-condition '((type . application)(subtype . t)
 571                            (encoding . t)
 572                            (body . invisible)
 573                            (body-presentation-method . mime-display-detect-application/octet-stream)))
 574
 575 (ctree-set-calist-strictly
 576  'mime-preview-condition
 577  '((type . text)(subtype . t)
 578    (body . visible)
 579    (body-presentation-method . mime-display-text/plain)))
 580
 581 (ctree-set-calist-strictly
 582  'mime-preview-condition
 583  '((type . text)(subtype . x-rot13-47-48)
 584    (body . visible)
 585    (body-presentation-method . mime-display-text/x-rot13-47-48)))
 586
 587 (ctree-set-calist-strictly
 588  'mime-preview-condition
 589  '((type . multipart)(subtype . alternative)
 590    (body . visible)
 591    (body-presentation-method . mime-display-multipart/alternative)))
 592
 593 (ctree-set-calist-strictly
 594  'mime-preview-condition
 595  '((type . multipart)(subtype . t)
 596    (body . visible)
 597    (body-presentation-method . mime-display-multipart/mixed)))
 598
 599 (ctree-set-calist-strictly
 600  'mime-preview-condition
 601  '((type . message)(subtype . partial)
 602    (body . visible)
 603    (body-presentation-method . mime-display-message/partial-button)))
 604
 605 (ctree-set-calist-strictly
 606  'mime-preview-condition
 607  '((type . message)(subtype . rfc822)
 608    (body . visible)
 609    (body-presentation-method . mime-display-multipart/mixed)
 610    (childrens-situation (header . visible)
 611                         (entity-button . invisible))))
 612
 613 (ctree-set-calist-strictly
 614  'mime-preview-condition
 615  '((type . message)(subtype . news)
 616    (body . visible)
 617    (body-presentation-method . mime-display-multipart/mixed)
 618    (childrens-situation (header . visible)
 619                         (entity-button . invisible))))
 620
 621 ;; message/external-body has only one child.
 622 (ctree-set-calist-strictly
 623  'mime-preview-condition
 624  '((type . message)(subtype . external-body)
 625    (body . visible)
 626    (body-presentation-method . nil)
 627    (childrens-situation (header . invisible)
 628                         (body . invisible)
 629                         (entity-button . visible))))
 630
 631
 632 ;;; @@@ entity presentation
 633 ;;;
 634
 635 (defun mime-display-text/plain (entity situation)
 636   (save-restriction
 637     (narrow-to-region (point-max)(point-max))
 638     (mime-insert-text-content entity)
 639     (run-hooks 'mime-text-decode-hook)
 640     (goto-char (point-max))
 641     (if (not (eq (char-after (1- (point))) ?\n))
 642         (insert "\n"))
 643     (mime-add-url-buttons)
 644     (run-hooks 'mime-display-text/plain-hook)))
 645
 646 (defun mime-display-text (entity situation)
 647   (save-restriction
 648     (narrow-to-region (point-max) (point-max))
 649     (insert
 650      (decode-coding-string
 651       (mime-decode-string
 652        (if (fboundp 'mime-entity-body)
 653            ;; FLIM 1.14
 654            (mime-entity-body entity)
 655          ;; #### This is wrong, but...
 656          (mime-entity-content entity))
 657        (or (cdr (assq 'encoding situation))
 658            (if (fboundp 'mime-entity-body)
 659                (mime-entity-encoding entity)
 660              "7bit")))
 661       (or (cdr (assq 'coding situation))
 662           'binary)))))
 663
 664 (defun mime-display-text/richtext (entity situation)
 665   (save-restriction
 666     (narrow-to-region (point-max)(point-max))
 667     (mime-insert-text-content entity)
 668     (run-hooks 'mime-text-decode-hook)
 669     (let ((beg (point-min)))
 670       (remove-text-properties beg (point-max) '(face nil))
 671       (richtext-decode beg (point-max)))))
 672
 673 (defun mime-display-text/enriched (entity situation)
 674   (save-restriction
 675     (narrow-to-region (point-max)(point-max))
 676     (mime-insert-text-content entity)
 677     (run-hooks 'mime-text-decode-hook)
 678     (let ((beg (point-min)))
 679       (remove-text-properties beg (point-max) '(face nil))
 680       (enriched-decode beg (point-max)))))
 681
 682 (defun mime-display-text/x-rot13-47-48 (entity situation)
 683   (save-restriction
 684     (narrow-to-region (point-max)(point-max))
 685     (mime-insert-text-content entity)
 686     (goto-char (point-max))
 687     (if (not (eq (char-after (1- (point))) ?\n))
 688         (insert "\n"))
 689     (mule-caesar-region (point-min) (point-max))
 690     (mime-add-url-buttons)))
 691
 692 (put 'unpack 'lisp-indent-function 1)
 693 (defmacro unpack (string &rest body)
 694   `(let* ((*unpack*string* (string-as-unibyte ,string))
 695           (*unpack*index* 0))
 696      ,@body))
 697
 698 (defun unpack-skip (len)
 699   (setq *unpack*index* (+ len *unpack*index*)))
 700
 701 (defun unpack-fixed (len)
 702   (prog1
 703       (substring *unpack*string* *unpack*index* (+ *unpack*index* len))
 704     (unpack-skip len)))
 705
 706 (defun unpack-byte ()
 707   (char-int (aref (unpack-fixed 1) 0)))
 708
 709 (defun unpack-short ()
 710   (let* ((b0 (unpack-byte))
 711          (b1 (unpack-byte)))
 712     (+ (* 256 b0) b1)))
 713
 714 (defun unpack-long ()
 715   (let* ((s0 (unpack-short))
 716          (s1 (unpack-short)))
 717     (+ (* 65536 s0) s1)))
 718
 719 (defun unpack-string ()
 720   (let ((len (unpack-byte)))
 721     (unpack-fixed len)))
 722
 723 (defun unpack-string-sjis ()
 724   (decode-mime-charset-string (unpack-string) 'shift_jis))
 725
 726 (defun postpet-decode (string)
 727   (condition-case nil
 728       (unpack string
 729         (let (res)
 730           (unpack-skip 4)
 731           (set-alist 'res 'carryingcount (unpack-long))
 732           (unpack-skip 8)
 733           (set-alist 'res 'sentyear (unpack-short))
 734           (set-alist 'res 'sentmonth (unpack-short))
 735           (set-alist 'res 'sentday (unpack-short))
 736           (unpack-skip 8)
 737           (set-alist 'res 'petname (unpack-string-sjis))
 738           (set-alist 'res 'owner (unpack-string-sjis))
 739           (set-alist 'res 'pettype (unpack-fixed 4))
 740           (set-alist 'res 'health (unpack-short))
 741           (unpack-skip 2)
 742           (set-alist 'res 'sex (unpack-long))
 743           (unpack-skip 1)
 744           (set-alist 'res 'brain (unpack-byte))
 745           (unpack-skip 39)
 746           (set-alist 'res 'happiness (unpack-byte))
 747           (unpack-skip 14)
 748           (set-alist 'res 'petbirthyear (unpack-short))
 749           (set-alist 'res 'petbirthmonth (unpack-short))
 750           (set-alist 'res 'petbirthday (unpack-short))
 751           (unpack-skip 8)
 752           (set-alist 'res 'from (unpack-string))
 753           (unpack-skip 5)
 754           (unpack-skip 160)
 755           (unpack-skip 4)
 756           (unpack-skip 8)
 757           (unpack-skip 8)
 758           (unpack-skip 26)
 759           (set-alist 'res 'treasure (unpack-short))
 760           (set-alist 'res 'money (unpack-long))
 761           res))
 762     (error nil)))
 763
 764 (defun mime-display-application/x-postpet (entity situation)
 765   (save-restriction
 766     (narrow-to-region (point-max)(point-max))
 767     (let ((pet (postpet-decode (mime-entity-content entity))))
 768       (if pet
 769           (insert "Petname: " (cdr (assq 'petname pet)) "\n"
 770                   "Owner: " (cdr (assq 'owner pet)) "\n"
 771                   "Pettype: " (cdr (assq 'pettype pet)) "\n"
 772                   "From: " (cdr (assq 'from pet)) "\n"
 773                   "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) "\n"
 774                   "SentYear: " (int-to-string (cdr (assq 'sentyear pet))) "\n"
 775                   "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) "\n"
 776                   "SentDay: " (int-to-string (cdr (assq 'sentday pet))) "\n"
 777                   "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) "\n"
 778                   "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) "\n"
 779                   "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) "\n"
 780                   "Health: " (int-to-string (cdr (assq 'health pet))) "\n"
 781                   "Sex: " (int-to-string (cdr (assq 'sex pet))) "\n"
 782                   "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n"
 783                   "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n"
 784                   "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n"
 785                   "Money: " (int-to-string (cdr (assq 'money pet))) "\n")
 786         (insert "Invalid format\n"))
 787       (run-hooks 'mime-display-application/x-postpet-hook))))
 788
 789
 790 (defvar mime-view-announcement-for-message/partial
 791   (if (and (>= emacs-major-version 19) window-system)
 792       "\
 793 This is message/partial style split message.
 794 Please press `v' key in this buffer or click here by mouse button-2."
 795     "\
 796 This is message/partial style split message.
 797 Please press `v' key in this buffer."))
 798
 799 (defun mime-display-message/partial-button (&optional entity situation)
 800   (save-restriction
 801     (goto-char (point-max))
 802     (if (not (search-backward "\n\n" nil t))
 803         (insert "\n"))
 804     (goto-char (point-max))
 805     ;;(narrow-to-region (point-max)(point-max))
 806     ;;(insert mime-view-announcement-for-message/partial)
 807     ;; (mime-add-button (point-min)(point-max)
 808     ;;                  #'mime-preview-play-current-entity)
 809     (mime-insert-button mime-view-announcement-for-message/partial
 810                         #'mime-preview-play-current-entity)))
 811
 812 (defun mime-display-multipart/mixed (entity situation)
 813   (let ((children (mime-entity-children entity))
 814         (original-major-mode-cell (assq 'major-mode situation))
 815         (default-situation
 816           (cdr (assq 'childrens-situation situation))))
 817     (if original-major-mode-cell
 818         (setq default-situation
 819               (cons original-major-mode-cell default-situation)))
 820     (while children
 821       (mime-display-entity (car children) nil default-situation)
 822       (setq children (cdr children)))))
 823
 824 (defun mime-display-multipart/alternative (entity situation)
 825   (let* ((children (mime-entity-children entity))
 826          (original-major-mode-cell (assq 'major-mode situation))
 827          (default-situation
 828            (cdr (assq 'childrens-situation situation)))
 829          (i 0)
 830          (p 0)
 831          (max-score 0)
 832          situations)
 833     (if original-major-mode-cell
 834         (setq default-situation
 835               (cons original-major-mode-cell default-situation)))
 836     (setq situations
 837           (mapcar (function
 838                    (lambda (child)
 839                      (let ((situation
 840                             (or (ctree-match-calist
 841                                  mime-preview-condition
 842                                  (append (mime-entity-situation child)
 843                                          default-situation))
 844                                 default-situation)))
 845                        (if (cdr (assq 'body-presentation-method situation))
 846                            (let ((score
 847                                   (cdr
 848                                    (or (assoc
 849                                         (cons
 850                                          (cdr (assq 'type situation))
 851                                          (cdr (assq 'subtype situation)))
 852                                         mime-view-type-subtype-score-alist)
 853                                        (assq
 854                                         (cdr (assq 'type situation))
 855                                         mime-view-type-subtype-score-alist)
 856                                        (assq
 857                                         t
 858                                         mime-view-type-subtype-score-alist)))))
 859                              (if (> score max-score)
 860                                  (setq p i
 861                                        max-score score))))
 862                        (setq i (1+ i))
 863                        situation)))
 864                   children))
 865     (setq i 0)
 866     (while children
 867       (let ((child (car children))
 868             (situation (car situations)))
 869         (mime-display-entity child (if (= i p)
 870                                        situation
 871                                      (del-alist 'body-presentation-method
 872                                                 (copy-alist situation)))))
 873       (setq children (cdr children)
 874             situations (cdr situations)
 875             i (1+ i)))))
 876
 877 (defun mime-display-detect-application/octet-stream (entity situation)
 878   "Detect unknown ENTITY and display it inline.
 879 This can only handle gzipped contents."
 880   (or (and (mime-entity-filename entity)
 881            (string-match "\\.gz$" (mime-entity-filename entity))
 882            (mime-display-gzipped entity situation))
 883       (mime-display-text/plain entity situation)))
 884
 885 (defun mime-display-gzipped (entity situation)
 886   "Ungzip gzipped part and display."
 887     (insert
 888      (decode-coding-string
 889       (with-temp-buffer
 890         ;; #### Kludge to make FSF Emacs happy.
 891         (if (featurep 'xemacs)
 892             (insert (mime-entity-content entity))
 893           (let ((content (mime-entity-content entity)))
 894             (if (not (multibyte-string-p content))
 895                 ;; I really hate this brain-damaged function.
 896                 (set-buffer-multibyte nil))
 897             (insert content)))
 898         (as-binary-process
 899          (call-process-region (point-min) (point-max) "gzip" t t
 900                               nil "-cd"))
 901         ;; Oh my goodness.
 902         (when (fboundp 'set-buffer-multibyte)
 903           (set-buffer-multibyte t))
 904         (buffer-string))
 905       mime-view-automatic-conversion))
 906      t)
 907
 908 (defun mime-preview-inline ()
 909   "View part as text without code conversion."
 910   (interactive)
 911   (let ((inhibit-read-only t)
 912         (entity (get-text-property (point) 'mime-view-entity))
 913         (situation (get-text-property (point) 'mime-view-situation))
 914         start)
 915     (when (and entity
 916                (not (get-text-property (point) 'mime-view-entity-header))
 917                (not (memq (mime-entity-media-type entity)
 918                           '(multipart message))))
 919       (setq start (or (and (not (mime-entity-parent entity))
 920                            (1+ (previous-single-property-change
 921                                 (point)
 922                                 'mime-view-entity-header)))
 923                       (and (not (eq (point) (point-min)))
 924                            (not (eq (get-text-property (1- (point))
 925                                                        'mime-view-entity)
 926                                     entity))
 927                            (point))
 928                       (previous-single-property-change (point)
 929                                                    'mime-view-entity)
 930                       (point)))
 931       (delete-region start
 932                      (1-
 933                       (or (next-single-property-change (point)
 934                                                        'mime-view-entity)
 935                           (point-max))))
 936       (setq start (point))
 937       (if (mime-view-entity-button-visible-p entity)
 938           (mime-view-insert-entity-button entity))
 939       (insert (mime-entity-content entity))
 940       (if (and (bolp) (eolp))
 941           (delete-char 1)
 942         (forward-char 1))
 943       (add-text-properties start (point)
 944                            (list 'mime-view-entity entity
 945                                  'mime-view-situation situation))
 946       (goto-char start))))
 947
 948 (defun mime-preview-text (&optional ask-coding)
 949   "View part as text. MIME charset will be guessed automatically.
 950 With prefix, it prompts for coding-system."
 951   (interactive "P")
 952   (let ((inhibit-read-only t)
 953         (mime-view-force-inline-types t)
 954         (position (mime-preview-entity-boundary))
 955         (coding (if ask-coding
 956                     (or (read-coding-system "Coding system: ")
 957                         mime-view-automatic-conversion)
 958                   mime-view-automatic-conversion))
 959         (cte (if ask-coding
 960                  (completing-read "Content Transfer Encoding: "
 961                                   (mime-encoding-alist) nil t)))
 962         entity situation)
 963     (setq entity (get-text-property (car position) 'mime-view-entity)
 964           situation (get-text-property (car position) 'mime-view-situation))
 965     (setq situation
 966           (put-alist
 967            'encoding cte
 968            (put-alist
 969             'coding coding
 970             (put-alist
 971              'body-presentation-method 'mime-display-text
 972              (put-alist '*body 'visible situation)))))
 973     (save-excursion
 974       (delete-region (car position) (cdr position))
 975       (mime-display-entity entity situation))))
 976
 977 (defun mime-preview-type ()
 978   "View part as text without code conversion."
 979   (interactive)
 980   (mime-preview-toggle-content t))
 981
 982 (defun mime-preview-buttonize ()
 983   (interactive)
 984   (save-excursion
 985     (goto-char (point-min))
 986     (let (point)
 987       (while (setq point (next-single-property-change
 988                           (point) 'mime-view-entity))
 989         (goto-char point)
 990         (unless (get-text-property (point) 'mime-button)
 991           (mime-preview-toggle-button t))))))
 992
 993 (defun mime-preview-unbuttonize ()
 994   (interactive)
 995   (save-excursion
 996     (goto-char (point-min))
 997     (let (point)
 998       (while (setq point (next-single-property-change
 999                           (point) 'mime-view-entity))
1000         (goto-char point)
1001         (when (get-text-property (point) 'mime-button)
1002           (mime-preview-toggle-button 'hide))))))
1003
1004
1005 ;;; @ acting-condition
1006 ;;;
1007
1008 (defvar mime-acting-condition nil
1009   "Condition-tree about how to process entity.")
1010
1011 (defvar mime-view-mailcap-parsed-p nil)
1012
1013 ;; ### Fix flim
1014 (defun mime-view-parse-mailcap-files (&optional path)
1015   (if (not (or path (setq path (getenv "MAILCAPS"))))
1016       (setq path mime-view-mailcap-files))
1017   (let ((fnames (reverse
1018                  (if (stringp path)
1019                      (parse-colon-path path)
1020                    path)))
1021         fname)
1022     (setq mim-view-mailcap-parsed-p t)
1023     (with-temp-buffer
1024       (while fnames
1025         (setq fname (car fnames))
1026         (when (and (file-readable-p fname)
1027                    (file-regular-p fname))
1028           (insert-file-contents fname)
1029           (unless (bolp)
1030             (insert "\n")))
1031         (setq fnames (cdr fnames)))
1032       (mailcap-parse-buffer))))
1033
1034 (defun mime-view-parse-mailcap (&optional path force)
1035     "Parse out all the mailcaps specified in a path string PATH.
1036 Components of PATH are separated by the `path-separator' character
1037 appropriate for this system.  If FORCE, re-parse even if already
1038 parsed.  If PATH is omitted, use the value of `mime-view-mailcap-files'."
1039     (interactive (list nil t))
1040     (when (or (not mime-view-mailcap-parsed-p)
1041               force)
1042       (let ((entries (mime-view-parse-mailcap-files path)))
1043         (while entries
1044           (let ((entry (car entries))
1045                 view print shared)
1046             (while entry
1047               (let* ((field (car entry))
1048                      (field-type (car field)))
1049                 (cond ((eq field-type 'view)
1050                        (setq view field))
1051                       ((eq field-type 'print)
1052                        (setq print field))
1053                       ((memq field-type '(compose composetyped edit)))
1054                       (t
1055                        (setq shared (cons field shared)))))
1056               (setq entry (cdr entry)))
1057             (setq shared (nreverse shared))
1058             (ctree-set-calist-with-default
1059              'mime-acting-condition
1060              (append shared
1061                      (list '(mode . "play") (cons 'method (cdr view)))))
1062             (if print
1063                 (ctree-set-calist-with-default
1064                  'mime-acting-condition
1065                  (append shared
1066                          (list '(mode . "print") (cons 'method (cdr view)))))))
1067           (setq entries (cdr entries))))))
1068
1069 (mime-view-parse-mailcap)
1070
1071 (ctree-set-calist-strictly
1072  'mime-acting-condition
1073  '((type . application)(subtype . octet-stream)
1074    (mode . "play")
1075    (method . mime-detect-content)))
1076
1077 (ctree-set-calist-with-default
1078  'mime-acting-condition
1079  '((mode . "extract")
1080    (method . mime-save-content)))
1081
1082 (ctree-set-calist-strictly
1083  'mime-acting-condition
1084  '((type . text)(subtype . x-rot13-47)(mode . "play")
1085    (method . mime-view-caesar)))
1086 (ctree-set-calist-strictly
1087  'mime-acting-condition
1088  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
1089    (method . mime-view-caesar)))
1090
1091 (ctree-set-calist-strictly
1092  'mime-acting-condition
1093  '((type . message)(subtype . rfc822)(mode . "play")
1094    (method . mime-view-message/rfc822)))
1095 (ctree-set-calist-strictly
1096  'mime-acting-condition
1097  '((type . message)(subtype . partial)(mode . "play")
1098    (method . mime-store-message/partial-piece)))
1099
1100 (ctree-set-calist-strictly
1101  'mime-acting-condition
1102  '((type . message)(subtype . external-body)
1103    ("access-type" . "anon-ftp")
1104    (method . mime-view-message/external-anon-ftp)))
1105
1106 (ctree-set-calist-strictly
1107  'mime-acting-condition
1108  '((type . message)(subtype . external-body)
1109    ("access-type" . "url")
1110    (method . mime-view-message/external-url)))
1111
1112 (ctree-set-calist-strictly
1113  'mime-acting-condition
1114  '((type . application)(subtype . octet-stream)
1115    (method . mime-save-content)))
1116
1117
1118 ;;; @ quitting method
1119 ;;;
1120
1121 (defvar mime-preview-quitting-method-alist
1122   '((mime-show-message-mode
1123      . mime-preview-quitting-method-for-mime-show-message-mode))
1124   "Alist of `major-mode' vs. quitting-method of mime-view.")
1125
1126 (defvar mime-preview-over-to-previous-method-alist nil
1127   "Alist of `major-mode' vs. over-to-previous-method of mime-view.")
1128
1129 (defvar mime-preview-over-to-next-method-alist nil
1130   "Alist of `major-mode' vs. over-to-next-method of mime-view.")
1131
1132
1133 ;;; @ following method
1134 ;;;
1135
1136 (defvar mime-preview-following-method-alist nil
1137   "Alist of `major-mode' vs. following-method of mime-view.")
1138
1139 (defvar mime-view-following-required-fields-list
1140   '("From"))
1141
1142
1143 ;;; @ buffer setup
1144 ;;;
1145
1146 (defun mime-display-entity (entity &optional situation
1147                                    default-situation preview-buffer)
1148   "Display mime-entity ENTITY."
1149   (or preview-buffer
1150       (setq preview-buffer (current-buffer)))
1151   (in-calist-package 'mime-view)
1152   (or situation
1153       (setq situation
1154             (or (ctree-match-calist mime-preview-condition
1155                                     (append (mime-entity-situation entity)
1156                                             default-situation))
1157                 default-situation)))
1158   (let ((button-is-visible (mime-view-button-is-visible situation))
1159         (header-is-visible
1160          (mime-view-header-is-visible situation))
1161         (header-presentation-method
1162          (or (cdr (assq '*header-presentation-method situation))
1163              (cdr (assq 'header-presentation-method situation))
1164              (cdr (assq (cdr (assq 'major-mode situation))
1165                         mime-header-presentation-method-alist))))
1166         (body-is-visible
1167          (mime-view-body-is-visible situation))
1168         (body-presentation-method
1169          (cdr (assq 'body-presentation-method situation)))
1170         (children (mime-entity-children entity))
1171         nb ne nhb nbb)
1172     ;; Check if attachment is specified.
1173     ;; if inline is forced or not.
1174     (unless (or (eq t mime-view-force-inline-types)
1175                 (memq (mime-entity-media-type entity)
1176                       mime-view-force-inline-types)
1177                 (memq (mime-view-entity-type/subtype entity)
1178                       mime-view-force-inline-types)
1179                 ;; whether Content-Disposition header exists.
1180                 (not (mime-entity-content-disposition entity))
1181                 (eq 'inline
1182                     (mime-content-disposition-type
1183                      (mime-entity-content-disposition entity))))
1184       ;; This is attachment.
1185       ;; But show header when this is root entity.
1186       (if (mime-root-entity-p entity)
1187           (progn (setq body-is-visible nil)
1188                  (put-alist 'body 'invisible situation))
1189         (setq header-is-visible nil)
1190         (put-alist 'header 'invisible situation)))
1191     (set-buffer preview-buffer)
1192     (setq nb (point))
1193     (save-restriction
1194       (narrow-to-region nb nb)
1195       (if button-is-visible
1196           (mime-view-insert-entity-button entity
1197                                           ;; work around composite type
1198                                           (not (or children
1199                                                    body-is-visible))))
1200       (when header-is-visible
1201         (setq nhb (point))
1202         (if header-presentation-method
1203             (funcall header-presentation-method entity situation)
1204           (mime-insert-header entity
1205                               mime-view-ignored-field-list
1206                               mime-view-visible-field-list))
1207         (run-hooks 'mime-display-header-hook)
1208         (put-text-property nhb (point-max) 'mime-view-entity-header entity)
1209         (goto-char (point-max))
1210         (insert "\n"))
1211       (setq nbb (point))
1212       (cond (children)
1213             ((and body-is-visible
1214                   (functionp body-presentation-method))
1215              (funcall body-presentation-method entity situation))
1216             (t
1217              ;; When both body and button is not displayed,
1218              ;; there should be a button to indicate there's a part.
1219              (unless button-is-visible
1220                (goto-char (point-max))
1221                (mime-view-insert-entity-button entity
1222                                                ;; work around composite type
1223                                                (not (or children
1224                                                         body-is-visible))))
1225              (unless header-is-visible
1226                (goto-char (point-max))
1227                (insert "\n"))))
1228       (setq ne (point-max)))
1229     (put-text-property nb ne 'mime-view-entity entity)
1230     (put-text-property nb ne 'mime-view-situation situation)
1231     (put-text-property nbb ne 'mime-view-entity-body entity)
1232     (goto-char ne)
1233     (if (and children body-is-visible)
1234         (if (functionp body-presentation-method)
1235             (funcall body-presentation-method entity situation)
1236           (mime-display-multipart/mixed entity situation)))))
1237
1238 ;;; @ MIME viewer mode
1239 ;;;
1240
1241 (defconst mime-view-menu-title "MIME-View")
1242 (defconst mime-view-menu-list
1243   '((up          "Move to upper entity"    mime-preview-move-to-upper)
1244     (previous    "Move to previous entity" mime-preview-move-to-previous)
1245     (next        "Move to next entity"     mime-preview-move-to-next)
1246     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
1247     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
1248     (play        "Play current entity"     mime-preview-play-current-entity)
1249     (extract     "Extract current entity"  mime-preview-extract-current-entity)
1250     (print       "Print current entity"    mime-preview-print-current-entity)
1251     (raw "View text without code conversion" mime-preview-inline)
1252     (text "View text with code conversion" mime-preview-text)
1253     (type "View internally as type" mime-preview-type))
1254   "Menu for MIME Viewer.")
1255
1256 (cond ((featurep 'xemacs)
1257        (defvar mime-view-xemacs-popup-menu
1258          (cons mime-view-menu-title
1259                (mapcar (function
1260                         (lambda (item)
1261                           (vector (nth 1 item)(nth 2 item) t)))
1262                        mime-view-menu-list)))
1263        (defun mime-view-xemacs-popup-menu (event)
1264          "Popup the menu in the MIME Viewer buffer"
1265          (interactive "e")
1266          (select-window (event-window event))
1267          (set-buffer (event-buffer event))
1268          (popup-menu 'mime-view-xemacs-popup-menu))
1269        (defvar mouse-button-2 'button2))
1270       (t
1271        (defvar mouse-button-2 [mouse-2])))
1272
1273 (defun mime-view-define-keymap (&optional default)
1274   (let ((mime-view-mode-map (if (keymapp default)
1275                                 (copy-keymap default)
1276                               (make-sparse-keymap))))
1277     (define-key mime-view-mode-map
1278       "u"        (function mime-preview-move-to-upper))
1279     (define-key mime-view-mode-map
1280       "p"        (function mime-preview-move-to-previous))
1281     (define-key mime-view-mode-map
1282       "n"        (function mime-preview-move-to-next))
1283     (define-key mime-view-mode-map
1284       "\e\t"     (function mime-preview-move-to-previous))
1285     (define-key mime-view-mode-map
1286       "\t"       (function mime-preview-move-to-next))
1287     (define-key mime-view-mode-map
1288       " "        (function mime-preview-scroll-up-entity))
1289     (define-key mime-view-mode-map
1290       "\M- "     (function mime-preview-scroll-down-entity))
1291     (define-key mime-view-mode-map
1292       "\177"     (function mime-preview-scroll-down-entity))
1293     (define-key mime-view-mode-map
1294       "\C-m"     (function mime-preview-next-line-entity))
1295     (define-key mime-view-mode-map
1296       "\C-\M-m"  (function mime-preview-previous-line-entity))
1297     (define-key mime-view-mode-map
1298       "v"        (function mime-preview-play-current-entity))
1299     (define-key mime-view-mode-map
1300       "e"        (function mime-preview-extract-current-entity))
1301     (define-key mime-view-mode-map
1302       "\C-c\C-e"        (function mime-preview-extract-current-entity))
1303     (define-key mime-view-mode-map
1304       "i"        (function mime-preview-inline))
1305     (define-key mime-view-mode-map
1306       "c"        (function mime-preview-text))
1307     (define-key mime-view-mode-map
1308       "t"        (function mime-preview-type))
1309     (define-key mime-view-mode-map
1310       "b"        (function mime-preview-buttonize))
1311     (define-key mime-view-mode-map
1312       "B"        (function mime-preview-unbuttonize))
1313     (define-key mime-view-mode-map
1314       "\C-c\C-t\C-h" (function mime-preview-toggle-header))
1315     (define-key mime-view-mode-map
1316       "\C-c\C-th" (function mime-preview-toggle-header))
1317     (define-key mime-view-mode-map
1318       "\C-c\C-t\C-c" (function mime-preview-toggle-content))
1319     (define-key mime-view-mode-map
1320       "\C-c\C-tc" (function mime-preview-toggle-content))
1321     (define-key mime-view-mode-map
1322       "\C-c\C-tH" (function mime-preview-toggle-all-header))
1323     (define-key mime-view-mode-map
1324       "\C-c\C-tb" (function mime-preview-toggle-button))
1325     (define-key mime-view-mode-map
1326       "\C-c\C-p" (function mime-preview-print-current-entity))
1327     (define-key mime-view-mode-map
1328       "a"        (function mime-preview-follow-current-entity))
1329     (define-key mime-view-mode-map
1330       "q"        (function mime-preview-quit))
1331     (define-key mime-view-mode-map
1332       "\C-c\C-x" (function mime-preview-kill-buffer))
1333     ;; (define-key mime-view-mode-map
1334     ;;   "<"        (function beginning-of-buffer))
1335     ;; (define-key mime-view-mode-map
1336     ;;   ">"        (function end-of-buffer))
1337     (define-key mime-view-mode-map
1338       "?"        (function describe-mode))
1339     (define-key mime-view-mode-map
1340       [tab] (function mime-preview-move-to-next))
1341     (define-key mime-view-mode-map
1342       [delete] (function mime-preview-scroll-down-entity))
1343     (define-key mime-view-mode-map
1344       [backspace] (function mime-preview-scroll-down-entity))
1345     (if (functionp default)
1346         (cond ((featurep 'xemacs)
1347                (set-keymap-default-binding mime-view-mode-map default))
1348               (t
1349                (setq mime-view-mode-map
1350                      (append mime-view-mode-map (list (cons t default)))))))
1351     (if mouse-button-2
1352         (define-key mime-view-mode-map
1353           mouse-button-2 (function mime-button-dispatcher)))
1354     (cond ((featurep 'xemacs)
1355            (define-key mime-view-mode-map
1356              mouse-button-3 (function mime-view-xemacs-popup-menu)))
1357           ((>= emacs-major-version 19)
1358            (define-key mime-view-mode-map [menu-bar mime-view]
1359              (cons mime-view-menu-title
1360                    (make-sparse-keymap mime-view-menu-title)))
1361            (mapcar (function
1362                     (lambda (item)
1363                       (define-key mime-view-mode-map
1364                         (vector 'menu-bar 'mime-view (car item))
1365                         (cons (nth 1 item)(nth 2 item)))))
1366                    (reverse mime-view-menu-list))))
1367     (use-local-map mime-view-mode-map)
1368     (run-hooks 'mime-view-define-keymap-hook)))
1369
1370 (defsubst mime-maybe-hide-echo-buffer ()
1371   "Clear mime-echo buffer and delete window for it."
1372   (let ((buf (get-buffer mime-echo-buffer-name)))
1373     (if buf
1374         (save-excursion
1375           (set-buffer buf)
1376           (erase-buffer)
1377           (let ((win (get-buffer-window buf)))
1378             (if win
1379                 (delete-window win)))
1380           (bury-buffer buf)))))
1381
1382 (defvar mime-view-redisplay nil)
1383
1384 ;;;###autoload
1385 (defun mime-display-message (message &optional preview-buffer
1386                                      mother default-keymap-or-function
1387                                      original-major-mode)
1388   "View MESSAGE in MIME-View mode.
1389
1390 Optional argument PREVIEW-BUFFER specifies the buffer of the
1391 presentation.  It must be either nil or a name of preview buffer.
1392
1393 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1394
1395 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1396 function.  If it is a keymap, keymap of MIME-View mode will be added
1397 to it.  If it is a function, it will be bound as default binding of
1398 keymap of MIME-View mode."
1399   (mime-maybe-hide-echo-buffer)
1400   (let ((win-conf (current-window-configuration)))
1401     (or preview-buffer
1402         (setq preview-buffer
1403               (concat "*Preview-" (mime-entity-name message) "*")))
1404     (or original-major-mode
1405         (setq original-major-mode major-mode))
1406     (let ((inhibit-read-only t))
1407       (set-buffer (get-buffer-create preview-buffer))
1408       (widen)
1409       (erase-buffer)
1410       (if mother
1411           (setq mime-mother-buffer mother))
1412       (setq mime-preview-original-window-configuration win-conf)
1413       (setq major-mode 'mime-view-mode)
1414       (setq mode-name "MIME-View")
1415       (mime-display-entity message nil
1416                            (list (cons 'entity-button 'invisible)
1417                                  (cons 'header 'visible)
1418                                  (cons 'major-mode original-major-mode))
1419                            preview-buffer)
1420       (mime-view-define-keymap default-keymap-or-function)
1421       (set (make-local-variable 'line-move-ignore-invisible) t)
1422       (let ((point
1423              (next-single-property-change (point-min) 'mime-view-entity)))
1424         (if point
1425             (goto-char point)
1426           (goto-char (point-min))
1427           (search-forward "\n\n" nil t)))
1428       (run-hooks 'mime-view-mode-hook)
1429       (set-buffer-modified-p nil)
1430       (setq buffer-read-only t)
1431       preview-buffer)))
1432
1433 ;;;###autoload
1434 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1435                                    default-keymap-or-function
1436                                    representation-type)
1437   "View RAW-BUFFER in MIME-View mode.
1438 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1439 buffer.
1440 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1441 function.  If it is a keymap, keymap of MIME-View mode will be added
1442 to it.  If it is a function, it will be bound as default binding of
1443 keymap of MIME-View mode.
1444 Optional argument REPRESENTATION-TYPE is representation-type of
1445 message.  It must be nil, `binary' or `cooked'.  If it is nil,
1446 `cooked' is used as default."
1447   (interactive)
1448   (or raw-buffer
1449       (setq raw-buffer (current-buffer)))
1450   (or representation-type
1451       (setq representation-type
1452             (save-excursion
1453               (set-buffer raw-buffer)
1454               (cdr (or (assq major-mode mime-raw-representation-type-alist)
1455                        (assq t mime-raw-representation-type-alist))))))
1456   (if (eq representation-type 'binary)
1457       (setq representation-type 'buffer))
1458   (setq preview-buffer (mime-display-message
1459                         (mime-open-entity representation-type raw-buffer)
1460                         preview-buffer mother default-keymap-or-function))
1461   (or (get-buffer-window preview-buffer)
1462       (let ((r-win (get-buffer-window raw-buffer)))
1463         (if r-win
1464             (set-window-buffer r-win preview-buffer)
1465           (let ((m-win (and mother (get-buffer-window mother))))
1466             (if m-win
1467                 (set-window-buffer m-win preview-buffer)
1468               (switch-to-buffer preview-buffer)))))))
1469
1470 (defun mime-view-mode (&optional mother ctl encoding
1471                                  raw-buffer preview-buffer
1472                                  default-keymap-or-function)
1473   "Major mode for viewing MIME message.
1474
1475 Here is a list of the standard keys for mime-view-mode.
1476
1477 key             feature
1478 ---             -------
1479
1480 u               Move to upper content
1481 p or M-TAB      Move to previous content
1482 n or TAB        Move to next content
1483 SPC             Scroll up or move to next content
1484 M-SPC or DEL    Scroll down or move to previous content
1485 RET             Move to next line
1486 M-RET           Move to previous line
1487 v               Decode current content as `play mode'
1488 e               Decode current content as `extract mode'
1489 C-c C-p         Decode current content as `print mode'
1490 a               Followup to current content.
1491 q               Quit
1492 button-2        Move to point under the mouse cursor
1493                 and decode current content as `play mode'"
1494   (interactive)
1495   (unless mime-view-redisplay
1496     (save-excursion
1497       (if raw-buffer (set-buffer raw-buffer))
1498       (let ((type
1499              (cdr
1500               (or (assq major-mode mime-raw-representation-type-alist)
1501                   (assq t mime-raw-representation-type-alist)))))
1502         (if (eq type 'binary)
1503             (setq type 'buffer))
1504         (setq mime-message-structure (mime-open-entity type raw-buffer))
1505         (or (mime-entity-content-type mime-message-structure)
1506             (mime-entity-set-content-type-internal
1507              mime-message-structure ctl)))
1508       (or (mime-entity-encoding mime-message-structure)
1509           (mime-entity-set-encoding-internal mime-message-structure encoding))))
1510   (mime-display-message mime-message-structure preview-buffer
1511                         mother default-keymap-or-function))
1512
1513
1514 ;;; @@ playing
1515 ;;;
1516
1517 (autoload 'mime-preview-play-current-entity "mime-play"
1518   "Play current entity." t)
1519
1520 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1521   "Extract current entity into file (maybe).
1522 It decodes current entity to call internal or external method as
1523 \"extract\" mode.  The method is selected from variable
1524 `mime-acting-condition'."
1525   (interactive "P")
1526   (mime-preview-play-current-entity ignore-examples "extract"))
1527
1528 (defun mime-preview-print-current-entity (&optional ignore-examples)
1529   "Print current entity (maybe).
1530 It decodes current entity to call internal or external method as
1531 \"print\" mode.  The method is selected from variable
1532 `mime-acting-condition'."
1533   (interactive "P")
1534   (mime-preview-play-current-entity ignore-examples "print"))
1535
1536
1537 ;;; @@ following
1538 ;;;
1539
1540 (defun mime-preview-follow-current-entity ()
1541   "Write follow message to current entity.
1542 It calls following-method selected from variable
1543 `mime-preview-following-method-alist'."
1544   (interactive)
1545   (let (entity position entity-node-id header-exists)
1546     (while (null (setq entity
1547                        (get-text-property (point) 'mime-view-entity)))
1548       (backward-char))
1549     (setq position (mime-preview-entity-boundary))
1550     (setq entity-node-id (mime-entity-node-id entity)
1551           header-exists
1552           ;; When on an invisible entity, there's no header.
1553           (or (mime-view-header-is-visible
1554                (get-text-property (car position) 'mime-view-situation))
1555               ;; We are on a rfc822 button.
1556               (and (eq 'message (mime-entity-media-type
1557                                  entity))
1558                    (eq 'rfc822 (mime-entity-media-subtype
1559                                 entity))
1560                    (get-text-property
1561                     (next-single-property-change
1562                      (car position) 'mime-button
1563                      nil (point-max))
1564                     'mime-view-entity-header))))
1565     (let* ((mode (mime-preview-original-major-mode 'recursive))
1566            (new-name
1567             (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1568            new-buf
1569            (the-buf (current-buffer))
1570            fields)
1571       (save-excursion
1572         (set-buffer (setq new-buf (get-buffer-create new-name)))
1573         (erase-buffer)
1574         ;; Compatibility kludge.
1575         ;; FSF Emacs can only take substring of current-buffer.
1576         (insert
1577          (save-excursion
1578            (set-buffer the-buf)
1579            (buffer-substring-no-properties (car position)
1580                                            (cdr position))))
1581         (if header-exists
1582             (delete-region (goto-char (point-min))
1583                            (re-search-forward "^$"))
1584           (goto-char (point-min))
1585           (insert "\n"))
1586         (goto-char (point-min))
1587         (let ((current-entity
1588                (if (and (eq (mime-entity-media-type entity) 'message)
1589                         (eq (mime-entity-media-subtype entity) 'rfc822))
1590                    (car (mime-entity-children entity))
1591                  entity)))
1592           (while (and current-entity
1593                       (if (and (eq (mime-entity-media-type
1594                                     current-entity) 'message)
1595                                (eq (mime-entity-media-subtype
1596                                     current-entity) 'rfc822))
1597                           nil
1598                         (mime-insert-header current-entity fields)
1599                         t))
1600             (setq fields (std11-collect-field-names)
1601                   current-entity (mime-entity-parent current-entity))))
1602         (let ((rest mime-view-following-required-fields-list)
1603               field-name ret)
1604           (while rest
1605             (setq field-name (car rest))
1606             (or (std11-field-body field-name)
1607                 (progn
1608                   (save-excursion
1609                     (set-buffer the-buf)
1610                     (let ((entity (when mime-mother-buffer
1611                                     (set-buffer mime-mother-buffer)
1612                                     (get-text-property (point)
1613                                                        'mime-view-entity))))
1614                       (while (and entity
1615                                   (null (setq ret (mime-entity-fetch-field
1616                                                    entity field-name))))
1617                         (setq entity (mime-entity-parent entity)))))
1618                   (if ret
1619                       (insert (concat field-name ": " ret "\n")))))
1620             (setq rest (cdr rest))))
1621         (mime-decode-header-in-buffer))
1622       (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1623         (if (functionp f)
1624             (funcall f new-buf)
1625           (message
1626            (format
1627             "Sorry, following method for %s is not implemented yet."
1628             mode)))))))
1629
1630
1631 ;;; @@ moving
1632 ;;;
1633
1634 (defun mime-preview-move-to-upper ()
1635   "Move to upper entity.
1636 If there is no upper entity, call function `mime-preview-quit'."
1637   (interactive)
1638   (let (cinfo)
1639     (while (null (setq cinfo
1640                        (get-text-property (point) 'mime-view-entity)))
1641       (backward-char))
1642     (let ((r (mime-entity-parent cinfo))
1643           point)
1644       (catch 'tag
1645         (while (setq point (previous-single-property-change
1646                             (point) 'mime-view-entity))
1647           (goto-char point)
1648           (when (eq r (get-text-property (point) 'mime-view-entity))
1649             (if (or (eq mime-preview-move-scroll t)
1650                     (and mime-preview-move-scroll
1651                          (>= point
1652                              (save-excursion
1653                                (move-to-window-line -1)
1654                                (forward-line (* -1 next-screen-context-lines))
1655                                (beginning-of-line)
1656                                (point)))))
1657                 (recenter next-screen-context-lines))
1658             (throw 'tag t)))
1659         (mime-preview-quit)))))
1660
1661 (defun mime-preview-move-to-previous ()
1662   "Move to previous entity.
1663 If there is no previous entity, it calls function registered in
1664 variable `mime-preview-over-to-previous-method-alist'."
1665   (interactive)
1666   (while (and (not (bobp))
1667               (null (get-text-property (point) 'mime-view-entity)))
1668     (backward-char))
1669   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1670     (if (and point
1671              (>= point (point-min)))
1672         (if (get-text-property (1- point) 'mime-view-entity)
1673             (progn (goto-char point)
1674                    (if
1675                     (or (eq mime-preview-move-scroll t)
1676                         (and mime-preview-move-scroll
1677                              (<= point
1678                                 (save-excursion
1679                                   (move-to-window-line 0)
1680                                   (forward-line next-screen-context-lines)
1681                                   (end-of-line)
1682                                   (point)))))
1683                         (recenter next-screen-context-lines)))
1684           (goto-char (1- point))
1685           (mime-preview-move-to-previous))
1686       (let ((f (assq (mime-preview-original-major-mode)
1687                      mime-preview-over-to-previous-method-alist)))
1688         (if f
1689             (funcall (cdr f)))))))
1690
1691 (defun mime-preview-move-to-next ()
1692   "Move to next entity.
1693 If there is no previous entity, it calls function registered in
1694 variable `mime-preview-over-to-next-method-alist'."
1695   (interactive)
1696   (while (and (not (eobp))
1697               (null (get-text-property (point) 'mime-view-entity)))
1698     (forward-char))
1699   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1700     (if (and point
1701              (<= point (point-max)))
1702         (progn
1703           (goto-char point)
1704           (if (null (get-text-property point 'mime-view-entity))
1705               (mime-preview-move-to-next)
1706             (and
1707              (or (eq mime-preview-move-scroll t)
1708                  (and mime-preview-move-scroll
1709                       (>= point
1710                          (save-excursion
1711                            (move-to-window-line -1)
1712                            (forward-line
1713                             (* -1 next-screen-context-lines))
1714                            (beginning-of-line)
1715                            (point)))))
1716                  (recenter next-screen-context-lines))))
1717       (let ((f (assq (mime-preview-original-major-mode)
1718                      mime-preview-over-to-next-method-alist)))
1719         (if f
1720             (funcall (cdr f)))))))
1721
1722 (defun mime-preview-scroll-up-entity (&optional h)
1723   "Scroll up current entity.
1724 If reached to (point-max), it calls function registered in variable
1725 `mime-preview-over-to-next-method-alist'."
1726   (interactive)
1727   (if (eobp)
1728       (let ((f (assq (mime-preview-original-major-mode)
1729                      mime-preview-over-to-next-method-alist)))
1730         (if f
1731             (funcall (cdr f))))
1732     (let ((point
1733            (or (next-single-property-change (point) 'mime-view-entity)
1734                (point-max)))
1735           (bottom (window-end (selected-window))))
1736       (if (and (not h)
1737                (> bottom point)
1738                (not mime-preview-scroll-full-screen))
1739           (progn (goto-char point)
1740                  (recenter next-screen-context-lines))
1741         (condition-case nil
1742             (let (window-pixel-scroll-increment)
1743               (scroll-up h))
1744           (end-of-buffer
1745            (goto-char (point-max))))))))
1746
1747 (defun mime-preview-scroll-down-entity (&optional h)
1748   "Scroll down current entity.
1749 If reached to (point-min), it calls function registered in variable
1750 `mime-preview-over-to-previous-method-alist'."
1751   (interactive)
1752   (if (bobp)
1753       (let ((f (assq (mime-preview-original-major-mode)
1754                      mime-preview-over-to-previous-method-alist)))
1755         (if f
1756             (funcall (cdr f))))
1757     (let ((point
1758            (or (previous-single-property-change (point) 'mime-view-entity)
1759                (point-min)))
1760           (top (window-start (selected-window))))
1761       (if (and (not h)
1762                (< top point)
1763                (not mime-preview-scroll-full-screen))
1764           (progn (goto-char point)
1765                  (recenter (* -1 next-screen-context-lines)))
1766         (condition-case nil
1767             (let (window-pixel-scroll-increment)
1768               (scroll-down h))
1769           (beginning-of-buffer
1770            (goto-char (point-min))))))))
1771
1772 (defun mime-preview-next-line-entity (&optional lines)
1773   "Scroll up one line (or prefix LINES lines).
1774 If LINES is negative, scroll down LINES lines."
1775   (interactive "p")
1776   (mime-preview-scroll-up-entity (or lines 1)))
1777
1778 (defun mime-preview-previous-line-entity (&optional lines)
1779   "Scrroll down one line (or prefix LINES lines).
1780 If LINES is negative, scroll up LINES lines."
1781   (interactive "p")
1782   (mime-preview-scroll-down-entity (or lines 1)))
1783
1784 (defun mime-preview-entity-boundary (&optional point)
1785   (or point
1786       (setq point (point)))
1787   (and (eq point (point-max))
1788        (setq point (1- (point-max))))
1789   (let ((entity (get-text-property point 'mime-view-entity))
1790         (start (previous-single-property-change (1+ point) 'mime-view-entity
1791                                                 nil (point-min)))
1792         end done)
1793     (if (not (mime-entity-node-id entity))
1794         (setq end (point-max))
1795       (while (and (mime-entity-children entity)
1796                   (not done))
1797         (if (not (mime-view-body-is-visible
1798                   (get-text-property point 'mime-view-situation)))
1799             (setq done t)
1800           ;; If the part is shown, search the last part.
1801           (let* ((child (car (last (mime-entity-children entity))))
1802                  (node-id (mime-entity-node-id child))
1803                  (tmp-node-id (mime-entity-node-id
1804                                  (get-text-property point
1805                                                     'mime-view-entity))))
1806             (while (or (< (length tmp-node-id)
1807                           (length node-id))
1808                        (not (eq (nthcdr (- (length tmp-node-id)
1809                                            (length node-id))
1810                                         tmp-node-id)
1811                                 node-id)))
1812               (setq point
1813                     (next-single-property-change point 'mime-view-entity)
1814                     tmp-node-id (mime-entity-node-id
1815                                  (get-text-property point
1816                                                     'mime-view-entity))))
1817             (setq entity child))))
1818       (setq end (next-single-property-change
1819                  point 'mime-view-entity nil (point-max))))
1820     (cons start end)))
1821
1822 (defun mime-preview-toggle-header (&optional show)
1823   "Toggle display of entity header.
1824 When prefix is given, it always displays the header."
1825   (interactive "P")
1826   (let ((inhibit-read-only t)
1827         (mime-view-force-inline-types t)
1828         (position (mime-preview-entity-boundary))
1829         entity header-is-visible situation)
1830     (setq entity (get-text-property (car position) 'mime-view-entity)
1831           situation (get-text-property (car position) 'mime-view-situation))
1832     (setq header-is-visible (mime-view-header-is-visible situation))
1833     (save-excursion
1834       (delete-region (car position) (cdr position))
1835       (if (or show (not header-is-visible))
1836           (mime-display-entity
1837            entity
1838            (del-alist '*entity-button
1839                       (put-alist '*header 'visible
1840                                  situation)))
1841         (mime-display-entity
1842          entity
1843          (put-alist '*entity-button
1844                     'visible
1845                     (put-alist '*header 'invisible
1846                                situation)))))))
1847
1848 (defun mime-preview-toggle-all-header (&optional show)
1849   "Toggle display of entity header.
1850 When prefix is given, it always displays the header."
1851   (interactive "P")
1852   (let ((inhibit-read-only t)
1853         (mime-view-force-inline-types t)
1854         (position (mime-preview-entity-boundary))
1855         entity header-is-visible situation)
1856     (setq entity (get-text-property (car position) 'mime-view-entity)
1857           situation (get-text-property (car position) 'mime-view-situation))
1858     (setq header-is-visible (mime-view-header-is-visible situation))
1859     (save-excursion
1860       (delete-region (car position) (cdr position))
1861       (if (or show (not header-is-visible))
1862           (mime-display-entity
1863            entity
1864            (del-alist '*entity-button
1865                       (del-alist '*header
1866                                  (del-alist '*header-presentation-method
1867                                             situation))))
1868         (mime-display-entity
1869          entity
1870          (put-alist
1871           '*entity-button
1872           'visible
1873           (put-alist
1874            '*header 'invisible
1875            (put-alist '*header-presentation-method
1876                       #'(lambda (entity situation)
1877                           (mime-insert-header
1878                            entity nil '(".*")))
1879                       situation))))))))
1880
1881 (defun mime-preview-toggle-content (&optional show)
1882   "Toggle display of entity body.
1883 When prefix is given, it always displays the content."
1884   (interactive "P")
1885   (let ((inhibit-read-only t)
1886         (mime-view-force-inline-types t)
1887         (position (mime-preview-entity-boundary))
1888         entity situation)
1889     (setq entity (get-text-property (car position) 'mime-view-entity)
1890           situation (get-text-property (car position) 'mime-view-situation))
1891     (setq situation
1892           (if (or show (not (mime-view-body-is-visible situation)))
1893               (del-alist
1894                '*entity-button
1895                (put-alist '*body 'visible situation))
1896             (put-alist
1897              '*entity-button 'visible
1898              (put-alist '*body 'invisible situation))))
1899     (save-excursion
1900       (delete-region (car position) (cdr position))
1901       (mime-display-entity entity situation))))
1902
1903 (defun mime-preview-toggle-button (&optional condition)
1904   "Toggle display of entity button.
1905 When prefix is given, it always displays the content.
1906 If condition is 'hide, hide all buttons."
1907   (interactive "P")
1908   (let ((inhibit-read-only t)
1909         (mime-view-force-inline-types t)
1910         (position (mime-preview-entity-boundary))
1911         entity situation button-is-visible)
1912     (setq entity (get-text-property (car position) 'mime-view-entity)
1913           situation (get-text-property (car position) 'mime-view-situation)
1914           button-is-visible (mime-view-button-is-visible situation))
1915     (save-excursion
1916       (delete-region (car position) (cdr position))
1917       (if (or (eq condition 'hide)
1918               (and (not condition) button-is-visible))
1919           (mime-display-entity entity
1920                                (put-alist '*entity-button
1921                                           'invisible situation))
1922         (mime-display-entity entity
1923                              (put-alist '*entity-button
1924                                         'visible situation))))))
1925
1926 ;;; @@ quitting
1927 ;;;
1928
1929 (defun mime-preview-quit ()
1930   "Quit from MIME-preview buffer.
1931 It calls function registered in variable
1932 `mime-preview-quitting-method-alist'."
1933   (interactive)
1934   (let ((r (assq (mime-preview-original-major-mode)
1935                  mime-preview-quitting-method-alist)))
1936     (if r
1937         (funcall (cdr r))
1938       (kill-buffer (current-buffer)))))
1939
1940 (defun mime-preview-kill-buffer ()
1941   (interactive)
1942   (kill-buffer (current-buffer)))
1943
1944
1945 ;;; @ end
1946 ;;;
1947
1948 (provide 'mime-view)
1949
1950 (run-hooks 'mime-view-load-hook)
1951
1952 ;;; mime-view.el ends here