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