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