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