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.65 $
  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.65 1997-03-18 08:06:39 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-article/decode-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                          (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 300                              (match-beginning 0)
 301                            (point-max)))
 302           ))))
 303
 304 (defun mime-view-default-content-header-filter ()
 305   (mime-view-cut-header)
 306   (eword-decode-header)
 307   )
 308
 309 (defvar mime-view-content-header-filter-alist nil)
 310
 311
 312 ;;; @@ content filter
 313 ;;;
 314
 315 (defvar mime-view-content-filter-alist
 316   '(("text/enriched" . mime-preview/filter-for-text/enriched)
 317     ("text/richtext" . mime-preview/filter-for-text/richtext)
 318     (t . mime-preview/filter-for-text/plain)
 319     ))
 320
 321
 322 ;;; @@ entity separator
 323 ;;;
 324
 325 (defun mime-view-entity-separator-function (rcnum cinfo ctype params subj)
 326   "Insert entity separator conditionally.
 327 Please redefine this function if you want to change default setting."
 328   (or (mime-view-header-visible-p rcnum cinfo)
 329       (mime-view-body-visible-p rcnum cinfo ctype)
 330       (progn
 331         (goto-char (point-max))
 332         (insert "\n")
 333         )))
 334
 335
 336 ;;; @@ buffer local variables
 337 ;;;
 338
 339 ;;; @@@ in raw buffer
 340 ;;;
 341
 342 (make-variable-buffer-local 'mime::article/content-info)
 343
 344 (defvar mime::article/preview-buffer nil)
 345 (make-variable-buffer-local 'mime::article/preview-buffer)
 346
 347
 348 ;;; @@@ in view buffer
 349 ;;;
 350
 351 (make-variable-buffer-local 'mime::preview/mother-buffer)
 352 (make-variable-buffer-local 'mime::preview/content-list)
 353
 354 (defvar mime::preview/article-buffer nil)
 355 (make-variable-buffer-local 'mime::preview/article-buffer)
 356
 357 (make-variable-buffer-local 'mime::preview/original-major-mode)
 358 (make-variable-buffer-local 'mime::preview/original-window-configuration)
 359
 360
 361 ;;; @@ quitting method
 362 ;;;
 363
 364 (defvar mime-view-quitting-method-alist
 365   '((mime-show-message-mode
 366      . mime-view-quitting-method-for-mime-show-message-mode))
 367   "Alist of major-mode vs. quitting-method of mime-view.")
 368
 369 (defvar mime-view-over-to-previous-method-alist nil)
 370 (defvar mime-view-over-to-next-method-alist nil)
 371
 372 (defvar mime-view-show-summary-method nil
 373   "Alist of major-mode vs. show-summary-method.")
 374
 375
 376 ;;; @@ following method
 377 ;;;
 378
 379 (defvar mime-view-following-method-alist nil)
 380
 381 (defvar mime-view-following-required-fields-list
 382   '("From"))
 383
 384
 385 ;;; @@ X-Face
 386 ;;;
 387
 388 ;; hack from Gnus 5.0.4.
 389
 390 (defvar mime-view-x-face-to-pbm-command
 391   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 392
 393 (defvar mime-view-x-face-command
 394   (concat mime-view-x-face-to-pbm-command
 395           " | xv -quit -")
 396   "String to be executed to display an X-Face field.
 397 The command will be executed in a sub-shell asynchronously.
 398 The compressed face will be piped to this command.")
 399
 400 (defun mime-view-x-face-function ()
 401   "Function to display X-Face field. You can redefine to customize."
 402   ;; 1995/10/12 (c.f. tm-eng:130)
 403   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 404   (save-restriction
 405     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 406     ;; end
 407     (goto-char (point-min))
 408     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 409         (let ((beg (match-end 0))
 410               (end (std11-field-end))
 411               )
 412           (call-process-region beg end "sh" nil 0 nil
 413                                "-c" mime-view-x-face-command)
 414           ))))
 415
 416
 417 ;;; @@ utility
 418 ;;;
 419
 420 (defun mime-preview/get-original-major-mode ()
 421   (if mime::preview/mother-buffer
 422       (save-excursion
 423         (set-buffer mime::preview/mother-buffer)
 424         (mime-preview/get-original-major-mode)
 425         )
 426     mime::preview/original-major-mode))
 427
 428
 429 ;;; @ data structures
 430 ;;;
 431
 432 ;;; @@ preview-content-info
 433 ;;;
 434
 435 (define-structure mime::preview-content-info
 436   point-min point-max buffer content-info)
 437
 438
 439 ;;; @ buffer setup
 440 ;;;
 441
 442 (defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf)
 443   (if ibuf
 444       (progn
 445         (get-buffer ibuf)
 446         (set-buffer ibuf)
 447         ))
 448   (or mime-view-redisplay
 449       (setq mime::article/content-info (mime-parse-message ctl encoding))
 450       )
 451   (let ((ret (mime-view-make-preview-buffer obuf)))
 452     (setq mime::article/preview-buffer (car ret))
 453     ret))
 454
 455 (defun mime-view-make-preview-buffer (&optional obuf)
 456   (let* ((cinfo mime::article/content-info)
 457          (pcl (mime/flatten-content-info cinfo))
 458          (dest (make-list (length pcl) nil))
 459          (the-buf (current-buffer))
 460          (mode major-mode)
 461          )
 462     (or obuf
 463         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 464     (set-buffer (get-buffer-create obuf))
 465     (setq buffer-read-only nil)
 466     (widen)
 467     (erase-buffer)
 468     (setq mime::preview/article-buffer the-buf)
 469     (setq mime::preview/original-major-mode mode)
 470     (setq major-mode 'mime-view-mode)
 471     (setq mode-name "MIME-View")
 472     (let ((drest dest))
 473       (while pcl
 474         (setcar drest
 475                 (mime-view-display-entity (car pcl) cinfo the-buf obuf))
 476         (setq pcl (cdr pcl)
 477               drest (cdr drest))
 478         ))
 479     (set-buffer-modified-p nil)
 480     (setq buffer-read-only t)
 481     (set-buffer the-buf)
 482     (list obuf dest)
 483     ))
 484
 485 (defun mime-view-display-entity (content cinfo ibuf obuf)
 486   "Display entity from content-info CONTENT."
 487   (let* ((beg (mime::content-info/point-min content))
 488          (end (mime::content-info/point-max content))
 489          (ctype (mime::content-info/type content))
 490          (params (mime::content-info/parameters content))
 491          (encoding (mime::content-info/encoding content))
 492          (rcnum (mime::content-info/rcnum content))
 493          he e nb ne subj)
 494     (set-buffer ibuf)
 495     (goto-char beg)
 496     (setq he (if (re-search-forward "^$" nil t)
 497                  (1+ (match-end 0))
 498                end))
 499     (if (> he end)
 500         (setq he end)
 501       )
 502     (save-restriction
 503       (narrow-to-region beg end)
 504       (setq subj
 505             (eword-decode-string
 506              (mime-article/get-subject params encoding)))
 507       )
 508     (set-buffer obuf)
 509     (setq nb (point))
 510     (narrow-to-region nb nb)
 511     (mime-view-entity-button-function rcnum cinfo ctype params subj encoding)
 512     (if (mime-view-header-visible-p rcnum cinfo)
 513         (mime-preview/display-header beg he)
 514       )
 515     (if (and (null rcnum)
 516              (member
 517               ctype mime-view-content-button-visible-ctype-list))
 518         (save-excursion
 519           (goto-char (point-max))
 520           (mime-view-insert-entity-button
 521            rcnum cinfo ctype params subj encoding)
 522           ))
 523     (cond ((mime-view-body-visible-p rcnum cinfo ctype)
 524            (mime-preview/display-body he end
 525                                       rcnum cinfo ctype params subj encoding)
 526            )
 527           ((equal ctype "message/partial")
 528            (mime-preview/display-message/partial)
 529            )
 530           ((and (null rcnum)
 531                 (null (mime::content-info/children cinfo))
 532                 )
 533            (goto-char (point-max))
 534            (mime-view-insert-entity-button
 535             rcnum cinfo ctype params subj encoding)
 536            ))
 537     (mime-view-entity-separator-function rcnum cinfo ctype params subj)
 538     (prog1
 539         (progn
 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           (mime::preview-content-info/create nb (1- ne) ibuf content)
 545           )
 546       (goto-char ne)
 547       )))
 548
 549 (defun mime-preview/display-header (beg end)
 550   (save-restriction
 551     (narrow-to-region (point)(point))
 552     (insert-buffer-substring mime::preview/article-buffer beg end)
 553     (let ((f (cdr (assq mime::preview/original-major-mode
 554                         mime-view-content-header-filter-alist))))
 555       (if (functionp f)
 556           (funcall f)
 557         (mime-view-default-content-header-filter)
 558         ))
 559     (run-hooks 'mime-view-content-header-filter-hook)
 560     ))
 561
 562 (defun mime-preview/display-body (beg end
 563                                       rcnum cinfo ctype params subj encoding)
 564   (save-restriction
 565     (narrow-to-region (point-max)(point-max))
 566     (insert-buffer-substring mime::preview/article-buffer beg end)
 567     (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist)
 568                       (assq t mime-view-content-filter-alist)))))
 569       (and (functionp f)
 570            (funcall f ctype params encoding)
 571            )
 572       )))
 573
 574 (defun mime-preview/display-message/partial ()
 575   (save-restriction
 576     (goto-char (point-max))
 577     (if (not (search-backward "\n\n" nil t))
 578         (insert "\n")
 579       )
 580     (let ((be (point-max)))
 581       (narrow-to-region be be)
 582       (insert mime-view-announcement-for-message/partial)
 583       (mime-add-button (point-min)(point-max)
 584                        (function mime-view-play-current-entity))
 585       )))
 586
 587 (defun mime-article/get-uu-filename (param &optional encoding)
 588   (if (member (or encoding
 589                   (cdr (assq 'encoding param))
 590                   )
 591               mime-view-uuencode-encoding-name-list)
 592       (save-excursion
 593         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 594                 (if (looking-at ".+$")
 595                     (buffer-substring (match-beginning 0)(match-end 0))
 596                   ))
 597             ""))
 598     ))
 599
 600 (defun mime-article/get-subject (param &optional encoding)
 601   (or (std11-find-field-body '("Content-Description" "Subject"))
 602       (let (ret)
 603         (if (or (and (setq ret (mime/Content-Disposition))
 604                      (setq ret (assoc "filename" (cdr ret)))
 605                      )
 606                 (setq ret (assoc "name" param))
 607                 (setq ret (assoc "x-name" param))
 608                 )
 609             (std11-strip-quoted-string (cdr ret))
 610           ))
 611       (mime-article/get-uu-filename param encoding)
 612       ""))
 613
 614
 615 ;;; @ content information
 616 ;;;
 617
 618 (defun mime-article/point-content-number (p &optional cinfo)
 619   (or cinfo
 620       (setq cinfo mime::article/content-info)
 621       )
 622   (let ((b (mime::content-info/point-min cinfo))
 623         (e (mime::content-info/point-max cinfo))
 624         (c (mime::content-info/children cinfo))
 625         )
 626     (if (and (<= b p)(<= p e))
 627         (or (let (co ret (sn 0))
 628               (catch 'tag
 629                 (while c
 630                   (setq co (car c))
 631                   (setq ret (mime-article/point-content-number p co))
 632                   (cond ((eq ret t) (throw 'tag (list sn)))
 633                         (ret (throw 'tag (cons sn ret)))
 634                         )
 635                   (setq c (cdr c))
 636                   (setq sn (1+ sn))
 637                   )))
 638             t))))
 639
 640 (defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
 641   (or cinfo
 642       (setq cinfo mime::article/content-info)
 643       )
 644   (find-if (function
 645             (lambda (ci)
 646               (equal (mime::content-info/rcnum ci) rcnum)
 647               ))
 648            (mime/flatten-content-info cinfo)
 649            ))
 650
 651 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 652   (or cinfo
 653       (setq cinfo mime::article/content-info)
 654       )
 655   (if (eq cn t)
 656       cinfo
 657     (let ((sn (car cn)))
 658       (if (null sn)
 659           cinfo
 660         (let ((rc (nth sn (mime::content-info/children cinfo))))
 661           (if rc
 662               (mime-article/cnum-to-cinfo (cdr cn) rc)
 663             ))
 664         ))))
 665
 666 (defun mime/flatten-content-info (&optional cinfo)
 667   (or cinfo
 668       (setq cinfo mime::article/content-info)
 669       )
 670   (let ((dest (list cinfo))
 671         (rcl (mime::content-info/children cinfo))
 672         )
 673     (while rcl
 674       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 675       (setq rcl (cdr rcl))
 676       )
 677     dest))
 678
 679 (defun mime-preview/point-pcinfo (p &optional pcl)
 680   (or pcl
 681       (setq pcl mime::preview/content-list)
 682       )
 683   (catch 'tag
 684     (let ((r pcl) cell)
 685       (while r
 686         (setq cell (car r))
 687         (if (and (<= (mime::preview-content-info/point-min cell) p)
 688                  (<= p (mime::preview-content-info/point-max cell))
 689                  )
 690             (throw 'tag cell)
 691           )
 692         (setq r (cdr r))
 693         ))
 694     (car (last pcl))
 695     ))
 696
 697
 698 ;;; @ MIME viewer mode
 699 ;;;
 700
 701 (defconst mime-view-menu-title "MIME-View")
 702 (defconst mime-view-menu-list
 703   '((up          "Move to upper content"      mime-view-move-to-upper)
 704     (previous    "Move to previous content"   mime-view-move-to-previous)
 705     (next        "Move to next content"       mime-view-move-to-next)
 706     (scroll-down "Scroll to previous content" mime-view-scroll-down-entity)
 707     (scroll-up   "Scroll to next content"     mime-view-scroll-up-entity)
 708     (play        "Play Content"               mime-view-play-current-entity)
 709     (extract     "Extract Content"            mime-view-extract-current-entity)
 710     (print       "Print"                      mime-view-print-current-entity)
 711     (x-face      "Show X Face"                mime-view-display-x-face)
 712     )
 713   "Menu for MIME Viewer")
 714
 715 (cond (running-xemacs
 716        (defvar mime-view-xemacs-popup-menu
 717          (cons mime-view-menu-title
 718                (mapcar (function
 719                         (lambda (item)
 720                           (vector (nth 1 item)(nth 2 item) t)
 721                           ))
 722                        mime-view-menu-list)))
 723        (defun mime-view-xemacs-popup-menu (event)
 724          "Popup the menu in the MIME Viewer buffer"
 725          (interactive "e")
 726          (select-window (event-window event))
 727          (set-buffer (event-buffer event))
 728          (popup-menu 'mime-view-xemacs-popup-menu))
 729        (defvar mouse-button-2 'button2)
 730        )
 731       (t
 732        (defvar mouse-button-2 [mouse-2])
 733        ))
 734
 735 (defun mime-view-define-keymap (&optional default)
 736   (let ((mime-view-mode-map (if (keymapp default)
 737                                 (copy-keymap default)
 738                               (make-sparse-keymap)
 739                               )))
 740     (define-key mime-view-mode-map
 741       "u"        (function mime-view-move-to-upper))
 742     (define-key mime-view-mode-map
 743       "p"        (function mime-view-move-to-previous))
 744     (define-key mime-view-mode-map
 745       "n"        (function mime-view-move-to-next))
 746     (define-key mime-view-mode-map
 747       "\e\t"     (function mime-view-move-to-previous))
 748     (define-key mime-view-mode-map
 749       "\t"       (function mime-view-move-to-next))
 750     (define-key mime-view-mode-map
 751       " "        (function mime-view-scroll-up-entity))
 752     (define-key mime-view-mode-map
 753       "\M- "     (function mime-view-scroll-down-entity))
 754     (define-key mime-view-mode-map
 755       "\177"     (function mime-view-scroll-down-entity))
 756     (define-key mime-view-mode-map
 757       "\C-m"     (function mime-view-next-line-content))
 758     (define-key mime-view-mode-map
 759       "\C-\M-m"  (function mime-view-previous-line-content))
 760     (define-key mime-view-mode-map
 761       "v"        (function mime-view-play-current-entity))
 762     (define-key mime-view-mode-map
 763       "e"        (function mime-view-extract-current-entity))
 764     (define-key mime-view-mode-map
 765       "\C-c\C-p" (function mime-view-print-current-entity))
 766     (define-key mime-view-mode-map
 767       "a"        (function mime-view-follow-content))
 768     (define-key mime-view-mode-map
 769       "q"        (function mime-view-quit))
 770     (define-key mime-view-mode-map
 771       "h"        (function mime-view-show-summary))
 772     (define-key mime-view-mode-map
 773       "\C-c\C-x" (function mime-view-kill-buffer))
 774     (define-key mime-view-mode-map
 775       "<"        (function beginning-of-buffer))
 776     (define-key mime-view-mode-map
 777       ">"        (function end-of-buffer))
 778     (define-key mime-view-mode-map
 779       "?"        (function describe-mode))
 780     (if (functionp default)
 781         (setq mime-view-mode-map
 782               (append mime-view-mode-map (list (cons t default)))
 783               ))
 784     (if mouse-button-2
 785         (define-key mime-view-mode-map
 786           mouse-button-2 (function mime-button-dispatcher))
 787       )
 788     (cond (running-xemacs
 789            (define-key mime-view-mode-map
 790              mouse-button-3 (function mime-view-xemacs-popup-menu))
 791            )
 792           ((>= emacs-major-version 19)
 793            (define-key mime-view-mode-map [menu-bar mime-view]
 794              (cons mime-view-menu-title
 795                    (make-sparse-keymap mime-view-menu-title)))
 796            (mapcar (function
 797                     (lambda (item)
 798                       (define-key mime-view-mode-map
 799                         (vector 'menu-bar 'mime-view (car item))
 800                         (cons (nth 1 item)(nth 2 item))
 801                         )
 802                       ))
 803                    (reverse mime-view-menu-list)
 804                    )
 805            ))
 806     (use-local-map mime-view-mode-map)
 807     (run-hooks 'mime-view-define-keymap-hook)
 808     ))
 809
 810 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 811                                  default-keymap-or-function)
 812   "Major mode for viewing MIME message.
 813
 814 Here is a list of the standard keys for mime-view-mode.
 815
 816 key             feature
 817 ---             -------
 818
 819 u               Move to upper content
 820 p or M-TAB      Move to previous content
 821 n or TAB        Move to next content
 822 SPC             Scroll up or move to next content
 823 M-SPC or DEL    Scroll down or move to previous content
 824 RET             Move to next line
 825 M-RET           Move to previous line
 826 v               Decode current content as `play mode'
 827 e               Decode current content as `extract mode'
 828 C-c C-p         Decode current content as `print mode'
 829 a               Followup to current content.
 830 x               Display X-Face
 831 q               Quit
 832 button-2        Move to point under the mouse cursor
 833                 and decode current content as `play mode'
 834 "
 835   (interactive)
 836   (let ((buf (get-buffer mime/output-buffer-name)))
 837     (if buf
 838         (save-excursion
 839           (set-buffer buf)
 840           (erase-buffer)
 841           )))
 842   (let ((ret (mime-view-setup-buffer ctl encoding ibuf obuf))
 843         (win-conf (current-window-configuration))
 844         )
 845     (prog1
 846         (switch-to-buffer (car ret))
 847       (setq mime::preview/original-window-configuration win-conf)
 848       (if mother
 849           (progn
 850             (setq mime::preview/mother-buffer mother)
 851             ))
 852       (mime-view-define-keymap default-keymap-or-function)
 853       (setq mime::preview/content-list (nth 1 ret))
 854       (goto-char
 855        (let ((ce (mime::preview-content-info/point-max
 856                   (car mime::preview/content-list)
 857                   ))
 858              e)
 859          (goto-char (point-min))
 860          (search-forward "\n\n" nil t)
 861          (setq e (match-end 0))
 862          (if (<= e ce)
 863              e
 864            ce)))
 865       (run-hooks 'mime-view-mode-hook)
 866       )))
 867
 868 (defun mime-preview/cinfo-to-pcinfo (cinfo)
 869   (let ((rpcl mime::preview/content-list) cell)
 870     (catch 'tag
 871       (while rpcl
 872         (setq cell (car rpcl))
 873         (if (eq cinfo (mime::preview-content-info/content-info cell))
 874             (throw 'tag cell)
 875           )
 876         (setq rpcl (cdr rpcl))
 877         ))))
 878
 879 (autoload 'mime-view-play-current-entity "mime-play" "Play current entity." t)
 880
 881 (defun mime-view-extract-current-entity ()
 882   "Extract current entity into file (maybe).
 883 It decodes current entity to call internal or external method as
 884 \"extract\" mode.  The method is selected from variable
 885 `mime/content-decoding-condition'."
 886   (interactive)
 887   (mime-view-play-current-entity "extract")
 888   )
 889
 890 (defun mime-view-print-current-entity ()
 891   "Print current entity (maybe).
 892 It decodes current entity to call internal or external method as
 893 \"print\" mode.  The method is selected from variable
 894 `mime/content-decoding-condition'."
 895   (interactive)
 896   (mime-view-play-current-entity "print")
 897   )
 898
 899 (defun mime-view-follow-content ()
 900   (interactive)
 901   (let ((root-cinfo
 902          (mime::preview-content-info/content-info
 903           (car mime::preview/content-list)))
 904         pc p-beg p-end cinfo rcnum)
 905     (let ((rest mime::preview/content-list)
 906           b e cell len rc)
 907       (if (catch 'tag
 908             (while (setq cell (car rest))
 909               (setq b (mime::preview-content-info/point-min cell)
 910                     e (mime::preview-content-info/point-max cell))
 911               (setq rest (cdr rest))
 912               (if (and (<= b (point))(<= (point) e))
 913                   (throw 'tag cell)
 914                 )
 915               ))
 916           (progn
 917             (setq pc cell
 918                   cinfo (mime::preview-content-info/content-info pc)
 919                   rcnum (mime::content-info/rcnum cinfo))
 920             (setq len (length rcnum))
 921             (setq p-beg (mime::preview-content-info/point-min pc)
 922                   p-end (mime::preview-content-info/point-max pc))
 923             (while (and (setq cell (car rest))
 924                         (progn
 925                           (setq rc
 926                                 (mime::content-info/rcnum
 927                                  (mime::preview-content-info/content-info
 928                                   cell)))
 929                           (equal rcnum
 930                                  (nthcdr (- (length rc) len) rc))
 931                           ))
 932               (setq p-end (mime::preview-content-info/point-max cell))
 933               (setq rest (cdr rest))
 934               ))))
 935     (if pc
 936         (let* ((mode (mime-preview/get-original-major-mode))
 937                (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 938                new-buf
 939                (the-buf (current-buffer))
 940                (a-buf mime::preview/article-buffer)
 941                fields)
 942           (save-excursion
 943             (set-buffer (setq new-buf (get-buffer-create new-name)))
 944             (erase-buffer)
 945             (insert-buffer-substring the-buf p-beg p-end)
 946             (goto-char (point-min))
 947             (if (mime-view-header-visible-p rcnum root-cinfo)
 948                 (delete-region (goto-char (point-min))
 949                                (if (re-search-forward "^$" nil t)
 950                                    (match-end 0)
 951                                  (point-min)))
 952               )
 953             (goto-char (point-min))
 954             (insert "\n")
 955             (goto-char (point-min))
 956             (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
 957               (while (progn
 958                        (setq str
 959                              (save-excursion
 960                                (set-buffer a-buf)
 961                                (setq ci (mime-article/rcnum-to-cinfo rcnum))
 962                                (save-restriction
 963                                  (narrow-to-region
 964                                   (mime::content-info/point-min ci)
 965                                   (mime::content-info/point-max ci)
 966                                   )
 967                                  (std11-header-string-except
 968                                   (concat "^"
 969                                           (apply (function regexp-or) fields)
 970                                           ":") ""))))
 971                        (if (string= (mime::content-info/type ci)
 972                                     "message/rfc822")
 973                            nil
 974                          (if str
 975                              (insert str)
 976                            )
 977                          rcnum))
 978                 (setq fields (std11-collect-field-names)
 979                       rcnum (cdr rcnum))
 980                 )
 981               )
 982             (let ((rest mime-view-following-required-fields-list))
 983               (while rest
 984                 (let ((field-name (car rest)))
 985                   (or (std11-field-body field-name)
 986                       (insert
 987                        (format
 988                         (concat field-name
 989                                 ": "
 990                                 (save-excursion
 991                                   (set-buffer the-buf)
 992                                   (set-buffer mime::preview/mother-buffer)
 993                                   (set-buffer mime::preview/article-buffer)
 994                                   (std11-field-body field-name)
 995                                   )
 996                                 "\n")))
 997                       ))
 998                 (setq rest (cdr rest))
 999                 ))
1000             (eword-decode-header)
1001             )
1002           (let ((f (cdr (assq mode mime-view-following-method-alist))))
1003             (if (functionp f)
1004                 (funcall f new-buf)
1005               (message
1006                (format
1007                 "Sorry, following method for %s is not implemented yet."
1008                 mode))
1009               ))
1010           ))))
1011
1012 (defun mime-view-display-x-face ()
1013   (interactive)
1014   (save-window-excursion
1015     (set-buffer mime::preview/article-buffer)
1016     (mime-view-x-face-function)
1017     ))
1018
1019 (defun mime-view-move-to-upper ()
1020   "Move to upper entity.
1021 If there is no upper entity, call function `mime-view-quit'."
1022   (interactive)
1023   (let (cinfo)
1024     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
1025       (backward-char)
1026       )
1027     (let ((r (mime-article/rcnum-to-cinfo
1028               (cdr (mime::content-info/rcnum cinfo))
1029               (get-text-property 1 'mime-view-cinfo)))
1030           point)
1031       (catch 'tag
1032         (while (setq point (previous-single-property-change
1033                             (point) 'mime-view-cinfo))
1034           (goto-char point)
1035           (if (eq r (get-text-property (point) 'mime-view-cinfo))
1036               (throw 'tag t)
1037             )
1038           )
1039         (mime-view-quit)
1040         ))))
1041
1042 (defun mime-view-move-to-previous ()
1043   "Move to previous entity.
1044 If there is no previous entity, it calls function registered in
1045 variable `mime-view-over-to-previous-method-alist'."
1046   (interactive)
1047   (while (null (get-text-property (point) 'mime-view-cinfo))
1048     (backward-char)
1049     )
1050   (let ((point (previous-single-property-change (point) 'mime-view-cinfo)))
1051     (if point
1052         (goto-char point)
1053       (let ((f (assq mime::preview/original-major-mode
1054                      mime-view-over-to-previous-method-alist)))
1055         (if f
1056             (funcall (cdr f))
1057           ))
1058       )))
1059
1060 (defun mime-view-move-to-next ()
1061   "Move to next entity.
1062 If there is no previous entity, it calls function registered in
1063 variable `mime-view-over-to-next-method-alist'."
1064   (interactive)
1065   (let ((point (next-single-property-change (point) 'mime-view-cinfo)))
1066     (if point
1067         (goto-char point)
1068       (let ((f (assq mime::preview/original-major-mode
1069                      mime-view-over-to-next-method-alist)))
1070         (if f
1071             (funcall (cdr f))
1072           ))
1073       )))
1074
1075 (defun mime-view-scroll-up-entity (&optional h)
1076   "Scroll up current entity.
1077 If reached to (point-max), it calls function registered in variable
1078 `mime-view-over-to-next-method-alist'."
1079   (interactive)
1080   (or h
1081       (setq h (1- (window-height)))
1082       )
1083   (if (= (point) (point-max))
1084       (let ((f (assq mime::preview/original-major-mode
1085                      mime-view-over-to-next-method-alist)))
1086         (if f
1087             (funcall (cdr f))
1088           ))
1089     (let ((point
1090            (or (next-single-property-change (point) 'mime-view-cinfo)
1091                (point-max))))
1092       (forward-line h)
1093       (if (> (point) point)
1094           (goto-char point)
1095         )
1096       )))
1097
1098 (defun mime-view-scroll-down-entity (&optional h)
1099   "Scroll down current entity.
1100 If reached to (point-min), it calls function registered in variable
1101 `mime-view-over-to-previous-method-alist'."
1102   (interactive)
1103   (or h
1104       (setq h (1- (window-height)))
1105       )
1106   (if (= (point) (point-min))
1107       (let ((f (assq mime::preview/original-major-mode
1108                      mime-view-over-to-previous-method-alist)))
1109         (if f
1110             (funcall (cdr f))
1111           ))
1112     (let (point)
1113       (save-excursion
1114         (catch 'tag
1115           (while (> (point) 1)
1116             (if (setq point
1117                       (previous-single-property-change (point)
1118                                                        'mime-view-cinfo))
1119                 (throw 'tag t)
1120               )
1121             (backward-char)
1122             )
1123           (setq point (point-min))
1124           ))
1125       (forward-line (- h))
1126       (if (< (point) point)
1127           (goto-char point)
1128         ))))
1129
1130 (defun mime-view-next-line-content ()
1131   (interactive)
1132   (mime-view-scroll-up-entity 1)
1133   )
1134
1135 (defun mime-view-previous-line-content ()
1136   (interactive)
1137   (mime-view-scroll-down-entity 1)
1138   )
1139
1140 (defun mime-view-quit ()
1141   "Quit from MIME-View buffer.
1142 It calls function registered in variable
1143 `mime-view-quitting-method-alist'."
1144   (interactive)
1145   (let ((r (assq mime::preview/original-major-mode
1146                  mime-view-quitting-method-alist)))
1147     (if r
1148         (funcall (cdr r))
1149       )))
1150
1151 (defun mime-view-show-summary ()
1152   "Show summary.
1153 It calls function registered in variable
1154 `mime-view-show-summary-method'."
1155   (interactive)
1156   (let ((r (assq mime::preview/original-major-mode
1157                  mime-view-show-summary-method)))
1158     (if r
1159         (funcall (cdr r))
1160       )))
1161
1162 (defun mime-view-kill-buffer ()
1163   (interactive)
1164   (kill-buffer (current-buffer))
1165   )
1166
1167
1168 ;;; @ end
1169 ;;;
1170
1171 (provide 'mime-view)
1172
1173 (run-hooks 'mime-view-load-hook)
1174
1175 ;;; mime-view.el ends here