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