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