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                                (item :tag "Type/Subtype"
 470                                      (cons symbol symbol))
 471                                (item :tag "Type" symbol)
 472                                (item :tag "Default" t))
 473                        integer)))
 474
 475 (defun mime-display-multipart/alternative (entity situation)
 476   (let* ((children (mime-entity-children entity))
 477          (default-situation
 478            (cdr (assq 'childrens-situation situation)))
 479          (i 0)
 480          (p 0)
 481          (max-score 0)
 482          (situations
 483           (mapcar (function
 484                    (lambda (child)
 485                      (let ((situation
 486                             (or (ctree-match-calist
 487                                  mime-preview-condition
 488                                  (append (mime-entity-situation child)
 489                                          default-situation))
 490                                 default-situation)))
 491                        (if (cdr (assq 'body-presentation-method situation))
 492                            (let ((score
 493                                   (cdr
 494                                    (or (assoc
 495                                         (cons
 496                                          (cdr (assq 'type situation))
 497                                          (cdr (assq 'subtype situation)))
 498                                         mime-view-type-subtype-score-alist)
 499                                        (assq
 500                                         (cdr (assq 'type situation))
 501                                         mime-view-type-subtype-score-alist)
 502                                        (assq
 503                                         t
 504                                         mime-view-type-subtype-score-alist)
 505                                        ))))
 506                              (if (> score max-score)
 507                                  (setq p i
 508                                        max-score score)
 509                                )))
 510                        (setq i (1+ i))
 511                        situation)
 512                      ))
 513                   children)))
 514     (setq i 0)
 515     (while children
 516       (let ((child (car children))
 517             (situation (car situations)))
 518         (mime-display-entity child (if (= i p)
 519                                        situation
 520                                      (del-alist 'body-presentation-method
 521                                                 (copy-alist situation))))
 522         )
 523       (setq children (cdr children)
 524             situations (cdr situations)
 525             i (1+ i))
 526       )))
 527
 528
 529 ;;; @ acting-condition
 530 ;;;
 531
 532 (defvar mime-acting-condition nil
 533   "Condition-tree about how to process entity.")
 534
 535 (if (file-readable-p mailcap-file)
 536     (let ((entries (mailcap-parse-file)))
 537       (while entries
 538         (let ((entry (car entries))
 539               view print shared)
 540           (while entry
 541             (let* ((field (car entry))
 542                    (field-type (car field)))
 543               (cond ((eq field-type 'view)  (setq view field))
 544                     ((eq field-type 'print) (setq print field))
 545                     ((memq field-type '(compose composetyped edit)))
 546                     (t (setq shared (cons field shared))))
 547               )
 548             (setq entry (cdr entry))
 549             )
 550           (setq shared (nreverse shared))
 551           (ctree-set-calist-with-default
 552            'mime-acting-condition
 553            (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 554           (if print
 555               (ctree-set-calist-with-default
 556                'mime-acting-condition
 557                (append shared
 558                        (list '(mode . "print")(cons 'method (cdr view))))
 559                ))
 560           )
 561         (setq entries (cdr entries))
 562         )))
 563
 564 (ctree-set-calist-strictly
 565  'mime-acting-condition
 566  '((type . application)(subtype . octet-stream)
 567    (mode . "play")
 568    (method . mime-detect-content)
 569    ))
 570
 571 (ctree-set-calist-with-default
 572  'mime-acting-condition
 573  '((mode . "extract")
 574    (method . mime-save-content)))
 575
 576 (ctree-set-calist-strictly
 577  'mime-acting-condition
 578  '((type . text)(subtype . x-rot13-47)(mode . "play")
 579    (method . mime-view-caesar)
 580    ))
 581 (ctree-set-calist-strictly
 582  'mime-acting-condition
 583  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
 584    (method . mime-view-caesar)
 585    ))
 586
 587 (ctree-set-calist-strictly
 588  'mime-acting-condition
 589  '((type . message)(subtype . rfc822)(mode . "play")
 590    (method . mime-view-message/rfc822)
 591    ))
 592 (ctree-set-calist-strictly
 593  'mime-acting-condition
 594  '((type . message)(subtype . partial)(mode . "play")
 595    (method . mime-store-message/partial-piece)
 596    ))
 597
 598 (ctree-set-calist-strictly
 599  'mime-acting-condition
 600  '((type . message)(subtype . external-body)
 601    ("access-type" . "anon-ftp")
 602    (method . mime-view-message/external-anon-ftp)
 603    ))
 604
 605 (ctree-set-calist-strictly
 606  'mime-acting-condition
 607  '((type . message)(subtype . external-body)
 608    ("access-type" . "url")
 609    (method . mime-view-message/external-url)
 610    ))
 611
 612 (ctree-set-calist-strictly
 613  'mime-acting-condition
 614  '((type . application)(subtype . octet-stream)
 615    (method . mime-save-content)
 616    ))
 617
 618
 619 ;;; @ quitting method
 620 ;;;
 621
 622 (defvar mime-preview-quitting-method-alist
 623   '((mime-show-message-mode
 624      . mime-preview-quitting-method-for-mime-show-message-mode))
 625   "Alist of major-mode vs. quitting-method of mime-view.")
 626
 627 (defvar mime-preview-over-to-previous-method-alist nil
 628   "Alist of major-mode vs. over-to-previous-method of mime-view.")
 629
 630 (defvar mime-preview-over-to-next-method-alist nil
 631   "Alist of major-mode vs. over-to-next-method of mime-view.")
 632
 633
 634 ;;; @ following method
 635 ;;;
 636
 637 (defvar mime-preview-following-method-alist nil
 638   "Alist of major-mode vs. following-method of mime-view.")
 639
 640 (defvar mime-view-following-required-fields-list
 641   '("From"))
 642
 643
 644 ;;; @ buffer setup
 645 ;;;
 646
 647 (defun mime-display-entity (entity &optional situation
 648                                    default-situation preview-buffer)
 649   (or preview-buffer
 650       (setq preview-buffer (current-buffer)))
 651   (let* ((raw-buffer (mime-entity-buffer entity))
 652          (start (mime-entity-point-min entity))
 653          e nb ne)
 654     (set-buffer raw-buffer)
 655     (goto-char start)
 656     (or situation
 657         (setq situation
 658               (or (ctree-match-calist mime-preview-condition
 659                                       (append (mime-entity-situation entity)
 660                                               default-situation))
 661                   default-situation)))
 662     (let ((button-is-invisible
 663            (eq (cdr (assq 'entity-button situation)) 'invisible))
 664           (header-is-visible
 665            (eq (cdr (assq 'header situation)) 'visible))
 666           (header-presentation-method
 667            (or (cdr (assq 'header-presentation-method situation))
 668                (cdr (assq major-mode mime-header-presentation-method-alist))))
 669           (body-presentation-method
 670            (cdr (assq 'body-presentation-method situation)))
 671           (children (mime-entity-children entity)))
 672       (set-buffer preview-buffer)
 673       (setq nb (point))
 674       (narrow-to-region nb nb)
 675       (or button-is-invisible
 676           (if (mime-view-entity-button-visible-p entity)
 677               (mime-view-insert-entity-button entity)
 678             ))
 679       (when header-is-visible
 680         (if header-presentation-method
 681             (funcall header-presentation-method entity situation)
 682           (mime-insert-decoded-header entity
 683                                       mime-view-ignored-field-list
 684                                       mime-view-visible-field-list
 685                                       (if (mime-entity-cooked-p entity)
 686                                           nil
 687                                         default-mime-charset))
 688           )
 689         (goto-char (point-max))
 690         (insert "\n")
 691         (run-hooks 'mime-display-header-hook)
 692         )
 693       (cond (children)
 694             ((functionp body-presentation-method)
 695              (funcall body-presentation-method entity situation)
 696              )
 697             (t
 698              (when button-is-invisible
 699                (goto-char (point-max))
 700                (mime-view-insert-entity-button entity)
 701                )
 702              (or header-is-visible
 703                  (progn
 704                    (goto-char (point-max))
 705                    (insert "\n")
 706                    ))
 707              ))
 708       (setq ne (point-max))
 709       (widen)
 710       (put-text-property nb ne 'mime-view-entity entity)
 711       (goto-char ne)
 712       (if children
 713           (if (functionp body-presentation-method)
 714               (funcall body-presentation-method entity situation)
 715             (mime-display-multipart/mixed entity situation)
 716             ))
 717       )))
 718
 719
 720 ;;; @ MIME viewer mode
 721 ;;;
 722
 723 (defconst mime-view-menu-title "MIME-View")
 724 (defconst mime-view-menu-list
 725   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 726     (previous    "Move to previous entity" mime-preview-move-to-previous)
 727     (next        "Move to next entity"     mime-preview-move-to-next)
 728     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 729     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 730     (play        "Play current entity"     mime-preview-play-current-entity)
 731     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 732     (print       "Print current entity"    mime-preview-print-current-entity)
 733     )
 734   "Menu for MIME Viewer")
 735
 736 (cond (running-xemacs
 737        (defvar mime-view-xemacs-popup-menu
 738          (cons mime-view-menu-title
 739                (mapcar (function
 740                         (lambda (item)
 741                           (vector (nth 1 item)(nth 2 item) t)
 742                           ))
 743                        mime-view-menu-list)))
 744        (defun mime-view-xemacs-popup-menu (event)
 745          "Popup the menu in the MIME Viewer buffer"
 746          (interactive "e")
 747          (select-window (event-window event))
 748          (set-buffer (event-buffer event))
 749          (popup-menu 'mime-view-xemacs-popup-menu))
 750        (defvar mouse-button-2 'button2)
 751        )
 752       (t
 753        (defvar mouse-button-2 [mouse-2])
 754        ))
 755
 756 (defun mime-view-define-keymap (&optional default)
 757   (let ((mime-view-mode-map (if (keymapp default)
 758                                 (copy-keymap default)
 759                               (make-sparse-keymap)
 760                               )))
 761     (define-key mime-view-mode-map
 762       "u"        (function mime-preview-move-to-upper))
 763     (define-key mime-view-mode-map
 764       "p"        (function mime-preview-move-to-previous))
 765     (define-key mime-view-mode-map
 766       "n"        (function mime-preview-move-to-next))
 767     (define-key mime-view-mode-map
 768       "\e\t"     (function mime-preview-move-to-previous))
 769     (define-key mime-view-mode-map
 770       "\t"       (function mime-preview-move-to-next))
 771     (define-key mime-view-mode-map
 772       " "        (function mime-preview-scroll-up-entity))
 773     (define-key mime-view-mode-map
 774       "\M- "     (function mime-preview-scroll-down-entity))
 775     (define-key mime-view-mode-map
 776       "\177"     (function mime-preview-scroll-down-entity))
 777     (define-key mime-view-mode-map
 778       "\C-m"     (function mime-preview-next-line-entity))
 779     (define-key mime-view-mode-map
 780       "\C-\M-m"  (function mime-preview-previous-line-entity))
 781     (define-key mime-view-mode-map
 782       "v"        (function mime-preview-play-current-entity))
 783     (define-key mime-view-mode-map
 784       "e"        (function mime-preview-extract-current-entity))
 785     (define-key mime-view-mode-map
 786       "\C-c\C-p" (function mime-preview-print-current-entity))
 787     (define-key mime-view-mode-map
 788       "a"        (function mime-preview-follow-current-entity))
 789     (define-key mime-view-mode-map
 790       "q"        (function mime-preview-quit))
 791     (define-key mime-view-mode-map
 792       "\C-c\C-x" (function mime-preview-kill-buffer))
 793     ;; (define-key mime-view-mode-map
 794     ;;   "<"        (function beginning-of-buffer))
 795     ;; (define-key mime-view-mode-map
 796     ;;   ">"        (function end-of-buffer))
 797     (define-key mime-view-mode-map
 798       "?"        (function describe-mode))
 799     (define-key mime-view-mode-map
 800       [tab] (function mime-preview-move-to-next))
 801     (define-key mime-view-mode-map
 802       [delete] (function mime-preview-scroll-down-entity))
 803     (define-key mime-view-mode-map
 804       [backspace] (function mime-preview-scroll-down-entity))
 805     (if (functionp default)
 806         (cond (running-xemacs
 807                (set-keymap-default-binding mime-view-mode-map default)
 808                )
 809               (t
 810                (setq mime-view-mode-map
 811                      (append mime-view-mode-map (list (cons t default))))
 812                )))
 813     (if mouse-button-2
 814         (define-key mime-view-mode-map
 815           mouse-button-2 (function mime-button-dispatcher))
 816       )
 817     (cond (running-xemacs
 818            (define-key mime-view-mode-map
 819              mouse-button-3 (function mime-view-xemacs-popup-menu))
 820            )
 821           ((>= emacs-major-version 19)
 822            (define-key mime-view-mode-map [menu-bar mime-view]
 823              (cons mime-view-menu-title
 824                    (make-sparse-keymap mime-view-menu-title)))
 825            (mapcar (function
 826                     (lambda (item)
 827                       (define-key mime-view-mode-map
 828                         (vector 'menu-bar 'mime-view (car item))
 829                         (cons (nth 1 item)(nth 2 item))
 830                         )
 831                       ))
 832                    (reverse mime-view-menu-list)
 833                    )
 834            ))
 835     (use-local-map mime-view-mode-map)
 836     (run-hooks 'mime-view-define-keymap-hook)
 837     ))
 838
 839 (defsubst mime-maybe-hide-echo-buffer ()
 840   "Clear mime-echo buffer and delete window for it."
 841   (let ((buf (get-buffer mime-echo-buffer-name)))
 842     (if buf
 843         (save-excursion
 844           (set-buffer buf)
 845           (erase-buffer)
 846           (let ((win (get-buffer-window buf)))
 847             (if win
 848                 (delete-window win)
 849               ))
 850           (bury-buffer buf)
 851           ))))
 852
 853 (defvar mime-view-redisplay nil)
 854
 855 (defun mime-display-message (message &optional preview-buffer
 856                                      mother default-keymap-or-function)
 857   (mime-maybe-hide-echo-buffer)
 858   (let ((win-conf (current-window-configuration))
 859         (raw-buffer (mime-entity-buffer message)))
 860     (or preview-buffer
 861         (setq preview-buffer
 862               (concat "*Preview-" (buffer-name raw-buffer) "*")))
 863     (set-buffer raw-buffer)
 864     (setq mime-preview-buffer preview-buffer)
 865     (let ((inhibit-read-only t))
 866       (set-buffer (get-buffer-create preview-buffer))
 867       (widen)
 868       (erase-buffer)
 869       (setq mime-raw-buffer raw-buffer)
 870       (if mother
 871           (setq mime-mother-buffer mother)
 872         )
 873       (setq mime-preview-original-window-configuration win-conf)
 874       (setq major-mode 'mime-view-mode)
 875       (setq mode-name "MIME-View")
 876       (mime-display-entity message nil
 877                            '((entity-button . invisible)
 878                              (header . visible))
 879                            preview-buffer)
 880       (mime-view-define-keymap default-keymap-or-function)
 881       (let ((point
 882              (next-single-property-change (point-min) 'mime-view-entity)))
 883         (if point
 884             (goto-char point)
 885           (goto-char (point-min))
 886           (search-forward "\n\n" nil t)
 887           ))
 888       (run-hooks 'mime-view-mode-hook)
 889       (set-buffer-modified-p nil)
 890       (setq buffer-read-only t)
 891       (or (get-buffer-window preview-buffer)
 892           (let ((r-win (get-buffer-window raw-buffer)))
 893             (if r-win
 894                 (set-window-buffer r-win preview-buffer)
 895               (let ((m-win (and mother (get-buffer-window mother))))
 896                 (if m-win
 897                     (set-window-buffer m-win preview-buffer)
 898                   (switch-to-buffer preview-buffer)
 899                   )))))
 900       )))
 901
 902 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
 903                                    default-keymap-or-function
 904                                    representation-type)
 905   "View RAW-BUFFER in MIME-View mode.
 906 Optional argument PREVIEW-BUFFER is either nil or a name of preview
 907 buffer.
 908 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
 909 function.  If it is a keymap, keymap of MIME-View mode will be added
 910 to it.  If it is a function, it will be bound as default binding of
 911 keymap of MIME-View mode.
 912 Optional argument REPRESENTATION-TYPE is representation-type of
 913 message.  It must be nil, `binary' or `cooked'.  If it is nil,
 914 `binary' is used as default."
 915   (interactive)
 916   (or raw-buffer
 917       (setq raw-buffer (current-buffer)))
 918   (or representation-type
 919       (setq representation-type
 920             (save-excursion
 921               (set-buffer raw-buffer)
 922               (cdr (or (assq major-mode mime-raw-representation-type-alist)
 923                        (assq t mime-raw-representation-type-alist)))
 924               )))
 925   (if (eq representation-type 'binary)
 926       (setq representation-type 'buffer)
 927     )
 928   (mime-display-message
 929    (mime-open-entity representation-type raw-buffer)
 930    preview-buffer mother default-keymap-or-function))
 931
 932 (defun mime-view-mode (&optional mother ctl encoding
 933                                  raw-buffer preview-buffer
 934                                  default-keymap-or-function)
 935   "Major mode for viewing MIME message.
 936
 937 Here is a list of the standard keys for mime-view-mode.
 938
 939 key             feature
 940 ---             -------
 941
 942 u               Move to upper content
 943 p or M-TAB      Move to previous content
 944 n or TAB        Move to next content
 945 SPC             Scroll up or move to next content
 946 M-SPC or DEL    Scroll down or move to previous content
 947 RET             Move to next line
 948 M-RET           Move to previous line
 949 v               Decode current content as `play mode'
 950 e               Decode current content as `extract mode'
 951 C-c C-p         Decode current content as `print mode'
 952 a               Followup to current content.
 953 q               Quit
 954 button-2        Move to point under the mouse cursor
 955                 and decode current content as `play mode'
 956 "
 957   (interactive)
 958   (unless mime-view-redisplay
 959     (save-excursion
 960       (if raw-buffer (set-buffer raw-buffer))
 961       (let ((type
 962              (cdr
 963               (or (assq major-mode mime-raw-representation-type-alist)
 964                   (assq t mime-raw-representation-type-alist)))))
 965         (if (eq type 'binary)
 966             (setq type 'buffer)
 967           )
 968         (setq mime-message-structure (mime-open-entity type raw-buffer))
 969         (or (mime-entity-content-type mime-message-structure)
 970             (mime-entity-set-content-type-internal
 971              mime-message-structure ctl))
 972         )
 973       (or (mime-entity-encoding mime-message-structure)
 974           (mime-entity-set-encoding-internal mime-message-structure encoding))
 975       ))
 976   (mime-display-message mime-message-structure preview-buffer
 977                         mother default-keymap-or-function)
 978   )
 979
 980
 981 ;;; @@ playing
 982 ;;;
 983
 984 (autoload 'mime-preview-play-current-entity "mime-play"
 985   "Play current entity." t)
 986
 987 (defun mime-preview-extract-current-entity ()
 988   "Extract current entity into file (maybe).
 989 It decodes current entity to call internal or external method as
 990 \"extract\" mode.  The method is selected from variable
 991 `mime-acting-condition'."
 992   (interactive)
 993   (mime-preview-play-current-entity "extract")
 994   )
 995
 996 (defun mime-preview-print-current-entity ()
 997   "Print current entity (maybe).
 998 It decodes current entity to call internal or external method as
 999 \"print\" mode.  The method is selected from variable
1000 `mime-acting-condition'."
1001   (interactive)
1002   (mime-preview-play-current-entity "print")
1003   )
1004
1005
1006 ;;; @@ following
1007 ;;;
1008
1009 (defun mime-preview-follow-current-entity ()
1010   "Write follow message to current entity.
1011 It calls following-method selected from variable
1012 `mime-preview-following-method-alist'."
1013   (interactive)
1014   (let (entity)
1015     (while (null (setq entity
1016                        (get-text-property (point) 'mime-view-entity)))
1017       (backward-char)
1018       )
1019     (let* ((p-beg
1020             (previous-single-property-change (point) 'mime-view-entity))
1021            p-end
1022            (entity-node-id (mime-entity-node-id entity))
1023            (len (length entity-node-id))
1024            )
1025       (cond ((null p-beg)
1026              (setq p-beg
1027                    (if (eq (next-single-property-change (point-min)
1028                                                         'mime-view-entity)
1029                            (point))
1030                        (point)
1031                      (point-min)))
1032              )
1033             ((eq (next-single-property-change p-beg 'mime-view-entity)
1034                  (point))
1035              (setq p-beg (point))
1036              ))
1037       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1038       (cond ((null p-end)
1039              (setq p-end (point-max))
1040              )
1041             ((null entity-node-id)
1042              (setq p-end (point-max))
1043              )
1044             (t
1045              (save-excursion
1046                (goto-char p-end)
1047                (catch 'tag
1048                  (let (e)
1049                    (while (setq e
1050                                 (next-single-property-change
1051                                  (point) 'mime-view-entity))
1052                      (goto-char e)
1053                      (let ((rc (mime-entity-node-id
1054                                 (get-text-property (point)
1055                                                    'mime-view-entity))))
1056                        (or (equal entity-node-id
1057                                   (nthcdr (- (length rc) len) rc))
1058                            (throw 'tag nil)
1059                            ))
1060                      (setq p-end e)
1061                      ))
1062                  (setq p-end (point-max))
1063                  ))
1064              ))
1065       (let* ((mode (mime-preview-original-major-mode 'recursive))
1066              (new-name
1067               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1068              new-buf
1069              (the-buf (current-buffer))
1070              (a-buf mime-raw-buffer)
1071              fields)
1072         (save-excursion
1073           (set-buffer (setq new-buf (get-buffer-create new-name)))
1074           (erase-buffer)
1075           (insert-buffer-substring the-buf p-beg p-end)
1076           (goto-char (point-min))
1077           (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1078             (while (progn
1079                      (setq
1080                       str
1081                       (save-excursion
1082                         (set-buffer a-buf)
1083                         (setq ci
1084                               (mime-find-entity-from-node-id entity-node-id))
1085                         (save-restriction
1086                           (narrow-to-region
1087                            (mime-entity-point-min ci)
1088                            (mime-entity-point-max ci)
1089                            )
1090                           (std11-header-string-except
1091                            (concat "^"
1092                                    (apply (function regexp-or) fields)
1093                                    ":") ""))))
1094                      (if (and
1095                           (eq (mime-entity-media-type ci) 'message)
1096                           (eq (mime-entity-media-subtype ci) 'rfc822))
1097                          nil
1098                        (if str
1099                            (insert str)
1100                          )
1101                        entity-node-id))
1102               (setq fields (std11-collect-field-names)
1103                     entity-node-id (cdr entity-node-id))
1104               )
1105             )
1106           (let ((rest mime-view-following-required-fields-list))
1107             (while rest
1108               (let ((field-name (car rest)))
1109                 (or (std11-field-body field-name)
1110                     (insert
1111                      (format
1112                       (concat field-name
1113                               ": "
1114                               (save-excursion
1115                                 (set-buffer the-buf)
1116                                 (set-buffer mime-mother-buffer)
1117                                 (set-buffer mime-raw-buffer)
1118                                 (std11-field-body field-name)
1119                                 )
1120                               "\n")))
1121                     ))
1122               (setq rest (cdr rest))
1123               ))
1124           (eword-decode-header)
1125           )
1126         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1127           (if (functionp f)
1128               (funcall f new-buf)
1129             (message
1130              (format
1131               "Sorry, following method for %s is not implemented yet."
1132               mode))
1133             ))
1134         ))))
1135
1136
1137 ;;; @@ moving
1138 ;;;
1139
1140 (defun mime-preview-move-to-upper ()
1141   "Move to upper entity.
1142 If there is no upper entity, call function `mime-preview-quit'."
1143   (interactive)
1144   (let (cinfo)
1145     (while (null (setq cinfo
1146                        (get-text-property (point) 'mime-view-entity)))
1147       (backward-char)
1148       )
1149     (let ((r (mime-entity-parent cinfo))
1150           point)
1151       (catch 'tag
1152         (while (setq point (previous-single-property-change
1153                             (point) 'mime-view-entity))
1154           (goto-char point)
1155           (if (eq r (get-text-property (point) 'mime-view-entity))
1156               (throw 'tag t)
1157             )
1158           )
1159         (mime-preview-quit)
1160         ))))
1161
1162 (defun mime-preview-move-to-previous ()
1163   "Move to previous entity.
1164 If there is no previous entity, it calls function registered in
1165 variable `mime-preview-over-to-previous-method-alist'."
1166   (interactive)
1167   (while (null (get-text-property (point) 'mime-view-entity))
1168     (backward-char)
1169     )
1170   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1171     (if point
1172         (if (get-text-property (1- point) 'mime-view-entity)
1173             (goto-char point)
1174           (goto-char (1- point))
1175           (mime-preview-move-to-previous)
1176           )
1177       (let ((f (assq (mime-preview-original-major-mode)
1178                      mime-preview-over-to-previous-method-alist)))
1179         (if f
1180             (funcall (cdr f))
1181           ))
1182       )))
1183
1184 (defun mime-preview-move-to-next ()
1185   "Move to next entity.
1186 If there is no previous entity, it calls function registered in
1187 variable `mime-preview-over-to-next-method-alist'."
1188   (interactive)
1189   (while (null (get-text-property (point) 'mime-view-entity))
1190     (forward-char)
1191     )
1192   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1193     (if point
1194         (progn
1195           (goto-char point)
1196           (if (null (get-text-property point 'mime-view-entity))
1197               (mime-preview-move-to-next)
1198             ))
1199       (let ((f (assq (mime-preview-original-major-mode)
1200                      mime-preview-over-to-next-method-alist)))
1201         (if f
1202             (funcall (cdr f))
1203           ))
1204       )))
1205
1206 (defun mime-preview-scroll-up-entity (&optional h)
1207   "Scroll up current entity.
1208 If reached to (point-max), it calls function registered in variable
1209 `mime-preview-over-to-next-method-alist'."
1210   (interactive)
1211   (or h
1212       (setq h (1- (window-height)))
1213       )
1214   (if (= (point) (point-max))
1215       (let ((f (assq (mime-preview-original-major-mode)
1216                      mime-preview-over-to-next-method-alist)))
1217         (if f
1218             (funcall (cdr f))
1219           ))
1220     (let ((point
1221            (or (next-single-property-change (point) 'mime-view-entity)
1222                (point-max))))
1223       (forward-line h)
1224       (if (> (point) point)
1225           (goto-char point)
1226         )
1227       )))
1228
1229 (defun mime-preview-scroll-down-entity (&optional h)
1230   "Scroll down current entity.
1231 If reached to (point-min), it calls function registered in variable
1232 `mime-preview-over-to-previous-method-alist'."
1233   (interactive)
1234   (or h
1235       (setq h (1- (window-height)))
1236       )
1237   (if (= (point) (point-min))
1238       (let ((f (assq (mime-preview-original-major-mode)
1239                      mime-preview-over-to-previous-method-alist)))
1240         (if f
1241             (funcall (cdr f))
1242           ))
1243     (let ((point
1244            (or (previous-single-property-change (point) 'mime-view-entity)
1245                (point-min))))
1246       (forward-line (- h))
1247       (if (< (point) point)
1248           (goto-char point)
1249         ))))
1250
1251 (defun mime-preview-next-line-entity ()
1252   (interactive)
1253   (mime-preview-scroll-up-entity 1)
1254   )
1255
1256 (defun mime-preview-previous-line-entity ()
1257   (interactive)
1258   (mime-preview-scroll-down-entity 1)
1259   )
1260
1261
1262 ;;; @@ quitting
1263 ;;;
1264
1265 (defun mime-preview-quit ()
1266   "Quit from MIME-preview buffer.
1267 It calls function registered in variable
1268 `mime-preview-quitting-method-alist'."
1269   (interactive)
1270   (let ((r (assq (mime-preview-original-major-mode)
1271                  mime-preview-quitting-method-alist)))
1272     (if r
1273         (funcall (cdr r))
1274       )))
1275
1276 (defun mime-preview-kill-buffer ()
1277   (interactive)
1278   (kill-buffer (current-buffer))
1279   )
1280
1281
1282 ;;; @ end
1283 ;;;
1284
1285 (provide 'mime-view)
1286
1287 (run-hooks 'mime-view-load-hook)
1288
1289 ;;; mime-view.el ends here