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       )
 587   (let ((b (mime-entity-info-point-min message-info))
 588         (e (mime-entity-info-point-max message-info))
 589         (c (mime-entity-info-children message-info))
 590         )
 591     (if (and (<= b position)(<= position e))
 592         (or (let (co ret (sn 0))
 593               (catch 'tag
 594                 (while c
 595                   (setq co (car c))
 596                   (setq ret (mime-raw-point-to-entity-number position co))
 597                   (cond ((eq ret t) (throw 'tag (list sn)))
 598                         (ret (throw 'tag (cons sn ret)))
 599                         )
 600                   (setq c (cdr c))
 601                   (setq sn (1+ sn))
 602                   )))
 603             t))))
 604
 605 (defsubst mime-raw-rcnum-to-cinfo (rnum &optional cinfo)
 606   (mime-raw-cnum-to-cinfo (reverse rnum) cinfo)
 607   )
 608
 609 (defun mime-raw-cnum-to-cinfo (cn &optional cinfo)
 610   (or cinfo
 611       (setq cinfo mime-raw-message-info)
 612       )
 613   (if (eq cn t)
 614       cinfo
 615     (let ((sn (car cn)))
 616       (if (null sn)
 617           cinfo
 618         (let ((rc (nth sn (mime-entity-info-children cinfo))))
 619           (if rc
 620               (mime-raw-cnum-to-cinfo (cdr cn) rc)
 621             ))
 622         ))))
 623
 624 (defun mime/flatten-content-info (&optional cinfo)
 625   (or cinfo
 626       (setq cinfo mime-raw-message-info)
 627       )
 628   (let ((dest (list cinfo))
 629         (rcl (mime-entity-info-children cinfo))
 630         )
 631     (while rcl
 632       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 633       (setq rcl (cdr rcl))
 634       )
 635     dest))
 636
 637
 638 ;;; @@ predicate functions
 639 ;;;
 640
 641 (defun mime-view-header-visible-p (rcnum cinfo)
 642   "Return non-nil if header of current entity is visible."
 643   (or (null rcnum)
 644       (member (mime-entity-info-type/subtype
 645                (mime-raw-rcnum-to-cinfo (cdr rcnum) cinfo))
 646               mime-view-childrens-header-showing-Content-Type-list)
 647       ))
 648
 649 (defun mime-view-body-visible-p (rcnum cinfo media-type media-subtype)
 650   (let ((ctype (if media-type
 651                    (if media-subtype
 652                        (format "%s/%s" media-type media-subtype)
 653                      (symbol-name media-type)
 654                      ))))
 655     (and (member ctype mime-view-visible-media-type-list)
 656          (if (and (eq media-type 'application)
 657                   (eq media-subtype 'octet-stream))
 658              (let ((ccinfo (mime-raw-rcnum-to-cinfo rcnum cinfo)))
 659                (member (mime-entity-info-encoding ccinfo)
 660                        '(nil "7bit" "8bit"))
 661                )
 662            t))
 663     ))
 664
 665
 666 ;;; @ MIME viewer mode
 667 ;;;
 668
 669 (defconst mime-view-menu-title "MIME-View")
 670 (defconst mime-view-menu-list
 671   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 672     (previous    "Move to previous entity" mime-preview-move-to-previous)
 673     (next        "Move to next entity"     mime-preview-move-to-next)
 674     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 675     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 676     (play        "Play current entity"     mime-preview-play-current-entity)
 677     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 678     (print       "Print current entity"    mime-preview-print-current-entity)
 679     (x-face      "Show X Face"             mime-preview-display-x-face)
 680     )
 681   "Menu for MIME Viewer")
 682
 683 (cond (running-xemacs
 684        (defvar mime-view-xemacs-popup-menu
 685          (cons mime-view-menu-title
 686                (mapcar (function
 687                         (lambda (item)
 688                           (vector (nth 1 item)(nth 2 item) t)
 689                           ))
 690                        mime-view-menu-list)))
 691        (defun mime-view-xemacs-popup-menu (event)
 692          "Popup the menu in the MIME Viewer buffer"
 693          (interactive "e")
 694          (select-window (event-window event))
 695          (set-buffer (event-buffer event))
 696          (popup-menu 'mime-view-xemacs-popup-menu))
 697        (defvar mouse-button-2 'button2)
 698        )
 699       (t
 700        (defvar mouse-button-2 [mouse-2])
 701        ))
 702
 703 (defun mime-view-define-keymap (&optional default)
 704   (let ((mime-view-mode-map (if (keymapp default)
 705                                 (copy-keymap default)
 706                               (make-sparse-keymap)
 707                               )))
 708     (define-key mime-view-mode-map
 709       "u"        (function mime-preview-move-to-upper))
 710     (define-key mime-view-mode-map
 711       "p"        (function mime-preview-move-to-previous))
 712     (define-key mime-view-mode-map
 713       "n"        (function mime-preview-move-to-next))
 714     (define-key mime-view-mode-map
 715       "\e\t"     (function mime-preview-move-to-previous))
 716     (define-key mime-view-mode-map
 717       "\t"       (function mime-preview-move-to-next))
 718     (define-key mime-view-mode-map
 719       " "        (function mime-preview-scroll-up-entity))
 720     (define-key mime-view-mode-map
 721       "\M- "     (function mime-preview-scroll-down-entity))
 722     (define-key mime-view-mode-map
 723       "\177"     (function mime-preview-scroll-down-entity))
 724     (define-key mime-view-mode-map
 725       "\C-m"     (function mime-preview-next-line-entity))
 726     (define-key mime-view-mode-map
 727       "\C-\M-m"  (function mime-preview-previous-line-entity))
 728     (define-key mime-view-mode-map
 729       "v"        (function mime-preview-play-current-entity))
 730     (define-key mime-view-mode-map
 731       "e"        (function mime-preview-extract-current-entity))
 732     (define-key mime-view-mode-map
 733       "\C-c\C-p" (function mime-preview-print-current-entity))
 734     (define-key mime-view-mode-map
 735       "a"        (function mime-preview-follow-current-entity))
 736     (define-key mime-view-mode-map
 737       "q"        (function mime-preview-quit))
 738     (define-key mime-view-mode-map
 739       "h"        (function mime-preview-show-summary))
 740     (define-key mime-view-mode-map
 741       "\C-c\C-x" (function mime-preview-kill-buffer))
 742     ;; (define-key mime-view-mode-map
 743     ;;   "<"        (function beginning-of-buffer))
 744     ;; (define-key mime-view-mode-map
 745     ;;   ">"        (function end-of-buffer))
 746     (define-key mime-view-mode-map
 747       "?"        (function describe-mode))
 748     (define-key mime-view-mode-map
 749       [tab] (function mime-preview-move-to-next))
 750     (define-key mime-view-mode-map
 751       [delete] (function mime-preview-scroll-down-entity))
 752     (define-key mime-view-mode-map
 753       [backspace] (function mime-preview-scroll-down-entity))
 754     (if (functionp default)
 755         (cond (running-xemacs
 756                (set-keymap-default-binding mime-view-mode-map default)
 757                )
 758               (t
 759                (setq mime-view-mode-map
 760                      (append mime-view-mode-map (list (cons t default))))
 761                )))
 762     (if mouse-button-2
 763         (define-key mime-view-mode-map
 764           mouse-button-2 (function mime-button-dispatcher))
 765       )
 766     (cond (running-xemacs
 767            (define-key mime-view-mode-map
 768              mouse-button-3 (function mime-view-xemacs-popup-menu))
 769            )
 770           ((>= emacs-major-version 19)
 771            (define-key mime-view-mode-map [menu-bar mime-view]
 772              (cons mime-view-menu-title
 773                    (make-sparse-keymap mime-view-menu-title)))
 774            (mapcar (function
 775                     (lambda (item)
 776                       (define-key mime-view-mode-map
 777                         (vector 'menu-bar 'mime-view (car item))
 778                         (cons (nth 1 item)(nth 2 item))
 779                         )
 780                       ))
 781                    (reverse mime-view-menu-list)
 782                    )
 783            ))
 784     (use-local-map mime-view-mode-map)
 785     (run-hooks 'mime-view-define-keymap-hook)
 786     ))
 787
 788 (defsubst mime-maybe-hide-echo-buffer ()
 789   "Clear mime-echo buffer and delete window for it."
 790   (let ((buf (get-buffer mime-echo-buffer-name)))
 791     (if buf
 792         (save-excursion
 793           (set-buffer buf)
 794           (erase-buffer)
 795           (let ((win (get-buffer-window buf)))
 796             (if win
 797                 (delete-window win)
 798               ))
 799           (bury-buffer buf)
 800           ))))
 801
 802 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 803                                  default-keymap-or-function)
 804   "Major mode for viewing MIME message.
 805
 806 Here is a list of the standard keys for mime-view-mode.
 807
 808 key             feature
 809 ---             -------
 810
 811 u               Move to upper content
 812 p or M-TAB      Move to previous content
 813 n or TAB        Move to next content
 814 SPC             Scroll up or move to next content
 815 M-SPC or DEL    Scroll down or move to previous content
 816 RET             Move to next line
 817 M-RET           Move to previous line
 818 v               Decode current content as `play mode'
 819 e               Decode current content as `extract mode'
 820 C-c C-p         Decode current content as `print mode'
 821 a               Followup to current content.
 822 x               Display X-Face
 823 q               Quit
 824 button-2        Move to point under the mouse cursor
 825                 and decode current content as `play mode'
 826 "
 827   (interactive)
 828   (mime-maybe-hide-echo-buffer)
 829   (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf))
 830         (win-conf (current-window-configuration))
 831         )
 832     (prog1
 833         (switch-to-buffer ret)
 834       (setq mime-preview-original-window-configuration win-conf)
 835       (if mother
 836           (progn
 837             (setq mime-mother-buffer mother)
 838             ))
 839       (mime-view-define-keymap default-keymap-or-function)
 840       (let ((point (next-single-property-change (point-min) 'mime-view-cinfo)))
 841         (if point
 842             (goto-char point)
 843           (goto-char (point-min))
 844           (search-forward "\n\n" nil t)
 845           ))
 846       (run-hooks 'mime-view-mode-hook)
 847       )))
 848
 849
 850 ;;; @@ playing
 851 ;;;
 852
 853 (autoload 'mime-preview-play-current-entity "mime-play"
 854   "Play current entity." t)
 855
 856 (defun mime-preview-extract-current-entity ()
 857   "Extract current entity into file (maybe).
 858 It decodes current entity to call internal or external method as
 859 \"extract\" mode.  The method is selected from variable
 860 `mime-acting-condition'."
 861   (interactive)
 862   (mime-preview-play-current-entity "extract")
 863   )
 864
 865 (defun mime-preview-print-current-entity ()
 866   "Print current entity (maybe).
 867 It decodes current entity to call internal or external method as
 868 \"print\" mode.  The method is selected from variable
 869 `mime-acting-condition'."
 870   (interactive)
 871   (mime-preview-play-current-entity "print")
 872   )
 873
 874
 875 ;;; @@ following
 876 ;;;
 877
 878 (defun mime-preview-original-major-mode ()
 879   "Return major-mode of original buffer.
 880 If a current buffer has mime-mother-buffer, return original major-mode
 881 of the mother-buffer."
 882   (if mime-mother-buffer
 883       (save-excursion
 884         (set-buffer mime-mother-buffer)
 885         (mime-preview-original-major-mode)
 886         )
 887     mime-preview-original-major-mode))
 888
 889 (defun mime-preview-follow-current-entity ()
 890   "Write follow message to current entity.
 891 It calls following-method selected from variable
 892 `mime-view-following-method-alist'."
 893   (interactive)
 894   (let ((root-cinfo (get-text-property (point-min) 'mime-view-cinfo))
 895         cinfo)
 896     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
 897       (backward-char)
 898       )
 899     (let* ((p-beg (previous-single-property-change (point) 'mime-view-cinfo))
 900            p-end
 901            (rcnum (mime-entity-info-rnum cinfo))
 902            (len (length rcnum))
 903            )
 904       (cond ((null p-beg)
 905              (setq p-beg
 906                    (if (eq (next-single-property-change (point-min)
 907                                                         'mime-view-cinfo)
 908                            (point))
 909                        (point)
 910                      (point-min)))
 911              )
 912             ((eq (next-single-property-change p-beg 'mime-view-cinfo)
 913                  (point))
 914              (setq p-beg (point))
 915              ))
 916       (setq p-end (next-single-property-change p-beg 'mime-view-cinfo))
 917       (cond ((null p-end)
 918              (setq p-end (point-max))
 919              )
 920             ((null rcnum)
 921              (setq p-end (point-max))
 922              )
 923             (t
 924              (save-excursion
 925                (goto-char p-end)
 926                (catch 'tag
 927                  (let (e)
 928                    (while (setq e
 929                                 (next-single-property-change
 930                                  (point) 'mime-view-cinfo))
 931                      (goto-char e)
 932                      (let ((rc (mime-entity-info-rnum
 933                                 (get-text-property (point)
 934                                                    'mime-view-cinfo))))
 935                        (or (equal rcnum (nthcdr (- (length rc) len) rc))
 936                            (throw 'tag nil)
 937                            ))
 938                      (setq p-end e)
 939                      ))
 940                  (setq p-end (point-max))
 941                  ))
 942              ))
 943       (let* ((mode (mime-preview-original-major-mode))
 944              (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 945              new-buf
 946              (the-buf (current-buffer))
 947              (a-buf mime-raw-buffer)
 948              fields)
 949         (save-excursion
 950           (set-buffer (setq new-buf (get-buffer-create new-name)))
 951           (erase-buffer)
 952           (insert-buffer-substring the-buf p-beg p-end)
 953           (goto-char (point-min))
 954           (if (mime-view-header-visible-p rcnum root-cinfo)
 955               (delete-region (goto-char (point-min))
 956                              (if (re-search-forward "^$" nil t)
 957                                  (match-end 0)
 958                                (point-min)))
 959             )
 960           (goto-char (point-min))
 961           (insert "\n")
 962           (goto-char (point-min))
 963           (let ((rcnum (mime-entity-info-rnum cinfo)) ci str)
 964             (while (progn
 965                      (setq str
 966                            (save-excursion
 967                              (set-buffer a-buf)
 968                              (setq ci (mime-raw-rcnum-to-cinfo rcnum))
 969                              (save-restriction
 970                                (narrow-to-region
 971                                 (mime-entity-info-point-min ci)
 972                                 (mime-entity-info-point-max ci)
 973                                 )
 974                                (std11-header-string-except
 975                                 (concat "^"
 976                                         (apply (function regexp-or) fields)
 977                                         ":") ""))))
 978                      (if (and
 979                           (eq (mime-entity-info-media-type ci) 'message)
 980                           (eq (mime-entity-info-media-subtype ci) 'rfc822))
 981                          nil
 982                        (if str
 983                            (insert str)
 984                          )
 985                        rcnum))
 986               (setq fields (std11-collect-field-names)
 987                     rcnum (cdr rcnum))
 988               )
 989             )
 990           (let ((rest mime-view-following-required-fields-list))
 991             (while rest
 992               (let ((field-name (car rest)))
 993                 (or (std11-field-body field-name)
 994                     (insert
 995                      (format
 996                       (concat field-name
 997                               ": "
 998                               (save-excursion
 999                                 (set-buffer the-buf)
1000                                 (set-buffer mime-mother-buffer)
1001                                 (set-buffer mime-raw-buffer)
1002                                 (std11-field-body field-name)
1003                                 )
1004                               "\n")))
1005                     ))
1006               (setq rest (cdr rest))
1007               ))
1008           (eword-decode-header)
1009           )
1010         (let ((f (cdr (assq mode mime-view-following-method-alist))))
1011           (if (functionp f)
1012               (funcall f new-buf)
1013             (message
1014              (format
1015               "Sorry, following method for %s is not implemented yet."
1016               mode))
1017             ))
1018         ))))
1019
1020
1021 ;;; @@ X-Face
1022 ;;;
1023
1024 (defun mime-preview-display-x-face ()
1025   (interactive)
1026   (save-window-excursion
1027     (set-buffer mime-raw-buffer)
1028     (mime-view-x-face-function)
1029     ))
1030
1031
1032 ;;; @@ moving
1033 ;;;
1034
1035 (defun mime-preview-move-to-upper ()
1036   "Move to upper entity.
1037 If there is no upper entity, call function `mime-preview-quit'."
1038   (interactive)
1039   (let (cinfo)
1040     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
1041       (backward-char)
1042       )
1043     (let ((r (mime-raw-rcnum-to-cinfo
1044               (cdr (mime-entity-info-rnum cinfo))
1045               (get-text-property 1 'mime-view-cinfo)))
1046           point)
1047       (catch 'tag
1048         (while (setq point (previous-single-property-change
1049                             (point) 'mime-view-cinfo))
1050           (goto-char point)
1051           (if (eq r (get-text-property (point) 'mime-view-cinfo))
1052               (throw 'tag t)
1053             )
1054           )
1055         (mime-preview-quit)
1056         ))))
1057
1058 (defun mime-preview-move-to-previous ()
1059   "Move to previous entity.
1060 If there is no previous entity, it calls function registered in
1061 variable `mime-view-over-to-previous-method-alist'."
1062   (interactive)
1063   (while (null (get-text-property (point) 'mime-view-cinfo))
1064     (backward-char)
1065     )
1066   (let ((point (previous-single-property-change (point) 'mime-view-cinfo)))
1067     (if point
1068         (goto-char point)
1069       (let ((f (assq mime-preview-original-major-mode
1070                      mime-view-over-to-previous-method-alist)))
1071         (if f
1072             (funcall (cdr f))
1073           ))
1074       )))
1075
1076 (defun mime-preview-move-to-next ()
1077   "Move to next entity.
1078 If there is no previous entity, it calls function registered in
1079 variable `mime-view-over-to-next-method-alist'."
1080   (interactive)
1081   (let ((point (next-single-property-change (point) 'mime-view-cinfo)))
1082     (if point
1083         (goto-char point)
1084       (let ((f (assq mime-preview-original-major-mode
1085                      mime-view-over-to-next-method-alist)))
1086         (if f
1087             (funcall (cdr f))
1088           ))
1089       )))
1090
1091 (defun mime-preview-scroll-up-entity (&optional h)
1092   "Scroll up current entity.
1093 If reached to (point-max), it calls function registered in variable
1094 `mime-view-over-to-next-method-alist'."
1095   (interactive)
1096   (or h
1097       (setq h (1- (window-height)))
1098       )
1099   (if (= (point) (point-max))
1100       (let ((f (assq mime-preview-original-major-mode
1101                      mime-view-over-to-next-method-alist)))
1102         (if f
1103             (funcall (cdr f))
1104           ))
1105     (let ((point
1106            (or (next-single-property-change (point) 'mime-view-cinfo)
1107                (point-max))))
1108       (forward-line h)
1109       (if (> (point) point)
1110           (goto-char point)
1111         )
1112       )))
1113
1114 (defun mime-preview-scroll-down-entity (&optional h)
1115   "Scroll down current entity.
1116 If reached to (point-min), it calls function registered in variable
1117 `mime-view-over-to-previous-method-alist'."
1118   (interactive)
1119   (or h
1120       (setq h (1- (window-height)))
1121       )
1122   (if (= (point) (point-min))
1123       (let ((f (assq mime-preview-original-major-mode
1124                      mime-view-over-to-previous-method-alist)))
1125         (if f
1126             (funcall (cdr f))
1127           ))
1128     (let (point)
1129       (save-excursion
1130         (catch 'tag
1131           (while (> (point) 1)
1132             (if (setq point
1133                       (previous-single-property-change (point)
1134                                                        'mime-view-cinfo))
1135                 (throw 'tag t)
1136               )
1137             (backward-char)
1138             )
1139           (setq point (point-min))
1140           ))
1141       (forward-line (- h))
1142       (if (< (point) point)
1143           (goto-char point)
1144         ))))
1145
1146 (defun mime-preview-next-line-entity ()
1147   (interactive)
1148   (mime-preview-scroll-up-entity 1)
1149   )
1150
1151 (defun mime-preview-previous-line-entity ()
1152   (interactive)
1153   (mime-preview-scroll-down-entity 1)
1154   )
1155
1156
1157 ;;; @@ quitting
1158 ;;;
1159
1160 (defun mime-preview-quit ()
1161   "Quit from MIME-preview buffer.
1162 It calls function registered in variable
1163 `mime-view-quitting-method-alist'."
1164   (interactive)
1165   (let ((r (assq mime-preview-original-major-mode
1166                  mime-view-quitting-method-alist)))
1167     (if r
1168         (funcall (cdr r))
1169       )))
1170
1171 (defun mime-preview-show-summary ()
1172   "Show summary.
1173 It calls function registered in variable
1174 `mime-view-show-summary-method'."
1175   (interactive)
1176   (let ((r (assq mime-preview-original-major-mode
1177                  mime-view-show-summary-method)))
1178     (if r
1179         (funcall (cdr r))
1180       )))
1181
1182 (defun mime-preview-kill-buffer ()
1183   (interactive)
1184   (kill-buffer (current-buffer))
1185   )
1186
1187
1188 ;;; @ end
1189 ;;;
1190
1191 (provide 'mime-view)
1192
1193 (run-hooks 'mime-view-load-hook)
1194
1195 ;;; mime-view.el ends here