mime-view.el

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