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