mime-view.el

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