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