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