mime-view.el

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