mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 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 (Sophisticated Emacs 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 'mime)
  31 (require 'semi-def)
  32 (require 'calist)
  33 (require 'alist)
  34 (require 'mailcap)
  35
  36
  37 ;;; @ version
  38 ;;;
  39
  40 (defconst mime-view-version-string
  41   `,(concat (car mime-user-interface-version) " MIME-View "
  42             (mapconcat #'number-to-string
  43                        (cddr mime-user-interface-version) ".")
  44             " (" (cadr mime-user-interface-version) ")"))
  45
  46
  47 ;;; @ variables
  48 ;;;
  49
  50 (defgroup mime-view nil
  51   "MIME view mode"
  52   :group 'mime)
  53
  54 (defcustom mime-view-find-every-acting-situation t
  55   "*Find every available acting-situation if non-nil."
  56   :group 'mime-view
  57   :type 'boolean)
  58
  59 (defcustom mime-acting-situation-examples-file "~/.mime-example"
  60   "*File name of example about acting-situation demonstrated by user."
  61   :group 'mime-view
  62   :type 'file)
  63
  64
  65 ;;; @ in raw-buffer (representation space)
  66 ;;;
  67
  68 (defvar mime-preview-buffer nil
  69   "MIME-preview buffer corresponding with the (raw) buffer.")
  70 (make-variable-buffer-local 'mime-preview-buffer)
  71
  72
  73 (defvar mime-raw-representation-type-alist
  74   '((mime-show-message-mode     . binary)
  75     (mime-temp-message-mode     . binary)
  76     (t                          . cooked)
  77     )
  78   "Alist of major-mode vs. representation-type of mime-raw-buffer.
  79 Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
  80 major-mode or t.  t means default.  REPRESENTATION-TYPE must be
  81 `binary' or `cooked'.")
  82
  83
  84 (defun mime-raw-find-entity-from-point (point &optional message-info)
  85   "Return entity from POINT in mime-raw-buffer.
  86 If optional argument MESSAGE-INFO is not specified,
  87 `mime-message-structure' is used."
  88   (or message-info
  89       (setq message-info mime-message-structure))
  90   (if (and (<= (mime-entity-point-min message-info) point)
  91            (<= point (mime-entity-point-max message-info)))
  92       (let ((children (mime-entity-children message-info)))
  93         (catch 'tag
  94           (while children
  95             (let ((ret
  96                    (mime-raw-find-entity-from-point point (car children))))
  97               (if ret
  98                   (throw 'tag ret)
  99                 ))
 100             (setq children (cdr children)))
 101           message-info))))
 102
 103
 104 ;;; @ in preview-buffer (presentation space)
 105 ;;;
 106
 107 (defvar mime-mother-buffer nil
 108   "Mother buffer corresponding with the (MIME-preview) buffer.
 109 If current MIME-preview buffer is generated by other buffer, such as
 110 message/partial, it is called `mother-buffer'.")
 111 (make-variable-buffer-local 'mime-mother-buffer)
 112
 113 (defvar mime-raw-buffer nil
 114   "Raw buffer corresponding with the (MIME-preview) buffer.")
 115 (make-variable-buffer-local 'mime-raw-buffer)
 116
 117 (defvar mime-preview-original-window-configuration nil
 118   "Window-configuration before mime-view-mode is called.")
 119 (make-variable-buffer-local 'mime-preview-original-window-configuration)
 120
 121 (defun mime-preview-original-major-mode (&optional recursive)
 122   "Return major-mode of original buffer.
 123 If optional argument RECURSIVE is non-nil and current buffer has
 124 mime-mother-buffer, it returns original major-mode of the
 125 mother-buffer."
 126   (if (and recursive mime-mother-buffer)
 127       (save-excursion
 128         (set-buffer mime-mother-buffer)
 129         (mime-preview-original-major-mode recursive)
 130         )
 131     (save-excursion
 132       (set-buffer
 133        (mime-entity-buffer
 134         (get-text-property (point-min) 'mime-view-entity)))
 135       major-mode)))
 136
 137
 138 ;;; @ entity information
 139 ;;;
 140
 141 (defun mime-entity-situation (entity)
 142   "Return situation of ENTITY."
 143   (append (or (mime-entity-content-type entity)
 144               (make-mime-content-type 'text 'plain))
 145           (let ((d (mime-entity-content-disposition entity)))
 146             (cons (cons 'disposition-type
 147                         (mime-content-disposition-type d))
 148                   (mapcar (function
 149                            (lambda (param)
 150                              (let ((name (car param)))
 151                                (cons (cond ((string= name "filename")
 152                                             'filename)
 153                                            ((string= name "creation-date")
 154                                             'creation-date)
 155                                            ((string= name "modification-date")
 156                                             'modification-date)
 157                                            ((string= name "read-date")
 158                                             'read-date)
 159                                            ((string= name "size")
 160                                             'size)
 161                                            (t (cons 'disposition (car param))))
 162                                      (cdr param)))))
 163                           (mime-content-disposition-parameters d))
 164                   ))
 165           (list (cons 'encoding (mime-entity-encoding entity))
 166                 (cons 'major-mode
 167                       (save-excursion
 168                         (set-buffer (mime-entity-buffer entity))
 169                         major-mode)))
 170           ))
 171
 172
 173 (defun mime-view-entity-title (entity)
 174   (or (mime-read-field 'Content-Description entity)
 175       (mime-read-field 'Subject entity)
 176       (mime-entity-filename entity)
 177       ""))
 178
 179
 180 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
 181   "Return entity-node-id from POINT in mime-raw-buffer.
 182 If optional argument MESSAGE-INFO is not specified,
 183 `mime-message-structure' is used."
 184   (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
 185
 186 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
 187   "Return entity-number from POINT in mime-raw-buffer.
 188 If optional argument MESSAGE-INFO is not specified,
 189 `mime-message-structure' is used."
 190   (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
 191
 192 (defun mime-raw-flatten-message-info (&optional message-info)
 193   "Return list of entity in mime-raw-buffer.
 194 If optional argument MESSAGE-INFO is not specified,
 195 `mime-message-structure' is used."
 196   (or message-info
 197       (setq message-info mime-message-structure))
 198   (let ((dest (list message-info))
 199         (rcl (mime-entity-children message-info)))
 200     (while rcl
 201       (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
 202       (setq rcl (cdr rcl)))
 203     dest))
 204
 205
 206 ;;; @ presentation of preview
 207 ;;;
 208
 209 ;;; @@ entity-button
 210 ;;;
 211
 212 ;;; @@@ predicate function
 213 ;;;
 214
 215 (defun mime-view-entity-button-visible-p (entity)
 216   "Return non-nil if header of ENTITY is visible.
 217 Please redefine this function if you want to change default setting."
 218   (let ((media-type (mime-entity-media-type entity))
 219         (media-subtype (mime-entity-media-subtype entity)))
 220     (or (not (eq media-type 'application))
 221         (and (not (eq media-subtype 'x-selection))
 222              (or (not (eq media-subtype 'octet-stream))
 223                  (let ((mother-entity (mime-entity-parent entity)))
 224                    (or (not (eq (mime-entity-media-type mother-entity)
 225                                 'multipart))
 226                        (not (eq (mime-entity-media-subtype mother-entity)
 227                                 'encrypted)))
 228                    )
 229                  )))))
 230
 231 ;;; @@@ entity button generator
 232 ;;;
 233
 234 (defun mime-view-insert-entity-button (entity)
 235   "Insert entity-button of ENTITY."
 236   (let ((entity-node-id (mime-entity-node-id entity))
 237         (params (mime-entity-parameters entity))
 238         (subject (mime-view-entity-title entity)))
 239     (mime-insert-button
 240      (let ((access-type (assoc "access-type" params))
 241            (num (or (cdr (assoc "x-part-number" params))
 242                     (if (consp entity-node-id)
 243                         (mapconcat (function
 244                                     (lambda (num)
 245                                       (format "%s" (1+ num))
 246                                       ))
 247                                    (reverse entity-node-id) ".")
 248                       "0"))
 249                 ))
 250        (cond (access-type
 251               (let ((server (assoc "server" params)))
 252                 (setq access-type (cdr access-type))
 253                 (if server
 254                     (format "%s %s ([%s] %s)"
 255                             num subject access-type (cdr server))
 256                 (let ((site (cdr (assoc "site" params)))
 257                       (dir (cdr (assoc "directory" params)))
 258                       )
 259                   (format "%s %s ([%s] %s:%s)"
 260                           num subject access-type site dir)
 261                   )))
 262             )
 263            (t
 264             (let ((media-type (mime-entity-media-type entity))
 265                   (media-subtype (mime-entity-media-subtype entity))
 266                   (charset (cdr (assoc "charset" params)))
 267                   (encoding (mime-entity-encoding entity)))
 268               (concat
 269                num " " subject
 270                (let ((rest
 271                       (format " <%s/%s%s%s>"
 272                               media-type media-subtype
 273                               (if charset
 274                                   (concat "; " charset)
 275                                 "")
 276                               (if encoding
 277                                   (concat " (" encoding ")")
 278                                 ""))))
 279                  (if (>= (+ (current-column)(length rest))(window-width))
 280                      "\n\t")
 281                  rest)))
 282             )))
 283      (function mime-preview-play-current-entity))
 284     ))
 285
 286
 287 ;;; @@ entity-header
 288 ;;;
 289
 290 (defvar mime-header-presentation-method-alist nil
 291   "Alist of major mode vs. corresponding header-presentation-method functions.
 292 Each element looks like (SYMBOL . FUNCTION).
 293 SYMBOL must be major mode in raw-buffer or t.  t means default.
 294 Interface of FUNCTION must be (ENTITY SITUATION).")
 295
 296 (defvar mime-view-ignored-field-list
 297   '(".*Received" ".*Path" ".*Id" "References"
 298     "Replied" "Errors-To"
 299     "Lines" "Sender" ".*Host" "Xref"
 300     "Content-Type" "Precedence"
 301     "Status" "X-VM-.*")
 302   "All fields that match this list will be hidden in MIME preview buffer.
 303 Each elements are regexp of field-name.")
 304
 305 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
 306   "All fields that match this list will be displayed in MIME preview buffer.
 307 Each elements are regexp of field-name.")
 308
 309
 310 ;;; @@ entity-body
 311 ;;;
 312
 313 ;;; @@@ predicate function
 314 ;;;
 315
 316 (defun mime-calist::field-match-method-as-default-rule (calist
 317                                                         field-type field-value)
 318   (let ((s-field (assq field-type calist)))
 319     (cond ((null s-field)
 320            (cons (cons field-type field-value) calist)
 321            )
 322           (t calist))))
 323
 324 (define-calist-field-match-method
 325   'header #'mime-calist::field-match-method-as-default-rule)
 326
 327 (define-calist-field-match-method
 328   'body #'mime-calist::field-match-method-as-default-rule)
 329
 330
 331 (defvar mime-preview-condition nil
 332   "Condition-tree about how to display entity.")
 333
 334 (ctree-set-calist-strictly
 335  'mime-preview-condition '((type . application)(subtype . octet-stream)
 336                            (encoding . nil)
 337                            (body . visible)))
 338 (ctree-set-calist-strictly
 339  'mime-preview-condition '((type . application)(subtype . octet-stream)
 340                            (encoding . "7bit")
 341                            (body . visible)))
 342 (ctree-set-calist-strictly
 343  'mime-preview-condition '((type . application)(subtype . octet-stream)
 344                            (encoding . "8bit")
 345                            (body . visible)))
 346
 347 (ctree-set-calist-strictly
 348  'mime-preview-condition '((type . application)(subtype . pgp)
 349                            (body . visible)))
 350
 351 (ctree-set-calist-strictly
 352  'mime-preview-condition '((type . application)(subtype . x-latex)
 353                            (body . visible)))
 354
 355 (ctree-set-calist-strictly
 356  'mime-preview-condition '((type . application)(subtype . x-selection)
 357                            (body . visible)))
 358
 359 (ctree-set-calist-strictly
 360  'mime-preview-condition '((type . application)(subtype . x-comment)
 361                            (body . visible)))
 362
 363 (ctree-set-calist-strictly
 364  'mime-preview-condition '((type . message)(subtype . delivery-status)
 365                            (body . visible)))
 366
 367 (ctree-set-calist-strictly
 368  'mime-preview-condition
 369  '((body . visible)
 370    (body-presentation-method . mime-display-text/plain)))
 371
 372 (ctree-set-calist-strictly
 373  'mime-preview-condition
 374  '((type . nil)
 375    (body . visible)
 376    (body-presentation-method . mime-display-text/plain)))
 377
 378 (ctree-set-calist-strictly
 379  'mime-preview-condition
 380  '((type . text)(subtype . enriched)
 381    (body . visible)
 382    (body-presentation-method . mime-display-text/enriched)))
 383
 384 (ctree-set-calist-strictly
 385  'mime-preview-condition
 386  '((type . text)(subtype . richtext)
 387    (body . visible)
 388    (body-presentation-method . mime-display-text/richtext)))
 389
 390 (ctree-set-calist-strictly
 391  'mime-preview-condition
 392  '((type . text)(subtype . t)
 393    (body . visible)
 394    (body-presentation-method . mime-display-text/plain)))
 395
 396 (ctree-set-calist-strictly
 397  'mime-preview-condition
 398  '((type . multipart)(subtype . alternative)
 399    (body . visible)
 400    (body-presentation-method . mime-display-multipart/alternative)))
 401
 402 (ctree-set-calist-strictly
 403  'mime-preview-condition '((type . message)(subtype . partial)
 404                            (body-presentation-method
 405                             . mime-display-message/partial-button)))
 406
 407 (ctree-set-calist-strictly
 408  'mime-preview-condition '((type . message)(subtype . rfc822)
 409                            (body-presentation-method . nil)
 410                            (childrens-situation (header . visible)
 411                                                 (entity-button . invisible))))
 412
 413 (ctree-set-calist-strictly
 414  'mime-preview-condition '((type . message)(subtype . news)
 415                            (body-presentation-method . nil)
 416                            (childrens-situation (header . visible)
 417                                                 (entity-button . invisible))))
 418
 419
 420 ;;; @@@ entity presentation
 421 ;;;
 422
 423 (autoload 'mime-display-text/plain "mime-text")
 424 (autoload 'mime-display-text/enriched "mime-text")
 425 (autoload 'mime-display-text/richtext "mime-text")
 426
 427 (defvar mime-view-announcement-for-message/partial
 428   (if (and (>= emacs-major-version 19) window-system)
 429       "\
 430 \[[ This is message/partial style split message. ]]
 431 \[[ Please press `v' key in this buffer          ]]
 432 \[[ or click here by mouse button-2.             ]]"
 433     "\
 434 \[[ This is message/partial style split message. ]]
 435 \[[ Please press `v' key in this buffer.         ]]"
 436     ))
 437
 438 (defun mime-display-message/partial-button (&optional entity situation)
 439   (save-restriction
 440     (goto-char (point-max))
 441     (if (not (search-backward "\n\n" nil t))
 442         (insert "\n")
 443       )
 444     (goto-char (point-max))
 445     (narrow-to-region (point-max)(point-max))
 446     (insert mime-view-announcement-for-message/partial)
 447     (mime-add-button (point-min)(point-max)
 448                      #'mime-preview-play-current-entity)
 449     ))
 450
 451 (defun mime-display-multipart/mixed (entity situation)
 452   (let ((children (mime-entity-children entity))
 453         (default-situation
 454           (cdr (assq 'childrens-situation situation))))
 455     (while children
 456       (mime-display-entity (car children) nil default-situation)
 457       (setq children (cdr children))
 458       )))
 459
 460 (defcustom mime-view-type-subtype-score-alist
 461   '(((text . enriched) . 3)
 462     ((text . richtext) . 2)
 463     ((text . plain)    . 1)
 464     (t . 0))
 465   "Alist MEDIA-TYPE vs corresponding score.
 466 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 467   :group 'mime-view
 468   :type '(repeat (cons (choice :tag "Media-Type"
 469                                (cons :tag "Type/Subtype"
 470                                      (symbol :tag "Primary-type")
 471                                      (symbol :tag "Subtype"))
 472                                (symbol :tag "Type")
 473                                (const :tag "Default" t))
 474                        integer)))
 475
 476 (defun mime-display-multipart/alternative (entity situation)
 477   (let* ((children (mime-entity-children entity))
 478          (default-situation
 479            (cdr (assq 'childrens-situation situation)))
 480          (i 0)
 481          (p 0)
 482          (max-score 0)
 483          (situations
 484           (mapcar (function
 485                    (lambda (child)
 486                      (let ((situation
 487                             (or (ctree-match-calist
 488                                  mime-preview-condition
 489                                  (append (mime-entity-situation child)
 490                                          default-situation))
 491                                 default-situation)))
 492                        (if (cdr (assq 'body-presentation-method situation))
 493                            (let ((score
 494                                   (cdr
 495                                    (or (assoc
 496                                         (cons
 497                                          (cdr (assq 'type situation))
 498                                          (cdr (assq 'subtype situation)))
 499                                         mime-view-type-subtype-score-alist)
 500                                        (assq
 501                                         (cdr (assq 'type situation))
 502                                         mime-view-type-subtype-score-alist)
 503                                        (assq
 504                                         t
 505                                         mime-view-type-subtype-score-alist)
 506                                        ))))
 507                              (if (> score max-score)
 508                                  (setq p i
 509                                        max-score score)
 510                                )))
 511                        (setq i (1+ i))
 512                        situation)
 513                      ))
 514                   children)))
 515     (setq i 0)
 516     (while children
 517       (let ((child (car children))
 518             (situation (car situations)))
 519         (mime-display-entity child (if (= i p)
 520                                        situation
 521                                      (del-alist 'body-presentation-method
 522                                                 (copy-alist situation))))
 523         )
 524       (setq children (cdr children)
 525             situations (cdr situations)
 526             i (1+ i))
 527       )))
 528
 529
 530 ;;; @ acting-condition
 531 ;;;
 532
 533 (defvar mime-acting-condition nil
 534   "Condition-tree about how to process entity.")
 535
 536 (if (file-readable-p mailcap-file)
 537     (let ((entries (mailcap-parse-file)))
 538       (while entries
 539         (let ((entry (car entries))
 540               view print shared)
 541           (while entry
 542             (let* ((field (car entry))
 543                    (field-type (car field)))
 544               (cond ((eq field-type 'view)  (setq view field))
 545                     ((eq field-type 'print) (setq print field))
 546                     ((memq field-type '(compose composetyped edit)))
 547                     (t (setq shared (cons field shared))))
 548               )
 549             (setq entry (cdr entry))
 550             )
 551           (setq shared (nreverse shared))
 552           (ctree-set-calist-with-default
 553            'mime-acting-condition
 554            (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 555           (if print
 556               (ctree-set-calist-with-default
 557                'mime-acting-condition
 558                (append shared
 559                        (list '(mode . "print")(cons 'method (cdr view))))
 560                ))
 561           )
 562         (setq entries (cdr entries))
 563         )))
 564
 565 (ctree-set-calist-strictly
 566  'mime-acting-condition
 567  '((type . application)(subtype . octet-stream)
 568    (mode . "play")
 569    (method . mime-detect-content)
 570    ))
 571
 572 (ctree-set-calist-with-default
 573  'mime-acting-condition
 574  '((mode . "extract")
 575    (method . mime-save-content)))
 576
 577 (ctree-set-calist-strictly
 578  'mime-acting-condition
 579  '((type . text)(subtype . x-rot13-47)(mode . "play")
 580    (method . mime-view-caesar)
 581    ))
 582 (ctree-set-calist-strictly
 583  'mime-acting-condition
 584  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
 585    (method . mime-view-caesar)
 586    ))
 587
 588 (ctree-set-calist-strictly
 589  'mime-acting-condition
 590  '((type . message)(subtype . rfc822)(mode . "play")
 591    (method . mime-view-message/rfc822)
 592    ))
 593 (ctree-set-calist-strictly
 594  'mime-acting-condition
 595  '((type . message)(subtype . partial)(mode . "play")
 596    (method . mime-store-message/partial-piece)
 597    ))
 598
 599 (ctree-set-calist-strictly
 600  'mime-acting-condition
 601  '((type . message)(subtype . external-body)
 602    ("access-type" . "anon-ftp")
 603    (method . mime-view-message/external-anon-ftp)
 604    ))
 605
 606 (ctree-set-calist-strictly
 607  'mime-acting-condition
 608  '((type . message)(subtype . external-body)
 609    ("access-type" . "url")
 610    (method . mime-view-message/external-url)
 611    ))
 612
 613 (ctree-set-calist-strictly
 614  'mime-acting-condition
 615  '((type . application)(subtype . octet-stream)
 616    (method . mime-save-content)
 617    ))
 618
 619
 620 ;;; @ quitting method
 621 ;;;
 622
 623 (defvar mime-preview-quitting-method-alist
 624   '((mime-show-message-mode
 625      . mime-preview-quitting-method-for-mime-show-message-mode))
 626   "Alist of major-mode vs. quitting-method of mime-view.")
 627
 628 (defvar mime-preview-over-to-previous-method-alist nil
 629   "Alist of major-mode vs. over-to-previous-method of mime-view.")
 630
 631 (defvar mime-preview-over-to-next-method-alist nil
 632   "Alist of major-mode vs. over-to-next-method of mime-view.")
 633
 634
 635 ;;; @ following method
 636 ;;;
 637
 638 (defvar mime-preview-following-method-alist nil
 639   "Alist of major-mode vs. following-method of mime-view.")
 640
 641 (defvar mime-view-following-required-fields-list
 642   '("From"))
 643
 644
 645 ;;; @ buffer setup
 646 ;;;
 647
 648 (defun mime-display-entity (entity &optional situation
 649                                    default-situation preview-buffer)
 650   (or preview-buffer
 651       (setq preview-buffer (current-buffer)))
 652   (let* ((raw-buffer (mime-entity-buffer entity))
 653          (start (mime-entity-point-min entity))
 654          e nb ne)
 655     (set-buffer raw-buffer)
 656     (goto-char start)
 657     (or situation
 658         (setq situation
 659               (or (ctree-match-calist mime-preview-condition
 660                                       (append (mime-entity-situation entity)
 661                                               default-situation))
 662                   default-situation)))
 663     (let ((button-is-invisible
 664            (eq (cdr (assq 'entity-button situation)) 'invisible))
 665           (header-is-visible
 666            (eq (cdr (assq 'header situation)) 'visible))
 667           (header-presentation-method
 668            (or (cdr (assq 'header-presentation-method situation))
 669                (cdr (assq major-mode mime-header-presentation-method-alist))))
 670           (body-presentation-method
 671            (cdr (assq 'body-presentation-method situation)))
 672           (children (mime-entity-children entity)))
 673       (set-buffer preview-buffer)
 674       (setq nb (point))
 675       (narrow-to-region nb nb)
 676       (or button-is-invisible
 677           (if (mime-view-entity-button-visible-p entity)
 678               (mime-view-insert-entity-button entity)
 679             ))
 680       (when header-is-visible
 681         (if header-presentation-method
 682             (funcall header-presentation-method entity situation)
 683           (mime-insert-decoded-header entity
 684                                       mime-view-ignored-field-list
 685                                       mime-view-visible-field-list))
 686         (goto-char (point-max))
 687         (insert "\n")
 688         (run-hooks 'mime-display-header-hook)
 689         )
 690       (cond (children)
 691             ((functionp body-presentation-method)
 692              (funcall body-presentation-method entity situation)
 693              )
 694             (t
 695              (when button-is-invisible
 696                (goto-char (point-max))
 697                (mime-view-insert-entity-button entity)
 698                )
 699              (or header-is-visible
 700                  (progn
 701                    (goto-char (point-max))
 702                    (insert "\n")
 703                    ))
 704              ))
 705       (setq ne (point-max))
 706       (widen)
 707       (put-text-property nb ne 'mime-view-entity entity)
 708       (goto-char ne)
 709       (if children
 710           (if (functionp body-presentation-method)
 711               (funcall body-presentation-method entity situation)
 712             (mime-display-multipart/mixed entity situation)
 713             ))
 714       )))
 715
 716
 717 ;;; @ MIME viewer mode
 718 ;;;
 719
 720 (defconst mime-view-menu-title "MIME-View")
 721 (defconst mime-view-menu-list
 722   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 723     (previous    "Move to previous entity" mime-preview-move-to-previous)
 724     (next        "Move to next entity"     mime-preview-move-to-next)
 725     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 726     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 727     (play        "Play current entity"     mime-preview-play-current-entity)
 728     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 729     (print       "Print current entity"    mime-preview-print-current-entity)
 730     )
 731   "Menu for MIME Viewer")
 732
 733 (cond (running-xemacs
 734        (defvar mime-view-xemacs-popup-menu
 735          (cons mime-view-menu-title
 736                (mapcar (function
 737                         (lambda (item)
 738                           (vector (nth 1 item)(nth 2 item) t)
 739                           ))
 740                        mime-view-menu-list)))
 741        (defun mime-view-xemacs-popup-menu (event)
 742          "Popup the menu in the MIME Viewer buffer"
 743          (interactive "e")
 744          (select-window (event-window event))
 745          (set-buffer (event-buffer event))
 746          (popup-menu 'mime-view-xemacs-popup-menu))
 747        (defvar mouse-button-2 'button2)
 748        )
 749       (t
 750        (defvar mouse-button-2 [mouse-2])
 751        ))
 752
 753 (defun mime-view-define-keymap (&optional default)
 754   (let ((mime-view-mode-map (if (keymapp default)
 755                                 (copy-keymap default)
 756                               (make-sparse-keymap)
 757                               )))
 758     (define-key mime-view-mode-map
 759       "u"        (function mime-preview-move-to-upper))
 760     (define-key mime-view-mode-map
 761       "p"        (function mime-preview-move-to-previous))
 762     (define-key mime-view-mode-map
 763       "n"        (function mime-preview-move-to-next))
 764     (define-key mime-view-mode-map
 765       "\e\t"     (function mime-preview-move-to-previous))
 766     (define-key mime-view-mode-map
 767       "\t"       (function mime-preview-move-to-next))
 768     (define-key mime-view-mode-map
 769       " "        (function mime-preview-scroll-up-entity))
 770     (define-key mime-view-mode-map
 771       "\M- "     (function mime-preview-scroll-down-entity))
 772     (define-key mime-view-mode-map
 773       "\177"     (function mime-preview-scroll-down-entity))
 774     (define-key mime-view-mode-map
 775       "\C-m"     (function mime-preview-next-line-entity))
 776     (define-key mime-view-mode-map
 777       "\C-\M-m"  (function mime-preview-previous-line-entity))
 778     (define-key mime-view-mode-map
 779       "v"        (function mime-preview-play-current-entity))
 780     (define-key mime-view-mode-map
 781       "e"        (function mime-preview-extract-current-entity))
 782     (define-key mime-view-mode-map
 783       "\C-c\C-p" (function mime-preview-print-current-entity))
 784     (define-key mime-view-mode-map
 785       "a"        (function mime-preview-follow-current-entity))
 786     (define-key mime-view-mode-map
 787       "q"        (function mime-preview-quit))
 788     (define-key mime-view-mode-map
 789       "\C-c\C-x" (function mime-preview-kill-buffer))
 790     ;; (define-key mime-view-mode-map
 791     ;;   "<"        (function beginning-of-buffer))
 792     ;; (define-key mime-view-mode-map
 793     ;;   ">"        (function end-of-buffer))
 794     (define-key mime-view-mode-map
 795       "?"        (function describe-mode))
 796     (define-key mime-view-mode-map
 797       [tab] (function mime-preview-move-to-next))
 798     (define-key mime-view-mode-map
 799       [delete] (function mime-preview-scroll-down-entity))
 800     (define-key mime-view-mode-map
 801       [backspace] (function mime-preview-scroll-down-entity))
 802     (if (functionp default)
 803         (cond (running-xemacs
 804                (set-keymap-default-binding mime-view-mode-map default)
 805                )
 806               (t
 807                (setq mime-view-mode-map
 808                      (append mime-view-mode-map (list (cons t default))))
 809                )))
 810     (if mouse-button-2
 811         (define-key mime-view-mode-map
 812           mouse-button-2 (function mime-button-dispatcher))
 813       )
 814     (cond (running-xemacs
 815            (define-key mime-view-mode-map
 816              mouse-button-3 (function mime-view-xemacs-popup-menu))
 817            )
 818           ((>= emacs-major-version 19)
 819            (define-key mime-view-mode-map [menu-bar mime-view]
 820              (cons mime-view-menu-title
 821                    (make-sparse-keymap mime-view-menu-title)))
 822            (mapcar (function
 823                     (lambda (item)
 824                       (define-key mime-view-mode-map
 825                         (vector 'menu-bar 'mime-view (car item))
 826                         (cons (nth 1 item)(nth 2 item))
 827                         )
 828                       ))
 829                    (reverse mime-view-menu-list)
 830                    )
 831            ))
 832     (use-local-map mime-view-mode-map)
 833     (run-hooks 'mime-view-define-keymap-hook)
 834     ))
 835
 836 (defsubst mime-maybe-hide-echo-buffer ()
 837   "Clear mime-echo buffer and delete window for it."
 838   (let ((buf (get-buffer mime-echo-buffer-name)))
 839     (if buf
 840         (save-excursion
 841           (set-buffer buf)
 842           (erase-buffer)
 843           (let ((win (get-buffer-window buf)))
 844             (if win
 845                 (delete-window win)
 846               ))
 847           (bury-buffer buf)
 848           ))))
 849
 850 (defvar mime-view-redisplay nil)
 851
 852 (defun mime-display-message (message &optional preview-buffer
 853                                      mother default-keymap-or-function)
 854   (mime-maybe-hide-echo-buffer)
 855   (let ((win-conf (current-window-configuration))
 856         (raw-buffer (mime-entity-buffer message)))
 857     (or preview-buffer
 858         (setq preview-buffer
 859               (concat "*Preview-" (buffer-name raw-buffer) "*")))
 860     (set-buffer raw-buffer)
 861     (setq mime-preview-buffer preview-buffer)
 862     (let ((inhibit-read-only t))
 863       (set-buffer (get-buffer-create preview-buffer))
 864       (widen)
 865       (erase-buffer)
 866       (setq mime-raw-buffer raw-buffer)
 867       (if mother
 868           (setq mime-mother-buffer mother)
 869         )
 870       (setq mime-preview-original-window-configuration win-conf)
 871       (setq major-mode 'mime-view-mode)
 872       (setq mode-name "MIME-View")
 873       (mime-display-entity message nil
 874                            '((entity-button . invisible)
 875                              (header . visible))
 876                            preview-buffer)
 877       (mime-view-define-keymap default-keymap-or-function)
 878       (let ((point
 879              (next-single-property-change (point-min) 'mime-view-entity)))
 880         (if point
 881             (goto-char point)
 882           (goto-char (point-min))
 883           (search-forward "\n\n" nil t)
 884           ))
 885       (run-hooks 'mime-view-mode-hook)
 886       (set-buffer-modified-p nil)
 887       (setq buffer-read-only t)
 888       (or (get-buffer-window preview-buffer)
 889           (let ((r-win (get-buffer-window raw-buffer)))
 890             (if r-win
 891                 (set-window-buffer r-win preview-buffer)
 892               (let ((m-win (and mother (get-buffer-window mother))))
 893                 (if m-win
 894                     (set-window-buffer m-win preview-buffer)
 895                   (switch-to-buffer preview-buffer)
 896                   )))))
 897       )))
 898
 899 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
 900                                    default-keymap-or-function
 901                                    representation-type)
 902   "View RAW-BUFFER in MIME-View mode.
 903 Optional argument PREVIEW-BUFFER is either nil or a name of preview
 904 buffer.
 905 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
 906 function.  If it is a keymap, keymap of MIME-View mode will be added
 907 to it.  If it is a function, it will be bound as default binding of
 908 keymap of MIME-View mode.
 909 Optional argument REPRESENTATION-TYPE is representation-type of
 910 message.  It must be nil, `binary' or `cooked'.  If it is nil,
 911 `binary' is used as default."
 912   (interactive)
 913   (or raw-buffer
 914       (setq raw-buffer (current-buffer)))
 915   (or representation-type
 916       (setq representation-type
 917             (save-excursion
 918               (set-buffer raw-buffer)
 919               (cdr (or (assq major-mode mime-raw-representation-type-alist)
 920                        (assq t mime-raw-representation-type-alist)))
 921               )))
 922   (if (eq representation-type 'binary)
 923       (setq representation-type 'buffer)
 924     )
 925   (mime-display-message
 926    (mime-open-entity representation-type raw-buffer)
 927    preview-buffer mother default-keymap-or-function))
 928
 929 (defun mime-view-mode (&optional mother ctl encoding
 930                                  raw-buffer preview-buffer
 931                                  default-keymap-or-function)
 932   "Major mode for viewing MIME message.
 933
 934 Here is a list of the standard keys for mime-view-mode.
 935
 936 key             feature
 937 ---             -------
 938
 939 u               Move to upper content
 940 p or M-TAB      Move to previous content
 941 n or TAB        Move to next content
 942 SPC             Scroll up or move to next content
 943 M-SPC or DEL    Scroll down or move to previous content
 944 RET             Move to next line
 945 M-RET           Move to previous line
 946 v               Decode current content as `play mode'
 947 e               Decode current content as `extract mode'
 948 C-c C-p         Decode current content as `print mode'
 949 a               Followup to current content.
 950 q               Quit
 951 button-2        Move to point under the mouse cursor
 952                 and decode current content as `play mode'
 953 "
 954   (interactive)
 955   (unless mime-view-redisplay
 956     (save-excursion
 957       (if raw-buffer (set-buffer raw-buffer))
 958       (let ((type
 959              (cdr
 960               (or (assq major-mode mime-raw-representation-type-alist)
 961                   (assq t mime-raw-representation-type-alist)))))
 962         (if (eq type 'binary)
 963             (setq type 'buffer)
 964           )
 965         (setq mime-message-structure (mime-open-entity type raw-buffer))
 966         (or (mime-entity-content-type mime-message-structure)
 967             (mime-entity-set-content-type-internal
 968              mime-message-structure ctl))
 969         )
 970       (or (mime-entity-encoding mime-message-structure)
 971           (mime-entity-set-encoding-internal mime-message-structure encoding))
 972       ))
 973   (mime-display-message mime-message-structure preview-buffer
 974                         mother default-keymap-or-function)
 975   )
 976
 977
 978 ;;; @@ playing
 979 ;;;
 980
 981 (autoload 'mime-preview-play-current-entity "mime-play"
 982   "Play current entity." t)
 983
 984 (defun mime-preview-extract-current-entity (&optional ignore-examples)
 985   "Extract current entity into file (maybe).
 986 It decodes current entity to call internal or external method as
 987 \"extract\" mode.  The method is selected from variable
 988 `mime-acting-condition'."
 989   (interactive "P")
 990   (mime-preview-play-current-entity ignore-examples "extract")
 991   )
 992
 993 (defun mime-preview-print-current-entity (&optional ignore-examples)
 994   "Print current entity (maybe).
 995 It decodes current entity to call internal or external method as
 996 \"print\" mode.  The method is selected from variable
 997 `mime-acting-condition'."
 998   (interactive "P")
 999   (mime-preview-play-current-entity ignore-examples "print")
1000   )
1001
1002
1003 ;;; @@ following
1004 ;;;
1005
1006 (defun mime-preview-follow-current-entity ()
1007   "Write follow message to current entity.
1008 It calls following-method selected from variable
1009 `mime-preview-following-method-alist'."
1010   (interactive)
1011   (let (entity)
1012     (while (null (setq entity
1013                        (get-text-property (point) 'mime-view-entity)))
1014       (backward-char)
1015       )
1016     (let* ((p-beg
1017             (previous-single-property-change (point) 'mime-view-entity))
1018            p-end
1019            (entity-node-id (mime-entity-node-id entity))
1020            (len (length entity-node-id))
1021            )
1022       (cond ((null p-beg)
1023              (setq p-beg
1024                    (if (eq (next-single-property-change (point-min)
1025                                                         'mime-view-entity)
1026                            (point))
1027                        (point)
1028                      (point-min)))
1029              )
1030             ((eq (next-single-property-change p-beg 'mime-view-entity)
1031                  (point))
1032              (setq p-beg (point))
1033              ))
1034       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1035       (cond ((null p-end)
1036              (setq p-end (point-max))
1037              )
1038             ((null entity-node-id)
1039              (setq p-end (point-max))
1040              )
1041             (t
1042              (save-excursion
1043                (goto-char p-end)
1044                (catch 'tag
1045                  (let (e)
1046                    (while (setq e
1047                                 (next-single-property-change
1048                                  (point) 'mime-view-entity))
1049                      (goto-char e)
1050                      (let ((rc (mime-entity-node-id
1051                                 (get-text-property (point)
1052                                                    'mime-view-entity))))
1053                        (or (equal entity-node-id
1054                                   (nthcdr (- (length rc) len) rc))
1055                            (throw 'tag nil)
1056                            ))
1057                      (setq p-end e)
1058                      ))
1059                  (setq p-end (point-max))
1060                  ))
1061              ))
1062       (let* ((mode (mime-preview-original-major-mode 'recursive))
1063              (new-name
1064               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1065              new-buf
1066              (the-buf (current-buffer))
1067              (a-buf mime-raw-buffer)
1068              fields)
1069         (save-excursion
1070           (set-buffer (setq new-buf (get-buffer-create new-name)))
1071           (erase-buffer)
1072           (insert-buffer-substring the-buf p-beg p-end)
1073           (goto-char (point-min))
1074           (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1075             (while (progn
1076                      (setq
1077                       str
1078                       (save-excursion
1079                         (set-buffer a-buf)
1080                         (setq ci
1081                               (mime-find-entity-from-node-id entity-node-id))
1082                         (save-restriction
1083                           (narrow-to-region
1084                            (mime-entity-point-min ci)
1085                            (mime-entity-point-max ci)
1086                            )
1087                           (std11-header-string-except
1088                            (concat "^"
1089                                    (apply (function regexp-or) fields)
1090                                    ":") ""))))
1091                      (if (and
1092                           (eq (mime-entity-media-type ci) 'message)
1093                           (eq (mime-entity-media-subtype ci) 'rfc822))
1094                          nil
1095                        (if str
1096                            (insert str)
1097                          )
1098                        entity-node-id))
1099               (setq fields (std11-collect-field-names)
1100                     entity-node-id (cdr entity-node-id))
1101               )
1102             )
1103           (let ((rest mime-view-following-required-fields-list))
1104             (while rest
1105               (let ((field-name (car rest)))
1106                 (or (std11-field-body field-name)
1107                     (insert
1108                      (format
1109                       (concat field-name
1110                               ": "
1111                               (save-excursion
1112                                 (set-buffer the-buf)
1113                                 (set-buffer mime-mother-buffer)
1114                                 (set-buffer mime-raw-buffer)
1115                                 (std11-field-body field-name)
1116                                 )
1117                               "\n")))
1118                     ))
1119               (setq rest (cdr rest))
1120               ))
1121           (eword-decode-header)
1122           )
1123         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1124           (if (functionp f)
1125               (funcall f new-buf)
1126             (message
1127              (format
1128               "Sorry, following method for %s is not implemented yet."
1129               mode))
1130             ))
1131         ))))
1132
1133
1134 ;;; @@ moving
1135 ;;;
1136
1137 (defun mime-preview-move-to-upper ()
1138   "Move to upper entity.
1139 If there is no upper entity, call function `mime-preview-quit'."
1140   (interactive)
1141   (let (cinfo)
1142     (while (null (setq cinfo
1143                        (get-text-property (point) 'mime-view-entity)))
1144       (backward-char)
1145       )
1146     (let ((r (mime-entity-parent cinfo))
1147           point)
1148       (catch 'tag
1149         (while (setq point (previous-single-property-change
1150                             (point) 'mime-view-entity))
1151           (goto-char point)
1152           (if (eq r (get-text-property (point) 'mime-view-entity))
1153               (throw 'tag t)
1154             )
1155           )
1156         (mime-preview-quit)
1157         ))))
1158
1159 (defun mime-preview-move-to-previous ()
1160   "Move to previous entity.
1161 If there is no previous entity, it calls function registered in
1162 variable `mime-preview-over-to-previous-method-alist'."
1163   (interactive)
1164   (while (null (get-text-property (point) 'mime-view-entity))
1165     (backward-char)
1166     )
1167   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1168     (if point
1169         (if (get-text-property (1- point) 'mime-view-entity)
1170             (goto-char point)
1171           (goto-char (1- point))
1172           (mime-preview-move-to-previous)
1173           )
1174       (let ((f (assq (mime-preview-original-major-mode)
1175                      mime-preview-over-to-previous-method-alist)))
1176         (if f
1177             (funcall (cdr f))
1178           ))
1179       )))
1180
1181 (defun mime-preview-move-to-next ()
1182   "Move to next entity.
1183 If there is no previous entity, it calls function registered in
1184 variable `mime-preview-over-to-next-method-alist'."
1185   (interactive)
1186   (while (null (get-text-property (point) 'mime-view-entity))
1187     (forward-char)
1188     )
1189   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1190     (if point
1191         (progn
1192           (goto-char point)
1193           (if (null (get-text-property point 'mime-view-entity))
1194               (mime-preview-move-to-next)
1195             ))
1196       (let ((f (assq (mime-preview-original-major-mode)
1197                      mime-preview-over-to-next-method-alist)))
1198         (if f
1199             (funcall (cdr f))
1200           ))
1201       )))
1202
1203 (defun mime-preview-scroll-up-entity (&optional h)
1204   "Scroll up current entity.
1205 If reached to (point-max), it calls function registered in variable
1206 `mime-preview-over-to-next-method-alist'."
1207   (interactive)
1208   (or h
1209       (setq h (1- (window-height)))
1210       )
1211   (if (= (point) (point-max))
1212       (let ((f (assq (mime-preview-original-major-mode)
1213                      mime-preview-over-to-next-method-alist)))
1214         (if f
1215             (funcall (cdr f))
1216           ))
1217     (let ((point
1218            (or (next-single-property-change (point) 'mime-view-entity)
1219                (point-max))))
1220       (forward-line h)
1221       (if (> (point) point)
1222           (goto-char point)
1223         )
1224       )))
1225
1226 (defun mime-preview-scroll-down-entity (&optional h)
1227   "Scroll down current entity.
1228 If reached to (point-min), it calls function registered in variable
1229 `mime-preview-over-to-previous-method-alist'."
1230   (interactive)
1231   (or h
1232       (setq h (1- (window-height)))
1233       )
1234   (if (= (point) (point-min))
1235       (let ((f (assq (mime-preview-original-major-mode)
1236                      mime-preview-over-to-previous-method-alist)))
1237         (if f
1238             (funcall (cdr f))
1239           ))
1240     (let ((point
1241            (or (previous-single-property-change (point) 'mime-view-entity)
1242                (point-min))))
1243       (forward-line (- h))
1244       (if (< (point) point)
1245           (goto-char point)
1246         ))))
1247
1248 (defun mime-preview-next-line-entity ()
1249   (interactive)
1250   (mime-preview-scroll-up-entity 1)
1251   )
1252
1253 (defun mime-preview-previous-line-entity ()
1254   (interactive)
1255   (mime-preview-scroll-down-entity 1)
1256   )
1257
1258
1259 ;;; @@ quitting
1260 ;;;
1261
1262 (defun mime-preview-quit ()
1263   "Quit from MIME-preview buffer.
1264 It calls function registered in variable
1265 `mime-preview-quitting-method-alist'."
1266   (interactive)
1267   (let ((r (assq (mime-preview-original-major-mode)
1268                  mime-preview-quitting-method-alist)))
1269     (if r
1270         (funcall (cdr r))
1271       )))
1272
1273 (defun mime-preview-kill-buffer ()
1274   (interactive)
1275   (kill-buffer (current-buffer))
1276   )
1277
1278
1279 ;;; @ end
1280 ;;;
1281
1282 (provide 'mime-view)
1283
1284 (run-hooks 'mime-view-load-hook)
1285
1286 ;;; mime-view.el ends here