mime-view.el

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