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