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         (goto-char (point-max))
 686         (insert "\n")
 687         (run-hooks 'mime-display-header-hook)
 688         )
 689       (cond (children)
 690             ((functionp body-presentation-method)
 691              (funcall body-presentation-method entity situation)
 692              )
 693             (t
 694              (when button-is-invisible
 695                (goto-char (point-max))
 696                (mime-view-insert-entity-button entity)
 697                )
 698              (or header-is-visible
 699                  (progn
 700                    (goto-char (point-max))
 701                    (insert "\n")
 702                    ))
 703              ))
 704       (setq ne (point-max))
 705       (widen)
 706       (put-text-property nb ne 'mime-view-entity entity)
 707       (goto-char ne)
 708       (if children
 709           (if (functionp body-presentation-method)
 710               (funcall body-presentation-method entity situation)
 711             (mime-display-multipart/mixed entity situation)
 712             ))
 713       )))
 714
 715
 716 ;;; @ MIME viewer mode
 717 ;;;
 718
 719 (defconst mime-view-menu-title "MIME-View")
 720 (defconst mime-view-menu-list
 721   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 722     (previous    "Move to previous entity" mime-preview-move-to-previous)
 723     (next        "Move to next entity"     mime-preview-move-to-next)
 724     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 725     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 726     (play        "Play current entity"     mime-preview-play-current-entity)
 727     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 728     (print       "Print current entity"    mime-preview-print-current-entity)
 729     )
 730   "Menu for MIME Viewer")
 731
 732 (cond (running-xemacs
 733        (defvar mime-view-xemacs-popup-menu
 734          (cons mime-view-menu-title
 735                (mapcar (function
 736                         (lambda (item)
 737                           (vector (nth 1 item)(nth 2 item) t)
 738                           ))
 739                        mime-view-menu-list)))
 740        (defun mime-view-xemacs-popup-menu (event)
 741          "Popup the menu in the MIME Viewer buffer"
 742          (interactive "e")
 743          (select-window (event-window event))
 744          (set-buffer (event-buffer event))
 745          (popup-menu 'mime-view-xemacs-popup-menu))
 746        (defvar mouse-button-2 'button2)
 747        )
 748       (t
 749        (defvar mouse-button-2 [mouse-2])
 750        ))
 751
 752 (defun mime-view-define-keymap (&optional default)
 753   (let ((mime-view-mode-map (if (keymapp default)
 754                                 (copy-keymap default)
 755                               (make-sparse-keymap)
 756                               )))
 757     (define-key mime-view-mode-map
 758       "u"        (function mime-preview-move-to-upper))
 759     (define-key mime-view-mode-map
 760       "p"        (function mime-preview-move-to-previous))
 761     (define-key mime-view-mode-map
 762       "n"        (function mime-preview-move-to-next))
 763     (define-key mime-view-mode-map
 764       "\e\t"     (function mime-preview-move-to-previous))
 765     (define-key mime-view-mode-map
 766       "\t"       (function mime-preview-move-to-next))
 767     (define-key mime-view-mode-map
 768       " "        (function mime-preview-scroll-up-entity))
 769     (define-key mime-view-mode-map
 770       "\M- "     (function mime-preview-scroll-down-entity))
 771     (define-key mime-view-mode-map
 772       "\177"     (function mime-preview-scroll-down-entity))
 773     (define-key mime-view-mode-map
 774       "\C-m"     (function mime-preview-next-line-entity))
 775     (define-key mime-view-mode-map
 776       "\C-\M-m"  (function mime-preview-previous-line-entity))
 777     (define-key mime-view-mode-map
 778       "v"        (function mime-preview-play-current-entity))
 779     (define-key mime-view-mode-map
 780       "e"        (function mime-preview-extract-current-entity))
 781     (define-key mime-view-mode-map
 782       "\C-c\C-p" (function mime-preview-print-current-entity))
 783     (define-key mime-view-mode-map
 784       "a"        (function mime-preview-follow-current-entity))
 785     (define-key mime-view-mode-map
 786       "q"        (function mime-preview-quit))
 787     (define-key mime-view-mode-map
 788       "\C-c\C-x" (function mime-preview-kill-buffer))
 789     ;; (define-key mime-view-mode-map
 790     ;;   "<"        (function beginning-of-buffer))
 791     ;; (define-key mime-view-mode-map
 792     ;;   ">"        (function end-of-buffer))
 793     (define-key mime-view-mode-map
 794       "?"        (function describe-mode))
 795     (define-key mime-view-mode-map
 796       [tab] (function mime-preview-move-to-next))
 797     (define-key mime-view-mode-map
 798       [delete] (function mime-preview-scroll-down-entity))
 799     (define-key mime-view-mode-map
 800       [backspace] (function mime-preview-scroll-down-entity))
 801     (if (functionp default)
 802         (cond (running-xemacs
 803                (set-keymap-default-binding mime-view-mode-map default)
 804                )
 805               (t
 806                (setq mime-view-mode-map
 807                      (append mime-view-mode-map (list (cons t default))))
 808                )))
 809     (if mouse-button-2
 810         (define-key mime-view-mode-map
 811           mouse-button-2 (function mime-button-dispatcher))
 812       )
 813     (cond (running-xemacs
 814            (define-key mime-view-mode-map
 815              mouse-button-3 (function mime-view-xemacs-popup-menu))
 816            )
 817           ((>= emacs-major-version 19)
 818            (define-key mime-view-mode-map [menu-bar mime-view]
 819              (cons mime-view-menu-title
 820                    (make-sparse-keymap mime-view-menu-title)))
 821            (mapcar (function
 822                     (lambda (item)
 823                       (define-key mime-view-mode-map
 824                         (vector 'menu-bar 'mime-view (car item))
 825                         (cons (nth 1 item)(nth 2 item))
 826                         )
 827                       ))
 828                    (reverse mime-view-menu-list)
 829                    )
 830            ))
 831     (use-local-map mime-view-mode-map)
 832     (run-hooks 'mime-view-define-keymap-hook)
 833     ))
 834
 835 (defsubst mime-maybe-hide-echo-buffer ()
 836   "Clear mime-echo buffer and delete window for it."
 837   (let ((buf (get-buffer mime-echo-buffer-name)))
 838     (if buf
 839         (save-excursion
 840           (set-buffer buf)
 841           (erase-buffer)
 842           (let ((win (get-buffer-window buf)))
 843             (if win
 844                 (delete-window win)
 845               ))
 846           (bury-buffer buf)
 847           ))))
 848
 849 (defvar mime-view-redisplay nil)
 850
 851 (defun mime-display-message (message &optional preview-buffer
 852                                      mother default-keymap-or-function)
 853   (mime-maybe-hide-echo-buffer)
 854   (let ((win-conf (current-window-configuration))
 855         (raw-buffer (mime-entity-buffer message)))
 856     (or preview-buffer
 857         (setq preview-buffer
 858               (concat "*Preview-" (buffer-name raw-buffer) "*")))
 859     (set-buffer raw-buffer)
 860     (setq mime-preview-buffer preview-buffer)
 861     (let ((inhibit-read-only t))
 862       (set-buffer (get-buffer-create preview-buffer))
 863       (widen)
 864       (erase-buffer)
 865       (setq mime-raw-buffer raw-buffer)
 866       (if mother
 867           (setq mime-mother-buffer mother)
 868         )
 869       (setq mime-preview-original-window-configuration win-conf)
 870       (setq major-mode 'mime-view-mode)
 871       (setq mode-name "MIME-View")
 872       (mime-display-entity message nil
 873                            '((entity-button . invisible)
 874                              (header . visible))
 875                            preview-buffer)
 876       (mime-view-define-keymap default-keymap-or-function)
 877       (let ((point
 878              (next-single-property-change (point-min) 'mime-view-entity)))
 879         (if point
 880             (goto-char point)
 881           (goto-char (point-min))
 882           (search-forward "\n\n" nil t)
 883           ))
 884       (run-hooks 'mime-view-mode-hook)
 885       (set-buffer-modified-p nil)
 886       (setq buffer-read-only t)
 887       (or (get-buffer-window preview-buffer)
 888           (let ((r-win (get-buffer-window raw-buffer)))
 889             (if r-win
 890                 (set-window-buffer r-win preview-buffer)
 891               (let ((m-win (and mother (get-buffer-window mother))))
 892                 (if m-win
 893                     (set-window-buffer m-win preview-buffer)
 894                   (switch-to-buffer preview-buffer)
 895                   )))))
 896       )))
 897
 898 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
 899                                    default-keymap-or-function
 900                                    representation-type)
 901   "View RAW-BUFFER in MIME-View mode.
 902 Optional argument PREVIEW-BUFFER is either nil or a name of preview
 903 buffer.
 904 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
 905 function.  If it is a keymap, keymap of MIME-View mode will be added
 906 to it.  If it is a function, it will be bound as default binding of
 907 keymap of MIME-View mode.
 908 Optional argument REPRESENTATION-TYPE is representation-type of
 909 message.  It must be nil, `binary' or `cooked'.  If it is nil,
 910 `binary' is used as default."
 911   (interactive)
 912   (or raw-buffer
 913       (setq raw-buffer (current-buffer)))
 914   (or representation-type
 915       (setq representation-type
 916             (save-excursion
 917               (set-buffer raw-buffer)
 918               (cdr (or (assq major-mode mime-raw-representation-type-alist)
 919                        (assq t mime-raw-representation-type-alist)))
 920               )))
 921   (if (eq representation-type 'binary)
 922       (setq representation-type 'buffer)
 923     )
 924   (mime-display-message
 925    (mime-open-entity representation-type raw-buffer)
 926    preview-buffer mother default-keymap-or-function))
 927
 928 (defun mime-view-mode (&optional mother ctl encoding
 929                                  raw-buffer preview-buffer
 930                                  default-keymap-or-function)
 931   "Major mode for viewing MIME message.
 932
 933 Here is a list of the standard keys for mime-view-mode.
 934
 935 key             feature
 936 ---             -------
 937
 938 u               Move to upper content
 939 p or M-TAB      Move to previous content
 940 n or TAB        Move to next content
 941 SPC             Scroll up or move to next content
 942 M-SPC or DEL    Scroll down or move to previous content
 943 RET             Move to next line
 944 M-RET           Move to previous line
 945 v               Decode current content as `play mode'
 946 e               Decode current content as `extract mode'
 947 C-c C-p         Decode current content as `print mode'
 948 a               Followup to current content.
 949 q               Quit
 950 button-2        Move to point under the mouse cursor
 951                 and decode current content as `play mode'
 952 "
 953   (interactive)
 954   (unless mime-view-redisplay
 955     (save-excursion
 956       (if raw-buffer (set-buffer raw-buffer))
 957       (let ((type
 958              (cdr
 959               (or (assq major-mode mime-raw-representation-type-alist)
 960                   (assq t mime-raw-representation-type-alist)))))
 961         (if (eq type 'binary)
 962             (setq type 'buffer)
 963           )
 964         (setq mime-message-structure (mime-open-entity type raw-buffer))
 965         (or (mime-entity-content-type mime-message-structure)
 966             (mime-entity-set-content-type-internal
 967              mime-message-structure ctl))
 968         )
 969       (or (mime-entity-encoding mime-message-structure)
 970           (mime-entity-set-encoding-internal mime-message-structure encoding))
 971       ))
 972   (mime-display-message mime-message-structure preview-buffer
 973                         mother default-keymap-or-function)
 974   )
 975
 976
 977 ;;; @@ playing
 978 ;;;
 979
 980 (autoload 'mime-preview-play-current-entity "mime-play"
 981   "Play current entity." t)
 982
 983 (defun mime-preview-extract-current-entity ()
 984   "Extract current entity into file (maybe).
 985 It decodes current entity to call internal or external method as
 986 \"extract\" mode.  The method is selected from variable
 987 `mime-acting-condition'."
 988   (interactive)
 989   (mime-preview-play-current-entity "extract")
 990   )
 991
 992 (defun mime-preview-print-current-entity ()
 993   "Print current entity (maybe).
 994 It decodes current entity to call internal or external method as
 995 \"print\" mode.  The method is selected from variable
 996 `mime-acting-condition'."
 997   (interactive)
 998   (mime-preview-play-current-entity "print")
 999   )
1000
1001
1002 ;;; @@ following
1003 ;;;
1004
1005 (defun mime-preview-follow-current-entity ()
1006   "Write follow message to current entity.
1007 It calls following-method selected from variable
1008 `mime-preview-following-method-alist'."
1009   (interactive)
1010   (let (entity)
1011     (while (null (setq entity
1012                        (get-text-property (point) 'mime-view-entity)))
1013       (backward-char)
1014       )
1015     (let* ((p-beg
1016             (previous-single-property-change (point) 'mime-view-entity))
1017            p-end
1018            (entity-node-id (mime-entity-node-id entity))
1019            (len (length entity-node-id))
1020            )
1021       (cond ((null p-beg)
1022              (setq p-beg
1023                    (if (eq (next-single-property-change (point-min)
1024                                                         'mime-view-entity)
1025                            (point))
1026                        (point)
1027                      (point-min)))
1028              )
1029             ((eq (next-single-property-change p-beg 'mime-view-entity)
1030                  (point))
1031              (setq p-beg (point))
1032              ))
1033       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1034       (cond ((null p-end)
1035              (setq p-end (point-max))
1036              )
1037             ((null entity-node-id)
1038              (setq p-end (point-max))
1039              )
1040             (t
1041              (save-excursion
1042                (goto-char p-end)
1043                (catch 'tag
1044                  (let (e)
1045                    (while (setq e
1046                                 (next-single-property-change
1047                                  (point) 'mime-view-entity))
1048                      (goto-char e)
1049                      (let ((rc (mime-entity-node-id
1050                                 (get-text-property (point)
1051                                                    'mime-view-entity))))
1052                        (or (equal entity-node-id
1053                                   (nthcdr (- (length rc) len) rc))
1054                            (throw 'tag nil)
1055                            ))
1056                      (setq p-end e)
1057                      ))
1058                  (setq p-end (point-max))
1059                  ))
1060              ))
1061       (let* ((mode (mime-preview-original-major-mode 'recursive))
1062              (new-name
1063               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1064              new-buf
1065              (the-buf (current-buffer))
1066              (a-buf mime-raw-buffer)
1067              fields)
1068         (save-excursion
1069           (set-buffer (setq new-buf (get-buffer-create new-name)))
1070           (erase-buffer)
1071           (insert-buffer-substring the-buf p-beg p-end)
1072           (goto-char (point-min))
1073           (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1074             (while (progn
1075                      (setq
1076                       str
1077                       (save-excursion
1078                         (set-buffer a-buf)
1079                         (setq ci
1080                               (mime-find-entity-from-node-id entity-node-id))
1081                         (save-restriction
1082                           (narrow-to-region
1083                            (mime-entity-point-min ci)
1084                            (mime-entity-point-max ci)
1085                            )
1086                           (std11-header-string-except
1087                            (concat "^"
1088                                    (apply (function regexp-or) fields)
1089                                    ":") ""))))
1090                      (if (and
1091                           (eq (mime-entity-media-type ci) 'message)
1092                           (eq (mime-entity-media-subtype ci) 'rfc822))
1093                          nil
1094                        (if str
1095                            (insert str)
1096                          )
1097                        entity-node-id))
1098               (setq fields (std11-collect-field-names)
1099                     entity-node-id (cdr entity-node-id))
1100               )
1101             )
1102           (let ((rest mime-view-following-required-fields-list))
1103             (while rest
1104               (let ((field-name (car rest)))
1105                 (or (std11-field-body field-name)
1106                     (insert
1107                      (format
1108                       (concat field-name
1109                               ": "
1110                               (save-excursion
1111                                 (set-buffer the-buf)
1112                                 (set-buffer mime-mother-buffer)
1113                                 (set-buffer mime-raw-buffer)
1114                                 (std11-field-body field-name)
1115                                 )
1116                               "\n")))
1117                     ))
1118               (setq rest (cdr rest))
1119               ))
1120           (eword-decode-header)
1121           )
1122         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1123           (if (functionp f)
1124               (funcall f new-buf)
1125             (message
1126              (format
1127               "Sorry, following method for %s is not implemented yet."
1128               mode))
1129             ))
1130         ))))
1131
1132
1133 ;;; @@ moving
1134 ;;;
1135
1136 (defun mime-preview-move-to-upper ()
1137   "Move to upper entity.
1138 If there is no upper entity, call function `mime-preview-quit'."
1139   (interactive)
1140   (let (cinfo)
1141     (while (null (setq cinfo
1142                        (get-text-property (point) 'mime-view-entity)))
1143       (backward-char)
1144       )
1145     (let ((r (mime-entity-parent cinfo))
1146           point)
1147       (catch 'tag
1148         (while (setq point (previous-single-property-change
1149                             (point) 'mime-view-entity))
1150           (goto-char point)
1151           (if (eq r (get-text-property (point) 'mime-view-entity))
1152               (throw 'tag t)
1153             )
1154           )
1155         (mime-preview-quit)
1156         ))))
1157
1158 (defun mime-preview-move-to-previous ()
1159   "Move to previous entity.
1160 If there is no previous entity, it calls function registered in
1161 variable `mime-preview-over-to-previous-method-alist'."
1162   (interactive)
1163   (while (null (get-text-property (point) 'mime-view-entity))
1164     (backward-char)
1165     )
1166   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1167     (if point
1168         (if (get-text-property (1- point) 'mime-view-entity)
1169             (goto-char point)
1170           (goto-char (1- point))
1171           (mime-preview-move-to-previous)
1172           )
1173       (let ((f (assq (mime-preview-original-major-mode)
1174                      mime-preview-over-to-previous-method-alist)))
1175         (if f
1176             (funcall (cdr f))
1177           ))
1178       )))
1179
1180 (defun mime-preview-move-to-next ()
1181   "Move to next entity.
1182 If there is no previous entity, it calls function registered in
1183 variable `mime-preview-over-to-next-method-alist'."
1184   (interactive)
1185   (while (null (get-text-property (point) 'mime-view-entity))
1186     (forward-char)
1187     )
1188   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1189     (if point
1190         (progn
1191           (goto-char point)
1192           (if (null (get-text-property point 'mime-view-entity))
1193               (mime-preview-move-to-next)
1194             ))
1195       (let ((f (assq (mime-preview-original-major-mode)
1196                      mime-preview-over-to-next-method-alist)))
1197         (if f
1198             (funcall (cdr f))
1199           ))
1200       )))
1201
1202 (defun mime-preview-scroll-up-entity (&optional h)
1203   "Scroll up current entity.
1204 If reached to (point-max), it calls function registered in variable
1205 `mime-preview-over-to-next-method-alist'."
1206   (interactive)
1207   (or h
1208       (setq h (1- (window-height)))
1209       )
1210   (if (= (point) (point-max))
1211       (let ((f (assq (mime-preview-original-major-mode)
1212                      mime-preview-over-to-next-method-alist)))
1213         (if f
1214             (funcall (cdr f))
1215           ))
1216     (let ((point
1217            (or (next-single-property-change (point) 'mime-view-entity)
1218                (point-max))))
1219       (forward-line h)
1220       (if (> (point) point)
1221           (goto-char point)
1222         )
1223       )))
1224
1225 (defun mime-preview-scroll-down-entity (&optional h)
1226   "Scroll down current entity.
1227 If reached to (point-min), it calls function registered in variable
1228 `mime-preview-over-to-previous-method-alist'."
1229   (interactive)
1230   (or h
1231       (setq h (1- (window-height)))
1232       )
1233   (if (= (point) (point-min))
1234       (let ((f (assq (mime-preview-original-major-mode)
1235                      mime-preview-over-to-previous-method-alist)))
1236         (if f
1237             (funcall (cdr f))
1238           ))
1239     (let ((point
1240            (or (previous-single-property-change (point) 'mime-view-entity)
1241                (point-min))))
1242       (forward-line (- h))
1243       (if (< (point) point)
1244           (goto-char point)
1245         ))))
1246
1247 (defun mime-preview-next-line-entity ()
1248   (interactive)
1249   (mime-preview-scroll-up-entity 1)
1250   )
1251
1252 (defun mime-preview-previous-line-entity ()
1253   (interactive)
1254   (mime-preview-scroll-down-entity 1)
1255   )
1256
1257
1258 ;;; @@ quitting
1259 ;;;
1260
1261 (defun mime-preview-quit ()
1262   "Quit from MIME-preview buffer.
1263 It calls function registered in variable
1264 `mime-preview-quitting-method-alist'."
1265   (interactive)
1266   (let ((r (assq (mime-preview-original-major-mode)
1267                  mime-preview-quitting-method-alist)))
1268     (if r
1269         (funcall (cdr r))
1270       )))
1271
1272 (defun mime-preview-kill-buffer ()
1273   (interactive)
1274   (kill-buffer (current-buffer))
1275   )
1276
1277
1278 ;;; @ end
1279 ;;;
1280
1281 (provide 'mime-view)
1282
1283 (run-hooks 'mime-view-load-hook)
1284
1285 ;;; mime-view.el ends here