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