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-read-field 'Content-Description entity)
 255       (mime-read-field 'Subject entity)
 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       (set-buffer (get-buffer-create 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       (set-buffer-modified-p nil)
 963       (setq buffer-read-only t)
 964       (or (get-buffer-window preview-buffer)
 965           (let ((r-win (get-buffer-window raw-buffer)))
 966             (if r-win
 967                 (set-window-buffer r-win preview-buffer)
 968               (switch-to-buffer preview-buffer)
 969               )))
 970       )))
 971
 972 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
 973                                    default-keymap-or-function)
 974   (interactive)
 975   (mime-display-message
 976    (mime-parse-buffer raw-buffer)
 977    preview-buffer mother default-keymap-or-function))
 978
 979 (defun mime-view-mode (&optional mother ctl encoding
 980                                  raw-buffer preview-buffer
 981                                  default-keymap-or-function)
 982   "Major mode for viewing MIME message.
 983
 984 Here is a list of the standard keys for mime-view-mode.
 985
 986 key             feature
 987 ---             -------
 988
 989 u               Move to upper content
 990 p or M-TAB      Move to previous content
 991 n or TAB        Move to next content
 992 SPC             Scroll up or move to next content
 993 M-SPC or DEL    Scroll down or move to previous content
 994 RET             Move to next line
 995 M-RET           Move to previous line
 996 v               Decode current content as `play mode'
 997 e               Decode current content as `extract mode'
 998 C-c C-p         Decode current content as `print mode'
 999 a               Followup to current content.
1000 q               Quit
1001 button-2        Move to point under the mouse cursor
1002                 and decode current content as `play mode'
1003 "
1004   (interactive)
1005   (mime-display-message
1006    (save-excursion
1007      (if raw-buffer (set-buffer raw-buffer))
1008      (or mime-view-redisplay
1009          (setq mime-message-structure (mime-parse-message ctl encoding)))
1010      )
1011    preview-buffer mother default-keymap-or-function))
1012
1013
1014 ;;; @@ playing
1015 ;;;
1016
1017 (autoload 'mime-preview-play-current-entity "mime-play"
1018   "Play current entity." t)
1019
1020 (defun mime-preview-extract-current-entity ()
1021   "Extract current entity into file (maybe).
1022 It decodes current entity to call internal or external method as
1023 \"extract\" mode.  The method is selected from variable
1024 `mime-acting-condition'."
1025   (interactive)
1026   (mime-preview-play-current-entity "extract")
1027   )
1028
1029 (defun mime-preview-print-current-entity ()
1030   "Print current entity (maybe).
1031 It decodes current entity to call internal or external method as
1032 \"print\" mode.  The method is selected from variable
1033 `mime-acting-condition'."
1034   (interactive)
1035   (mime-preview-play-current-entity "print")
1036   )
1037
1038
1039 ;;; @@ following
1040 ;;;
1041
1042 (defun mime-preview-follow-current-entity ()
1043   "Write follow message to current entity.
1044 It calls following-method selected from variable
1045 `mime-preview-following-method-alist'."
1046   (interactive)
1047   (let (entity)
1048     (while (null (setq entity
1049                        (get-text-property (point) 'mime-view-entity)))
1050       (backward-char)
1051       )
1052     (let* ((p-beg
1053             (previous-single-property-change (point) 'mime-view-entity))
1054            p-end
1055            (entity-node-id (mime-entity-node-id entity))
1056            (len (length entity-node-id))
1057            )
1058       (cond ((null p-beg)
1059              (setq p-beg
1060                    (if (eq (next-single-property-change (point-min)
1061                                                         'mime-view-entity)
1062                            (point))
1063                        (point)
1064                      (point-min)))
1065              )
1066             ((eq (next-single-property-change p-beg 'mime-view-entity)
1067                  (point))
1068              (setq p-beg (point))
1069              ))
1070       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1071       (cond ((null p-end)
1072              (setq p-end (point-max))
1073              )
1074             ((null entity-node-id)
1075              (setq p-end (point-max))
1076              )
1077             (t
1078              (save-excursion
1079                (goto-char p-end)
1080                (catch 'tag
1081                  (let (e)
1082                    (while (setq e
1083                                 (next-single-property-change
1084                                  (point) 'mime-view-entity))
1085                      (goto-char e)
1086                      (let ((rc (mime-entity-node-id
1087                                 (get-text-property (point)
1088                                                    'mime-view-entity))))
1089                        (or (equal entity-node-id
1090                                   (nthcdr (- (length rc) len) rc))
1091                            (throw 'tag nil)
1092                            ))
1093                      (setq p-end e)
1094                      ))
1095                  (setq p-end (point-max))
1096                  ))
1097              ))
1098       (let* ((mode (mime-preview-original-major-mode 'recursive))
1099              (new-name
1100               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1101              new-buf
1102              (the-buf (current-buffer))
1103              (a-buf mime-raw-buffer)
1104              fields)
1105         (save-excursion
1106           (set-buffer (setq new-buf (get-buffer-create new-name)))
1107           (erase-buffer)
1108           (insert-buffer-substring the-buf p-beg p-end)
1109           (goto-char (point-min))
1110           (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1111             (while (progn
1112                      (setq
1113                       str
1114                       (save-excursion
1115                         (set-buffer a-buf)
1116                         (setq
1117                          ci
1118                          (mime-raw-find-entity-from-node-id entity-node-id))
1119                         (save-restriction
1120                           (narrow-to-region
1121                            (mime-entity-point-min ci)
1122                            (mime-entity-point-max ci)
1123                            )
1124                           (std11-header-string-except
1125                            (concat "^"
1126                                    (apply (function regexp-or) fields)
1127                                    ":") ""))))
1128                      (if (and
1129                           (eq (mime-entity-media-type ci) 'message)
1130                           (eq (mime-entity-media-subtype ci) 'rfc822))
1131                          nil
1132                        (if str
1133                            (insert str)
1134                          )
1135                        entity-node-id))
1136               (setq fields (std11-collect-field-names)
1137                     entity-node-id (cdr entity-node-id))
1138               )
1139             )
1140           (let ((rest mime-view-following-required-fields-list))
1141             (while rest
1142               (let ((field-name (car rest)))
1143                 (or (std11-field-body field-name)
1144                     (insert
1145                      (format
1146                       (concat field-name
1147                               ": "
1148                               (save-excursion
1149                                 (set-buffer the-buf)
1150                                 (set-buffer mime-mother-buffer)
1151                                 (set-buffer mime-raw-buffer)
1152                                 (std11-field-body field-name)
1153                                 )
1154                               "\n")))
1155                     ))
1156               (setq rest (cdr rest))
1157               ))
1158           (eword-decode-header)
1159           )
1160         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1161           (if (functionp f)
1162               (funcall f new-buf)
1163             (message
1164              (format
1165               "Sorry, following method for %s is not implemented yet."
1166               mode))
1167             ))
1168         ))))
1169
1170
1171 ;;; @@ moving
1172 ;;;
1173
1174 (defun mime-preview-move-to-upper ()
1175   "Move to upper entity.
1176 If there is no upper entity, call function `mime-preview-quit'."
1177   (interactive)
1178   (let (cinfo)
1179     (while (null (setq cinfo
1180                        (get-text-property (point) 'mime-view-entity)))
1181       (backward-char)
1182       )
1183     (let ((r (mime-raw-find-entity-from-node-id
1184               (cdr (mime-entity-node-id cinfo))
1185               (get-text-property 1 'mime-view-entity)))
1186           point)
1187       (catch 'tag
1188         (while (setq point (previous-single-property-change
1189                             (point) 'mime-view-entity))
1190           (goto-char point)
1191           (if (eq r (get-text-property (point) 'mime-view-entity))
1192               (throw 'tag t)
1193             )
1194           )
1195         (mime-preview-quit)
1196         ))))
1197
1198 (defun mime-preview-move-to-previous ()
1199   "Move to previous entity.
1200 If there is no previous entity, it calls function registered in
1201 variable `mime-preview-over-to-previous-method-alist'."
1202   (interactive)
1203   (while (null (get-text-property (point) 'mime-view-entity))
1204     (backward-char)
1205     )
1206   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1207     (if point
1208         (if (get-text-property (1- point) 'mime-view-entity)
1209             (goto-char point)
1210           (goto-char (1- point))
1211           (mime-preview-move-to-previous)
1212           )
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       )))
1219
1220 (defun mime-preview-move-to-next ()
1221   "Move to next entity.
1222 If there is no previous entity, it calls function registered in
1223 variable `mime-preview-over-to-next-method-alist'."
1224   (interactive)
1225   (while (null (get-text-property (point) 'mime-view-entity))
1226     (forward-char)
1227     )
1228   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1229     (if point
1230         (progn
1231           (goto-char point)
1232           (if (null (get-text-property point 'mime-view-entity))
1233               (mime-preview-move-to-next)
1234             ))
1235       (let ((f (assq (mime-preview-original-major-mode)
1236                      mime-preview-over-to-next-method-alist)))
1237         (if f
1238             (funcall (cdr f))
1239           ))
1240       )))
1241
1242 (defun mime-preview-scroll-up-entity (&optional h)
1243   "Scroll up current entity.
1244 If reached to (point-max), it calls function registered in variable
1245 `mime-preview-over-to-next-method-alist'."
1246   (interactive)
1247   (or h
1248       (setq h (1- (window-height)))
1249       )
1250   (if (= (point) (point-max))
1251       (let ((f (assq (mime-preview-original-major-mode)
1252                      mime-preview-over-to-next-method-alist)))
1253         (if f
1254             (funcall (cdr f))
1255           ))
1256     (let ((point
1257            (or (next-single-property-change (point) 'mime-view-entity)
1258                (point-max))))
1259       (forward-line h)
1260       (if (> (point) point)
1261           (goto-char point)
1262         )
1263       )))
1264
1265 (defun mime-preview-scroll-down-entity (&optional h)
1266   "Scroll down current entity.
1267 If reached to (point-min), it calls function registered in variable
1268 `mime-preview-over-to-previous-method-alist'."
1269   (interactive)
1270   (or h
1271       (setq h (1- (window-height)))
1272       )
1273   (if (= (point) (point-min))
1274       (let ((f (assq (mime-preview-original-major-mode)
1275                      mime-preview-over-to-previous-method-alist)))
1276         (if f
1277             (funcall (cdr f))
1278           ))
1279     (let ((point
1280            (or (previous-single-property-change (point) 'mime-view-entity)
1281                (point-min))))
1282       (forward-line (- h))
1283       (if (< (point) point)
1284           (goto-char point)
1285         ))))
1286
1287 (defun mime-preview-next-line-entity ()
1288   (interactive)
1289   (mime-preview-scroll-up-entity 1)
1290   )
1291
1292 (defun mime-preview-previous-line-entity ()
1293   (interactive)
1294   (mime-preview-scroll-down-entity 1)
1295   )
1296
1297
1298 ;;; @@ quitting
1299 ;;;
1300
1301 (defun mime-preview-quit ()
1302   "Quit from MIME-preview buffer.
1303 It calls function registered in variable
1304 `mime-preview-quitting-method-alist'."
1305   (interactive)
1306   (let ((r (assq (mime-preview-original-major-mode)
1307                  mime-preview-quitting-method-alist)))
1308     (if r
1309         (funcall (cdr r))
1310       )))
1311
1312 (defun mime-preview-kill-buffer ()
1313   (interactive)
1314   (kill-buffer (current-buffer))
1315   )
1316
1317
1318 ;;; @ end
1319 ;;;
1320
1321 (provide 'mime-view)
1322
1323 (run-hooks 'mime-view-load-hook)
1324
1325 ;;; mime-view.el ends here