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