mime-view.el

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