mime-view.el

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