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