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